Index: /branches/qres/ccl/.cvsignore =================================================================== --- /branches/qres/ccl/.cvsignore (revision 13564) +++ /branches/qres/ccl/.cvsignore (revision 13564) @@ -0,0 +1,10 @@ +*\.?fsl +*CL* +*cl* +*boot* +*fsl +.gdb* +*.image +README* +*~.* +*.app Index: /branches/qres/ccl/LGPL =================================================================== --- /branches/qres/ccl/LGPL (revision 13564) +++ /branches/qres/ccl/LGPL (revision 13564) @@ -0,0 +1,513 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 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. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + 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 Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +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 and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +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 other code 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. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + 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, whereas the latter must +be combined with the library in order to run. + + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser 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 combine 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) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) 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. + + d) 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. + + e) 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 materials to be 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 with +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 Lesser 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 + + + 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 Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; 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. + +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! + + Index: /branches/qres/ccl/LICENSE =================================================================== --- /branches/qres/ccl/LICENSE (revision 13564) +++ /branches/qres/ccl/LICENSE (revision 13564) @@ -0,0 +1,65 @@ + +Preamble to the Gnu Lesser General Public License + +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 +("LGPL") has been adopted to govern the use and distribution of +above-mentioned application. However, the LGPL uses terminology that +is more appropriate for a program written in C than one written in +Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if +certain clarifications are made. This document details those +clarifications. Accordingly, the license for the open-source Lisp +applications consists of this document plus the LGPL. Wherever there +is a conflict between this document and the LGPL, this document takes +precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. A Lisp application +may include the same set of Lisp objects as does a Library, but this +does not mean that the application is necessarily a "work based on the +Library" it contains. + +The Library consists of everything in the distribution file set before +any modifications are made to the files. If any of the functions or +classes in the Library are redefined in other files, then those +redefinitions ARE considered a work based on the Library. If +additional methods are added to generic functions in the Library, +those additional methods are NOT considered a work based on the +Library. If Library classes are subclassed, these subclasses are NOT +considered a work based on the Library. If the Library is modified to +explicitly call other functions that are neither part of Lisp itself +nor an available add-on module to Lisp, then the functions called by +the modified Library ARE considered a work based on the Library. The +goal is to ensure that the Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it +must be done in a way such that the Library will still run without +that proprietary code present. Section 5 of the LGPL distinguishes +between the case of a library being dynamically linked at runtime and +one being statically linked at build time. Section 5 of the LGPL +states that the former results in an executable that is a "work that +uses the Library." Section 5 of the LGPL states that the latter +results in one that is a "derivative of the Library", which is +therefore covered by the LGPL. Since Lisp only offers one choice, +which is to link the Library into an executable at build time, we +declare that, for the purpose applying the LGPL to the Library, an +executable that results from linking a "work that uses the Library" +with the Library is considered a "work that uses the Library" and is +therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to +the Library. However, in connection with each distribution of this +executable, you must also deliver, in accordance with the terms and +conditions of the LGPL, the source code of Library (or your derivative +thereof) that is incorporated into this executable. + +End of Document Index: /branches/qres/ccl/bin/.cvsignore =================================================================== --- /branches/qres/ccl/bin/.cvsignore (revision 13564) +++ /branches/qres/ccl/bin/.cvsignore (revision 13564) @@ -0,0 +1,3 @@ +*fsl + + Index: /branches/qres/ccl/compiler/.cvsignore =================================================================== --- /branches/qres/ccl/compiler/.cvsignore (revision 13564) +++ /branches/qres/ccl/compiler/.cvsignore (revision 13564) @@ -0,0 +1,1 @@ +*~.* Index: /branches/qres/ccl/compiler/X86/.cvsignore =================================================================== --- /branches/qres/ccl/compiler/X86/.cvsignore (revision 13564) +++ /branches/qres/ccl/compiler/X86/.cvsignore (revision 13564) @@ -0,0 +1,1 @@ +*~.* Index: /branches/qres/ccl/compiler/X86/X8632/x8632-arch.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/X8632/x8632-arch.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/X8632/x8632-arch.lisp (revision 13564) @@ -0,0 +1,1262 @@ +;;;-*- Mode: Lisp; Package: (X8632 :use CL) -*- + +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; This stuff has to match lisp-kernel/x86-constants32.[hs] + +(defpackage "X8632" + (:use "CL") + #+x8632-target + (:nicknames "TARGET")) + +(in-package "X8632") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "X86-ARCH") + (require "X86-LAP") + +(defparameter *x8632-symbolic-register-names* + (make-hash-table :test #'equal) + "For the disassembler, mostly.") + +;;; Define integer constants which map to indices in the +;;; X86::*X8632-REGISTER-ENTRIES* array. +(ccl::defenum () + ;; 32-bit registers + eax + ecx + edx + ebx + esp + ebp + esi + edi + ;; 16-bit-registers + ax + cx + dx + bx + sp + bp + si + di + ;; 8-bit registers + al + cl + dl + bl + ah + ch + dh + bh + ;; xmm registers + xmm0 + xmm1 + xmm2 + xmm3 + xmm4 + xmm5 + xmm6 + xmm7 + ;; MMX registers + mm0 + mm1 + mm2 + mm3 + mm4 + mm5 + mm6 + mm7 + ;; x87 FP regs + st[0] + st[1] + st[2] + st[3] + st[4] + st[5] + st[6] + st[7] + ;; Segment registers + cs + ds + ss + es + fs + gs + ) + +(defmacro defx86reg (alias known) + (let* ((known-entry (gensym))) + `(let* ((,known-entry (gethash ,(string known) x86::*x8632-registers*))) + (unless ,known-entry + (error "register ~a not defined" ',known)) + (setf (gethash ,(string alias) x86::*x8632-registers*) ,known-entry) + (unless (gethash ,(string-downcase (string known)) *x8632-symbolic-register-names*) + (setf (gethash ,(string-downcase (string known)) *x8632-symbolic-register-names*) + (string-downcase ,(string alias)))) + (defconstant ,alias ,known)))) + +;;; The limited number of registers that we have may make it +;;; impossible to statically partition the register file into +;;; immediate and tagged sets. +;;; +;;; As a baseline, we will use the scheme defined below. This +;;; partitioning will be in effect any time a function is entered +;;; (and therefore at the time of a function call). +;;; +;;; This partitioning can be altered by setting or clearing bits in +;;; thread-private memory which indicate whether a register is an +;;; immmediate or a node. The GC will look at these flag bits to +;;; decide how to treat the registers. +;;; +;;; "Lispy" register names might be therefore be confusing at times. +;;; + +(defx86reg imm0 eax) +(defx86reg imm0.w ax) +(defx86reg imm0.b al) +(defx86reg imm0.bh ah) + +(defx86reg temp0 ecx) +(defx86reg temp0.w cx) +(defx86reg temp0.b cl) +(defx86reg temp0.bh ch) +(defx86reg shift cl) + +(defx86reg temp1 edx) +(defx86reg temp1.w dx) +(defx86reg temp1.b dl) +(defx86reg temp1.bh dh) +(defx86reg nargs edx) + +(defx86reg arg_z ebx) +(defx86reg arg_z.w bx) +(defx86reg arg_z.b bl) +(defx86reg arg_z.bh bh) + +(defx86reg arg_y esi) +(defx86reg arg_y.w si) + +(defx86reg fn edi) + +;; Callee-saved non-volatile registers are probably a non-starter on +;; IA-32. + +;;; Use xmm regs for floating-point. (They can also hold integer values.) +(defx86reg fp0 xmm0) +(defx86reg fp1 xmm1) +(defx86reg fp2 xmm2) +(defx86reg fp3 xmm3) +(defx86reg fp4 xmm4) +(defx86reg fp5 xmm5) +(defx86reg fp6 xmm6) +(defx86reg fp7 xmm7) + +(defx86reg fpzero fp7) + +;;; The 8 MMX registers overlap the x87 FPU. +;;; (so when/if we use the x87 FPU, we need to be careful with this) +(defx86reg stack-temp mm7) + +(defx86reg fname temp0) + +(defx86reg allocptr temp0) + +(defx86reg ra0 temp0) + +;;; We rely one at least one of %ra0/%fn pointing to the current function +;;; (or to a TRA that references the function) at all times. When we +;;; tail call something, we want %RA0 to point to our caller's TRA and +;;; %FN to point to the new function. Unless we go out of line to +;;; do tail calls, we need some register not involved in the calling +;;; sequence to hold the current function, since it might get GCed otherwise. +;;; (The odds of this happening are low, but non-zero.) +;;; xxx +(defx86reg xfn temp1) + +(defx86reg next-method-context temp0) + +;;; This follows the ppc32 scheme pretty closely. + +(defconstant nbits-in-word 32) +(defconstant nbits-in-byte 8) +(defconstant ntagbits 3) +(defconstant nlisptagbits 2) +(defconstant nfixnumtagbits 2) +(defconstant num-subtag-bits 8) +(defconstant subtagmask 255) +(defconstant fixnumshift 2) +(defconstant fixnum-shift 2) +(defconstant fulltagmask 7) +(defconstant tagmask 3) +(defconstant fixnummask 3) +(defconstant ncharcodebits 8) +(defconstant charcode-shift 8) +(defconstant word-shift 2) +(defconstant word-size-in-bytes 4) +(defconstant node-size word-size-in-bytes) +(defconstant dnode-size 8) +(defconstant dnode-align-bits 3) +(defconstant dnode-shift dnode-align-bits) +(defconstant bitmap-shift 5) + +(defconstant fixnumone (ash 1 fixnumshift)) +(defconstant fixnum-one fixnumone) +(defconstant fixnum1 fixnumone) + +(defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits)))) +(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits))))) + +;;; bits correspond to reg encoding used in instructions +;;; 7 6 5 4 3 2 1 0 +;;; edi esi ebp esp ebx edx ecx eax + +(defconstant default-node-regs-mask #b11001110) + +;;; 2-bit "lisptag" values +(defconstant tag-fixnum 0) +(defconstant tag-list 1) ;a misnomer now +(defconstant tag-misc 2) +(defconstant tag-imm 3) + +;;; 3-bit "fulltag" values +(defconstant fulltag-even-fixnum 0) +(defconstant fulltag-cons 1) +(defconstant fulltag-nodeheader 2) +(defconstant fulltag-imm 3) +(defconstant fulltag-odd-fixnum 4) +(defconstant fulltag-tra 5) ;was for nil on PPC32 +(defconstant fulltag-misc 6) +(defconstant fulltag-immheader 7) + +(defmacro define-subtag (name tag subtag) + `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,subtag ntagbits)))) + +(defmacro define-imm-subtag (name subtag) + `(define-subtag ,name fulltag-immheader ,subtag)) + +(defmacro define-node-subtag (name subtag) + `(define-subtag ,name fulltag-nodeheader ,subtag)) + +;;; The order in which various header values are defined is +;;; significant in several ways: +;;; 1) Numeric subtags precede non-numeric ones; there are further +;;; orderings among numeric subtags. +;;; 2) All subtags which denote CL arrays are preceded by those that +;;; don't, with a further ordering which requires that +;;; (< header-arrayH header-vectorH ,@all-other-CL-vector-types) +;;; 3) The element-size of ivectors is determined by the ordering of +;;; ivector subtags. +;;; 4) All subtags are >= fulltag-immheader. + +;;; Numeric subtags +(define-imm-subtag bignum 0) +(defconstant min-numeric-subtag subtag-bignum) +(define-node-subtag ratio 1) +(defconstant max-rational-subtag subtag-ratio) + +(define-imm-subtag single-float 1) +(define-imm-subtag double-float 2) +(defconstant min-float-subtag subtag-single-float) +(defconstant max-float-subtag subtag-double-float) +(defconstant max-real-subtag subtag-double-float) + +(define-node-subtag complex 3) +(defconstant max-numeric-subtag subtag-complex) + +;;; CL array types. There are more immediate types than node types; +;;; all CL array subtags must be > than all non-CL-array subtags. So +;;; we start by defining the immediate subtags in decreasing order, +;;; starting with that subtag whose element size isn't an integral +;;; number of bits and ending with those whose element size - like all +;;; non-CL-array fulltag-immheader types - is 32 bits. + +(define-imm-subtag bit-vector 31) +(define-imm-subtag double-float-vector 30) +(define-imm-subtag s16-vector 29) +(define-imm-subtag u16-vector 28) +(defconstant min-16-bit-ivector-subtag subtag-u16-vector) +(defconstant max-16-bit-ivector-subtag subtag-s16-vector) + +;imm-subtag 27 unused + +(define-imm-subtag s8-vector 26) +(define-imm-subtag u8-vector 25) +(defconstant min-8-bit-ivector-subtag subtag-u8-vector) +(defconstant max-8-bit-ivector-subtag (logior fulltag-immheader (ash 27 ntagbits))) + +(define-imm-subtag simple-base-string 24) +(define-imm-subtag fixnum-vector 23) +(define-imm-subtag s32-vector 22) +(define-imm-subtag u32-vector 21) +(define-imm-subtag single-float-vector 20) +(defconstant max-32-bit-ivector-subtag (logior fulltag-immheader (ash 24 ntagbits))) +(defconstant min-cl-ivector-subtag subtag-single-float-vector) + +(define-node-subtag arrayH 19) +(define-node-subtag vectorH 20) +(assert (< subtag-arrayH subtag-vectorH min-cl-ivector-subtag)) +(define-node-subtag simple-vector 21) ; Only one such subtag +(assert (< subtag-arrayH subtag-vectorH subtag-simple-vector)) +(defconstant min-vector-subtag subtag-vectorH) +(defconstant min-array-subtag subtag-arrayH) + +(define-imm-subtag macptr 3) +(defconstant min-non-numeric-imm-subtag subtag-macptr) +(assert (> min-non-numeric-imm-subtag max-numeric-subtag)) +(define-imm-subtag dead-macptr 4) +;;(define-imm-subtag unused 5) ;was creole-object +;;(define-imm-subtag unused 6) ;was code-vector +(define-imm-subtag xcode-vector 7) + +;;; immediate subtags +(define-subtag unbound fulltag-imm 6) +(defconstant unbound-marker subtag-unbound) +(defconstant undefined unbound-marker) +(define-subtag character fulltag-imm 9) +(define-subtag slot-unbound fulltag-imm 10) +(defconstant slot-unbound-marker subtag-slot-unbound) +(define-subtag illegal fulltag-imm 11) +(defconstant illegal-marker subtag-illegal) +(define-subtag forward-marker fulltag-imm 28) +(define-subtag reserved-frame fulltag-imm 29) +(defconstant reserved-frame-marker subtag-reserved-frame) +(define-subtag no-thread-local-binding fulltag-imm 30) + +;;; This has two functions: it tells the link-inverting marker where +;;; the code ends and the self-reference table and constants start, and it +;;; ensures that the 0th constant will never be in the same memozized +;;; dnode as some (unboxed) word of machine code. I'm not sure if +;;; there's a better way to do either of those things. +;;; +;;; Depending on how you look at it, we either lose 8 bytes per +;;; function, or gain 7 bytes of otherwise unused space for debugging +;;; info. +;;; xxx -- comments above not right for x8632 +(define-subtag function-boundary-marker fulltag-imm 31) +(defconstant function-boundary-marker subtag-function-boundary-marker) +(defconstant max-non-array-imm-subtag (logior (ash 19 ntagbits) fulltag-immheader)) + +(define-node-subtag catch-frame 4) +(defconstant min-non-numeric-node-subtag subtag-catch-frame) +(assert (> min-non-numeric-node-subtag max-numeric-subtag)) +(define-node-subtag function 5) +(define-node-subtag basic-stream 6) +(define-node-subtag symbol 7) +(define-node-subtag lock 8) +(define-node-subtag hash-vector 9) +(define-node-subtag pool 10) +(define-node-subtag weak 11) +(define-node-subtag package 12) +(define-node-subtag slot-vector 13) +(define-node-subtag instance 14) +(define-node-subtag struct 15) +(define-node-subtag istruct 16) +(define-node-subtag value-cell 17) +(define-node-subtag xfunction 18) ; Function for cross-development + +(defconstant max-non-array-node-subtag (logior (ash 18 ntagbits) fulltag-nodeheader)) + +(defconstant misc-header-offset (- fulltag-misc)) +(defconstant misc-subtag-offset misc-header-offset) +(defconstant misc-data-offset (+ misc-header-offset node-size)) +(defconstant misc-dfloat-offset ( + misc-header-offset 8)) + +(defconstant max-64-bit-constant-index (ash 1 24)) +(defconstant max-32-bit-constant-index (ash 1 24)) +(defconstant max-16-bit-constant-index (ash 1 24)) +(defconstant max-8-bit-constant-index (ash 1 24)) +(defconstant max-1-bit-constant-index (ash 1 24)) + +) ;eval-when + +;;; On IA-32, the tag which was used for nil on ppc32 is now used for +;;; tagged return addresses. We therefore make nil a distinguished +;;; CONS. This way, CAR and CDR can just check the tag, and +;;; CONSP/RPLACA/RPLACD can check the tag and complain if the argument +;;; is NIL. +(defconstant canonical-nil-value (+ #x13000 fulltag-cons)) +(defconstant canonical-t-value (+ #x13008 fulltag-misc)) +(defconstant t-offset (- canonical-t-value canonical-nil-value)) + +(defconstant misc-bias fulltag-misc) +(defconstant cons-bias fulltag-cons) + + +(defmacro define-storage-layout (name origin &rest cells) + `(progn + (ccl::defenum (:start ,origin :step 4) + ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells)) + (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells) 4)))) + +(defmacro define-lisp-object (name tagname &rest cells) + `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells)) + +(defmacro define-fixedsized-object (name &rest non-header-cells) + `(progn + (define-lisp-object ,name fulltag-misc header ,@non-header-cells) + (ccl::defenum () + ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells)) + (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells)))) + +(define-lisp-object cons tag-list + cdr + car) + +(define-fixedsized-object ratio + numer + denom) + +(define-fixedsized-object single-float + value) + +(define-fixedsized-object double-float + pad + value + val-high) + +(define-fixedsized-object complex + realpart + imagpart) + +;;; There are two kinds of macptr; use the length field of the header if you +;;; need to distinguish between them +(define-fixedsized-object macptr + address + domain + type +) + +(define-fixedsized-object xmacptr + address + domain + type + flags + link +) + +;;; Need to think about catch frames on x8632, too. +(define-fixedsized-object catch-frame + catch-tag ; # -> unwind-protect, else catch + link ; tagged pointer to next older catch frame + mvflag ; 0 if single-value, 1 if uwp or multiple-value + esp ; + ebp + foreign-sp + db-link ; value of dynamic-binding link on thread entry. + xframe ; exception-frame link + pc ; tra of catch exit/unwind cleanup +) + +(define-fixedsized-object lock + _value ;finalizable pointer to kernel object + kind ; '0 = recursive-lock, '1 = rwlock + writer ;tcr of owning thread or 0 + name + whostate + whostate-2 + ) + + + +(define-fixedsized-object symbol + pname + vcell + fcell + package-predicate + flags + plist + binding-index +) + +(defconstant nilsym-offset (+ t-offset symbol.size)) + +(define-fixedsized-object vectorH + logsize ; fillpointer if it has one, physsize otherwise + physsize ; total size of (possibly displaced) data vector + data-vector ; object this header describes + displacement ; true displacement or 0 + flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector. +) + +(define-lisp-object arrayH fulltag-misc + header ; subtag = subtag-arrayH + rank ; NEVER 1 + physsize ; total size of (possibly displaced) data vector + data-vector ; object this header describes + displacement ; true displacement or 0 + flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector. + ;; Dimensions follow +) + +(defconstant arrayH.rank-cell 0) +(defconstant arrayH.physsize-cell 1) +(defconstant arrayH.data-vector-cell 2) +(defconstant arrayH.displacement-cell 3) +(defconstant arrayH.flags-cell 4) +(defconstant arrayH.dim0-cell 5) + +(defconstant arrayH.flags-cell-bits-byte (byte 8 0)) +(defconstant arrayH.flags-cell-subtag-byte (byte 8 8)) + + +(define-fixedsized-object value-cell + value) + +(define-storage-layout lisp-frame 0 + backptr + return-address + xtra) + +(define-storage-layout tsp-frame 0 + backptr + ebp) + +(define-storage-layout csp-frame 0 + backptr + ebp) + +(define-storage-layout xcf 0 ;"exception callback frame" + backptr + return-address ; always 0 + nominal-function + relative-pc + containing-object + xp + ra0 + foreign-sp ;value of tcr.foreign_sp + prev-xframe ;tcr.xframe before exception + ) ;(last 2 needed by apply-in-frame) + +;;; The kernel uses these (rather generically named) structures +;;; to keep track of various memory regions it (or the lisp) is +;;; interested in. + +(define-storage-layout area 0 + pred ; pointer to preceding area in DLL + succ ; pointer to next area in DLL + low ; low bound on area addresses + high ; high bound on area addresses. + active ; low limit on stacks, high limit on heaps + softlimit ; overflow bound + hardlimit ; another one + code ; an area-code; see below + markbits ; bit vector for GC + ndnodes ; "active" size of dynamic area or stack + older ; in EGC sense + younger ; also for EGC + h ; Handle or null pointer + softprot ; protected_area structure pointer + hardprot ; another one. + owner ; fragment (library) which "owns" the area + refbits ; bitvector for intergenerational refernces + threshold ; for egc + gc-count ; generational gc count. + static-dnodes ; for honsing, etc. + static-used ; bitvector +) + +(define-storage-layout protected-area 0 + next + start ; first byte (page-aligned) that might be protected + end ; last byte (page-aligned) that could be protected + nprot ; Might be 0 + protsize ; number of bytes to protect + why) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant tcr-bias 0)) + +(define-storage-layout tcr (- tcr-bias) + next ; in doubly-linked list + prev ; in doubly-linked list + node-regs-mask ; bit set means corresponding reg contains node + linear + ;; save0 *must* be aligned on a 16-byte boundary! + save0 ;spill area for node registers + save1 ; (caller saved) + save2 ; probably saved/restored in + save3 ; callout/trap handlers + save-ebp ; lisp frame ptr for foreign code + lisp-mxcsr + foreign-mxcsr + db-link ; special binding chain head + catch-top ; top catch frame + save-vsp ; SP when in foreign code + save-tsp ; TSP, at all times + foreign-sp ; SP when in lisp code + cs-area ; cstack area pointer + vs-area ; vstack area pointer + ts-area ; tstack area pointer + cs-limit ; cstack overflow limit + total-bytes-allocated-low + total-bytes-allocated-high + log2-allocation-quantum ; unboxed + interrupt-pending ; fixnum + xframe ; exception frame linked list + errno-loc ; thread-private, maybe + ffi-exception ; fpscr bits from ff-call. + osid ; OS thread id + valence ; odd when in foreign code + foreign-exception-status + native-thread-info + native-thread-id + last-allocptr + save-allocptr + save-allocbase + reset-completion + activate + suspend-count + suspend-context + pending-exception-context + suspend ; semaphore for suspension notify + resume ; sempahore for resumption notify + flags ; foreign, being reset, ... + gc-context + termination-semaphore + unwinding + tlb-limit + tlb-pointer + shutdown-count + next-tsp + safe-ref-address + ldt-selector + scratch-mxcsr ;used for reading/writing mxcsr + unboxed0 ;unboxed scratch locations + unboxed1 + next-method-context ;used in lieu of register + save-eflags + allocated ;maybe unaligned TCR pointer + pending-io-info + io-datum ;for windows overlapped I/O +) + +(defconstant interrupt-level-binding-index (ash 1 fixnumshift)) + +(define-storage-layout lockptr 0 + avail + owner + count + signal + waiting + malloced-ptr + spinlock) + +(define-storage-layout rwlock 0 + spin + state + blocked-writers + blocked-readers + writer + reader-signal + writer-signal + malloced-ptr + ) + +(defmacro define-header (name element-count subtag) + `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag))) + +(define-header single-float-header single-float.element-count subtag-single-float) +(define-header double-float-header double-float.element-count subtag-double-float) + +;;; We could possibly have a one-digit bignum header when dealing +;;; with "small bignums" in some bignum code. Like other cases of +;;; non-normalized bignums, they should never escape from the lab. +(define-header one-digit-bignum-header 1 subtag-bignum) +(define-header two-digit-bignum-header 2 subtag-bignum) +(define-header three-digit-bignum-header 3 subtag-bignum) +(define-header symbol-header symbol.element-count subtag-symbol) +(define-header value-cell-header value-cell.element-count subtag-value-cell) +(define-header macptr-header macptr.element-count subtag-macptr) + +;;; see x86-clos.lisp +(defconstant gf-code-size 30) + +(defun %kernel-global (sym) + (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=))) + (if pos + (- (+ fulltag-cons (* (1+ pos) node-size))) + (error "Unknown kernel global : ~s ." sym)))) + +(defmacro kernel-global (sym) + (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=))) + (if pos + (- (+ fulltag-cons (* (1+ pos) node-size))) + (error "Unknown kernel global : ~s ." sym)))) + +(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step node-size) + fd-setsize-bytes + do-fd-set + do-fd-clr + do-fd-is-set + do-fd-zero + MakeDataExecutable + GetSharedLibrary + FindSymbol + malloc + free + jvm-init + tcr-frame-ptr + register-xmacptr-dispose-function + open-debug-output + get-r-debug + restore-soft-stack-limit + egc-control + lisp-bug + NewThread + cooperative-thread-startup + DisposeThread + ThreadCurrentStackSpace + usage-exit + save-fp-context + restore-fp-context + put-altivec-registers ;is there any + get-altivec-registers ;point to these on x86? + new-semaphore + wait-on-semaphore + signal-semaphore + destroy-semaphore + new-recursive-lock + lock-recursive-lock + unlock-recursive-lock + destroy-recursive-lock + suspend-other-threads + resume-other-threads + suspend-tcr + resume-tcr + rwlock-new + rwlock-destroy + rwlock-rlock + rwlock-wlock + rwlock-unlock + recursive-lock-trylock + foreign-name-and-offset + lisp-read + lisp-write + lisp-open + lisp-fchmod + lisp-lseek + lisp-close + lisp-ftruncate + lisp-stat + lisp-fstat + lisp-futex + lisp-opendir + lisp-readdir + lisp-closedir + lisp-pipe + lisp-gettimeofday + lisp-sigexit +) + +(defmacro nrs-offset (name) + (let* ((pos (position name x86::*x86-nilreg-relative-symbols* :test #'eq))) + (if pos (* (1- pos) symbol.size)))) + +(defmacro with-stack-short-floats (specs &body body) + (ccl::collect ((binds) + (inits) + (names)) + (dolist (spec specs) + (let ((name (first spec))) + (binds `(,name (ccl::%make-sfloat))) + (names name) + (let ((init (second spec))) + (when init + (inits `(ccl::%short-float ,init ,name)))))) + `(let* ,(binds) + (declare (dynamic-extent ,@(names)) + (short-float ,@(names))) + ,@(inits) + ,@body))) + +(defparameter *x8632-target-uvector-subtags* + `((:bignum . ,subtag-bignum) + (:ratio . ,subtag-ratio) + (:single-float . ,subtag-single-float) + (:double-float . ,subtag-double-float) + (:complex . ,subtag-complex ) + (:symbol . ,subtag-symbol) + (:function . ,subtag-function ) + (:xcode-vector . ,subtag-xcode-vector) + (:macptr . ,subtag-macptr ) + (:catch-frame . ,subtag-catch-frame) + (:struct . ,subtag-struct ) + (:istruct . ,subtag-istruct ) + (:pool . ,subtag-pool ) + (:population . ,subtag-weak ) + (:hash-vector . ,subtag-hash-vector ) + (:package . ,subtag-package ) + (:value-cell . ,subtag-value-cell) + (:instance . ,subtag-instance ) + (:lock . ,subtag-lock ) + (:slot-vector . ,subtag-slot-vector) + (:basic-stream . ,subtag-basic-stream) + (:simple-string . ,subtag-simple-base-string ) + (:bit-vector . ,subtag-bit-vector ) + (:signed-8-bit-vector . ,subtag-s8-vector ) + (:unsigned-8-bit-vector . ,subtag-u8-vector ) + (:signed-16-bit-vector . ,subtag-s16-vector ) + (:unsigned-16-bit-vector . ,subtag-u16-vector ) + (:signed-32-bit-vector . ,subtag-s32-vector ) + (:fixnum-vector . ,subtag-fixnum-vector) + (:unsigned-32-bit-vector . ,subtag-u32-vector ) + (:single-float-vector . ,subtag-single-float-vector) + (:double-float-vector . ,subtag-double-float-vector ) + (:simple-vector . ,subtag-simple-vector ) + (:vector-header . ,subtag-vectorH) + (:array-header . ,subtag-arrayH))) + +;;; This should return NIL unless it's sure of how the indicated +;;; type would be represented (in particular, it should return +;;; NIL if the element type is unknown or unspecified at compile-time. +(defun x8632-array-type-name-from-ctype (ctype) + (when (typep ctype 'ccl::array-ctype) + (let* ((element-type (ccl::array-ctype-element-type ctype))) + (typecase element-type + (ccl::class-ctype + (let* ((class (ccl::class-ctype-class element-type))) + (if (or (eq class ccl::*character-class*) + (eq class ccl::*base-char-class*) + (eq class ccl::*standard-char-class*)) + :simple-string + :simple-vector))) + (ccl::numeric-ctype + (if (eq (ccl::numeric-ctype-complexp element-type) :complex) + :simple-vector + (case (ccl::numeric-ctype-class element-type) + (integer + (let* ((low (ccl::numeric-ctype-low element-type)) + (high (ccl::numeric-ctype-high element-type))) + (cond ((or (null low) (null high)) :simple-vector) + ((and (>= low 0) (<= high 1) :bit-vector)) + ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector) + ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector) + ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector)) + ((and (>= low -128) (<= high 127)) :signed-8-bit-vector) + ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector)) + ((and (>= low target-most-negative-fixnum) + (<= high target-most-positive-fixnum)) + :fixnum-vector) + ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31)))) + :signed-32-bit-vector) + (t :simple-vector)))) + (float + (case (ccl::numeric-ctype-format element-type) + ((double-float long-float) :double-float-vector) + ((single-float short-float) :single-float-vector) + (t :simple-vector))) + (t :simple-vector)))) + (ccl::unknown-ctype) + (ccl::named-ctype + (if (eq element-type ccl::*universal-type*) + :simple-vector)) + (t nil))))) + +(defun x8632-misc-byte-count (subtag element-count) + (declare (fixnum subtag)) + (if (or (= fulltag-nodeheader (logand subtag fulltagmask)) + (<= subtag max-32-bit-ivector-subtag)) + (ash element-count 2) + (if (<= subtag max-8-bit-ivector-subtag) + element-count + (if (<= subtag max-16-bit-ivector-subtag) + (ash element-count 1) + (if (= subtag subtag-bit-vector) + (ash (+ element-count 7) -3) + (+ 4 (ash element-count 3))))))) + +(defparameter *x8632-subprims-shift* 2) +(defconstant x8632-subprims-base #x15000) + +(declaim (special *x8632-subprims*)) + +(let* ((origin x8632-subprims-base) + (step (ash 1 *x8632-subprims-shift*))) + (flet ((define-x8632-subprim (name) + (ccl::make-subprimitive-info :name (string name) + :offset (prog1 origin + (incf origin step))))) + (macrolet ((defx8632subprim (name) + `(define-x8632-subprim ',name))) + (defparameter *x8632-subprims* + (vector + (defx8632subprim .SPjmpsym) + (defx8632subprim .SPjmpnfn) + (defx8632subprim .SPfuncall) + (defx8632subprim .SPmkcatch1v) + (defx8632subprim .SPmkunwind) + (defx8632subprim .SPmkcatchmv) + (defx8632subprim .SPthrow) + (defx8632subprim .SPnthrowvalues) + (defx8632subprim .SPnthrow1value) + (defx8632subprim .SPbind) + (defx8632subprim .SPbind-self) + (defx8632subprim .SPbind-nil) + (defx8632subprim .SPbind-self-boundp-check) + (defx8632subprim .SPrplaca) + (defx8632subprim .SPrplacd) + (defx8632subprim .SPconslist) + (defx8632subprim .SPconslist-star) + (defx8632subprim .SPstkconslist) + (defx8632subprim .SPstkconslist-star) + (defx8632subprim .SPmkstackv) + (defx8632subprim .SPsubtag-misc-ref) + (defx8632subprim .SPsetqsym) + (defx8632subprim .SPprogvsave) + (defx8632subprim .SPstack-misc-alloc) + (defx8632subprim .SPgvector) + (defx8632subprim .SPnvalret) + (defx8632subprim .SPmvpass) + (defx8632subprim .SPrecover-values-for-mvcall) + (defx8632subprim .SPnthvalue) + (defx8632subprim .SPvalues) + (defx8632subprim .SPdefault-optional-args) + (defx8632subprim .SPopt-supplied-p) + (defx8632subprim .SPheap-rest-arg) + (defx8632subprim .SPreq-heap-rest-arg) + (defx8632subprim .SPheap-cons-rest-arg) + (defx8632subprim .SPsimple-keywords) + (defx8632subprim .SPkeyword-args) + (defx8632subprim .SPkeyword-bind) + (defx8632subprim .SPffcall) + (defx8632subprim .SParef2) + (defx8632subprim .SPksignalerr) + (defx8632subprim .SPstack-rest-arg) + (defx8632subprim .SPreq-stack-rest-arg) + (defx8632subprim .SPstack-cons-rest-arg) + (defx8632subprim .SPpoweropen-callbackX) ;needed on x86? + (defx8632subprim .SPcall-closure) + (defx8632subprim .SPgetXlong) + (defx8632subprim .SPspreadargz) + (defx8632subprim .SPtfuncallgen) + (defx8632subprim .SPtfuncallslide) + (defx8632subprim .SPtfuncallvsp) + (defx8632subprim .SPtcallsymgen) + (defx8632subprim .SPtcallsymslide) + (defx8632subprim .SPtcallsymvsp) + (defx8632subprim .SPtcallnfngen) + (defx8632subprim .SPtcallnfnslide) + (defx8632subprim .SPtcallnfnvsp) + (defx8632subprim .SPmisc-ref) + (defx8632subprim .SPmisc-set) + (defx8632subprim .SPstkconsyz) + (defx8632subprim .SPstkvcell0) + (defx8632subprim .SPstkvcellvsp) + (defx8632subprim .SPmakestackblock) + (defx8632subprim .SPmakestackblock0) + (defx8632subprim .SPmakestacklist) + (defx8632subprim .SPstkgvector) + (defx8632subprim .SPmisc-alloc) + (defx8632subprim .SPpoweropen-ffcallX) ;needed on x86? + (defx8632subprim .SPgvset) + (defx8632subprim .SPmacro-bind) + (defx8632subprim .SPdestructuring-bind) + (defx8632subprim .SPdestructuring-bind-inner) + (defx8632subprim .SPrecover-values) + (defx8632subprim .SPvpopargregs) + (defx8632subprim .SPinteger-sign) + (defx8632subprim .SPsubtag-misc-set) + (defx8632subprim .SPspread-lexpr-z) + (defx8632subprim .SPstore-node-conditional) + (defx8632subprim .SPreset) + (defx8632subprim .SPmvslide) + (defx8632subprim .SPsave-values) + (defx8632subprim .SPadd-values) + (defx8632subprim .SPcallback) + (defx8632subprim .SPmisc-alloc-init) + (defx8632subprim .SPstack-misc-alloc-init) + (defx8632subprim .SPset-hash-key) + (defx8632subprim .SPaset2) + (defx8632subprim .SPcallbuiltin) + (defx8632subprim .SPcallbuiltin0) + (defx8632subprim .SPcallbuiltin1) + (defx8632subprim .SPcallbuiltin2) + (defx8632subprim .SPcallbuiltin3) + (defx8632subprim .SPpopj) + (defx8632subprim .SPrestorefullcontext) + (defx8632subprim .SPsavecontextvsp) + (defx8632subprim .SPsavecontext0) + (defx8632subprim .SPrestorecontext) + (defx8632subprim .SPlexpr-entry) + (defx8632subprim .SPsyscall2) + (defx8632subprim .SPbuiltin-plus) + (defx8632subprim .SPbuiltin-minus) + (defx8632subprim .SPbuiltin-times) + (defx8632subprim .SPbuiltin-div) + (defx8632subprim .SPbuiltin-eq) + (defx8632subprim .SPbuiltin-ne) + (defx8632subprim .SPbuiltin-gt) + (defx8632subprim .SPbuiltin-ge) + (defx8632subprim .SPbuiltin-lt) + (defx8632subprim .SPbuiltin-le) + (defx8632subprim .SPbuiltin-eql) + (defx8632subprim .SPbuiltin-length) + (defx8632subprim .SPbuiltin-seqtype) + (defx8632subprim .SPbuiltin-assq) + (defx8632subprim .SPbuiltin-memq) + (defx8632subprim .SPbuiltin-logbitp) + (defx8632subprim .SPbuiltin-logior) + (defx8632subprim .SPbuiltin-logand) + (defx8632subprim .SPbuiltin-ash) + (defx8632subprim .SPbuiltin-negate) + (defx8632subprim .SPbuiltin-logxor) + (defx8632subprim .SPbuiltin-aref1) + (defx8632subprim .SPbuiltin-aset1) + (defx8632subprim .SPbreakpoint) + (defx8632subprim .SPeabi-ff-call) + (defx8632subprim .SPeabi-callback) + (defx8632subprim .SPsyscall) + (defx8632subprim .SPgetu64) + (defx8632subprim .SPgets64) + (defx8632subprim .SPmakeu64) + (defx8632subprim .SPmakes64) + (defx8632subprim .SPspecref) + (defx8632subprim .SPspecset) + (defx8632subprim .SPspecrefcheck) + (defx8632subprim .SPrestoreintlevel) + (defx8632subprim .SPmakes32) + (defx8632subprim .SPmakeu32) + (defx8632subprim .SPgets32) + (defx8632subprim .SPgetu32) + (defx8632subprim .SPfix-overflow) + (defx8632subprim .SPmvpasssym) + (defx8632subprim .SParef3) + (defx8632subprim .SPaset3) + (defx8632subprim .SPffcall-return-registers) + (defx8632subprim .SPaset1) + (defx8632subprim .SPset-hash-key-conditional) + (defx8632subprim .SPunbind-interrupt-level) + (defx8632subprim .SPunbind) + (defx8632subprim .SPunbind-n) + (defx8632subprim .SPunbind-to) + (defx8632subprim .SPbind-interrupt-level-m1) + (defx8632subprim .SPbind-interrupt-level) + (defx8632subprim .SPbind-interrupt-level-0) + (defx8632subprim .SPprogvrestore) + (defx8632subprim .SPnmkunwind) + ))))) + + + +(defparameter *x8632-target-arch* + (arch::make-target-arch :name :x8632 + :lisp-node-size node-size + :nil-value canonical-nil-value + :fixnum-shift fixnumshift + :most-positive-fixnum target-most-positive-fixnum + :most-negative-fixnum target-most-negative-fixnum + :misc-data-offset misc-data-offset + :misc-dfloat-offset misc-dfloat-offset + :nbits-in-word nbits-in-word + :ntagbits ntagbits + :nlisptagbits nlisptagbits + :uvector-subtags *x8632-target-uvector-subtags* + :max-64-bit-constant-index max-64-bit-constant-index + :max-32-bit-constant-index max-32-bit-constant-index + :max-16-bit-constant-index max-16-bit-constant-index + :max-8-bit-constant-index max-8-bit-constant-index + :max-1-bit-constant-index max-1-bit-constant-index + :word-shift word-shift + :code-vector-prefix () + :gvector-types '(:ratio :complex :symbol :function + :catch-frame :struct :istruct + :pool :population :hash-vector + :package :value-cell :instance + :lock :slot-vector + :simple-vector) + :1-bit-ivector-types '(:bit-vector) + :8-bit-ivector-types '(:signed-8-bit-vector + :unsigned-8-bit-vector) + :16-bit-ivector-types '(:signed-16-bit-vector + :unsigned-16-bit-vector) + :32-bit-ivector-types '(:signed-32-bit-vector + :unsigned-32-bit-vector + :single-float-vector + :fixnum-vector + :single-float + :double-float + :bignum + :simple-string) + :64-bit-ivector-types '(:double-float-vector) + :array-type-name-from-ctype-function + #'x8632-array-type-name-from-ctype + :package-name "X8632" + :t-offset t-offset + :array-data-size-function #'x8632-misc-byte-count + :numeric-type-name-to-typecode-function + #'(lambda (type-name) + (ecase type-name + (fixnum tag-fixnum) + (bignum subtag-bignum) + ((short-float single-float) subtag-single-float) + ((long-float double-float) subtag-double-float) + (ratio subtag-ratio) + (complex subtag-complex))) + :subprims-base x8632-subprims-base + :subprims-shift x8632::*x8632-subprims-shift* + :subprims-table x8632::*x8632-subprims* + :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus x8632::*x8632-subprims*))) + :unbound-marker-value unbound-marker + :slot-unbound-marker-value slot-unbound-marker + :fixnum-tag tag-fixnum + :single-float-tag subtag-single-float + :single-float-tag-is-subtag t + :double-float-tag subtag-double-float + :cons-tag fulltag-cons + :null-tag fulltag-cons + :symbol-tag subtag-symbol + :symbol-tag-is-subtag t + :function-tag subtag-function + :function-tag-is-subtag t + :big-endian nil + :misc-subtag-offset misc-subtag-offset + :car-offset cons.car + :cdr-offset cons.cdr + :subtag-char subtag-character + :charcode-shift charcode-shift + :fulltagmask fulltagmask + :fulltag-misc fulltag-misc + :char-code-limit #x110000 + )) + +;; arch macros + +(defmacro defx8632archmacro (name lambda-list &body body) + `(arch::defarchmacro :x8632 ,name ,lambda-list ,@body)) + +(defx8632archmacro ccl::%make-sfloat () + `(ccl::%alloc-misc x8632::single-float.element-count x8632::subtag-single-float)) + +(defx8632archmacro ccl::%make-dfloat () + `(ccl::%alloc-misc x8632::double-float.element-count x8632::subtag-double-float)) + +(defx8632archmacro ccl::%numerator (x) + `(ccl::%svref ,x x8632::ratio.numer-cell)) + +(defx8632archmacro ccl::%denominator (x) + `(ccl::%svref ,x x8632::ratio.denom-cell)) + +(defx8632archmacro ccl::%realpart (x) + `(ccl::%svref ,x x8632::complex.realpart-cell)) + +(defx8632archmacro ccl::%imagpart (x) + `(ccl::%svref ,x x8632::complex.imagpart-cell)) + +;;; +(defx8632archmacro ccl::%get-single-float-from-double-ptr (ptr offset) + `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset) + (ccl::%alloc-misc 1 x8632::subtag-single-float))) + +(defx8632archmacro ccl::codevec-header-p (word) + (declare (ignore word)) + (error "~s makes no sense on :X8632" 'ccl::codevec-header-p)) + +(defx8632archmacro ccl::immediate-p-macro (thing) + (let* ((tag (gensym))) + `(let* ((,tag (ccl::lisptag ,thing))) + (declare (fixnum ,tag)) + (or (= ,tag x8632::tag-fixnum) + (= ,tag x8632::tag-imm))))) + +(defx8632archmacro ccl::hashed-by-identity (thing) + (let* ((typecode (gensym))) + `(let* ((,typecode (ccl::typecode ,thing))) + (declare (fixnum ,typecode)) + (or + (= ,typecode x8632::tag-fixnum) + (= ,typecode x8632::tag-imm) + (= ,typecode x8632::subtag-symbol) + (= ,typecode x8632::subtag-instance))))) + +;;; +(defx8632archmacro ccl::%get-kernel-global (name) + `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value) + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name))))) + +(defx8632archmacro ccl::%get-kernel-global-ptr (name dest) + `(ccl::%setf-macptr + ,dest + (ccl::%fixnum-ref-macptr 0 (+ ,(ccl::target-nil-value) + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name)))))) + +(defx8632archmacro ccl::%target-kernel-global (name) + `(x8632::%kernel-global ,name)) + +(defx8632archmacro ccl::lfun-vector (fun) + fun) + +(defx8632archmacro ccl::lfun-vector-lfun (lfv) + lfv) + +(defx8632archmacro ccl::area-code () + area.code) + +(defx8632archmacro ccl::area-succ () + area.succ) + +(defx8632archmacro ccl::nth-immediate (f i) + `(ccl::%nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)))) + +(defx8632archmacro ccl::set-nth-immediate (f i new) + `(ccl::%set-nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)) ,new)) + +(defx8632archmacro ccl::symptr->symvector (s) + s) + +(defx8632archmacro ccl::symvector->symptr (s) + s) + +(defx8632archmacro ccl::function-to-function-vector (f) + f) + +(defx8632archmacro ccl::function-vector-to-function (v) + v) + +(defx8632archmacro ccl::with-ffcall-results ((buf) &body body) + ;; Reserve space for eax,edx,st0 only. + (let* ((size (+ (* 2 4) (* 1 8)))) + `(ccl::%stack-block ((,buf ,size :clear t)) + ,@body))) + +;;; When found at a tagged return address, the instruction +;;; (movl ($ imm32) (% fn)) +;;; lets the runtime easily map a return address to the containing +;;; function. +;;; +;;; The notation ($ :self) is used in the assembler to mean "a 32-bit +;;; immediate whose offset will be remembered in a table at the end of +;;; the function object." +;;; +;;; Before the function is made executable (or when the GC moves the +;;; function), these :self immediates are filled in with the actual +;;; address of the function. + +(defconstant recover-fn-opcode-byte #b10111111) ;when %fn is %edi +(defconstant recover-fn-address-offset 1) + +;;; For backtrace: the relative PC of an argument-check trap +;;; must be less than or equal to this value. (Because of +;;; the way that we do "anchored" UUOs, it should always be =.) +;;; (maybe not = on x8632) +(defconstant arg-check-trap-pc-limit 7) + +(provide "X8632-ARCH") Index: /branches/qres/ccl/compiler/X86/X8632/x8632-backend.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/X8632/x8632-backend.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/X8632/x8632-backend.lisp (revision 13564) @@ -0,0 +1,497 @@ +;;;-*- Mode: Lisp; Package: CCL -*- + +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "BACKEND")) + +(eval-when (:compile-toplevel :execute) + (require "NXENV") + (require "X8632ENV")) + +(defvar *x8632-vinsn-templates* (make-hash-table :test #'eq)) + +(defvar *known-x8632-backends* ()) + +#+darwinx86-target +(defvar *darwinx8632-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8632-vinsn-templates* + :p2-template-hash-name '*x8632-vinsn-templates* + :p2-compile 'x862-compile + :platform-syscall-mask (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) + :target-specific-features + '(:x8632 :x86-target :darwin-target :darwinx86-target :x8632-target + :darwinx8632-target + :little-endian-target + :32-bit-target) + :target-fasl-pathname (make-pathname :type "dx32fsl") + :target-platform (logior platform-cpu-x86 + platform-os-darwin + platform-word-size-32) + :target-os :darwinx86 + :name :darwinx8632 + :target-arch-name :x8632 + :target-foreign-type-data nil + :target-arch x8632::*x8632-target-arch* + :lisp-context-register x8632::fs + :num-arg-regs 2 + )) + + +#+darwinx86-target +(pushnew *darwinx8632-backend* *known-x8632-backends* :key #'backend-name) + +#+linuxx86-target +(defvar *linuxx8632-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8632-vinsn-templates* + :p2-template-hash-name '*x8632-vinsn-templates* + :p2-compile 'x862-compile + :platform-syscall-mask (logior platform-os-linux platform-cpu-x86 platform-word-size-32) + :target-specific-features + '(:x8632 :x86-target :linux-target :linuxx86-target :x8632-target + :linuxx8632-target + :little-endian-target + :32-bit-target) + :target-fasl-pathname (make-pathname :type "lx32fsl") + :target-platform (logior platform-cpu-x86 + platform-os-linux + platform-word-size-32) + :target-os :linuxx86 + :name :linuxx8632 + :target-arch-name :x8632 + :target-foreign-type-data nil + :target-arch x8632::*x8632-target-arch* + :lisp-context-register x8632::fs + :num-arg-regs 2 + )) + +#+linuxx86-target +(pushnew *linuxx8632-backend* *known-x8632-backends* :key #'backend-name) + +#+windows-target +(defvar *win32-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8632-vinsn-templates* + :p2-template-hash-name '*x8632-vinsn-templates* + :p2-compile 'x862-compile + :platform-syscall-mask (logior platform-os-windows platform-cpu-x86 platform-word-size-32) + :target-specific-features + '(:x8632 :x86-target :windows-target :win32-target :x8632-target + :windowsx8632-target + :little-endian-target + :32-bit-target) + :target-fasl-pathname (make-pathname :type "wx32fsl") + :target-platform (logior platform-cpu-x86 + platform-os-windows + platform-word-size-32) + :target-os :win32 + :name :win32 + :target-arch-name :x8632 + :target-foreign-type-data nil + :target-arch x8632::*x8632-target-arch* + :lisp-context-register x8632::es + :num-arg-regs 2 + )) + +#+windows-target +(pushnew *win32-backend* *known-x8632-backends* :key #'backend-name) + +#+solaris-target +(defvar *solaris-x8632-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8632-vinsn-templates* + :p2-template-hash-name '*x8632-vinsn-templates* + :p2-compile 'x862-compile + :platform-syscall-mask (logior platform-os-solaris platform-cpu-x86 platform-word-size-32) + :target-specific-features + '(:x8632 :x86-target :solaris-target :x8632-target + :solarisx8632-target + :little-endian-target + :32-bit-target) + :target-fasl-pathname (make-pathname :type "sx32fsl") + :target-platform (logior platform-cpu-x86 + platform-os-solaris + platform-word-size-32) + :target-os :solarisx8632 + :name :solarisx8632 + :target-arch-name :x8632 + :target-foreign-type-data nil + :target-arch x8632::*x8632-target-arch* + :lisp-context-register x8632::fs + :num-arg-regs 2 + )) +#+solaris-target +(pushnew *solaris-x8632-backend* *known-x8632-backends* :key #'backend-name) + +#+freebsd-target +(defvar *freebsd-x8632-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8632-vinsn-templates* + :p2-template-hash-name '*x8632-vinsn-templates* + :p2-compile 'x862-compile + :platform-syscall-mask (logior platform-os-freebsd platform-cpu-x86 platform-word-size-32) + :target-specific-features + '(:x8632 :x86-target :freebsd-target :x8632-target + :freebsdsx8632-target + :little-endian-target + :32-bit-target) + :target-fasl-pathname (make-pathname :type "fx32fsl") + :target-platform (logior platform-cpu-x86 + platform-os-freebsd + platform-word-size-32) + :target-os :freebsdx8632 + :name :freebsdx8632 + :target-arch-name :x8632 + :target-foreign-type-data nil + :target-arch x8632::*x8632-target-arch* + :lisp-context-register x8632::fs + :num-arg-regs 2 + )) + +#+freebsd-target +(pushnew *freebsd-x8632-backend* *known-x8632-backends* :key #'backend-name) + +(defvar *x8632-backend* (car *known-x8632-backends*)) + +(defun fixup-x8632-backend () + (dolist (b *known-x8632-backends*) + (setf #| (backend-lap-opcodes b) x86::*x86-opcodes* |# + (backend-p2-dispatch b) *x862-specials* + (backend-p2-vinsn-templates b) *x8632-vinsn-templates*) + (or (backend-lap-macros b) (setf (backend-lap-macros b) + (make-hash-table :test #'equalp))))) + + +(fixup-x8632-backend) + +#+x8632-target +(setq *host-backend* *x8632-backend* *target-backend* *x8632-backend*) + + +(defun setup-x8632-ftd (backend) + (or (backend-target-foreign-type-data backend) + (let* ((name (backend-name backend)) + (ftd + (case name + (:darwinx8632 + (make-ftd :interface-db-directory "ccl:darwin-x86-headers;" + :interface-package-name "X86-DARWIN32" + :attributes '(:bits-per-word 32 + :signed-char t + :struct-by-value t + :prepend-underscore t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-DARWIN32") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-DARWIN32") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-DARWIN32") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-DARWIN32"))) + (:linuxx8632 + (make-ftd :interface-db-directory "ccl:x86-headers;" + :interface-package-name "X86-LINUX32" + :attributes '(:bits-per-word 32 + :signed-char nil + :struct-by-value t + :float-results-in-x87 t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-LINUX32") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-LINUX32") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-LINUX32") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-LINUX32"))) + (:win32 + (make-ftd :interface-db-directory "ccl:win32-headers;" + :interface-package-name "WIN32" + :attributes '(:bits-per-word 32 + :signed-char nil + :struct-by-value t + :float-results-in-x87 t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "WIN32") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "WIN32") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "WIN32") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "WIN32"))) + (:solarisx8632 + (make-ftd :interface-db-directory "ccl:solarisx86-headers;" + :interface-package-name "X86-SOLARIS32" + :attributes '(:bits-per-word 32 + :signed-char nil + :struct-by-value t + :float-results-in-x87 t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-SOLARIS32") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-SOLARIS32") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-SOLARIS32") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-SOLARIS32"))) + (:freebsdx8632 + (make-ftd :interface-db-directory "ccl:freebsd-headers;" + :interface-package-name "X86-FREEBSD32" + :attributes '(:bits-per-word 32 + :signed-char nil + :struct-by-value t + :float-results-in-x87 t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-FREEBSD32") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-FREEBSD32") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-FREEBSD32") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-FREEBSD32"))) + ))) + (install-standard-foreign-types ftd) + (use-interface-dir :libc ftd) + (setf (backend-target-foreign-type-data backend) ftd)))) + +#-x8632-target +(setup-x8632-ftd *x8632-backend*) + +(pushnew *x8632-backend* *known-backends* :key #'backend-name) + +;;; FFI stuff. The vanilla i386 ABI always returns structures as a +;;; hidden first argument. Some systems (Darwin, FreeBSD) use a +;;; variant that returns small (<= 64 bit) structures in registers. + +;;; A returned structure is passed as a hidden first argument. +(defun x8632::record-type-returns-structure-as-first-arg (rtype) + (declare (ignore rtype)) + t) + +;;; All arguments are passed on the stack. +(defun x8632::expand-ff-call (callform args + &key (arg-coerce #'null-coerce-foreign-arg) + (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (struct-by-value-p nil) + (result-op nil) + (result-temp nil) + (result-form nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args)) + (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function + *target-ftd*) result-type) + (progn + (setq result-type *void-foreign-type* + result-type-spec :void) + (argforms :address) + (argforms result-form)) + (progn + (ecase (foreign-type-bits result-type) + (8 (setq result-type-spec :unsigned-byte + result-op '%get-unsigned-byte)) + (16 (setq result-type-spec :unsigned-halfword + result-op '%get-unsigned-word)) + (32 (setq result-type-spec :unsigned-fullword + result-op '%get-unsigned-long)) + (64 (setq result-type-spec :unsigned-doubleword + result-op '%%get-unsigned-longlong))) + (setq result-type (parse-foreign-type result-type-spec)) + (setq result-temp (gensym)) + (setq struct-by-value-p t)))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec)) + (bits (ensure-foreign-type-bits ftype))) + (when (and (typep ftype 'foreign-record-type) + (eq (foreign-record-type-kind ftype) + :transparent-union)) + (ensure-foreign-type-bits ftype) + (setq ftype (foreign-record-field-type + (car (foreign-record-type-fields ftype))) + arg-type-spec (foreign-type-to-representation-type + ftype) + bits (ensure-foreign-type-bits ftype))) + (if (typep ftype 'foreign-record-type) + (argforms (ceiling bits 32)) + (argforms (foreign-type-to-representation-type ftype))) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec + `(,@callform ,@(argforms))))) + (if struct-by-value-p + `(let* ((,result-temp (%null-ptr))) + (declare (dynamic-extent ,result-temp) + (type macptr ,result-temp)) + (%setf-macptr ,result-temp ,result-form) + (setf (,result-op ,result-temp 0) + ,call)) + call)))))) + +;;; Return 8 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args (not used on x8632) +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (not used on x8632) +;;; The byte offset of the foreign return address, relative to STACK-PTR +;;; The number of argument bytes pushed on the stack by the caller, or NIL +;;; if this can't be determined. (Only meaningful on Windows.) + +(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars + argspecs result-spec + struct-result-name) + (declare (ignore fp-args-ptr)) + (collect ((lets) + (rlets) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec))) + (when (typep rtype 'foreign-record-type) + (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function + *target-ftd*) rtype) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*) + (rlets (list struct-result-name (foreign-record-type-name rtype))))) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (offset 8)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4 + (- offset 8))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec)) + (bits (require-foreign-type-bits argtype)) + (double nil)) + (if (typep argtype 'foreign-record-type) + (let* ((form `(%inc-ptr ,stack-ptr + ,(prog1 offset + (incf offset + (* 4 (ceiling bits 32))))))) + (when name (lets (list name form)))) + (let* ((form `(, + (ecase (foreign-type-to-representation-type argtype) + (:single-float '%get-single-float) + (:double-float (setq double t) '%get-double-float) + (:signed-doubleword (setq double t) + '%%get-signed-longlong) + (:signed-fullword '%get-signed-long) + (:signed-halfword '%get-signed-word) + (:signed-byte '%get-signed-byte) + (:unsigned-doubleword (setq double t) + '%%get-unsigned-longlong) + (:unsigned-fullword '%get-unsigned-long) + (:unsigned-halfword '%get-unsigned-word) + (:unsigned-byte '%get-unsigned-byte) + (:address '%get-ptr)) + ,stack-ptr + ,offset))) + (when name (lets (list name form))) + (incf offset 4) + (when double (incf offset 4))))))))) + +(defun x8632::generate-callback-return-value (stack-ptr fp-args-ptr result + return-type struct-return-arg) + (declare (ignore fp-args-ptr)) + (unless (eq return-type *void-foreign-type*) + (if (typep return-type 'foreign-record-type) + ;; If the struct result is returned via a hidden argument, the + ;; return type would have been mapped to :VOID. On some + ;; systems, small (<= 64 bits) structs are returned by value, + ;; which we arrange to retrieve here. + (ecase (ensure-foreign-type-bits return-type) + (8 `(setf (%get-unsigned-byte ,stack-ptr -8) + (%get-unsigned-byte ,struct-return-arg 0))) + (16 `(setf (%get-unsigned-word ,stack-ptr -8) + (%get-unsigned-word ,struct-return-arg 0))) + (32 `(setf (%get-unsigned-long ,stack-ptr -8) + (%get-unsigned-long ,struct-return-arg 0))) + (64 `(setf (%%get-unsigned-longlong ,stack-ptr -8) + (%%get-unsigned-longlong ,struct-return-arg 0)))) + (let* ((return-type-keyword (foreign-type-to-representation-type + return-type))) + (collect ((forms)) + (forms 'progn) + (case return-type-keyword + (:single-float + (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1))) + (:double-float + (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2)))) + (forms + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + (:double-float '%get-double-float) + (:single-float '%get-single-float) + (:unsigned-fullword '%get-unsigned-long) + (t '%get-signed-long) + ) ,stack-ptr -8) ,result)) + (forms)))))) + + + +#+x8632-target +(require "X8632-VINSNS") + +(provide "X8632-BACKEND") + Index: /branches/qres/ccl/compiler/X86/X8632/x8632-vinsns.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/X8632/x8632-vinsns.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/X8632/x8632-vinsns.lisp (revision 13564) @@ -0,0 +1,4145 @@ +;;;-*- Mode: Lisp; Package: (CCL :use CL) -*- + +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "VINSN") + (require "X8632-BACKEND")) + +(eval-when (:compile-toplevel :execute) + (require "X8632ENV")) + +(defun unsigned-to-signed (u nbits) + (if (logbitp (1- nbits) u) + (- u (ash 1 nbits)) + u)) + +(defmacro define-x8632-vinsn (vinsn-name (results args &optional temps) &body body) + (%define-vinsn *x8632-backend* vinsn-name results args temps body)) + +(define-x8632-vinsn scale-32bit-misc-index (((dest :u32)) + ((idx :imm) ; A fixnum + ) + ()) + (movl (:%l idx) (:%l dest))) + +(define-x8632-vinsn scale-16bit-misc-index (((dest :u32)) + ((idx :imm))) ; A fixnum + (movl (:%l idx) (:%l dest)) + (shrl (:$ub 1) (:%l dest))) + +(define-x8632-vinsn scale-8bit-misc-index (((dest :u32)) + ((idx :imm))) ; A fixnum + (movl (:%l idx) (:%l dest)) + (shrl (:$ub 2) (:%l dest))) + +;;; same as above, but looks better in bit vector contexts +(define-x8632-vinsn scale-1bit-misc-index (((dest :u32)) + ((idx :imm))) ; A fixnum + (movl (:%l idx) (:%l dest)) + (shrl (:$ub 2) (:%l dest))) + +(define-x8632-vinsn misc-ref-u32 (((dest :u32)) + ((v :lisp) + (scaled-idx :u32))) + (movl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn misc-ref-double-float (((dest :double-float)) + ((v :lisp) + (scaled-idx :imm))) + (movsd (:@ x8632::misc-dfloat-offset (:%l v) (:%l scaled-idx) 2) (:%xmm dest))) + +(define-x8632-vinsn misc-ref-c-double-float (((dest :double-float)) + ((v :lisp) + (idx :s32const))) + (movsd (:@ (:apply + x8632::misc-dfloat-offset (:apply ash idx 3)) (:%l v)) (:%xmm dest))) + +(define-x8632-vinsn misc-ref-node (((dest :lisp)) + ((v :lisp) + (scaled-idx :imm))) + (movl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn (push-misc-ref-node :push :node :vsp) (() + ((v :lisp) + (scaled-idx :imm))) + (pushl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn misc-set-node (() + ((val :lisp) + (v :lisp) + (unscaled-idx :imm)) + ()) + (movl (:%l val) (:@ x8632::misc-data-offset (:%l v) (:%l unscaled-idx)))) + +(define-x8632-vinsn misc-set-immediate-node (() + ((val :s32const) + (v :lisp) + (unscaled-idx :imm)) + ()) + (movl (:$l val) (:@ x8632::misc-data-offset (:%l v) (:%l unscaled-idx)))) + +(define-x8632-vinsn misc-set-single-float (() + ((val :single-float) + (v :lisp) + (scaled-idx :u32)) + ()) + (movss (:%xmm val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn misc-set-double-float (() + ((val :double-float) + (v :lisp) + (unscaled-idx :imm)) + ()) + (movsd (:%xmm val) (:@ x8632::misc-dfloat-offset (:%l v) (:%l unscaled-idx) 2))) + +(define-x8632-vinsn misc-ref-u8 (((dest :u8)) + ((v :lisp) + (scaled-idx :s32))) + (movzbl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn misc-ref-s8 (((dest :s8)) + ((v :lisp) + (scaled-idx :s32))) + (movsbl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn misc-ref-c-u16 (((dest :u16)) + ((v :lisp) + (idx :u32const))) + (movzwl (:@ (:apply + x8632::misc-data-offset (:apply ash idx 1)) (:%l v)) (:%l dest))) + +(define-x8632-vinsn misc-ref-c-s16 (((dest :s16)) + ((v :lisp) + (idx :u32const))) + (movswl (:@ (:apply + x8632::misc-data-offset (:apply ash idx 1)) (:%l v)) (:%l dest))) + +(define-x8632-vinsn misc-ref-u16 (((dest :u16)) + ((v :lisp) + (scaled-idx :s32))) + (movzwl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn misc-ref-u32 (((dest :u32)) + ((v :lisp) + (scaled-idx :s32))) + (movl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn misc-ref-single-float (((dest :single-float)) + ((v :lisp) + (scaled-idx :s32))) + (movss (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%xmm dest))) + +(define-x8632-vinsn misc-ref-s32 (((dest :s32)) + ((v :lisp) + (scaled-idx :s32))) + (movl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn misc-ref-s16 (((dest :s16)) + ((v :lisp) + (scaled-idx :s32))) + (movswl (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)) (:%l dest))) + +(define-x8632-vinsn misc-ref-c-node (((dest :lisp)) + ((v :lisp) + (idx :u32const)) ; sic + ()) + (movl (:@ (:apply + x8632::misc-data-offset (:apply ash idx x8632::word-shift)) (:%l v)) (:%l dest))) + +(define-x8632-vinsn (push-misc-ref-c-node :push :node :vsp) + (() + ((v :lisp) + (idx :u32const)) ; sic + ()) + (pushl (:@ (:apply + x8632::misc-data-offset (:apply ash idx x8632::word-shift)) (:%l v)))) + +(define-x8632-vinsn misc-ref-c-u32 (((dest :u32)) + ((v :lisp) + (idx :u32const)) ; sic + ()) + ;; xxx - should the 2 be x8632::word-shift? + (movl (:@ (:apply + x8632::misc-data-offset (:apply ash idx 2)) (:%l v)) (:%l dest))) + +(define-x8632-vinsn misc-ref-c-s32 (((dest :s32)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movl (:@ (:apply + x8632::misc-data-offset (:apply ash idx x8632::word-shift)) (:%l v)) (:%l dest))) + +(define-x8632-vinsn misc-ref-c-single-float (((dest :single-float)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movss (:@ (:apply + x8632::misc-data-offset (:apply ash idx x8632::word-shift)) (:%l v)) (:%xmm dest))) + +(define-x8632-vinsn misc-ref-c-u8 (((dest :u32)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movzbl (:@ (:apply + x8632::misc-data-offset idx) (:%l v)) (:%l dest))) + +(define-x8632-vinsn misc-ref-c-s8 (((dest :s32)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movsbl (:@ (:apply + x8632::misc-data-offset idx) (:%l v)) (:%l dest))) + +(define-x8632-vinsn misc-set-c-s8 (((val :s8)) + ((v :lisp) + (idx :u32const)) + ()) + (movb (:%b val) (:@ (:apply + x8632::misc-data-offset idx) (:%l v)))) + +(define-x8632-vinsn misc-set-s8 (((val :s8)) + ((v :lisp) + (scaled-idx :s32)) + ()) + (movb (:%b val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn mem-ref-s8 (((dest :s8)) + ((src :address) + (index :s32))) + (movsbl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn misc-set-c-node (() + ((val :lisp) + (v :lisp) + (idx :s32const))) + (movl (:%l val) (:@ (:apply + x8632::misc-data-offset (:apply ash idx 2)) (:%l v)))) + +(define-x8632-vinsn misc-set-immediate-c-node (() + ((val :s32const) + (v :lisp) + (idx :s32const))) + (movl (:$l val) (:@ (:apply + x8632::misc-data-offset (:apply ash idx 2)) (:%l v)))) + +;;; xxx don't know if this is right +(define-x8632-vinsn set-closure-forward-reference (() + ((val :lisp) + (closure :lisp) + (idx :s32const))) + (movl (:%l val) (:@ (:apply + x8632::misc-data-offset (:apply ash idx x8632::word-shift)) (:%l closure)))) + +(define-x8632-vinsn misc-set-c-double-float (() + ((val :double-float) + (v :lisp) + (idx :s32const))) + (movsd (:%xmm val) (:@ (:apply + x8632::misc-dfloat-offset (:apply ash idx 3)) (:%l v)))) + +(define-x8632-vinsn (call-known-symbol :call) (((result (:lisp x8632::arg_z))) + () + ((entry (:label 1)))) + (:talign x8632::fulltag-tra) + (call (:@ x8632::symbol.fcell (:% x8632::fname))) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn (jump-known-symbol :jumplr) (() + ()) + + (jmp (:@ x8632::symbol.fcell (:% x8632::fname)))) + +(define-x8632-vinsn set-nargs (() + ((n :u16const))) + ((:pred = n 0) + (xorl (:%l x8632::nargs) (:%l x8632::nargs))) + ((:not (:pred = n 0)) + (movl (:$l (:apply ash n x8632::fixnumshift)) (:%l x8632::nargs)))) + +(define-x8632-vinsn check-exact-nargs (() + ((n :u16const))) + :resume + ((:pred = n 0) + (testl (:%l x8632::nargs) (:%l x8632::nargs))) + ((:and (:pred > n 0) (:pred < n 32)) + (cmpl (:$b (:apply ash n x8632::fixnumshift)) (:%l x8632::nargs))) + ((:pred >= n 32) + (cmpl (:$l (:apply ash n x8632::fixnumshift)) (:%l x8632::nargs))) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-wrong-number-of-args))) + +(define-x8632-vinsn check-min-nargs (() + ((min :u16const))) + :resume + ((:pred = min 1) + (testl (:%l x8632::nargs) (:%l x8632::nargs)) + (je :toofew)) + ((:not (:pred = min 1)) + ((:and (:pred > min 1) (:pred < min 32)) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash min x8632::fixnumshift)))) + ((:pred >= min 32) + (rcmpl (:%l x8632::nargs) (:$l (:apply ash min x8632::fixnumshift)))) + (jb :toofew)) + (:anchored-uuo-section :resume) + :toofew + (:anchored-uuo (uuo-error-too-few-args))) + +(define-x8632-vinsn check-max-nargs (() + ((n :u16const))) + :resume + ((:pred < n 32) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash n x8632::fixnumshift)))) + ((:pred >= n 32) + (rcmpl (:%l x8632::nargs) (:$l (:apply ash n x8632::fixnumshift)))) + (ja :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-too-many-args))) + +(define-x8632-vinsn check-min-max-nargs (() + ((min :u16const) + (max :u16))) + :resume + ((:pred = min 1) + (testl (:%l x8632::nargs) (:%l x8632::nargs)) + (je :toofew)) + ((:not (:pred = min 1)) + ((:pred < min 32) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash min x8632::word-shift)))) + ((:pred >= min 32) + (rcmpl (:%l x8632::nargs) (:$l (:apply ash min x8632::word-shift)))) + (jb :toofew)) + ((:pred < max 32) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash max x8632::word-shift)))) + ((:pred >= max 32) + (rcmpl (:%l x8632::nargs) (:$l (:apply ash max x8632::word-shift)))) + (ja :toomany) + + (:anchored-uuo-section :resume) + :toofew + (:anchored-uuo (uuo-error-too-few-args)) + (:anchored-uuo-section :resume) + :toomany + (:anchored-uuo (uuo-error-too-many-args))) + +(define-x8632-vinsn default-1-arg (() + ((min :u16const))) + ((:pred < min 32) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash min x8632::fixnumshift)))) + ((:pred >= min 32) + (rcmpl (:%l x8632::nargs) (:$l (:apply ash min x8632::fixnumshift)))) + (jne :done) + ((:pred >= min 2) + (pushl (:%l x8632::arg_y))) + ((:pred >= min 1) + (movl (:%l x8632::arg_z) (:%l x8632::arg_y))) + (movl (:$l (:apply target-nil-value)) (:%l x8632::arg_z)) + :done) + +(define-x8632-vinsn default-2-args (() + ((min :u16const))) + ((:pred < (:apply 1+ min) 32) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash (:apply 1+ min) x8632::fixnumshift)))) + ((:pred >= (:apply 1+ min) 32) + (rcmpl (:%l x8632::nargs) (:$l (:apply ash (:apply 1+ min) x8632::fixnumshift)))) + (ja :done) + (je :one) + ;; We got "min" args; arg_y & arg_z default to nil + ((:pred >= min 2) + (pushl (:%l x8632::arg_y))) + ((:pred >= min 1) + (pushl (:%l x8632::arg_z))) + (movl (:$l (:apply target-nil-value)) (:%l x8632::arg_y)) + (jmp :last) + :one + ;; We got min+1 args: arg_y was supplied, arg_z defaults to nil. + ((:pred >= min 1) + (pushl (:%l x8632::arg_y))) + (movl (:%l x8632::arg_z) (:%l x8632::arg_y)) + :last + (movl (:$l (:apply target-nil-value)) (:%l x8632::arg_z)) + :done) + +(define-x8632-vinsn default-optionals (() + ((n :u16const)) + ((temp :u32) + (nargs (:lisp #.x8632::nargs)))) + (movl (:%l x8632::nargs) (:%l temp)) + ((:pred < n 32) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash n x8632::fixnumshift)))) + ((:pred >= n 32) + (rcmpl (:%l x8632::nargs) (:$l (:apply ash n x8632::fixnumshift)))) + (jae :done) + :loop + (addl (:$b x8632::fixnumone) (:%l temp)) + (pushl (:$l (:apply target-nil-value))) + ((:pred < n 32) + (cmpl (:$b (:apply ash n x8632::fixnumshift)) (:%l temp))) + ((:pred >= n 32) + (cmpl (:$l (:apply ash n x8632::fixnumshift)) (:%l temp))) + (jne :loop) + :done) + +(define-x8632-vinsn save-lisp-context-no-stack-args (() + ()) + (pushl (:%l x8632::ebp)) + (movl (:%l x8632::esp) (:%l x8632::ebp))) + +(define-x8632-vinsn save-lisp-context-offset (() + ((nbytes-pushed :s32const))) + (movl (:%l x8632::ebp) (:@ (:apply + nbytes-pushed x8632::node-size) (:%l x8632::esp))) + (leal (:@ (:apply + nbytes-pushed x8632::node-size) (:%l x8632::esp)) (:%l x8632::ebp)) + (popl (:@ x8632::node-size (:%l x8632::ebp)))) + +(define-x8632-vinsn save-lisp-context-variable-arg-count (() + () + ((temp :u32) + (nargs (:lisp #.x8632::nargs)))) + (movl (:%l x8632::nargs) (:%l temp)) + (subl (:$b (* $numx8632argregs x8632::node-size)) (:%l temp)) + (jle :push) + (movl (:%l x8632::ebp) (:@ x8632::node-size (:%l x8632::esp) (:%l temp))) + (leal (:@ x8632::node-size (:%l x8632::esp) (:%l temp)) (:%l x8632::ebp)) + (popl (:@ x8632::node-size (:%l x8632::ebp))) + (jmp :done) + :push + (pushl (:%l x8632::ebp)) + (movl (:%l x8632::esp) (:%l x8632::ebp)) + :done) + +;;; We know that some args were pushed, but don't know how many were +;;; passed. +(define-x8632-vinsn save-lisp-context-in-frame (() + () + ((temp :u32) + (nargs (:lisp #.x8632::nargs)))) + (movl (:%l x8632::nargs) (:%l temp)) + (subl (:$b (* $numx8632argregs x8632::node-size)) (:%l temp)) + (movl (:%l x8632::ebp) (:@ x8632::node-size (:%l x8632::esp) (:%l temp))) + (leal (:@ x8632::node-size (:%l x8632::esp) (:%l temp)) (:%l x8632::ebp)) + (popl (:@ x8632::node-size (:%l x8632::ebp)))) + +(define-x8632-vinsn (vpush-register :push :node :vsp) + (() + ((reg :lisp))) + (pushl (:% reg))) + +(define-x8632-vinsn (vpush-fixnum :push :node :vsp) + (() + ((const :s32const))) + ((:and (:pred < const 128) (:pred >= const -128)) + (pushl (:$b const))) + ((:not (:and (:pred < const 128) (:pred >= const -128))) + (pushl (:$l const)))) + +(define-x8632-vinsn vframe-load (((dest :lisp)) + ((frame-offset :u16const) + (cur-vsp :u16const))) + (movl (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)) (:%l dest))) + +(define-x8632-vinsn compare-vframe-offset-to-nil (() + ((frame-offset :u16const) + (cur-vsp :u16const))) + (cmpl (:$l (:apply target-nil-value)) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) + +(define-x8632-vinsn compare-value-cell-to-nil (() + ((vcell :lisp))) + (cmpl (:$l (:apply target-nil-value)) (:@ x8632::value-cell.value (:%l vcell)))) + +(define-x8632-vinsn lcell-load (((dest :lisp)) + ((cell :lcell) + (top :lcell))) + (movl (:@ (:apply - (:apply + (:apply calc-lcell-offset cell) x8632::word-size-in-bytes)) (:%l x8632::ebp)) (:%l dest))) + +(define-x8632-vinsn (vframe-push :push :node :vsp) + (() + ((frame-offset :u16const) + (cur-vsp :u16const))) + (pushl (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) + +(define-x8632-vinsn vframe-store (() + ((src :lisp) + (frame-offset :u16const) + (cur-vsp :u16const))) + (movl (:%l src) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) + +(define-x8632-vinsn lcell-store (() + ((src :lisp) + (cell :lcell) + (top :lcell))) + (movl (:%l src) (:@ (:apply - (:apply + (:apply calc-lcell-offset cell) x8632::word-size-in-bytes)) (:%l x8632::ebp)))) + +(define-x8632-vinsn (popj :lispcontext :pop :csp :lrRestore :jumpLR) + (() + ()) + (leave) + (ret)) + +(define-x8632-vinsn (restore-full-lisp-context :lispcontext :pop :vsp ) + (() + ()) + (leave)) + +(define-x8632-vinsn compare-to-nil (() + ((arg0 t))) + (cmpl (:$l (:apply target-nil-value)) (:%l arg0))) + +(define-x8632-vinsn compare-to-t (() + ((arg0 t))) + (cmpl (:$l (:apply target-t-value)) (:%l arg0))) + +(define-x8632-vinsn ref-constant (((dest :lisp)) + ((lab :label))) + (movl (:@ (:^ lab) (:%l x8632::fn)) (:%l dest))) + +(define-x8632-vinsn compare-constant-to-register (() + ((lab :label) + (reg :lisp))) + (cmpl (:@ (:^ lab) (:%l x8632::fn)) (:%l reg))) + +(define-x8632-vinsn (vpush-constant :push :node :vsp) (() + ((lab :label))) + (pushl (:@ (:^ lab) (:%l x8632::fn)))) + +(define-x8632-vinsn (jump :jump) + (() + ((label :label))) + (jmp label)) + +(define-x8632-vinsn (cbranch-true :branch) (() + ((label :label) + (crbit :u8const))) + (jcc (:$ub crbit) label)) + +(define-x8632-vinsn (cbranch-false :branch) (() + ((label :label) + (crbit :u8const))) + (jcc (:$ub (:apply logxor 1 crbit)) label)) + +(define-x8632-vinsn (lri :constant-ref) (((dest :imm)) + ((intval :s32const)) + ()) + ((:pred = intval 0) + (xorl (:%l dest) (:%l dest))) + ((:not (:pred = intval 0)) + (movl (:$l intval) (:%l dest)))) + +(define-x8632-vinsn (lriu :constant-ref) (((dest :imm)) + ((intval :u32const)) + ()) + ((:pred = intval 0) + (xorl (:%l dest) (:%l dest))) + ((:not (:pred = intval 0)) + (movl (:$l intval) (:%l dest)))) + +;;; In the following trap/branch-unless vinsns, it might be worth +;;; trying to use byte instructions when the args are known to be +;;; accessible as byte regs. It also might be possible to +;;; special-case eax/ax/al. + +(define-x8632-vinsn trap-unless-bit (() + ((value :lisp))) + :resume + (testl (:$l (lognot x8632::fixnumone)) (:%l value)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l value) (:$ub arch::error-object-not-bit)))) + +;;; note that NIL is just a distinguished CONS. +;;; the tag formerly known as fulltag-nil is now +;;; for tagged return addresses. +(define-x8632-vinsn trap-unless-list (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:% object) (:% tag)) + (andl (:$b x8632::fulltagmask) (:% tag)) + (cmpl (:$b x8632::fulltag-cons) (:% tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-list (:%l object)))) + +(define-x8632-vinsn trap-unless-cons (() + ((object :lisp)) + ((tag :u8))) + ;; special check for NIL (which is a distinguished CONS on x8632) + :resume + (cmpl (:$l (:apply target-nil-value)) (:%l object)) + (je :bad) + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::fulltagmask) (:%l tag)) + (cmpl (:$b x8632::fulltag-cons) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%l object) (:$ub x8632::fulltag-cons)))) + +(define-x8632-vinsn set-z-flag-if-consp (() + ((object :lisp)) + ((tag (:u32 #.x8632::imm0)))) + (movl (:%l object) (:%accl tag)) + (andl (:$b x8632::fulltagmask) (:%accl tag)) + (cmpb (:$b x8632::fulltag-cons) (:%accb tag)) + (setne (:%b x8632::ah)) + (cmpl (:$l (:apply target-nil-value)) (:% object)) + (sete (:%b x8632::al)) + (orb (:%b x8632::ah) (:%b x8632::al))) + +(define-x8632-vinsn trap-unless-uvector (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%l object) (:$ub x8632::tag-misc)))) + +(define-x8632-vinsn trap-unless-character (() + ((object :lisp)) + ((tag :u8))) + ;; xxx can't be sure that object will be in a byte-accessible register + :resume + (movl (:%l object) (:%l tag)) + (cmpb (:$b x8632::subtag-character) (:%b tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo(uuo-error-reg-not-tag (:%l object) (:$ub x8632::subtag-character)))) + +(define-x8632-vinsn trap-unless-fixnum (() + ((object :lisp)) + ()) + :resume + (testl (:$l x8632::tagmask) (:%l object)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-fixnum (:%l object)))) + +(define-x8632-vinsn set-flags-from-lisptag (() + ((reg :lisp))) + (testl (:$l x8632::tagmask) (:%l reg))) + +(define-x8632-vinsn trap-unless-typecode= (() + ((object :lisp) + (tagval :u8const)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + ((:pred = (:apply %hard-regspec-value tag) x8632::eax) + ;; accumulator + (andl (:$b x8632::tagmask) (:%accl tag)) + (cmpl (:$b x8632::tag-misc) (:%accl tag))) + ((:pred > (:apply %hard-regspec-value tag) x8632::eax) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag))) + (jne :have-tag) + ;; This needs to be a sign-extending mov, since the cmpl below + ;; will sign-extend the 8-bit constant operand. + (movsbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l tag)) + :have-tag + (cmpl (:$b tagval) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%l object) (:$ub tagval)))) + +(define-x8632-vinsn trap-unless-single-float (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (movsbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l tag)) + (cmpl (:$b x8632::subtag-single-float) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%l object) (:$ub x8632::subtag-single-float)))) + +(define-x8632-vinsn trap-unless-double-float (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (movsbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l tag)) + (cmpl (:$b x8632::subtag-double-float) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%l object) (:$ub x8632::subtag-double-float)))) + +(define-x8632-vinsn trap-unless-macptr (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :have-tag) + (movsbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l tag)) + :have-tag + (cmpl (:$b x8632::subtag-macptr) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%l object) (:$ub x8632::subtag-macptr)))) + +(define-x8632-vinsn check-misc-bound (() + ((idx :imm) + (v :lisp)) + ((temp :u32))) + :resume + (movl (:@ x8632::misc-header-offset (:%l v)) (:%l temp)) + ((:and (:pred >= (:apply %hard-regspec-value temp) x8632::eax) + (:pred <= (:apply %hard-regspec-value temp) x8632::ebx)) + (xorb (:%b temp) (:%b temp)) + (shrl (:$ub (- x8632::num-subtag-bits x8632::fixnumshift)) (:%l temp))) + ((:pred > (:apply %hard-regspec-value temp) x8632::ebx) + (shrl (:$ub x8632::num-subtag-bits) (:%l temp)) + (shll (:$ub x8632::fixnumshift) (:%l temp))) + (rcmpl (:%l idx) (:%l temp)) + (jae :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-vector-bounds (:%l idx) (:%l v)))) + +(define-x8632-vinsn %cdr (((dest :lisp)) + ((src :lisp))) + (movl (:@ x8632::cons.cdr (:%l src)) (:%l dest))) + +(define-x8632-vinsn (%vpush-cdr :push :node :vsp) + (() + ((src :lisp))) + (pushl (:@ x8632::cons.cdr (:%l src)))) + +(define-x8632-vinsn %car (((dest :lisp)) + ((src :lisp))) + (movl (:@ x8632::cons.car (:%l src)) (:%l dest))) + +(define-x8632-vinsn (%vpush-car :push :node :vsp) + (() + ((src :lisp))) + (pushl (:@ x8632::cons.car (:%l src)))) + +(define-x8632-vinsn u32->char (((dest :lisp) + (src :u8)) + ((src :u8)) + ()) + (shll (:$ub x8632::charcode-shift) (:%l src)) + (leal (:@ x8632::subtag-character (:%l src)) (:%l dest))) + +(define-x8632-vinsn (load-nil :constant-ref) (((dest t)) + ()) + (movl (:$l (:apply target-nil-value)) (:%l dest))) + + +(define-x8632-vinsn (load-t :constant-ref) (((dest t)) + ()) + (movl (:$l (:apply target-t-value)) (:%l dest))) + +(define-x8632-vinsn extract-tag (((tag :u8)) + ((object :lisp))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag))) + +(define-x8632-vinsn extract-tag-fixnum (((tag :imm)) + ((object :lisp))) + (leal (:@ (:%l object) 4) (:%l tag)) + (andl (:$b (ash x8632::tagmask x8632::fixnumshift)) (:%l tag))) + +(define-x8632-vinsn extract-fulltag (((tag :u8)) + ((object :lisp))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::fulltagmask) (:%l tag))) + +(define-x8632-vinsn extract-fulltag-fixnum (((tag :imm)) + ((object :lisp))) + ((:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object)) + (shll (:$ub x8632::fixnumshift) (:%l object))) + ((:not (:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object))) + (imull (:$b x8632::fixnumone) (:%l object) (:%l tag))) + (andl (:$b (ash x8632::fulltagmask x8632::fixnumshift)) (:%l tag))) + +(define-x8632-vinsn extract-typecode (((tag :u32)) + ((object :lisp))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l tag)) + :have-tag) + +(define-x8632-vinsn extract-typecode-fixnum (((tag :imm)) + ((object :lisp)) + ((temp :u32))) + (movl (:%l object) (:%l temp)) + (andl (:$b x8632::tagmask) (:%l temp)) + (cmpl (:$b x8632::tag-misc) (:%l temp)) + (jne :have-tag) + (movzbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l temp)) + :have-tag + (leal (:@ (:%l temp) 4) (:%l tag))) + +(define-x8632-vinsn compare-reg-to-zero (() + ((reg :imm))) + (testl (:%l reg) (:%l reg))) + +;;; life will be sad if reg isn't byte accessible +(define-x8632-vinsn compare-u8-reg-to-zero (() + ((reg :u8))) + (testb (:%b reg) (:%b reg))) + +(define-x8632-vinsn cr-bit->boolean (((dest :lisp)) + ((crbit :u8const)) + ((temp :u32))) + (movl (:$l (:apply target-t-value)) (:%l temp)) + (leal (:@ (- x8632::t-offset) (:%l temp)) (:%l dest)) + (cmovccl (:$ub crbit) (:%l temp) (:%l dest))) + +(define-x8632-vinsn compare-s32-constant (() + ((val :imm) + (const :s32const))) + ((:or (:pred < const -128) (:pred > const 127)) + (rcmpl (:%l val) (:$l const))) + ((:not (:or (:pred < const -128) (:pred > const 127))) + (rcmpl (:%l val) (:$b const)))) + +(define-x8632-vinsn compare-u31-constant (() + ((val :u32) + (const :u32const))) + ((:pred > const 127) + (rcmpl (:%l val) (:$l const))) + ((:not (:pred > const 127)) + (rcmpl (:%l val) (:$b const)))) + +(define-x8632-vinsn compare-u8-constant (() + ((val :u8) + (const :u8const))) + ((:pred = (:apply %hard-regspec-value val) x8632::eax) + (rcmpb (:%accb val) (:$b const))) + ((:and (:pred > (:apply %hard-regspec-value val) x8632::eax) + (:pred <= (:apply %hard-regspec-value val) x8632::ebx)) + (rcmpb (:%b val) (:$b const))) + ((:pred > (:apply %hard-regspec-value val) x8632::ebx) + (rcmpl (:%l val) (:$l const))) + ) + +(define-x8632-vinsn cons (((dest :lisp)) + ((car :lisp) + (cdr :lisp)) + ((allocptr (:lisp #.x8632::allocptr)))) + (subl (:$b (- x8632::cons.size x8632::fulltag-cons)) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr)) + (movl (:@ (:%seg :rcontext) x8632::tcr.save-allocptr) (:%l x8632::allocptr)) + (rcmpl (:%l x8632::allocptr) (:@ (:%seg :rcontext) x8632::tcr.save-allocbase)) + (ja :no-trap) + (uuo-alloc) + :no-trap + (andb (:$b (lognot x8632::fulltagmask)) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr)) + (movl (:%l car) (:@ x8632::cons.car (:%l x8632::allocptr))) + (movl (:%l cdr) (:@ x8632::cons.cdr (:%l x8632::allocptr))) + (movl (:%l x8632::allocptr) (:%l dest))) + +(define-x8632-vinsn unbox-u8 (((dest :u8)) + ((src :lisp))) + :resume + (movl (:$l (lognot (ash #xff x8632::fixnumshift))) (:%l dest)) + (andl (:% src) (:% dest)) + (jne :bad) + (movl (:%l src) (:%l dest)) + (shrl (:$ub x8632::fixnumshift) (:%l dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l src) (:$ub arch::error-object-not-unsigned-byte-8)))) + +(define-x8632-vinsn %unbox-u8 (((dest :u8)) + ((src :lisp))) + (movl (:%l src) (:%l dest)) + (shrl (:$ub x8632::fixnumshift) (:%l dest)) + (andl (:$l #xff) (:%l dest))) + +(define-x8632-vinsn unbox-s8 (((dest :s8)) + ((src :lisp))) + :resume + (movl (:%l src) (:%l dest)) + (shll (:$ub (- x8632::nbits-in-word (+ 8 x8632::fixnumshift))) (:%l dest)) + (sarl (:$ub (- x8632::nbits-in-word (+ 8 x8632::fixnumshift))) (:%l dest)) + (cmpl (:%l src) (:%l dest)) + (jne :bad) + (testl (:$l x8632::fixnummask) (:%l dest)) + (jne :bad) + (sarl (:$ub x8632::fixnumshift) (:%l dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l src) (:$ub arch::error-object-not-signed-byte-8)))) + +(define-x8632-vinsn unbox-u16 (((dest :u16)) + ((src :lisp))) + :resume + (testl (:$l (lognot (ash #xffff x8632::fixnumshift))) (:% src)) + (movl (:%l src) (:%l dest)) + (jne :bad) + (shrl (:$ub x8632::fixnumshift) (:%l dest)) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l src) (:$ub arch::error-object-not-unsigned-byte-16)))) + +(define-x8632-vinsn %unbox-u16 (((dest :u16)) + ((src :lisp))) + (movl (:%l src) (:%l dest)) + (shrl (:$ub x8632::fixnumshift) (:%l dest))) + +(define-x8632-vinsn unbox-s16 (((dest :s16)) + ((src :lisp))) + :resume + (movl (:%l src) (:%l dest)) + (shll (:$ub (- x8632::nbits-in-word (+ 16 x8632::fixnumshift))) (:%l dest)) + (sarl (:$ub (- x8632::nbits-in-word (+ 16 x8632::fixnumshift))) (:%l dest)) + (cmpl (:%l src) (:%l dest)) + (jne :bad) + (testl (:$l x8632::fixnummask) (:%l dest)) + (jne :bad) + (sarl (:$ub x8632::fixnumshift) (:%l dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l src) (:$ub arch::error-object-not-signed-byte-16)))) + +(define-x8632-vinsn %unbox-s16 (((dest :s16)) + ((src :lisp))) + (movl (:%l src) (:%l dest)) + (sarl (:$ub x8632::fixnumshift) (:%l dest))) + +;;; An object is of type (UNSIGNED-BYTE 32) iff +;;; a) it's of type (UNSIGNED-BYTE 30) (e.g., an unsigned fixnum) +;;; b) it's a bignum of length 1 and the 0'th digit is positive +;;; c) it's a bignum of length 2 and the sign-digit is 0. +(define-x8632-vinsn unbox-u32 (((dest :u32)) + ((src :lisp))) + :resume + (movl (:$l (lognot (ash x8632::target-most-positive-fixnum x8632::fixnumshift))) (:%l dest)) + (testl (:%l dest) (:%l src)) + (movl (:%l src) (:%l dest)) + (jnz :maybe-bignum) + (sarl (:$ub x8632::fixnumshift) (:%l dest)) + (jmp :done) + :maybe-bignum + (andl (:$b x8632::tagmask) (:%l dest)) + (cmpl (:$b x8632::tag-misc) (:%l dest)) + (jne :bad) + (movl (:@ x8632::misc-header-offset (:%l src)) (:%l dest)) + (cmpl (:$l x8632::two-digit-bignum-header) (:%l dest)) + (je :two) + (cmpl (:$l x8632::one-digit-bignum-header) (:%l dest)) + (jne :bad) + (movl (:@ x8632::misc-data-offset (:%l src)) (:%l dest)) + (testl (:%l dest) (:%l dest)) + (js :bad) + (jmp :done) + :two + (movl (:@ (+ 4 x8632::misc-data-offset) (:%l src)) (:%l dest)) + (testl (:%l dest) (:%l dest)) + (jne :bad) + (movl (:@ x8632::misc-data-offset (:%l src)) (:%l dest)) + :done + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l src) (:$ub arch::error-object-not-unsigned-byte-32)))) + +;;; an object is of type (SIGNED-BYTE 32) iff +;;; a) it's a fixnum +;;; b) it's a bignum with exactly one digit. +(define-x8632-vinsn unbox-s32 (((dest :s32)) + ((src :lisp))) + :resume + (movl (:%l src) (:%l dest)) + (sarl (:$ub x8632::fixnumshift) (:%l dest)) + ;; Was it a fixnum ? + (testl (:$l x8632::fixnummask) (:%l src)) + (je :done) + ;; May be a 1-digit bignum + (movl (:%l src) (:%l dest)) + (andl (:$b x8632::tagmask) (:%l dest)) + (cmpl (:$b x8632::tag-misc) (:%l dest)) + (jne :bad) + (cmpl (:$l x8632::one-digit-bignum-header) (:@ x8632::misc-header-offset (:%l src))) + (movl (:@ x8632::misc-data-offset (:%l src)) (:%l dest)) + (jne :bad) + :done + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l src) (:$ub arch::error-object-not-signed-byte-32)))) + +(define-x8632-vinsn sign-extend-s8 (((dest :s32)) + ((src :s8))) + (movsbl (:%b src) (:%l dest))) + +(define-x8632-vinsn sign-extend-s16 (((dest :s32)) + ((src :s16))) + (movswl (:%w src) (:%l dest))) + +(define-x8632-vinsn zero-extend-u8 (((dest :s32)) + ((src :u8))) + (movzbl (:%b src) (:%l dest))) + +(define-x8632-vinsn zero-extend-u16 (((dest :s32)) + ((src :u16))) + (movzwl (:%w src) (:%l dest))) + +(define-x8632-vinsn (jump-subprim :jumpLR) (() + ((spno :s32const))) + (jmp (:@ spno))) + +;;; Call a subprimitive using a tail-aligned CALL instruction. +(define-x8632-vinsn (call-subprim :call) (() + ((spno :s32const)) + ((entry (:label 1)))) + (:talign x8632::fulltag-tra) + (call (:@ spno)) + (movl (:$self 0) (:% x8632::fn))) + +(define-x8632-vinsn fixnum-subtract-from (((dest t) + (y t)) + ((y t) + (x t))) + (subl (:%l y) (:%l x))) + +(define-x8632-vinsn %logand-c (((dest t) + (val t)) + ((val t) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (andl (:$b const) (:%l val))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (andl (:$l const) (:%l val)))) + +(define-x8632-vinsn %logior-c (((dest t) + (val t)) + ((val t) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (orl (:$b const) (:%l val))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (orl (:$l const) (:%l val)))) + +(define-x8632-vinsn %logxor-c (((dest t) + (val t)) + ((val t) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (xorl (:$b const) (:%l val))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (xorl (:$l const) (:%l val)))) + +(define-x8632-vinsn character->fixnum (((dest :lisp)) + ((src :lisp)) + ()) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movl (:%l src) (:%l dest))) + + ((:pred <= (:apply %hard-regspec-value dest) x8632::ebx) + (xorb (:%b dest) (:%b dest))) + ((:pred > (:apply %hard-regspec-value dest) x8632::ebx) + (andl (:$l -256) (:%l dest))) + (shrl (:$ub (- x8632::charcode-shift x8632::fixnumshift)) (:%l dest))) + +(define-x8632-vinsn compare (() + ((x t) + (y t))) + (rcmpl (:%l x) (:%l y))) + +(define-x8632-vinsn negate-fixnum (((val :lisp)) + ((val :imm))) + (negl (:% val))) + +;;; This handles the 1-bit overflow from addition/subtraction/unary negation +(define-x8632-vinsn set-bigits-and-header-for-fixnum-overflow + (() + ((val :lisp) + (no-overflow + :label)) + ((imm (:u32 #.x8632::imm0)))) + (jno no-overflow) + (movl (:%l val) (:%l imm)) + (sarl (:$ub x8632::fixnumshift) (:%l imm)) + (xorl (:$l #xc0000000) (:%l imm)) + ;; stash bignum digit + (movd (:%l imm) (:%mmx x8632::mm1)) + ;; set header + (movl (:$l x8632::one-digit-bignum-header) (:%l imm)) + (movd (:%l imm) (:%mmx x8632::mm0)) + ;; need 8 bytes of aligned memory for 1 digit bignum + (movl (:$l (- 8 x8632::fulltag-misc)) (:%l imm))) + +(define-x8632-vinsn handle-fixnum-overflow-inline + (() + ((val :lisp) + (no-overflow + :label)) + ((imm (:u32 #.x8632::imm0)) + (freeptr (:lisp #.x8632::allocptr)))) + (jo :overflow) + (:uuo-section) + :overflow + (movl (:%l val) (:%l imm)) + (sarl (:$ub x8632::fixnumshift) (:%l imm)) + (xorl (:$l #xc0000000) (:%l imm)) + ;; stash bignum digit + (movd (:%l imm) (:%mmx x8632::mm1)) + ;; set header + (movl (:$l x8632::one-digit-bignum-header) (:%l imm)) + (movd (:%l imm) (:%mmx x8632::mm0)) + ;; need 8 bytes of aligned memory for 1 digit bignum + (movl (:$l (- 8 x8632::fulltag-misc)) (:%l imm)) + (subl (:%l imm) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr)) + (movl (:@ (:%seg :rcontext) x8632::tcr.save-allocptr) (:%l freeptr)) + (rcmpl (:%l freeptr) (:@ (:%seg :rcontext) x8632::tcr.save-allocbase)) + (ja :no-trap) + (uuo-alloc) + :no-trap + (movd (:%mmx x8632::mm0) (:@ x8632::misc-header-offset (:%l freeptr))) + (andb (:$b (lognot x8632::fulltagmask)) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr)) + ((:not (:pred = freeptr + (:apply %hard-regspec-value val))) + (movl (:%l freeptr) (:%l val))) + (movd (:%mmx x8632::mm1) (:@ x8632::misc-data-offset (:%l val))) + (jmp no-overflow)) + + +(define-x8632-vinsn set-bigits-after-fixnum-overflow (() + ((bignum :lisp))) + (movd (:%mmx x8632::mm1) (:@ x8632::misc-data-offset (:%l bignum)))) + + +(define-x8632-vinsn %set-z-flag-if-s32-fits-in-fixnum (((dest :imm)) + ((src :s32)) + ((temp :s32))) + (movl (:%l src) (:%l temp)) + (shll (:$ub x8632::fixnumshift) (:%l temp)) + (movl (:%l temp) (:%l dest)) ; tagged as a fixnum + (sarl (:$ub x8632::fixnumshift) (:%l temp)) + (cmpl (:%l src) (:%l temp))) + +(define-x8632-vinsn %set-z-flag-if-u32-fits-in-fixnum (((dest :imm)) + ((src :u32)) + ((temp :u32))) + (movl (:%l src) (:%l temp)) + (shll (:$ub (1+ x8632::fixnumshift)) (:%l temp)) + (movl (:%l temp) (:%l dest)) ; tagged as an even fixnum + (shrl (:$ub (1+ x8632::fixnumshift)) (:%l temp)) + (shrl (:%l dest)) + (cmpl (:%l src) (:%l temp)) + :done) + +;;; setup-bignum-alloc-for-s32-overflow +;;; setup-bignum-alloc-for-u32-overflow + +(define-x8632-vinsn setup-uvector-allocation (() + ((header :imm))) + (movd (:%l header) (:%mmx x8632::mm0))) + +;;; The code that runs in response to the uuo-alloc +;;; expects a header in mm0, and a size in imm0. +;;; mm0 is an implicit arg (it contains the uvector header) +;;; size is actually an arg, not a temporary, +;;; but it appears that there's isn't a way to enforce +;;; register usage on vinsn args. +(define-x8632-vinsn %allocate-uvector (((dest :lisp)) + () + ((size (:u32 #.x8632::imm0)) + (freeptr (:lisp #.x8632::allocptr)))) + (subl (:%l size) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr)) + (movl (:@ (:%seg :rcontext) x8632::tcr.save-allocptr) (:%l freeptr)) + (rcmpl (:%l freeptr) (:@ (:%seg :rcontext) x8632::tcr.save-allocbase)) + (ja :no-trap) + (uuo-alloc) + :no-trap + (movd (:%mmx x8632::mm0) (:@ x8632::misc-header-offset (:%l freeptr))) + (andb (:$b (lognot x8632::fulltagmask)) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr)) + ((:not (:pred = freeptr + (:apply %hard-regspec-value dest))) + (movl (:%l freeptr) (:%l dest)))) + +(define-x8632-vinsn box-fixnum (((dest :imm)) + ((src :s32))) + ;;(imull (:$b x8632::fixnumone) (:%l src) (:%l dest)) + (leal (:@ (:%l src) x8632::fixnumone) (:%l dest))) + +(define-x8632-vinsn (fix-fixnum-overflow-ool :call) + (((val :lisp)) + ((val :lisp)) + ((unboxed (:s32 #.x8632::imm0)) + ;; we use %mm0 for header in subprim + (entry (:label 1)))) + (jno :done) + ((:not (:pred = x8632::arg_z + (:apply %hard-regspec-value val))) + (movl (:%l val) (:%l x8632::arg_z))) + (:talign 5) + (call (:@ .SPfix-overflow)) + (movl (:$self 0) (:%l x8632::fn)) + ((:not (:pred = x8632::arg_z + (:apply %hard-regspec-value val))) + (movl (:%l x8632::arg_z) (:%l val))) + :done) + +(define-x8632-vinsn (fix-fixnum-overflow-ool-and-branch :call) + (((val :lisp)) + ((val :lisp) + (lab :label)) + ((unboxed (:s32 #.x8632::imm0)) + ;; we use %mm0 for header in subprim + (entry (:label 1)))) + (jno lab) + ((:not (:pred = x8632::arg_z + (:apply %hard-regspec-value val))) + (movl (:%l val) (:%l x8632::arg_z))) + (:talign 5) + (call (:@ .SPfix-overflow)) + (movl (:$self 0) (:%l x8632::fn)) + ((:not (:pred = x8632::arg_z + (:apply %hard-regspec-value val))) + (movl (:%l x8632::arg_z) (:%l val))) + (jmp lab)) + + +(define-x8632-vinsn add-constant (((dest :imm)) + ((dest :imm) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (addl (:$b const) (:%l dest))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (addl (:$l const) (:%l dest)))) + +(define-x8632-vinsn add-constant3 (((dest :imm)) + ((src :imm) + (const :s32const))) + ((:pred = (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src)) + ((:and (:pred >= const -128) (:pred <= const 127)) + (addl (:$b const) (:%l dest))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (addl (:$l const) (:%l dest)))) + ((:not (:pred = (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (leal (:@ const (:%l src)) (:%l dest)))) + +(define-x8632-vinsn fixnum-add2 (((dest :imm)) + ((dest :imm) + (other :imm))) + (addl (:%l other) (:%l dest))) + +(define-x8632-vinsn fixnum-sub2 (((dest :imm)) + ((x :imm) + (y :imm)) + ((temp :imm))) + (movl (:%l x) (:%l temp)) + (subl (:%l y) (:%l temp)) + (movl (:%l temp) (:%l dest))) + +(define-x8632-vinsn fixnum-add3 (((dest :imm)) + ((x :imm) + (y :imm))) + + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (addl (:%l y) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (addl (:%l x) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (leal (:@ (:%l x) (:%l y)) (:%l dest))))) + +(define-x8632-vinsn copy-gpr (((dest t)) + ((src t))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movl (:%l src) (:%l dest)))) + +(define-x8632-vinsn (vpop-register :pop :node :vsp) + (((dest :lisp)) + ()) + (popl (:%l dest))) + +(define-x8632-vinsn (push-argregs :push :node :vsp) (() + ()) + (rcmpl (:%l x8632::nargs) (:$b (* 1 x8632::node-size))) + (jb :done) + (je :one) + (pushl (:%l x8632::arg_y)) + :one + (pushl (:%l x8632::arg_z)) + :done) + +(define-x8632-vinsn (push-max-argregs :push :node :vsp) (() + ((max :u32const))) + ((:pred >= max 2) + (rcmpl (:%l x8632::nargs) (:$b (* 1 x8632::node-size))) + (jb :done) + (je :one) + (pushl (:%l x8632::arg_y)) + :one + (pushl (:%l x8632::arg_z)) + :done) + ((:pred = max 1) + (testl (:%l x8632::nargs) (:%l x8632::nargs)) + (je :done) + (pushl (:%l x8632::arg_z)) + :done)) + +(define-x8632-vinsn (call-label :call) (() + ((label :label)) + ((entry (:label 1)))) + (:talign 5) + (call label) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn double-float-compare (() + ((arg0 :double-float) + (arg1 :double-float))) + (comisd (:%xmm arg1) (:%xmm arg0))) + +(define-x8632-vinsn single-float-compare (() + ((arg0 :single-float) + (arg1 :single-float))) + (comiss (:%xmm arg1) (:%xmm arg0))) + +(define-x8632-vinsn double-float+-2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (addsd (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (addsd (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movsd (:%xmm x) (:%xmm result)) + (addsd (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8632-vinsn double-float--2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movsd (:%xmm x) (:%xmm result))) + (subsd (:%xmm y) (:%xmm result))) + +(define-x8632-vinsn double-float*-2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (mulsd (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (mulsd (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movsd (:%xmm x) (:%xmm result)) + (mulsd (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8632-vinsn double-float/-2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movsd (:%xmm x) (:%xmm result))) + (divsd (:%xmm y) (:%xmm result))) + +(define-x8632-vinsn single-float+-2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (addss (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (addss (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movss (:%xmm x) (:%xmm result)) + (addss (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8632-vinsn single-float--2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movss (:%xmm x) (:%xmm result))) + (subss (:%xmm y) (:%xmm result))) + +(define-x8632-vinsn single-float*-2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (mulss (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (mulss (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movss (:%xmm x) (:%xmm result)) + (mulss (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8632-vinsn single-float/-2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movss (:%xmm x) (:%xmm result))) + (divss (:%xmm y) (:%xmm result))) + +(define-x8632-vinsn get-single (((result :single-float)) + ((source :lisp))) + (movss (:@ x8632::single-float.value (:%l source)) (:%xmm result))) + +(define-x8632-vinsn get-double (((result :double-float)) + ((source :lisp))) + (movsd (:@ x8632::double-float.value (:%l source)) (:%xmm result))) + +;;; Extract a double-float value, typechecking in the process. +;;; IWBNI we could simply call the "trap-unless-typecode=" vinsn here, +;;; instead of replicating it .. +(define-x8632-vinsn get-double? (((target :double-float)) + ((source :lisp)) + ((tag :u8))) + :resume + (movl (:%l source) (:%l tag)) + ((:pred = (:apply %hard-regspec-value tag) x8632::eax) + (andl (:$b x8632::tagmask) (:%accl tag)) + (cmpl (:$b x8632::tag-misc) (:%accl tag))) + ((:pred > (:apply %hard-regspec-value tag) x8632::eax) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag))) + (jne :have-tag) + (movsbl (:@ x8632::misc-subtag-offset (:%l source)) (:%l tag)) + :have-tag + (cmpl (:$b x8632::subtag-double-float) (:%l tag)) + (jne :bad) + (movsd (:@ x8632::double-float.value (:%l source)) (:%xmm target)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q source) (:$ub x8632::subtag-double-float)))) + +(define-x8632-vinsn copy-double-float (((dest :double-float)) + ((src :double-float))) + (movsd (:%xmm src) (:%xmm dest))) + +(define-x8632-vinsn copy-single-float (((dest :single-float)) + ((src :single-float))) + (movss (:%xmm src) (:%xmm dest))) + +(define-x8632-vinsn copy-single-to-double (((dest :double-float)) + ((src :single-float))) + (cvtss2sd (:%xmm src) (:%xmm dest))) + +(define-x8632-vinsn copy-double-to-single (((dest :single-float)) + ((src :double-float))) + (cvtsd2ss (:%xmm src) (:%xmm dest))) + +;;; these two clobber unboxed0, unboxed1 in tcr +;;; (There's no way to move a value from the x87 stack to an xmm register, +;;; so we have to go through memory.) +(define-x8632-vinsn fp-stack-to-single (((dest :single-float)) + ()) + (fstps (:@ (:%seg :rcontext) x8632::tcr.unboxed0)) + (movss (:@ (:%seg :rcontext) x8632::tcr.unboxed0) (:%xmm dest))) + +(define-x8632-vinsn fp-stack-to-double (((dest :double-float)) + ()) + (fstpl (:@ (:%seg :rcontext) x8632::tcr.unboxed0)) + (movsd (:@ (:%seg :rcontext) x8632::tcr.unboxed0) (:%xmm dest))) + +(define-x8632-vinsn fitvals (() + ((n :u16const)) + ((imm :u32))) + ((:pred = n 0) + (xorl (:%l imm) (:%l imm))) + ((:not (:pred = n 0)) + (movl (:$l (:apply ash n x8632::fixnumshift)) (:%l imm))) + (subl (:%l x8632::nargs) (:%l imm)) + (jae :push-more) + (subl (:%l imm) (:%l x8632::esp)) + (jmp :done) + :push-loop + (pushl (:$l (:apply target-nil-value))) + (addl (:$b x8632::node-size) (:%l x8632::nargs)) + (subl (:$b x8632::node-size) (:%l imm)) + :push-more + (jne :push-loop) + :done) + +(define-x8632-vinsn (nvalret :jumpLR) (() + ()) + (jmp (:@ .SPnvalret))) + +(define-x8632-vinsn lisp-word-ref (((dest t)) + ((base t) + (offset t))) + (movl (:@ (:%l base) (:%l offset)) (:%l dest))) + +(define-x8632-vinsn lisp-word-ref-c (((dest t)) + ((base t) + (offset :s32const))) + ((:pred = offset 0) + (movl (:@ (:%l base)) (:%l dest))) + ((:not (:pred = offset 0)) + (movl (:@ offset (:%l base)) (:%l dest)))) + +;; start-mv-call + +(define-x8632-vinsn (vpush-label :push :node :vsp) (() + ((label :label)) + ((temp :lisp))) + (leal (:@ (:^ label) (:%l x8632::fn)) (:%l temp)) + (pushl (:%l temp))) + +(define-x8632-vinsn emit-aligned-label (() + ((label :label))) + ;; We don't care about label. + ;; We just want the label following this stuff to be tra-tagged. + (:align 3) + (nop) (nop) (nop) (nop) (nop)) + +;; pass-multiple-values-symbol +;;; %ra0 is pointing into %fn, so no need to copy %fn here. +(define-x8632-vinsn pass-multiple-values-symbol (() + ()) + (pushl (:@ (:apply + (:apply target-nil-value) (x8632::%kernel-global 'x86::ret1valaddr)))) + (jmp (:@ x8632::symbol.fcell (:% x8632::fname)))) + + +;;; It'd be good to have a variant that deals with a known function +;;; as well as this. +(define-x8632-vinsn pass-multiple-values (() + () + ((tag :u8))) + :resume + (movl (:%l x8632::temp0) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (movsbl (:@ x8632::misc-subtag-offset (:%l x8632::temp0)) (:%l tag)) + (cmpl (:$b x8632::subtag-function) (:%l tag)) + (cmovel (:%l x8632::temp0) (:%l x8632::fn)) + (je :go) + (cmpl (:$b x8632::subtag-symbol) (:%l tag)) + (cmovel (:@ x8632::symbol.fcell (:%l x8632::fname)) (:%l x8632::fn)) + (jne :bad) + :go + (pushl (:@ (:apply + (:apply target-nil-value) (x8632::%kernel-global 'x86::ret1valaddr)))) + (jmp (:%l x8632::fn)) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable)) +) + + +(define-x8632-vinsn reserve-outgoing-frame (() + ()) + (pushl (:$b x8632::reserved-frame-marker)) + (pushl (:$b x8632::reserved-frame-marker))) + +;; implicit temp0 arg +(define-x8632-vinsn (call-known-function :call) (() + () + ((entry (:label 1)))) + (:talign 5) + (call (:%l x8632::temp0)) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn (jump-known-function :jumplr) (() + ()) + (jmp (:%l x8632::temp0))) + +(define-x8632-vinsn (list :call) (() + () + ((entry (:label 1)) + (temp (:lisp #.x8632::temp0)))) + (leal (:@ (:^ :back) (:%l x8632::fn)) (:%l x8632::temp0)) + (:talign 5) + (jmp (:@ .SPconslist)) + :back + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn make-fixed-stack-gvector (((dest :lisp)) + ((aligned-size :u32const) + (header :s32const)) + ((tempa :imm) + (tempb :imm))) + ((:and (:pred >= (:apply + aligned-size x8632::dnode-size) -128) + (:pred <= (:apply + aligned-size x8632::dnode-size) 127)) + (subl (:$b (:apply + aligned-size x8632::dnode-size)) + (:@ (:%seg :rcontext) x8632::tcr.next-tsp))) + ((:not (:and (:pred >= (:apply + aligned-size x8632::dnode-size) -128) + (:pred <= (:apply + aligned-size x8632::dnode-size) 127))) + (subl (:$l (:apply + aligned-size x8632::dnode-size)) + (:@ (:%seg :rcontext) x8632::tcr.next-tsp))) + (movl (:@ (:%seg :rcontext) x8632::tcr.save-tsp) (:%l tempb)) + (movl (:@ (:%seg :rcontext) x8632::tcr.next-tsp) (:%l tempa)) + (movd (:%l tempb) (:%mmx x8632::stack-temp)) + :loop + (movsd (:%xmm x8632::fpzero) (:@ -8 (:%l tempb))) + (subl (:$b x8632::dnode-size) (:%l tempb)) + (cmpl (:%l tempa) (:%l tempb)) + (jnz :loop) + (movd (:%mmx x8632::stack-temp) (:@ (:%l tempa))) + (movl (:%l tempa) (:@ (:%seg :rcontext) x8632::tcr.save-tsp)) + (movl (:$l header) (:@ x8632::dnode-size (:%l tempa))) + (leal (:@ (+ x8632::dnode-size x8632::fulltag-misc) (:%l tempa)) (:%l dest))) + + + + +(define-x8632-vinsn make-tsp-vcell (((dest :lisp)) + ((closed :lisp)) + ((temp :imm))) + (subl (:$b (+ x8632::value-cell.size x8632::dnode-size)) (:@ (:%seg :rcontext) x8632::tcr.next-tsp)) + (movd (:@ (:%seg :rcontext) x8632::tcr.save-tsp) (:%mmx x8632::stack-temp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.next-tsp) (:%l temp)) + (movsd (:%xmm x8632::fpzero) (:@ (:%l temp))) + (movsd (:%xmm x8632::fpzero) (:@ x8632::dnode-size (:%l temp))) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.save-tsp)) + (movl (:$l x8632::value-cell-header) (:@ x8632::dnode-size (:%l temp))) + (movl (:%l closed) (:@ (+ x8632::dnode-size x8632::node-size) (:%l temp))) + (leal (:@ (+ x8632::dnode-size x8632::fulltag-misc) (:%l temp)) (:%l dest))) + +(define-x8632-vinsn make-tsp-cons (((dest :lisp)) + ((car :lisp) (cdr :lisp)) + ((temp :imm))) + (subl (:$b (+ x8632::cons.size x8632::dnode-size)) (:@ (:%seg :rcontext) x8632::tcr.next-tsp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.next-tsp) (:%l temp)) + (movq (:%xmm x8632::fpzero) (:@ (:%l temp))) + (movq (:%xmm x8632::fpzero) (:@ 8 (:%l temp))) + (movd (:@ (:%seg :rcontext) x8632::tcr.save-tsp) (:%mmx x8632::stack-temp)) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.save-tsp)) + (leal (:@ (+ x8632::dnode-size x8632::fulltag-cons) (:%l temp)) (:%l temp)) + (movl (:%l car) (:@ x8632::cons.car (:%l temp))) + (movl (:%l cdr) (:@ x8632::cons.cdr (:%l temp))) + (movl (:%l temp) (:%l dest))) + + +;; make-fixed-stack-gvector + +(define-x8632-vinsn (discard-temp-frame :tsp :pop :discard) (() + () + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.save-tsp) (:%l temp)) + (movl (:@ (:%l temp)) (:%l temp)) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.save-tsp)) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.next-tsp)) + ) + +(define-x8632-vinsn (discard-c-frame :csp :pop :discard) (() + () + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movl (:@ (:%l temp)) (:%l temp)) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp))) + + +(define-x8632-vinsn (vstack-discard :vsp :pop :discard) (() + ((nwords :u32const))) + ((:not (:pred = nwords 0)) + ((:pred < nwords 16) + (addl (:$b (:apply ash nwords x8632::word-shift)) (:%l x8632::esp))) + ((:not (:pred < nwords 16)) + (addl (:$l (:apply ash nwords x8632::word-shift)) (:%l x8632::esp))))) + +(defmacro define-x8632-subprim-lea-jmp-vinsn ((name &rest other-attrs) spno) + `(define-x8632-vinsn (,name :call :subprim-call ,@other-attrs) (() + () + ((entry (:label 1)) + (ra (:lisp #.x8632::ra0)))) + (leal (:@ (:^ :back) (:%l x8632::fn)) (:%l ra)) + (:talign 5) + (jmp (:@ ,spno)) + :back + (movl (:$self 0) (:%l x8632::fn)))) + +(defmacro define-x8632-subprim-call-vinsn ((name &rest other-attrs) spno) + `(define-x8632-vinsn (,name :call :subprim-call ,@other-attrs) (() () ((entry (:label 1)))) + (:talign 5) + (call (:@ ,spno)) + :back + (movl (:$self 0) (:%l x8632::fn)))) + +(defmacro define-x8632-subprim-jump-vinsn ((name &rest other-attrs) spno) + `(define-x8632-vinsn (,name :jumpLR ,@other-attrs) (() ()) + (jmp (:@ ,spno)))) + +(define-x8632-vinsn (nthrowvalues :call :subprim-call) (() + ((lab :label)) + ((ra (:lisp #.x8632::ra0)))) + (leal (:@ (:^ lab) (:%l x8632::fn)) (:%l ra)) + (jmp (:@ .SPnthrowvalues))) + +(define-x8632-vinsn (nthrow1value :call :subprim-call) (() + ((lab :label)) + ((ra (:lisp #.x8632::ra0)))) + (leal (:@ (:^ lab) (:%l x8632::fn)) (:%l ra)) + (jmp (:@ .SPnthrow1value))) + +(define-x8632-vinsn set-single-c-arg (() + ((arg :single-float) + (offset :u32const)) + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movss (:%xmm arg) (:@ (:apply + 8 (:apply ash offset 2)) (:%l temp)))) + +(define-x8632-vinsn reload-single-c-arg (((arg :single-float)) + ((offset :u32const)) + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movss (:@ (:apply + 8 (:apply ash offset 2)) (:%l temp)) (:%xmm arg))) + +(define-x8632-vinsn set-double-c-arg (() + ((arg :double-float) + (offset :u32const)) + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movsd (:%xmm arg) (:@ (:apply + 8 (:apply ash offset 2)) (:%l temp)))) + +(define-x8632-vinsn reload-double-c-arg (((arg :double-float)) + ((offset :u32const)) + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movsd (:@ (:apply + 8 (:apply ash offset 2)) (:%l temp)) (:%xmm arg))) + +;;; .SPffcall has stored %edx in tcr.unboxed1. Load %mm0 with a +;;; 64-bit value composed from %edx:%eax. +(define-x8632-vinsn get-64-bit-ffcall-result (() + ()) + (movl (:%l x8632::eax) (:@ (:%seg :rcontext) x8632::tcr.unboxed0)) + (movq (:@ (:%seg :rcontext) x8632::tcr.unboxed0) (:%mmx x8632::mm0))) + +(define-x8632-subprim-call-vinsn (ff-call) .SPffcall) + +(define-x8632-subprim-call-vinsn (syscall) .SPsyscall) + +(define-x8632-subprim-call-vinsn (syscall2) .SPsyscall2) + +(define-x8632-subprim-call-vinsn (setqsym) .SPsetqsym) + +(define-x8632-subprim-call-vinsn (gets32) .SPgets32) + +(define-x8632-subprim-call-vinsn (getu32) .SPgetu32) + +(define-x8632-subprim-call-vinsn (gets64) .SPgets64) + +(define-x8632-subprim-call-vinsn (getu64) .SPgetu64) + +(define-x8632-subprim-call-vinsn (makes64) .SPmakes64) + +(define-x8632-subprim-call-vinsn (makeu64) .SPmakeu64) + +(define-x8632-subprim-lea-jmp-vinsn (stack-cons-list*) .SPstkconslist-star) + +(define-x8632-subprim-lea-jmp-vinsn (list*) .SPconslist-star) + +(define-x8632-subprim-lea-jmp-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0) + +(define-x8632-vinsn bind-interrupt-level-0-inline (() + () + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.tlb-pointer) (:%l temp)) + (cmpl (:$b 0) (:@ x8632::interrupt-level-binding-index (:%l temp))) + (pushl (:@ x8632::interrupt-level-binding-index (:%l temp))) + (pushl (:$b x8632::interrupt-level-binding-index)) + (pushl (:@ (:%seg :rcontext) x8632::tcr.db-link)) + (movl (:$l 0) (:@ x8632::interrupt-level-binding-index (:%l temp))) + (movl (:%l x8632::esp) (:@ (:%seg :rcontext) x8632::tcr.db-link)) + (jns :done) + (btrl (:$ub 31) (:@ (:%seg :rcontext) x8632::tcr.interrupt-pending)) + (jae :done) + (ud2a) + (:byte 2) + :done) + +(define-x8632-vinsn bind-interrupt-level-m1-inline (() + () + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.tlb-pointer) (:%l temp)) + (pushl (:@ x8632::interrupt-level-binding-index (:%l temp))) + (pushl (:$b x8632::interrupt-level-binding-index)) + (pushl (:@ (:%seg :rcontext) x8632::tcr.db-link)) + (movl (:$l (ash -1 x8632::fixnumshift)) (:@ x8632::interrupt-level-binding-index (:%l temp))) + (movl (:%l x8632::esp) (:@ (:%seg :rcontext) x8632::tcr.db-link))) + +(define-x8632-subprim-lea-jmp-vinsn (bind-interrupt-level-m1) .SPbind-interrupt-level-m1) + +(define-x8632-subprim-lea-jmp-vinsn (bind-interrupt-level) .SPbind-interrupt-level) + +(define-x8632-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level) + +#|| +(define-x8632-vinsn unbind-interrupt-level-inline (() + () + ((link :imm) + (curval :imm) + (oldval :imm) + (tlb :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.tlb-pointer) (:%l tlb)) + (movl (:@ (:%seg :rcontext) x8632::tcr.db-link) (:%l link)) + (movl (:@ x8632::interrupt-level-binding-index (:%l tlb)) (:%l curval)) + (testl (:%l curval) (:%l curval)) + (movl (:@ 8 #|binding.val|# (:%l link)) (:%l oldval)) + (movl (:@ #|binding.link|# (:%l link)) (:%l link)) + (movl (:%l oldval) (:@ x8632::interrupt-level-binding-index (:%l tlb))) + (movl (:%l link) (:@ (:%seg :rcontext) x8632::tcr.db-link)) + (jns :done) + (testl (:%l oldval) (:%l oldval)) + (js :done) + (btrl (:$ub 31) (:@ (:%seg :rcontext) x8632::tcr.interrupt-pending)) + (jae :done) + (ud2a) + (:byte 2) + :done) +||# + +(define-x8632-vinsn (jump-return-pc :jumpLR) (() + ()) + (ret)) + +;;; xxx +(define-x8632-vinsn (nmkcatchmv :call :subprim-call) (() + ((lab :label)) + ((entry (:label 1)) + (xfn (:lisp #.x8632::xfn)))) + (leal (:@ (:^ lab) (:%l x8632::fn)) (:%l xfn)) + (:talign 5) + (call (:@ .SPmkcatchmv)) + :back + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn (nmkcatch1v :call :subprim-call) (() + ((lab :label)) + ((entry (:label 1)) + (xfn (:lisp #.x8632::xfn)))) + (leal (:@ (:^ lab) (:%l x8632::fn)) (:%l x8632::xfn)) + (:talign 5) + (call (:@ .SPmkcatch1v)) + :back + (movl (:$self 0) (:%l x8632::fn))) + + +(define-x8632-vinsn (make-simple-unwind :call :subprim-call) (() + ((protform-lab :label) + (cleanup-lab :label))) + (leal (:@ (:^ protform-lab) (:%l x8632::fn)) (:%l x8632::ra0)) + (leal (:@ (:^ cleanup-lab) (:%l x8632::fn)) (:%l x8632::xfn)) + (jmp (:@ .SPmkunwind))) + +(define-x8632-vinsn (nmkunwind :call :subprim-call) (() + ((protform-lab :label) + (cleanup-lab :label))) + (leal (:@ (:^ protform-lab) (:%l x8632::fn)) (:%l x8632::ra0)) + (leal (:@ (:^ cleanup-lab) (:%l x8632::fn)) (:%l x8632::xfn)) + (jmp (:@ .SPnmkunwind))) + +(define-x8632-vinsn u16->u32 (((dest :u32)) + ((src :u16))) + (movzwl (:%w src) (:%l dest))) + +(define-x8632-vinsn u8->u32 (((dest :u32)) + ((src :u8))) + (movzbl (:%b src) (:%l dest))) + +(define-x8632-vinsn s16->s32 (((dest :s32)) + ((src :s16))) + (movswl (:%w src) (:%l dest))) + +(define-x8632-vinsn s8->s32 (((dest :s32)) + ((src :s8))) + (movsbl (:%b src) (:%l dest))) + +(define-x8632-subprim-jump-vinsn (tail-call-fn-gen) .SPtcallnfngen) + +(define-x8632-subprim-jump-vinsn (tail-call-fn-vsp) .SPtcallnfnvsp) + +(define-x8632-vinsn set-eq-bit (() + ()) + (testb (:%b x8632::arg_z) (:%b x8632::arg_z))) + +;;; %schar8 +;;; %schar32 +;;; %set-schar8 +;;; %set-schar32 + +(define-x8632-vinsn misc-set-c-single-float (((val :single-float)) + ((v :lisp) + (idx :u32const))) + (movss (:%xmm val) (:@ (:apply + x8632::misc-data-offset (:apply ash idx 2)) (:%l v)))) + +(define-x8632-vinsn array-data-vector-ref (((dest :lisp)) + ((header :lisp))) + (movl (:@ x8632::arrayH.data-vector (:%l header)) (:%l dest))) + +(define-x8632-vinsn set-z-flag-if-istruct-typep (() + ((val :lisp) + (type :lisp)) + ((tag :u8) + (valtype :lisp))) + (xorl (:%l valtype) (:%l valtype)) + (movl (:%l val) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :have-tag) + (movsbl (:@ x8632::misc-subtag-offset (:%l val)) (:%l tag)) + :have-tag + (cmpl (:$b x8632::subtag-istruct) (:%l tag)) + (jne :do-compare) + (movl (:@ x8632::misc-data-offset (:%l val)) (:%l valtype)) + :do-compare + (cmpl (:%l valtype) (:%l type))) + +(define-x8632-subprim-call-vinsn (subtag-misc-ref) .SPsubtag-misc-ref) + +(define-x8632-subprim-call-vinsn (subtag-misc-set) .SPsubtag-misc-set) + +(define-x8632-vinsn mem-set-c-constant-fullword (() + ((val :s32const) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movl (:$l val) (:@ (:%l dest)))) + ((:not (:pred = offset 0)) + (movl (:$l val) (:@ offset (:%l dest))))) + +(define-x8632-vinsn mem-set-c-halfword (() + ((val :u16) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movw (:%w val) (:@ (:%l dest)))) + ((:not (:pred = offset 0)) + (movw (:%w val) (:@ offset (:%l dest))))) + +(define-x8632-vinsn mem-set-c-constant-halfword (() + ((val :s16const) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movw (:$w val) (:@ (:%l dest)))) + ((:not (:pred = offset 0)) + (movw (:$w val) (:@ offset (:%l dest))))) + +(define-x8632-vinsn mem-set-c-constant-byte (() + ((val :s8const) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movb (:$b val) (:@ (:%l dest)))) + ((:not (:pred = offset 0)) + (movb (:$b val) (:@ offset (:%l dest))))) + +(define-x8632-vinsn mem-set-c-byte (() + ((val :u8) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movb (:%b val) (:@ (:%l dest)))) + ((:not (:pred = offset 0)) + (movb (:%b val) (:@ offset (:%l dest))))) + +(define-x8632-vinsn mem-ref-c-absolute-u8 (((dest :u8)) + ((addr :s32const))) + (movzbl (:@ addr) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-absolute-s8 (((dest :s8)) + ((addr :s32const))) + (movsbl (:@ addr) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-absolute-u16 (((dest :u16)) + ((addr :s32const))) + (movzwl (:@ addr) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-absolute-s16 (((dest :s16)) + ((addr :s32const))) + (movswl (:@ addr) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-absolute-fullword (((dest :u32)) + ((addr :s32const))) + (movl (:@ addr) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-absolute-signed-fullword (((dest :s32)) + ((addr :s32const))) + (movl (:@ addr) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-absolute-natural (((dest :u32)) + ((addr :s32const))) + (movl (:@ addr) (:%l dest))) + +(define-x8632-vinsn mem-ref-u8 (((dest :u8)) + ((src :address) + (index :s32))) + (movzbl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-u16 (((dest :u16)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movzwl (:@ (:%l src)) (:%l dest))) + ((:not (:pred = index 0)) + (movzwl (:@ index (:%l src)) (:%l dest)))) + +(define-x8632-vinsn mem-ref-u16 (((dest :u16)) + ((src :address) + (index :s32))) + (movzwl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-s16 (((dest :s16)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movswl (:@ (:%l src)) (:%l dest))) + ((:not (:pred = index 0)) + (movswl (:@ index (:%l src)) (:%l dest)))) + +(define-x8632-vinsn mem-ref-s16 (((dest :s16)) + ((src :address) + (index :s32))) + (movswl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-u8 (((dest :u8)) + ((src :address) + (index :s16const))) + ((:pred = index 0) + (movzbl (:@ (:%l src)) (:%l dest))) + ((:not (:pred = index 0)) + (movzbl (:@ index (:%l src)) (:%l dest)))) + +(define-x8632-vinsn mem-ref-u8 (((dest :u8)) + ((src :address) + (index :s32))) + (movzbl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-s8 (((dest :s8)) + ((src :address) + (index :s16const))) + ((:pred = index 0) + (movsbl (:@ (:%l src)) (:%l dest))) + ((:not (:pred = index 0)) + (movsbl (:@ index (:%l src)) (:%l dest)))) + +(define-x8632-vinsn misc-set-c-s8 (((val :s8)) + ((v :lisp) + (idx :u32const)) + ()) + (movb (:%b val) (:@ (:apply + x8632::misc-data-offset idx) (:%l v)))) + +(define-x8632-vinsn misc-set-s8 (((val :s8)) + ((v :lisp) + (scaled-idx :s32)) + ()) + (movb (:%b val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn mem-ref-s8 (((dest :s8)) + ((src :address) + (index :s32))) + (movsbl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn mem-set-constant-fullword (() + ((val :s32const) + (ptr :address) + (offset :s32))) + (movl (:$l val) (:@ (:%l ptr) (:%l offset)))) + + +(define-x8632-vinsn mem-set-constant-halfword (() + ((val :s16const) + (ptr :address) + (offset :s32))) + (movw (:$w val) (:@ (:%l ptr) (:%l offset)))) + +(define-x8632-vinsn mem-set-constant-byte (() + ((val :s8const) + (ptr :address) + (offset :s32))) + (movb (:$b val) (:@ (:%l ptr) (:%l offset)))) + +(define-x8632-vinsn misc-set-c-u8 (((val :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (movb (:%b val) (:@ (:apply + x8632::misc-data-offset idx) (:%l v)))) + +(define-x8632-vinsn misc-set-u8 (((val :u8)) + ((v :lisp) + (scaled-idx :s32)) + ()) + (movb (:%b val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn misc-set-c-u16 (() + ((val :u16) + (v :lisp) + (idx :s32const)) + ()) + (movw (:%w val) (:@ (:apply + x8632::misc-data-offset (:apply * 2 idx)) (:%l v)))) + +(define-x8632-vinsn misc-set-u16 (() + ((val :u16) + (v :lisp) + (scaled-idx :s32)) + ()) + (movw (:%w val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn misc-set-c-s16 (() + ((val :s16) + (v :lisp) + (idx :s32const)) + ()) + (movw (:%w val) (:@ (:apply + x8632::misc-data-offset (:apply * 2 idx)) (:%l v)))) + +(define-x8632-vinsn misc-set-s16 (() + ((val :s16) + (v :lisp) + (scaled-idx :s32)) + ()) + (movw (:%w val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn misc-set-c-u32 (() + ((val :u32) + (v :lisp) + (idx :u32const)) ; sic + ()) + (movl (:%l val) (:@ (:apply + x8632::misc-data-offset (:apply ash idx 2)) (:%l v)))) + +(define-x8632-vinsn misc-set-u32 (() + ((val :u32) + (v :lisp) + (scaled-idx :imm)) + ()) + (movl (:%l val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn misc-set-c-s32 (() + ((val :s32) + (v :lisp) + (idx :u32const)) ; sic + ()) + (movl (:%l val) (:@ (:apply + x8632::misc-data-offset (:apply ash idx 2)) (:%l v)))) + +(define-x8632-vinsn misc-set-s32 (() + ((val :s32) + (v :lisp) + (scaled-idx :imm)) + ()) + (movl (:%l val) (:@ x8632::misc-data-offset (:%l v) (:%l scaled-idx)))) + +(define-x8632-vinsn %iasr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s32) + (shiftcount (:s32 #.x8632::ecx)))) + (movl (:%l count) (:%l temp)) + (sarl (:$ub x8632::fixnumshift) (:%l temp)) + (movl (:$l 31) (:%l shiftcount)) + (rcmpl (:%l temp) (:%l shiftcount)) + (cmovbel (:%l temp) (:%l shiftcount)) + (movl (:%l src) (:%l temp)) + (sarl (:%shift x8632::cl) (:%l temp)) + (andl (:$l (lognot x8632::fixnummask)) (:%l temp)) + (movl (:%l temp) (:%l dest))) + +(define-x8632-vinsn %ilsr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s32) + (shiftcount (:s32 #.x8632::ecx)))) + (movl (:%l count) (:%l temp)) + (sarl (:$ub x8632::fixnumshift) (:%l temp)) + (movl (:$l 31) (:%l shiftcount)) + (rcmpl (:%l temp) (:%l shiftcount)) + (cmovbel (:%l temp) (:%l shiftcount)) + (movl (:%l src) (:%l temp)) + (shrl (:%shift x8632::cl) (:%l temp)) + (andl (:$b (lognot x8632::fixnummask)) (:%l temp)) + (movl (:%l temp) (:%l dest))) + +(define-x8632-vinsn %iasr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s32))) + (movl (:%l src) (:%l temp)) + (sarl (:$ub count) (:%l temp)) + (andb (:$b (lognot x8632::fixnummask)) (:%b temp)) + (movl (:%l temp) (:%l dest))) + +(define-x8632-vinsn %ilsr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s32))) + (movl (:%l src) (:%l temp)) + (shrl (:$ub count) (:%l temp)) + ;; xxx --- use :%acc + (andb (:$b (lognot x8632::fixnummask)) (:%b temp)) + (movl (:%l temp) (:%l dest))) + +(define-x8632-vinsn %ilsl (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp (:s32 #.x8632::eax)) + (shiftcount (:s32 #.x8632::ecx)))) + (movl (:%l count) (:%l temp)) + (sarl (:$ub x8632::fixnumshift) (:%l temp)) + (rcmpl (:%l temp) (:$l 31)) + (cmovbw (:%w temp) (:%w shiftcount)) + (movl (:%l src) (:%l temp)) + (jae :shift-max) + (shll (:%shift x8632::cl) (:%l temp)) + (jmp :done) + :shift-max + (xorl (:%l temp) (:%l temp)) + :done + (movl (:%l temp) (:%l dest))) + +(define-x8632-vinsn %ilsl-c (((dest :imm)) + ((count :u8const) + (src :imm))) + ((:not (:pred = + (:apply %hard-regspec-value src) + (:apply %hard-regspec-value dest))) + (movl (:%l src) (:%l dest))) + (shll (:$ub count) (:%l dest))) + +;;; In safe code, something else has ensured that the value is of type +;;; BIT. +(define-x8632-vinsn set-variable-bit-to-variable-value (() + ((vec :lisp) + (word-index :s32) + (bitnum :u8) + (value :lisp))) + (testl (:%l value) (:%l value)) + (je :clr) + (btsl (:%l bitnum) (:@ x8632::misc-data-offset (:%l vec) (:%l word-index) 4)) + (jmp :done) + :clr + (btrl (:%l bitnum) (:@ x8632::misc-data-offset (:%l vec) (:%l word-index) 4)) + :done) + +;;; In safe code, something else has ensured that the value is of type +;;; BIT. +(define-x8632-vinsn nset-variable-bit-to-variable-value (() + ((vec :lisp) + (index :s32) + (value :lisp))) + (testl (:%l value) (:%l value)) + (je :clr) + (btsl (:%l index) (:@ x8632::misc-data-offset (:%l vec))) + (jmp :done) + :clr + (btrl (:%l index) (:@ x8632::misc-data-offset (:%l vec))) + :done) + +(define-x8632-vinsn nset-variable-bit-to-zero (() + ((vec :lisp) + (index :s32))) + (btrl (:%l index) (:@ x8632::misc-data-offset (:%l vec)))) + +(define-x8632-vinsn nset-variable-bit-to-one (() + ((vec :lisp) + (index :s32))) + (btsl (:%l index) (:@ x8632::misc-data-offset (:%l vec)))) + +(define-x8632-vinsn set-variable-bit-to-zero (() + ((vec :lisp) + (word-index :s32) + (bitnum :u8))) + (btrl (:%l bitnum) (:@ x8632::misc-data-offset (:%l vec) (:%l word-index) 4))) + +(define-x8632-vinsn set-variable-bit-to-one (() + ((vec :lisp) + (word-index :s32) + (bitnum :u8))) + (btsl (:%l bitnum) (:@ x8632::misc-data-offset (:%l vec) (:%l word-index) 4))) + +(define-x8632-vinsn set-constant-bit-to-zero (() + ((src :lisp) + (idx :u32const))) + (btrl (:$ub (:apply logand 31 idx)) + (:@ (:apply + x8632::misc-data-offset (:apply ash (:apply ash idx -5) x8632::word-shift)) (:%l src)))) + +(define-x8632-vinsn set-constant-bit-to-one (() + ((src :lisp) + (idx :u32const))) + (btsl (:$ub (:apply logand 31 idx)) + (:@ (:apply + x8632::misc-data-offset (:apply ash (:apply ash idx -5) x8632::word-shift)) (:%l src)))) + +(define-x8632-vinsn set-constant-bit-to-variable-value (() + ((src :lisp) + (idx :u32const) + (value :lisp))) + (testl (:%l value) (:%l value)) + (je :clr) + (btsl (:$ub (:apply logand 31 idx)) + (:@ (:apply + x8632::misc-data-offset (:apply ash (:apply ash idx -5) x8632::word-shift)) (:%l src))) + (jmp :done) + :clr + (btrl (:$ub (:apply logand 31 idx)) + (:@ (:apply + x8632::misc-data-offset (:apply ash (:apply ash idx -5) x8632::word-shift)) (:%l src))) + :done) + +(define-x8632-vinsn require-fixnum (() + ((object :lisp))) + :again + ((:and (:pred > (:apply %hard-regspec-value object) x8632::eax) + (:pred <= (:apply %hard-regspec-value object) x8632::ebx)) + (testb (:$b x8632::fixnummask) (:%b object))) + ((:pred > (:apply %hard-regspec-value object) x8632::ebx) + (testl (:$l x8632::fixnummask) (:%l object))) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-fixnum)))) + +(define-x8632-vinsn require-integer (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + ((:pred = (:apply %hard-regspec-value tag) x8632::eax) + (andb (:$b x8632::fixnummask) (:%accb tag))) + ((:and (:pred > (:apply %hard-regspec-value tag) x8632::eax) + (:pred <= (:apply %hard-regspec-value tag) x8632::ebx)) + (andb (:$b x8632::fixnummask) (:%b tag))) + ((:pred > (:apply %hard-regspec-value object) x8632::ebx) + (andl (:$l x8632::fixnummask) (:%l tag))) + (je :got-it) + ((:pred = (:apply %hard-regspec-value tag) x8632::eax) + (cmpb (:$b x8632::tag-misc) (:%accb tag))) + ((:and (:pred > (:apply %hard-regspec-value tag) x8632::eax) + (:pred <= (:apply %hard-regspec-value tag) x8632::ebx)) + (cmpb (:$b x8632::tag-misc) (:%b tag))) + ((:pred > (:apply %hard-regspec-value object) x8632::ebx) + (cmpl (:$l x8632::tag-misc) (:%l tag))) + (jne :bad) + (cmpb (:$b x8632::subtag-bignum) (:@ x8632::misc-subtag-offset (:%l object))) + (jne :bad) + :got-it + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-integer)))) + +(define-x8632-vinsn require-simple-vector (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::fixnummask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8632::subtag-simple-vector) (:@ x8632::misc-subtag-offset (:%l object))) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-simple-vector)))) + +(define-x8632-vinsn require-simple-string (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::fixnummask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8632::subtag-simple-base-string) (:@ x8632::misc-subtag-offset (:%l object))) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-simple-string)))) + + +;;; naive +(define-x8632-vinsn require-real (() + ((object :lisp)) + ((tag :u8) + (mask :lisp))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l tag)) + :have-tag + (cmpl (:$b (1- (- x8632::nbits-in-word x8632::fixnumshift))) (:%l tag)) + (movl (:$l (ash (logior (ash 1 x8632::tag-fixnum) + (ash 1 x8632::subtag-single-float) + (ash 1 x8632::subtag-double-float) + (ash 1 x8632::subtag-bignum) + (ash 1 x8632::subtag-ratio)) + x8632::fixnumshift)) (:%l mask)) + (ja :bad) + (addl (:$b x8632::fixnumshift) (:%l tag)) + (btl (:%l tag) (:%l mask)) + (jnc :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-real)))) + +;;; naive +(define-x8632-vinsn require-number (() + ((object :lisp)) + ((tag :u8) + (mask :lisp))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8632::misc-subtag-offset (:%l object)) (:%l tag)) + :have-tag + (cmpl (:$b (1- (- x8632::nbits-in-word x8632::fixnumshift))) (:%l tag)) + (movl (:$l (ash (logior (ash 1 x8632::tag-fixnum) + (ash 1 x8632::subtag-single-float) + (ash 1 x8632::subtag-double-float) + (ash 1 x8632::subtag-bignum) + (ash 1 x8632::subtag-ratio) + (ash 1 x8632::subtag-complex)) + x8632::fixnumshift)) (:%l mask)) + (ja :bad) + (addl (:$b x8632::fixnumshift) (:%l tag)) + (btl (:%l tag) (:%l mask)) + (jnc :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-number)))) + +(define-x8632-vinsn require-list (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::fulltagmask) (:%l tag)) + (cmpl (:$b x8632::fulltag-cons) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-list)))) + +(define-x8632-vinsn require-symbol (() + ((object :lisp)) + ((tag :u8))) + :again + (cmpl (:$l (:apply target-nil-value)) (:%l object)) + (je :got-it) + (movl (:%l object) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8632::subtag-symbol) (:@ x8632::misc-subtag-offset (:%l object))) + (jne :bad) + :got-it + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-symbol))) +) + +(define-x8632-vinsn require-character (() + ((object :lisp))) + :again + (cmpb (:$b x8632::subtag-character) (:%b object)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-character)))) + +(define-x8632-vinsn require-s8 (() + ((object :lisp)) + ((tag :u32))) + :again + (movl (:%l object) (:%l tag)) + (shll (:$ub (- x8632::nbits-in-word (+ 8 x8632::fixnumshift))) (:%l tag)) + (sarl (:$ub (- x8632::nbits-in-word 8)) (:%l tag)) + (shll (:$ub x8632::fixnumshift) (:%l tag)) + (cmpl (:%l object) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-signed-byte-8)))) + +(define-x8632-vinsn require-u8 (() + ((object :lisp)) + ((tag :u32))) + :again + (movl (:$l (lognot (ash #xff x8632::fixnumshift))) (:%l tag)) + (andl (:%l object) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-unsigned-byte-8)))) + +(define-x8632-vinsn require-s16 (() + ((object :lisp)) + ((tag :s32))) + :again + (movl (:%l object) (:%l tag)) + (shll (:$ub (- x8632::nbits-in-word (+ 16 x8632::fixnumshift))) (:%l tag)) + (sarl (:$ub (- x8632::nbits-in-word 16)) (:%l tag)) + (shll (:$ub x8632::fixnumshift) (:%l tag)) + (cmpl (:%l object) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-signed-byte-16)))) + +(define-x8632-vinsn require-u16 (() + ((object :lisp)) + ((tag :u32))) + :again + (movl (:$l (lognot (ash #xffff x8632::fixnumshift))) (:%l tag)) + (andl (:%l object) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-unsigned-byte-16)))) + +(define-x8632-vinsn require-s32 (() + ((object :lisp)) + ((tag :s32))) + :again + (testl (:$l x8632::fixnummask) (:%l object)) + (movl (:%l object) (:%l tag)) + (je :ok) + (andl (:$l x8632::fulltagmask) (:%l tag)) + (cmpl (:$l x8632::fulltag-misc) (:%l tag)) + (jne :bad) + (cmpl (:$l x8632::one-digit-bignum-header) (:@ x8632::misc-header-offset (:%l object))) + (jne :bad) + :ok + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-signed-byte-32)))) + +(define-x8632-vinsn require-u32 (() + ((object :lisp)) + ((tag :s32))) + :again + (testl (:$l x8632::fixnummask) (:%l object)) + (movl (:%l object) (:%l tag)) + (je :ok-if-non-negative) + (andl (:$l x8632::fulltagmask) (:%l tag)) + (cmpl (:$l x8632::fulltag-misc) (:%l tag)) + (jne :bad) + (cmpl (:$l x8632::one-digit-bignum-header) (:@ x8632::misc-header-offset (:%l object))) + (je :one) + (cmpl (:$l x8632::two-digit-bignum-header) (:@ x8632::misc-header-offset (:%l object))) + (jne :bad) + (cmpl (:$b 0) (:@ (+ x8632::misc-data-offset 4) (:%l object))) + (je :ok) + :bad + (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-unsigned-byte-32)) + (jmp :again) + :one + (movl (:@ x8632::misc-data-offset (:%l object)) (:%l tag)) + :ok-if-non-negative + (testl (:%l tag) (:%l tag)) + (js :bad) + :ok) + +(define-x8632-vinsn require-s64 (() + ((object :lisp)) + ((tag :s32))) + :again + (testl (:$l x8632::fixnummask) (:%l object)) + (movl (:%l object) (:%l tag)) + (je :ok) + (andl (:$l x8632::fulltagmask) (:%l tag)) + (cmpl (:$l x8632::fulltag-misc) (:%l tag)) + (jne :bad) + (cmpl (:$l x8632::two-digit-bignum-header) (:@ x8632::misc-header-offset (:%l object))) + (jne :bad) + :ok + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-signed-byte-64)))) + +(define-x8632-vinsn require-u64 (() + ((object :lisp)) + ((tag :s32))) + :again + (testl (:$l x8632::fixnummask) (:%l object)) + (movl (:%l object) (:%l tag)) + (je :ok-if-non-negative) + (andl (:$l x8632::fulltagmask) (:%l tag)) + (cmpl (:$l x8632::fulltag-misc) (:%l tag)) + (jne :bad) + (cmpl (:$l x8632::two-digit-bignum-header) (:@ x8632::misc-header-offset (:%l object))) + (je :two) + (cmpl (:$l x8632::three-digit-bignum-header) (:@ x8632::misc-header-offset (:%l object))) + (jne :bad) + (cmpl (:$b 0) (:@ (+ x8632::misc-data-offset 8) (:%l object))) + (je :ok) + :bad + (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-unsigned-byte-64)) + (jmp :again) + :two + (movl (:@ x8632::misc-data-offset (:%l object)) (:%l tag)) + :ok-if-non-negative + (testl (:%l tag) (:%l tag)) + (js :bad) + :ok) + +(define-x8632-vinsn require-char-code (() + ((object :lisp)) + ((tag :u32))) + :again + (testb (:$b x8632::fixnummask) (:%b object)) + (jne :bad) + (cmpl (:$l (ash #x110000 x8632::fixnumshift)) (:%l object)) + (jae :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%l object) (:$ub arch::error-object-not-mod-char-code-limit)))) + +(define-x8632-vinsn mask-base-char (((dest :u8)) + ((src :lisp))) + (movzbl (:%b src) (:%l dest))) + +(define-x8632-vinsn event-poll (() + ()) + (btrl (:$ub 31) (:@ (:%seg :rcontext) x8632::tcr.interrupt-pending)) + (jae :no-interrupt) + (ud2a) + (:byte 2) + :no-interrupt) + +;;; check-2d-bound +;;; check-3d-bound + +(define-x8632-vinsn 2d-dim1 (((dest :u32)) + ((header :lisp))) + (movl (:@ (+ x8632::misc-data-offset (* 4 (1+ x8632::arrayH.dim0-cell))) + (:%l header)) (:%l dest)) + (sarl (:$ub x8632::fixnumshift) (:%l dest))) + +;;; 3d-dims + +;;; xxx +(define-x8632-vinsn 2d-unscaled-index (((dest :imm) + (dim1 :u32)) + ((dim1 :u32) + (i :imm) + (j :imm))) + + (imull (:%l i) (:%l dim1)) + (leal (:@ (:%l j) (:%l dim1)) (:%l dest))) + +;;; 3d-unscaled-index + +(define-x8632-vinsn branch-unless-both-args-fixnums (() + ((a :lisp) + (b :lisp) + (dest :label)) + ((tag :u8))) + (movl (:%l a) (:%l tag)) + (orl (:%l b) (:%l tag)) + ((:pred = (:apply %hard-regspec-value tag) x8632::eax) + (testb (:$b x8632::fixnummask) (:%accb tag))) + ((:and (:pred > (:apply %hard-regspec-value tag) x8632::eax) + (:pred <= (:apply %hard-regspec-value tag) x8632::ebx)) + (testb (:$b x8632::fixnummask) (:%b tag))) + ((:pred > (:apply %hard-regspec-value tag) x8632::ebx) + (testl (:$l x8632::fixnummask) (:%l tag))) + (jne dest)) + +(define-x8632-vinsn branch-unless-arg-fixnum (() + ((a :lisp) + (dest :label))) + ((:pred <= (:apply %hard-regspec-value a) x8632::ebx) + (testb (:$b x8632::fixnummask) (:%b a))) + ((:pred > (:apply %hard-regspec-value a) x8632::ebx) + (testl (:$l x8632::fixnummask) (:%l a))) + (jne dest)) + +(define-x8632-vinsn fixnum->single-float (((f :single-float)) + ((arg :lisp)) + ((unboxed :s32))) + (movl (:%l arg) (:%l unboxed)) + (sarl (:$ub x8632::fixnumshift) (:%l unboxed)) + (cvtsi2ssl (:%l unboxed) (:%xmm f))) + +(define-x8632-vinsn fixnum->double-float (((f :double-float)) + ((arg :lisp)) + ((unboxed :s32))) + (movl (:%l arg) (:%l unboxed)) + (sarl (:$ub x8632::fixnumshift) (:%l unboxed)) + (cvtsi2sdl (:%l unboxed) (:%xmm f))) + +(define-x8632-vinsn xchg-registers (() + ((a t) + (b t))) + (xchgl (:%l a) (:%l b))) + +(define-x8632-vinsn establish-fn (() + ()) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn %scharcode32 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32))) + (movl (:@ x8632::misc-data-offset (:%l str) (:%l idx)) (:%l imm)) + (imull (:$b x8632::fixnumone) (:%l imm) (:%l code))) + +(define-x8632-vinsn %set-scharcode32 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u32))) + (movl (:%l code) (:%l imm)) + (shrl (:$ub x8632::fixnumshift) (:%l imm)) + (movl (:%l imm) (:@ x8632::misc-data-offset (:%l str) (:%l idx)))) + + +(define-x8632-subprim-jump-vinsn (tail-call-sym-slide) .SPtcallsymslide) + +(define-x8632-subprim-jump-vinsn (tail-call-sym-vsp) .SPtcallsymvsp) + + +(define-x8632-vinsn character->code (((dest :u32)) + ((src :lisp))) + (movl (:%l src) (:%l dest)) + (sarl (:$ub x8632::charcode-shift) (:%l dest))) + +(define-x8632-vinsn adjust-vsp (() + ((amount :s32const))) + ((:and (:pred >= amount -128) (:pred <= amount 127)) + (addl (:$b amount) (:%l x8632::esp))) + ((:not (:and (:pred >= amount -128) (:pred <= amount 127))) + (addl (:$l amount) (:%l x8632::esp)))) + + +(define-x8632-vinsn (call-subprim-2 :call :subprim-call) (((dest t)) + ((spno :s32const) + (y t) + (z t)) + ((entry (:label 1)))) + (:talign 5) + (call (:@ spno)) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn %symbol->symptr (((dest :lisp)) + ((src :lisp)) + ((tag :u8))) + :resume + (cmpl (:$l (:apply target-nil-value)) (:%l src)) + (je :nilsym) + (movl (:%l src) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (movsbl (:@ x8632::misc-subtag-offset (:%l src)) (:%l tag)) + (cmpl (:$b x8632::subtag-symbol) (:%l tag)) + (jne :bad) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movl (:% src) (:% dest))) + (jmp :ok) + :nilsym + (movl (:$l (:apply + (:apply target-nil-value) x8632::nilsym-offset)) (:%l dest)) + :ok + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%l src) (:$ub x8632::subtag-symbol)))) + +(define-x8632-vinsn single-float-bits (((dest :u32)) + ((src :lisp))) + (movl (:@ x8632::misc-data-offset (:%l src)) (:%l dest))) + +(define-x8632-vinsn zero-double-float-register (((dest :double-float)) + ()) + (movsd (:%xmm x8632::fpzero) (:%xmm dest))) + +(define-x8632-vinsn zero-single-float-register (((dest :single-float)) + ()) + (movss (:%xmm x8632::fpzero) (:%xmm dest))) + +(define-x8632-subprim-lea-jmp-vinsn (heap-rest-arg) .SPheap-rest-arg) +(define-x8632-subprim-lea-jmp-vinsn (stack-rest-arg) .SPstack-rest-arg) +(define-x8632-subprim-lea-jmp-vinsn (req-stack-rest-arg) .SPreq-stack-rest-arg) + + +(define-x8632-subprim-call-vinsn (stack-misc-alloc) .SPstack-misc-alloc) + +(define-x8632-vinsn misc-element-count-fixnum (((dest :imm)) + ((src :lisp)) + ((temp :u32))) + (movl (:@ x8632::misc-header-offset (:%l src)) (:%l temp)) + (shrl (:$ub x8632::num-subtag-bits) (:%l temp)) + (leal (:@ (:%l temp) 4) (:%l dest))) + +(define-x8632-vinsn %logior2 (((dest :imm)) + ((x :imm) + (y :imm))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (orl (:%l y) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (orl (:%l x) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movl (:%l x) (:%l dest)) + (orl (:%l y) (:%l dest))))) + +(define-x8632-vinsn %logand2 (((dest :imm)) + ((x :imm) + (y :imm))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (andl (:%l y) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (andl (:%l x) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movl (:%l x) (:%l dest)) + (andl (:%l y) (:%l dest))))) + +(define-x8632-vinsn %logxor2 (((dest :imm)) + ((x :imm) + (y :imm))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (xorl (:%l y) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (xorl (:%l x) (:%l dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movl (:%l x) (:%l dest)) + (xorl (:%l y) (:%l dest))))) + + +(define-x8632-subprim-call-vinsn (integer-sign) .SPinteger-sign) + +(define-x8632-subprim-call-vinsn (misc-ref) .SPmisc-ref) + +(define-x8632-subprim-call-vinsn (ksignalerr) .SPksignalerr) + +(define-x8632-subprim-call-vinsn (misc-alloc-init) .SPmisc-alloc-init) + +(define-x8632-subprim-call-vinsn (misc-alloc) .SPmisc-alloc) + +(define-x8632-subprim-lea-jmp-vinsn (make-stack-gvector) .SPstkgvector) + +(define-x8632-vinsn load-character-constant (((dest :lisp)) + ((code :u32const)) + ()) + (movl (:$l (:apply logior (:apply ash code 8) x8632::subtag-character)) + (:%l dest))) + + +(define-x8632-vinsn setup-single-float-allocation (() + ()) + (movl (:$l (arch::make-vheader x8632::single-float.element-count x8632::subtag-single-float)) (:%l x8632::imm0)) + (movd (:%l x8632::imm0) (:%mmx x8632::mm0)) + (movl (:$l (- x8632::single-float.size x8632::fulltag-misc)) (:%l x8632::imm0))) + +(define-x8632-vinsn setup-double-float-allocation (() + ()) + (movl (:$l (arch::make-vheader x8632::double-float.element-count x8632::subtag-double-float)) (:%l x8632::imm0)) + (movd (:%l x8632::imm0) (:%mmx x8632::mm0)) + (movl (:$l (- x8632::double-float.size x8632::fulltag-misc)) (:%l x8632::imm0))) + +(define-x8632-vinsn set-single-float-value (() + ((node :lisp) + (val :single-float))) + (movss (:%xmm val) (:@ x8632::single-float.value (:%l node)))) + +(define-x8632-vinsn set-double-float-value (() + ((node :lisp) + (val :double-float))) + (movsd (:%xmm val) (:@ x8632::double-float.value (:%l node)))) + +(define-x8632-vinsn word-index-and-bitnum-from-index (((word-index :u32) + (bitnum :u8)) + ((index :imm))) + (movl (:%l index) (:%l word-index)) + (shrl (:$ub x8632::fixnumshift) (:%l word-index)) + (movl (:$l 31) (:%l bitnum)) + (andl (:%l word-index) (:%l bitnum)) + (shrl (:$ub 5) (:%l word-index))) + +(define-x8632-vinsn ref-bit-vector-fixnum (((dest :imm) + (bitnum :u8)) + ((bitnum :u8) + (bitvector :lisp) + (word-index :u32))) + (btl (:%l bitnum) (:@ x8632::misc-data-offset (:%l bitvector) (:%l word-index) 4)) + (setb (:%b bitnum)) + (negb (:%b bitnum)) + (andl (:$l x8632::fixnumone) (:%l bitnum)) + (movl (:%l bitnum) (:%l dest))) + +(define-x8632-vinsn nref-bit-vector-fixnum (((dest :imm) + (bitnum :s32)) + ((bitnum :s32) + (bitvector :lisp)) + ()) + (btl (:%l bitnum) (:@ x8632::misc-data-offset (:%l bitvector))) + (setc (:%b bitnum)) + (movzbl (:%b bitnum) (:%l bitnum)) + (imull (:$b x8632::fixnumone) (:%l bitnum) (:%l dest))) + +(define-x8632-vinsn nref-bit-vector-flags (() + ((bitnum :s32) + (bitvector :lisp)) + ()) + (btl (:%l bitnum) (:@ x8632::misc-data-offset (:%l bitvector)))) + +(define-x8632-vinsn misc-ref-c-bit-fixnum (((dest :imm)) + ((src :lisp) + (idx :u32const)) + ((temp :u8))) + (btl (:$ub (:apply logand 31 idx)) + (:@ (:apply + x8632::misc-data-offset (:apply ash (:apply ash idx -5) x8632::word-shift)) (:%l src))) + (setc (:%b temp)) + (movzbl (:%b temp) (:%l temp)) + (imull (:$b x8632::fixnumone) (:%l temp) (:%l dest))) + +(define-x8632-vinsn misc-ref-c-bit-flags (() + ((src :lisp) + (idx :u64const))) + (btl (:$ub (:apply logand 31 idx)) + (:@ (:apply + x8632::misc-data-offset (:apply ash (:apply ash idx -5) x8632::word-shift)) (:%l src)))) + +(define-x8632-vinsn set-macptr-address (() + ((addr :address) + (src :lisp)) + ()) + (movl (:%l addr) (:@ x8632::macptr.address (:%l src)))) + +(define-x8632-vinsn deref-macptr (((addr :address)) + ((src :lisp)) + ()) + (movl (:@ x8632::macptr.address (:%l src)) (:%l addr))) + +(define-x8632-vinsn setup-macptr-allocation (() + ((src :address))) + (movd (:%l src) (:%mmx x8632::mm1)) ;see %set-new-macptr-value, below + (movl (:$l x8632::macptr-header) (:%l x8632::imm0)) + (movd (:%l x8632::imm0) (:%mmx x8632::mm0)) + (movl (:$l (- x8632::macptr.size x8632::fulltag-misc)) (:%l x8632::imm0))) + +(define-x8632-vinsn %set-new-macptr-value (() + ((ptr :lisp))) + (movd (:%mmx x8632::mm1) (:@ x8632::macptr.address (:%l ptr)))) + +(define-x8632-vinsn mem-ref-natural (((dest :u32)) + ((src :address) + (index :s32))) + (movl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-fullword (((dest :u32)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movl (:@ (:%l src)) (:%l dest))) + ((:not (:pred = index 0)) + (movl (:@ index (:%l src)) (:%l dest)))) + +(define-x8632-vinsn mem-ref-c-signed-fullword (((dest :s32)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movl (:@ (:%l src)) (:%l dest))) + ((:not (:pred = index 0)) + (movl (:@ index (:%l src)) (:%l dest)))) + +(define-x8632-vinsn mem-ref-c-single-float (((dest :single-float)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movss (:@ (:%l src)) (:%xmm dest))) + ((:not (:pred = index 0)) + (movss (:@ index (:%l src)) (:%xmm dest)))) + +(define-x8632-vinsn mem-set-c-single-float (() + ((val :single-float) + (src :address) + (index :s16const))) + ((:pred = index 0) + (movss (:%xmm val) (:@ (:%l src)))) + ((:not (:pred = index 0)) + (movss (:%xmm val) (:@ index (:%l src))))) + +(define-x8632-vinsn mem-ref-c-natural (((dest :u32)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movl (:@ (:%l src)) (:%l dest))) + ((:not (:pred = index 0)) + (movl (:@ index (:%l src)) (:%l dest)))) + +(define-x8632-vinsn mem-ref-c-double-float (((dest :double-float)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movsd (:@ (:%l src)) (:%xmm dest))) + ((:not (:pred = index 0)) + (movsd (:@ index (:%l src)) (:%xmm dest)))) + +(define-x8632-vinsn mem-set-c-double-float (() + ((val :double-float) + (src :address) + (index :s32const))) + ((:pred = index 0) + (movsd (:%xmm val) (:@ (:%l src)))) + ((:not (:pred = index 0)) + (movsd (:%xmm val) (:@ index (:%l src))))) + +(define-x8632-vinsn mem-ref-fullword (((dest :u32)) + ((src :address) + (index :s32))) + (movl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn mem-ref-signed-fullword (((dest :s32)) + ((src :address) + (index :s32))) + (movl (:@ (:%l src) (:%l index)) (:%l dest))) + +(define-x8632-vinsn macptr->stack (((dest :lisp)) + ((ptr :address)) + ((temp :imm))) + (movd (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%mmx x8632::stack-temp)) + (subl (:$b (+ 8 x8632::macptr.size)) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:%l x8632::ebp) (:@ 4 (:%l temp))) + (leal (:@ (+ 8 x8632::fulltag-misc) (:%l temp)) (:%l dest)) + (movl (:$l x8632::macptr-header) (:@ x8632::macptr.header (:%l dest))) + (movl (:%l ptr) (:@ x8632::macptr.address (:%l dest))) + (movsd (:%xmm x8632::fpzero) (:@ x8632::macptr.domain (:%l dest)))) + +(define-x8632-vinsn fixnum->signed-natural (((dest :s32)) + ((src :imm))) + (movl (:%l src) (:%l dest)) + (sarl (:$ub x8632::fixnumshift) (:%l dest))) + +(define-x8632-vinsn fixnum->unsigned-natural (((dest :u32)) + ((src :imm))) + (movl (:%l src) (:%l dest)) + (shrl (:$ub x8632::fixnumshift) (:%l dest))) + +(define-x8632-vinsn mem-set-double-float (() + ((val :double-float) + (src :address) + (index :s32))) + (movsd (:%xmm val) (:@ (:%l src) (:%l index)))) + +(define-x8632-vinsn mem-set-single-float (() + ((val :single-float) + (src :address) + (index :s32))) + (movss (:%xmm val) (:@ (:%l src) (:%l index)))) + +(define-x8632-vinsn mem-set-c-fullword (() + ((val :u32) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movl (:%l val) (:@ (:%l dest)))) + ((:not (:pred = offset 0)) + (movl (:%l val) (:@ offset (:%l dest))))) + +(define-x8632-vinsn mem-set-bit-variable-value (((src :address)) + ((src :address) + (offset :lisp) + (value :lisp)) + ((temp :lisp))) + ;; (mark-as-imm temp) + (btrl (:$ub (:apply %hard-regspec-value temp)) + (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask)) + (movl (:%l offset) (:%l temp)) + (shrl (:$ub (+ 5 x8632::fixnumshift)) (:%l temp)) + (leal (:@ (:%l src) (:%l temp) 4) (:%l src)) + (movl (:%l offset) (:%l temp)) + (shrl (:$ub x8632::fixnumshift) (:%l temp)) + (andl (:$l 31) (:%l temp)) + (testl (:%l value) (:%l value)) + (jne :set) + (btrl (:%l temp) (:@ (:%l src))) + (jmp :done) + :set + (btsl (:%l temp) (:@ (:%l src))) + :done + ;; (mark-as-node temp) + (xorl (:%l temp) (:%l temp)) + (btsl (:$ub (:apply %hard-regspec-value temp)) + (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask))) + + +(define-x8632-vinsn mem-set-c-bit-variable-value (() + ((src :address) + (offset :s32const) + (value :lisp))) + (testl (:%l value) (:%l value)) + (jne :set) + ((:pred = 0 (:apply ash offset -5)) + (btrl (:$ub (:apply logand 31 offset)) + (:@ (:%l src)))) + ((:not (:pred = 0 (:apply ash offset -5))) + (btrl (:$ub (:apply logand 31 offset)) + (:@ (:apply ash (:apply ash offset -5) 4) (:%l src)))) + (jmp :done) + :set + ((:pred = 0 (:apply ash offset -5)) + (btsl (:$ub (:apply logand 31 offset)) + (:@ (:%l src)))) + ((:not (:pred = 0 (:apply ash offset -5))) + (btsl (:$ub (:apply logand 31 offset)) + (:@ (:apply ash (:apply ash offset -5) 2) (:%l src)))) + :done) + +(define-x8632-vinsn %natural+ (((result :u32)) + ((result :u32) + (other :u32))) + (addl (:%l other) (:%l result))) + +(define-x8632-vinsn %natural+-c (((result :u32)) + ((result :u32) + (constant :u32const))) + (addl (:$l (:apply unsigned-to-signed constant 32)) (:%l result))) + +(define-x8632-vinsn %natural- (((result :u32)) + ((result :u32) + (other :u32))) + (subl (:%l other) (:%l result))) + +(define-x8632-vinsn %natural--c (((result :u32)) + ((result :u32) + (constant :u32const))) + (subl (:$l (:apply unsigned-to-signed constant 32)) (:%l result))) + +(define-x8632-vinsn %natural-logior (((result :u32)) + ((result :u32) + (other :u32))) + (orl (:%l other) (:%l result))) + +(define-x8632-vinsn %natural-logior-c (((result :u32)) + ((result :u32) + (constant :u32const))) + (orl (:$l (:apply unsigned-to-signed constant 32)) (:%l result))) + +(define-x8632-vinsn %natural-logand (((result :u32)) + ((result :u32) + (other :u32))) + (andl (:%l other) (:%l result))) + +(define-x8632-vinsn %natural-logand-c (((result :u32)) + ((result :u32) + (constant :u32const))) + (andl (:$l (:apply unsigned-to-signed constant 32)) (:%l result))) + +(define-x8632-vinsn %natural-logxor (((result :u32)) + ((result :u32) + (other :u32))) + (xorl (:%l other) (:%l result))) + +(define-x8632-vinsn %natural-logxor-c (((result :u32)) + ((result :u32) + (constant :u32const))) + (xorl (:$l (:apply unsigned-to-signed constant 32)) (:%l result))) + +(define-x8632-vinsn natural-shift-left (((dest :u32)) + ((dest :u32) + (amt :u8const))) + (shll (:$ub amt) (:%l dest))) + +(define-x8632-vinsn natural-shift-right (((dest :u32)) + ((dest :u32) + (amt :u8const))) + (shrl (:$ub amt) (:%l dest))) + +(define-x8632-vinsn recover-fn (() + ()) + (movl (:$self 0) (:%l x8632::fn))) + +;;; xxx probably wrong +(define-x8632-vinsn (call-subprim-3 :call :subprim-call) (((dest t)) + ((spno :s32const) + (x t) + (y t) + (z t)) + ((entry (:label 1)))) + (:talign 5) + (call (:@ spno)) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn vcell-ref (((dest :lisp)) + ((vcell :lisp))) + (movl (:@ x8632::misc-data-offset (:%l vcell)) (:%l dest))) + +(define-x8632-vinsn setup-vcell-allocation (() + ()) + (movl (:$l x8632::value-cell-header) (:%l x8632::imm0)) + (movd (:%l x8632::imm0) (:%mmx x8632::mm0)) + (movl (:$l (- x8632::value-cell.size x8632::fulltag-misc)) (:%l x8632::imm0))) + +(define-x8632-vinsn %init-vcell (() + ((vcell :lisp) + (closed :lisp))) + (movl (:%l closed) (:@ x8632::value-cell.value (:%l vcell)))) + +;;; "old" mkunwind. Used by PROGV, since the binding of *interrupt-level* +;;; on entry to the new mkunwind confuses the issue. + +(define-x8632-vinsn (mkunwind :call :subprim-call) (() + ((protform-lab :label) + (cleanup-lab :label))) + (leal (:@ (:^ protform-lab) (:%l x8632::fn)) (:%l x8632::ra0)) + (leal (:@ (:^ cleanup-lab) (:%l x8632::fn)) (:%l x8632::xfn)) + (jmp (:@ .SPmkunwind))) + +;;; Funcall the function or symbol in temp0 and obtain the single +;;; value that it returns. +(define-x8632-subprim-call-vinsn (funcall) .SPfuncall) + +(define-x8632-vinsn tail-funcall (() + () + ((tag :u8))) + :resume + (movl (:%l x8632::temp0) (:%l tag)) + ((:pred = (:apply %hard-regspec-value tag) x8632::eax) + (andl (:$b x8632::tagmask) (:%accl tag)) + (cmpl (:$b x8632::tag-misc) (:%accl tag))) + ((:pred > (:apply %hard-regspec-value tag) x8632::eax) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag))) + (jne :bad) + (movsbl (:@ x8632::misc-subtag-offset (:%l x8632::temp0)) (:%l tag)) + (cmpl (:$b x8632::subtag-function) (:%l tag)) + (je :go) + (cmpl (:$b x8632::subtag-symbol) (:%l tag)) + (cmovel (:@ x8632::symbol.fcell (:%l x8632::temp0)) (:%l x8632::temp0)) + (jne :bad) + :go + (jmp (:%l x8632::temp0)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable))) + +;;; Magic numbers in here include the address of .SPcall-closure. + +;;; movl $self, %fn +;;; jmp *20660 (.SPcall-closure) +(define-x8632-vinsn init-nclosure (() + ((closure :lisp))) + (movb (:$b 6) (:@ x8632::misc-data-offset (:%l closure))) ;imm word count + (movb (:$b #xbf) (:@ (+ x8632::misc-data-offset 2) (:%l closure))) ;movl $self, %fn + (movl (:%l closure) (:@ (+ x8632::misc-data-offset 3) (:%l closure))) + (movb (:$b #xff) (:@ (+ x8632::misc-data-offset 7) (:%l closure))) ;jmp + (movl (:$l #x0150b425) (:@ (+ x8632::misc-data-offset 8) (:%l closure))) ;.SPcall-closure + ;; already aligned + ;; (movl ($ 0) (:@ (+ x8632::misc-data-offset 12))) ;"end" of self-references + (movb (:$b 7) (:@ (+ x8632::misc-data-offset 16) (:%l closure))) ;self-reference offset + (movb (:$b x8632::function-boundary-marker) (:@ (+ x8632::misc-data-offset 20) (:%l closure)))) + +(define-x8632-vinsn finalize-closure (((closure :lisp)) + ((closure :lisp))) + (nop)) + + +(define-x8632-vinsn (ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val))))) + (:talign 5) + (call (:@ .SPspecrefcheck)) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + :resume + (movl (:@ x8632::symbol.binding-index (:%l src)) (:%l idx)) + (rcmpl (:%l idx) (:@ (:%seg :rcontext) x8632::tcr.tlb-limit)) + (movl (:@ (:%seg :rcontext) x8632::tcr.tlb-pointer) (:%l table)) + (jae :symbol) + (movl (:@ (:%l table) (:%l idx)) (:%l dest)) + (cmpl (:$l x8632::subtag-no-thread-local-binding) (:%l dest)) + (jne :test) + :symbol + (movl (:@ x8632::symbol.vcell (:%l src)) (:%l dest)) + :test + (cmpl (:$l x8632::unbound-marker) (:%l dest)) + (je :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-unbound (:%l src)))) + +(define-x8632-vinsn (%ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val))))) + (:talign 5) + (call (:@ .SPspecref)) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn %ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + (movl (:@ x8632::symbol.binding-index (:%l src)) (:%l idx)) + (rcmpl (:%l idx) (:@ (:%seg :rcontext) x8632::tcr.tlb-limit)) + (jae :symbol) + (addl (:@ (:%seg :rcontext) x8632::tcr.tlb-pointer) (:%l idx)) + (movl (:@ (:%l idx)) (:%l dest)) + (cmpl (:$l x8632::subtag-no-thread-local-binding) (:%l dest)) + (jne :done) + :symbol + (movl (:@ x8632::symbol.vcell (:%l src)) (:%l dest)) + :done) + +(define-x8632-vinsn ref-interrupt-level (((dest :imm)) + () + ((temp :u32))) + (movl (:@ (:%seg :rcontext) x8632::tcr.tlb-pointer) (:%l temp)) + (movl (:@ x8632::interrupt-level-binding-index (:%l temp)) (:%l dest))) + +(define-x8632-subprim-lea-jmp-vinsn (bind-nil) .SPbind-nil) + +(define-x8632-subprim-lea-jmp-vinsn (bind-self) .SPbind-self) + +(define-x8632-subprim-lea-jmp-vinsn (bind-self-boundp-check) .SPbind-self-boundp-check) + +(define-x8632-subprim-lea-jmp-vinsn (bind) .SPbind) + +(define-x8632-vinsn (dpayback :call :subprim-call) (() + ((n :s16const)) + ((temp (:u32 #.x8632::imm0)) + (entry (:label 1)))) + ((:pred > n 0) + ((:pred > n 1) + (movl (:$l n) (:%l temp)) + (:talign 5) + (call (:@ .SPunbind-n))) + ((:pred = n 1) + (:talign 5) + (call (:@ .SPunbind))) + (movl (:$self 0) (:%l x8632::fn)))) + +(define-x8632-subprim-jump-vinsn (tail-call-sym-gen) .SPtcallsymgen) + +(define-x8632-subprim-call-vinsn (make-stack-list) .Spmakestacklist) + +(define-x8632-vinsn node-slot-ref (((dest :lisp)) + ((node :lisp) + (cellno :u32const))) + (movl (:@ (:apply + x8632::misc-data-offset (:apply ash cellno 2)) + (:%l node)) (:%l dest))) + +(define-x8632-subprim-lea-jmp-vinsn (stack-cons-list) .SPstkconslist) + +(define-x8632-vinsn save-lexpr-argregs (() + ((min-fixed :u16const))) + ((:pred >= min-fixed $numx8632argregs) + (pushl (:%l x8632::arg_y)) + (pushl (:%l x8632::arg_z))) + ((:pred = min-fixed 1) ; at least one arg + (rcmpl (:%l x8632::nargs) (:$b (ash 1 x8632::word-shift))) + (je :z1) ;skip arg_y if exactly 1 + (pushl (:%l x8632::arg_y)) + :z1 + (pushl (:%l x8632::arg_z))) + ((:pred = min-fixed 0) + (rcmpl (:%l x8632::nargs) (:$b (ash 1 x8632::word-shift))) + (je :z0) ;exactly one + (jl :none) ;none + ;two or more... + (pushl (:%l x8632::arg_y)) + :z0 + (pushl (:%l x8632::arg_z)) + :none + ) + ((:not (:pred = min-fixed 0)) + (leal (:@ (:apply - (:apply ash min-fixed x8632::word-shift)) (:%l x8632::nargs)) + (:%l x8632::nargs))) + (pushl (:%l x8632::nargs)) + (movl (:%l x8632::esp) (:%l x8632::arg_z))) + +;;; The frame that was built (by SAVE-LISP-CONTEXT-VARIABLE-ARG-COUNT +;;; and SAVE-LEXPR-ARGREGS) contains an unknown number of arguments +;;; followed by the count of non-required arguments; the count is on +;;; top of the stack and its address is in %arg_z. We need to build a +;;; frame so that the function can address its arguments (copies of +;;; the required arguments and the lexpr) and locals; when the +;;; function returns, it should one or more values (depending on how +;;; it was called) and discard the hidden lexpr frame. At this point, +;;; %ra0 still contains the "real" return address. If it's not the +;;; magic multiple-value address, we can make the function return to +;;; something that does a single-value return (.SPpopj); otherwise, we +;;; need to make it return multiple values to the real caller. (Unlike +;;; the PPC, this case only involves creating one frame here, but that +;;; frame has two return addresses.) +(define-x8632-vinsn build-lexpr-frame (() + () + ((temp :imm) + (ra0 (:lisp #.x8632::ra0)))) + (movl (:@ (:apply + (:apply target-nil-value) (x8632::%kernel-global 'x86::ret1valaddr))) + (:%l temp)) + (cmpl (:%l temp) (:%l ra0)) + (je :multiple) + (pushl (:@ (:apply + (:apply target-nil-value) (x8632::%kernel-global 'x86::lexpr-return1v)))) + (jmp :finish) + :multiple + (pushl (:@ (:apply + (:apply target-nil-value) (x8632::%kernel-global 'x86::lexpr-return)))) + (pushl (:%l temp)) + :finish + (pushl (:%l x8632::ebp)) + (movl (:%l x8632::esp) (:%l x8632::ebp))) + +(define-x8632-vinsn copy-lexpr-argument (() + ((n :u16const)) + ((temp :imm))) + (movl (:@ (:%l x8632::arg_z)) (:%l temp)) + (pushl (:@ (:apply ash n x8632::word-shift) (:%l x8632::arg_z) (:%l temp)))) + +(define-x8632-vinsn %current-tcr (((dest :lisp)) + ()) + (movl (:@ (:%seg :rcontext) x8632::tcr.linear) (:%l dest))) + +(define-x8632-vinsn (setq-special :call :subprim-call) + (() + ((sym :lisp) + (val :lisp)) + ((entry (:label 1)))) + (:talign 5) + (call (:@ .SPspecset)) + (movl (:$self 0) (:%l x8632::fn))) + +(define-x8632-vinsn pop-argument-registers (() + ()) + (testl (:%l x8632::nargs) (:%l x8632::nargs)) + (je :done) + (rcmpl (:%l x8632::nargs) (:$l (ash 1 x8632::word-shift))) + (popl (:%l x8632::arg_z)) + (je :done) + (popl (:%l x8632::arg_y)) + :done) + +(define-x8632-vinsn %symptr->symvector (((target :lisp)) + ((target :lisp))) + (nop)) + +(define-x8632-vinsn %symvector->symptr (((target :lisp)) + ((target :lisp))) + (nop)) + +(define-x8632-subprim-lea-jmp-vinsn (spread-lexpr) .SPspread-lexpr-z) + +(define-x8632-vinsn mem-ref-double-float (((dest :double-float)) + ((src :address) + (index :s32))) + (movsd (:@ (:%l src) (:%l index)) (:%xmm dest))) + +(define-x8632-vinsn mem-ref-single-float (((dest :single-float)) + ((src :address) + (index :s32))) + (movss (:@ (:%l src) (:%l index)) (:%xmm dest))) + +;;; This would normally be put in %nargs, but we need an +;;; extra node register for passing stuff into +;;; SPdestructuring_bind and friends. +(define-x8632-vinsn load-adl (() + ((n :u32const))) + (movl (:$l n) (:%l x8632::imm0))) + +(define-x8632-subprim-lea-jmp-vinsn (macro-bind) .SPmacro-bind) + +(define-x8632-subprim-lea-jmp-vinsn (destructuring-bind-inner) .SPdestructuring-bind-inner) + +(define-x8632-subprim-lea-jmp-vinsn (destructuring-bind) .SPdestructuring-bind) + + +(define-x8632-vinsn symbol-function (((val :lisp)) + ((sym (:lisp (:ne val)))) + ((tag :u8))) + :resume + (movl (:@ x8632::symbol.fcell (:%l sym)) (:%l val)) + (movl (:%l val) (:%l tag)) + (andl (:$b x8632::tagmask) (:%l tag)) + (cmpl (:$b x8632::tag-misc) (:%l tag)) + (jne :bad) + (movsbl (:@ x8632::misc-subtag-offset (:%l val)) (:%l tag)) + (cmpl (:$b x8632::subtag-function) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-udf (:%l sym)))) + +(define-x8632-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide) + +(define-x8632-vinsn load-double-float-constant (((dest :double-float)) + ((lab :label))) + (movsd (:@ (:^ lab) (:%l x8632::fn)) (:%xmm dest))) + +(define-x8632-vinsn load-single-float-constant (((dest :single-float)) + ((lab :label))) + (movss (:@ (:^ lab) (:%l x8632::fn)) (:%xmm dest))) + +(define-x8632-subprim-call-vinsn (misc-set) .SPmisc-set) + +(define-x8632-subprim-lea-jmp-vinsn (slide-values) .SPmvslide) + +(define-x8632-subprim-lea-jmp-vinsn (spread-list) .SPspreadargz) + +;;; Even though it's implemented by calling a subprim, THROW is really +;;; a JUMP (to a possibly unknown destination). If the destination's +;;; really known, it should probably be inlined (stack-cleanup, value +;;; transfer & jump ...) +(define-x8632-vinsn (throw :jump-unknown) (() + () + ((entry (:label 1)) + (ra (:lisp #.x8632::ra0)))) + (leal (:@ (:^ :back) (:%l x8632::fn)) (:%l ra)) + (:talign 5) + (jmp (:@ .SPthrow)) + :back + (movl (:$self 0) (:%l x8632::fn)) + (uuo-error-reg-not-tag (:%l x8632::temp0) (:$ub x8632::subtag-catch-frame))) + +(define-x8632-vinsn unbox-base-char (((dest :u32)) + ((src :lisp))) + (movl (:%l src) (:%l dest)) + ((:pred = (:apply %hard-regspec-value dest) x8632::eax) + (cmpb (:$b x8632::subtag-character) (:%accb dest))) + ((:and (:pred > (:apply %hard-regspec-value dest) x8632::eax) + (:pred <= (:apply %hard-regspec-value dest) x8632::ebx)) + (cmpb (:$b x8632::subtag-character) (:%b dest))) + ((:pred > (:apply %hard-regspec-value dest) x8632::ebx) + ;; very rare case, if even possible... + (andl (:$l #xff) (:%l dest)) + (cmpl (:$b x8632::subtag-character) (:%l dest)) + (cmovel (:%l src) (:%l dest))) + (je ::got-it) + (uuo-error-reg-not-tag (:%l src) (:$ub x8632::subtag-character)) + :got-it + (shrl (:$ub x8632::charcode-shift) (:%l dest))) + +(define-x8632-subprim-lea-jmp-vinsn (save-values) .SPsave-values) + +(define-x8632-subprim-lea-jmp-vinsn (recover-values) .SPrecover-values) + +(define-x8632-subprim-lea-jmp-vinsn (recover-values-for-mvcall) .SPrecover-values-for-mvcall) + +(define-x8632-subprim-lea-jmp-vinsn (add-values) .SPadd-values) + +(define-x8632-subprim-call-vinsn (make-stack-block) .SPmakestackblock) + +(define-x8632-subprim-call-vinsn (make-stack-block0) .Spmakestackblock0) + +;;; "dest" is preallocated, presumably on a stack somewhere. +(define-x8632-vinsn store-single (() + ((dest :lisp) + (source :single-float)) + ()) + (movss (:%xmm source) (:@ x8632::single-float.value (:%l dest)))) + +;;; "dest" is preallocated, presumably on a stack somewhere. +(define-x8632-vinsn store-double (() + ((dest :lisp) + (source :double-float)) + ()) + (movsd (:%xmm source) (:@ x8632::double-float.value (:%l dest)))) + +(define-x8632-vinsn fixnum->char (((dest :lisp)) + ((src :imm)) + ((temp :u32))) + (movl (:%l src) (:%l temp)) + (sarl (:$ub (+ x8632::fixnumshift 1)) (:%l temp)) + (cmpl (:$l (ash #xfffe -1)) (:%l temp)) + (je :bad-if-eq) + (sarl (:$ub (- 11 1)) (:%l temp)) + (cmpl (:$b (ash #xd800 -11))(:%l temp)) + :bad-if-eq + (movl (:$l (:apply target-nil-value)) (:%l temp)) + (cmovel (:%l temp) (:%l dest)) + (je :done) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movl (:%l src) (:%l dest))) + (shll (:$ub (- x8632::charcode-shift x8632::fixnumshift)) (:%l dest)) + (addl (:$b x8632::subtag-character) (:%l dest)) + :done) + +;;; src is known to be a code for which CODE-CHAR returns non-nil. +(define-x8632-vinsn code-char->char (((dest :lisp)) + ((src :imm)) + ()) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movl (:%l src) (:%l dest))) + (shll (:$ub (- x8632::charcode-shift x8632::fixnumshift)) (:%l dest)) + (addl (:$b x8632::subtag-character) (:%l dest)) + :done) + +(define-x8632-vinsn sign-extend-halfword (((dest :imm)) + ((src :imm))) + (movl (:%l src ) (:%l dest)) + (shll (:$ub (- 16 x8632::fixnumshift)) (:%l dest)) + (sarl (:$ub (- 16 x8632::fixnumshift)) (:%l dest))) + +(define-x8632-subprim-jump-vinsn (tail-funcall-gen) .SPtfuncallgen) + +(define-x8632-vinsn %init-gvector (() + ((v :lisp) + (nbytes :u32const)) + ((count :imm))) + (movl (:$l nbytes) (:%l count)) + (jmp :test) + :loop + (popl (:@ x8632::misc-data-offset (:%l v) (:%l count))) + :test + (subl (:$b x8632::node-size) (:%l count)) + (jge :loop)) + +(define-x8632-subprim-jump-vinsn (tail-funcall-slide) .SPtfuncallslide) + +(define-x8632-vinsn nth-value (((result :lisp)) + () + ((temp :u32) + (nargs (:lisp #.x8632::nargs)))) + (leal (:@ (:%l x8632::esp) (:%l x8632::nargs)) (:%l temp)) + (subl (:@ (:%l temp)) (:%l x8632::nargs)) + (movl (:$l (:apply target-nil-value)) (:%l result)) + (jle :done) + ;; I -think- that a CMOV would be safe here, assuming that N wasn't + ;; extremely large. Don't know if we can assume that. + (movl (:@ (- x8632::node-size) (:%l x8632::esp) (:%l x8632::nargs)) (:%l result)) + :done + (leal (:@ x8632::node-size (:%l temp)) (:%l x8632::esp))) + + +(define-x8632-subprim-lea-jmp-vinsn (req-heap-rest-arg) .SPreq-heap-rest-arg) + +(define-x8632-subprim-call-vinsn (stack-misc-alloc-init) .SPstack-misc-alloc-init) + +(define-x8632-vinsn %debug-trap (() + ()) + (uuo-error-debug-trap)) + +(define-x8632-vinsn double-to-single (((result :single-float)) + ((arg :double-float))) + (cvtsd2ss (:%xmm arg) (:%xmm result))) + +(define-x8632-vinsn single-to-double (((result :double-float)) + ((arg :single-float))) + (cvtss2sd (:%xmm arg) (:%xmm result))) + +(define-x8632-vinsn alloc-c-frame (() + ((nwords :u32const)) + ((temp :imm))) + (movd (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%mmx x8632::stack-temp)) + ;; Work around Apple bug number 6386516 (open stub may clobber stack) + ;; by leaving an extra word of space in the parameter area. + (subl (:$l (:apply ash (:apply 1+ nwords) x8632::word-shift)) + (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + ;; align stack to 16-byte boundary + (andb (:$b -16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (subl (:$b (* 2 x8632::node-size)) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:% x8632::ebp) (:@ 4 (:%l temp)))) + +(define-x8632-vinsn alloc-variable-c-frame (() + ((nwords :imm)) + ((temp :imm))) + (movd (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%mmx x8632::stack-temp)) + ;; Work around Apple bug number 6386516 (open stub may clobber stack) + ;; by leaving an extra word of space in the parameter area. + ;; Note that nwords is a fixnum. + (leal (:@ 4 (:%l nwords)) (:%l temp)) + (subl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + ;; align stack to 16-byte boundary + (andb (:$b -16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (subl (:$b (* 2 x8632::node-size)) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:% x8632::ebp) (:@ 4 (:%l temp)))) + +(define-x8632-vinsn set-c-arg (() + ((arg :u32) + (offset :u32const)) + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movl (:%l arg) (:@ (:apply + 8 (:apply ash offset 2)) (:%l temp)))) + +;;; This is a pretty big crock. +(define-x8632-vinsn set-c-arg-from-mm0 (() + ((offset :u32const)) + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movq (:%mmx x8632::mm0) (:@ (:apply + 8 (:apply ash offset 2)) (:%l temp)))) + +(define-x8632-vinsn eep.address (((dest t)) + ((src (:lisp (:ne dest ))))) + :resume + (movl (:@ (+ (ash 1 x8632::word-shift) x8632::misc-data-offset) (:%l src)) + (:%l dest)) + (cmpl (:$l (:apply target-nil-value)) (:%l dest)) + (je :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-eep-unresolved (:%l src) (:%l dest)))) + +(define-x8632-subprim-lea-jmp-vinsn (heap-cons-rest-arg) .SPheap-cons-rest-arg) + +(define-x8632-subprim-lea-jmp-vinsn (stack-cons-rest-arg) .SPstack-cons-rest-arg) + +(define-x8632-subprim-lea-jmp-vinsn (make-stack-vector) .SPmkstackv) + +(define-x8632-vinsn %current-frame-ptr (((dest :imm)) + ()) + (movl (:%l x8632::ebp) (:%l dest))) + +(define-x8632-vinsn %foreign-stack-pointer (((dest :imm)) + ()) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l dest))) + + +(define-x8632-vinsn %slot-ref (((dest :lisp)) + ((instance (:lisp (:ne dest))) + (index :lisp))) + (movl (:@ x8632::misc-data-offset (:%l instance) (:%l index)) (:%l dest)) + (cmpl (:$l x8632::slot-unbound-marker) (:%l dest)) + (je :bad) + :resume + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-slot-unbound (:%l dest) (:%l instance) (:%l index)))) + + + +(define-x8632-vinsn symbol-ref (((dest :lisp)) + ((src :lisp) + (cellno :u32const))) + (movl (:@ (:apply + (- x8632::node-size x8632::fulltag-misc) + (:apply ash cellno 2)) + (:%l src)) (:%l dest))) + +(define-x8632-vinsn mem-ref-c-bit-fixnum (((dest :lisp)) + ((src :address) + (offset :s32const)) + ((temp :imm))) + ((:pred = 0 (:apply ash offset -5)) + (btl (:$ub (:apply logand 31 offset)) + (:@ (:%l src)))) + ((:not (:pred = 0 (:apply ash offset -5))) + (btl (:$ub (:apply logand 31 offset)) + (:@ (:apply ash (:apply ash offset -5) 2) (:%l src)))) + (movl (:$l x8632::fixnumone) (:%l temp)) + (movl (:$l 0) (:%l dest)) + (cmovbl (:%l temp) (:%l dest))) + +(define-x8632-vinsn mem-ref-bit-fixnum (((dest :lisp) + (src :address)) + ((src :address) + (offset :lisp)) + ((temp :lisp))) + ;; (mark-as-imm temp) + (btrl (:$ub (:apply %hard-regspec-value temp)) + (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask)) + (movl (:%l offset) (:%l temp)) + (shrl (:$ub (+ 5 x8632::fixnumshift)) (:%l temp)) + (leal (:@ (:%l src) (:%l temp) 4) (:%l src)) + (movl (:%l offset) (:%l temp)) + (shrl (:$ub x8632::fixnumshift) (:%l temp)) + (andl (:$l 31) (:%l temp)) + (btl (:%l temp) (:@ (:%l src))) + (movl (:$l x8632::fixnumone) (:%l temp)) + (leal (:@ (- x8632::fixnumone) (:%l temp)) (:%l dest)) + (cmovbl (:%l temp) (:%l dest)) + ;; (mark-as-node temp) + (xorl (:%l temp) (:%l temp)) + (btsl (:$ub (:apply %hard-regspec-value temp)) + (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask))) + +(define-x8632-subprim-call-vinsn (progvsave) .SPprogvsave) + +(define-x8632-subprim-jump-vinsn (progvrestore) .SPprogvrestore) + +(define-x8632-subprim-lea-jmp-vinsn (simple-keywords) .SPsimple-keywords) + +(define-x8632-subprim-lea-jmp-vinsn (keyword-args) .SPkeyword-args) + +(define-x8632-subprim-lea-jmp-vinsn (keyword-bind) .SPkeyword-bind) + +(define-x8632-vinsn set-high-halfword (() + ((dest :imm) + (n :s16const))) + (orl (:$l (:apply ash n 16)) (:%l dest))) + +(define-x8632-vinsn scale-nargs (() + ((nfixed :s16const))) + ((:pred > nfixed 0) + ((:pred < nfixed 32) + (subl (:$b (:apply ash nfixed x8632::word-shift)) (:%l x8632::nargs))) + ((:pred >= nfixed 32) + (subl (:$l (:apply ash nfixed x8632::word-shift)) (:%l x8632::nargs))))) + +(define-x8632-vinsn opt-supplied-p (() + ((num-opt :u16const)) + ((nargs (:u32 #.x8632::nargs)) + (imm :imm))) + (xorl (:%l imm) (:%l imm)) + (movl (:$l (:apply target-nil-value)) (:%l x8632::arg_y)) + :loop + (rcmpl (:%l imm) (:%l nargs)) + (movl (:%l x8632::arg_y) (:%l x8632::arg_z)) + (cmovll (:@ (+ x8632::t-offset x8632::symbol.vcell) (:%l x8632::arg_y)) (:%l x8632::arg_z)) + (addl (:$b x8632::node-size) (:%l imm)) + (rcmpl (:%l imm) (:$l (:apply ash num-opt x8632::fixnumshift))) + (pushl (:%l x8632::arg_z)) + (jne :loop)) + +(define-x8632-vinsn one-opt-supplied-p (() + () + ((temp :u32))) + (testl (:%l x8632::nargs) (:%l x8632::nargs)) + (setne (:%b temp)) + (negb (:%b temp)) + (andl (:$b x8632::t-offset) (:%l temp)) + (addl (:$l (:apply target-nil-value)) (:%l temp)) + (pushl (:%l temp))) + +;; needs some love +(define-x8632-vinsn two-opt-supplied-p (() + ()) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash 2 x8632::word-shift))) + (jge :two) + (rcmpl (:%l x8632::nargs) (:$b (:apply ash 1 x8632::word-shift))) + (je :one) + ;; none + (pushl (:$l (:apply target-nil-value))) + (pushl (:$l (:apply target-nil-value))) + (jmp :done) + :one + (pushl (:$l (:apply target-t-value))) + (pushl (:$l (:apply target-nil-value))) + (jmp :done) + :two + (pushl (:$l (:apply target-t-value))) + (pushl (:$l (:apply target-t-value))) + :done) + +(define-x8632-vinsn set-c-flag-if-constant-logbitp (() + ((bit :u8const) + (int :imm))) + (btl (:$ub bit) (:%l int))) + +(define-x8632-vinsn set-c-flag-if-variable-logbitp (() + ((bit :imm) + (int :imm)) + ((temp :u32))) + (movl (:%l bit) (:%l temp)) + (sarl (:$ub x8632::fixnumshift) (:%l temp)) + (addl (:$b x8632::fixnumshift) (:%l temp)) + ;; Would be nice to use a cmov here, but the branch is probably + ;; cheaper than trying to scare up an additional unboxed temporary. + (cmpb (:$ub 31) (:%b temp)) + (jbe :test) + (movl (:$l 31) (:%l temp)) + :test + (btl (:%l temp) (:%l int))) + +(define-x8632-vinsn multiply-immediate (((dest :imm)) + ((src :imm) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (imull (:$b const) (:%l src) (:%l dest))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (imull (:$l const) (:%l src) (:%l dest)))) + +(define-x8632-vinsn multiply-fixnums (((dest :imm)) + ((x :imm) + (y :imm)) + ((unboxed :s32))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (movl (:%l y) (:%l unboxed)) + (sarl (:$ub x8632::fixnumshift) (:%l unboxed)) + (imull (:%l unboxed) (:%l dest))) + ((:and (:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movl (:%l x) (:%l unboxed)) + (sarl (:$ub x8632::fixnumshift) (:%l unboxed)) + (imull (:%l unboxed) (:%l dest))) + ((:and (:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + (:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)))) + (movl (:%l y) (:%l dest)) + (movl (:%l x) (:%l unboxed)) + (sarl (:$ub x8632::fixnumshift) (:%l unboxed)) + (imull (:%l unboxed) (:%l dest)))) + + +(define-x8632-vinsn mark-as-imm (() + ((reg :imm))) + (btrl (:$ub (:apply %hard-regspec-value reg)) (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask))) + +(define-x8632-vinsn mark-as-node (() + ((reg :imm))) + (xorl (:%l reg) (:%l reg)) + (btsl (:$ub (:apply %hard-regspec-value reg)) (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask))) + +(define-x8632-vinsn mark-temp1-as-node-preserving-flags (() + () + ((reg (:u32 #.x8632::temp1)))) + (movl (:$l 0) (:%l reg)) ;not xorl! + (cld)) ;well, preserving most flags. + + + + +(define-x8632-vinsn (temp-push-unboxed-word :push :word :csp) + (() + ((w :u32)) + ((temp :imm))) + (movd (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%mmx x8632::stack-temp)) + (subl (:$b 16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:%l x8632::ebp) (:@ 4 (:%l temp))) + (movl (:%l w) (:@ 8 (:%l temp)))) + +(define-x8632-vinsn (temp-pop-unboxed-word :pop :word :csp) + (((w :u32)) + ()) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l w)) + (movl (:@ 8 (:%l w)) (:%l w)) + (addl (:$b 16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp))) + +(define-x8632-vinsn (temp-pop-temp1-as-unboxed-word :pop :word :csp) + (() + () + ((w (:u32 #.x8632::temp1)))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l w)) + (std) + (movl (:@ 8 (:%l w)) (:%l w)) + (addl (:$b 16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp))) + +(define-x8632-vinsn (temp-push-node :push :word :tsp) + (() + ((w :lisp)) + ((temp :imm))) + (subl (:$b (* 2 x8632::dnode-size)) (:@ (:%seg :rcontext) x8632::tcr.next-tsp)) + (movd (:@ (:%seg :rcontext) x8632::tcr.save-tsp) (:%mmx x8632::stack-temp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.next-tsp) (:%l temp)) + (movsd (:%xmm x8632::fpzero) (:@ (:%l temp))) + (movsd (:%xmm x8632::fpzero) (:@ x8632::dnode-size (:%l temp))) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.save-tsp)) + (movl (:%l w) (:@ x8632::dnode-size (:%l temp)))) + +(define-x8632-vinsn (temp-pop-node :pop :word :tsp) + (((w :lisp)) + () + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.save-tsp) (:%l temp)) + (movl (:@ x8632::dnode-size (:%l temp)) (:%l w)) + (movl (:@ (:%l temp)) (:%l temp)) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.save-tsp)) + (movl (:%l temp) (:@ (:%seg :rcontext) x8632::tcr.next-tsp))) + +(define-x8632-vinsn (temp-push-single-float :push :word :csp) + (() + ((f :single-float)) + ((temp :imm))) + (movd (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%mmx x8632::stack-temp)) + (subl (:$b 16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:%l x8632::ebp) (:@ 4 (:%l temp))) + (movss (:%xmm f) (:@ 8 (:%l temp)))) + +(define-x8632-vinsn (temp-pop-single-float :pop :word :csp) + (((f :single-float)) + () + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movss (:@ 8 (:%l temp)) (:%xmm f)) + (addl (:$b 16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp))) + +(define-x8632-vinsn (temp-push-double-float :push :word :csp) + (() + ((f :double-float)) + ((temp :imm))) + (movd (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%mmx x8632::stack-temp)) + (subl (:$b 16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp)) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movd (:%mmx x8632::stack-temp) (:@ (:%l temp))) + (movl (:%l x8632::ebp) (:@ 4 (:%l temp))) + (movsd (:%xmm f) (:@ 8 (:%l temp)))) + +(define-x8632-vinsn (temp-pop-double-float :pop :word :csp) + (((f :double-float)) + () + ((temp :imm))) + (movl (:@ (:%seg :rcontext) x8632::tcr.foreign-sp) (:%l temp)) + (movsd (:@ 8 (:%l temp)) (:%xmm f)) + (addl (:$b 16) (:@ (:%seg :rcontext) x8632::tcr.foreign-sp))) + +(define-x8632-vinsn load-next-method-context (((dest :lisp)) + ()) + (movl (:@ (:%seg :rcontext) x8632::tcr.next-method-context) (:%l dest)) + (movl (:$l 0) (:@ (:%seg :rcontext) x8632::tcr.next-method-context))) + +(define-x8632-vinsn save-node-register-to-spill-area (() + ((src :lisp))) + ;; maybe add constant to index slot 0--3 + (movl (:%l src) (:@ (:%seg :rcontext) x8632::tcr.save3))) + +(define-x8632-vinsn load-node-register-from-spill-area (((dest :lisp)) + ()) + (movl (:@ (:%seg :rcontext) x8632::tcr.save3) (:%l dest)) + (movss (:%xmm x8632::fpzero) (:@ (:%seg :rcontext) x8632::tcr.save3))) + +(define-x8632-vinsn align-loop-head (() + ()) +) + +(queue-fixup + (fixup-x86-vinsn-templates + *x8632-vinsn-templates* + x86::*x86-opcode-template-lists* *x8632-backend*)) + +(provide "X8632-VINSNS") Index: /branches/qres/ccl/compiler/X86/X8664/x8664-arch.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/X8664/x8664-arch.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/X8664/x8664-arch.lisp (revision 13564) @@ -0,0 +1,1348 @@ +;;;-*- Mode: Lisp; Package: (X8664 :use CL) -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage "X8664" + (:use "CL") + #+x8664-target + (:nicknames "TARGET")) + +(in-package "X8664") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "X86-ARCH") + (require "X86-LAP") + +(defparameter *x8664-symbolic-register-names* + (make-hash-table :test #'equal) + "For the disassembler, mostly") + +;;; define integer constants which map to +;;; indices in the X86::*X8664-REGISTER-ENTRIES* array. +(ccl::defenum () + rax + rcx + rdx + rbx + rsp + rbp + rsi + rdi + r8 + r9 + r10 + r11 + r12 + r13 + r14 + r15 + ;; 32-bit registers + eax + ecx + edx + ebx + esp + ebp + esi + edi + r8d + r9d + r10d + r11d + r12d + r13d + r14d + r15d + ;; 16-bit-registers + ax + cx + dx + bx + sp + bp + si + di + r8w + r9w + r10w + r11w + r12w + r13w + r14w + r15w + ;; 8-bit registers + al + cl + dl + bl + spl + bpl + sil + dil + r8b + r9b + r10b + r11b + r12b + r13b + r14b + r15b + ;;; xmm registers + xmm0 + xmm1 + xmm2 + xmm3 + xmm4 + xmm5 + xmm6 + xmm7 + xmm8 + xmm9 + xmm10 + xmm11 + xmm12 + xmm13 + xmm14 + xmm15 + ;; MMX registers + mm0 + mm1 + mm2 + mm3 + mm4 + mm5 + mm6 + mm7 + ;; x87 FP regs. May or may not be useful. + st[0] + st[1] + st[2] + st[3] + st[4] + st[5] + st[6] + st[7] + ;; Segment registers + cs + ds + ss + es + fs + gs + rip + ) + +(defmacro defx86reg (alias known) + (let* ((known-entry (gensym))) + `(let* ((,known-entry (gethash ,(string known) x86::*x8664-registers*))) + (unless ,known-entry + (error "register ~a not defined" ',known)) + (setf (gethash ,(string alias) x86::*x8664-registers*) ,known-entry) + (unless (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*) + (setf (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*) + (string-downcase ,(string alias)))) + (defconstant ,alias ,known)))) + +(defx86reg imm0 rax) +(defx86reg imm0.l eax) +(defx86reg imm0.w ax) +(defx86reg imm0.b al) + +(defx86reg temp0 rbx) +(defx86reg temp0.l ebx) +(defx86reg temp0.w bx) +(defx86reg temp0.b bl) + +(defx86reg imm2 rcx) +(defx86reg nargs ecx) +(defx86reg imm2.l ecx) +(defx86reg nargs.w cx) +(defx86reg nargs.q rcx) +(defx86reg imm2.w cx) +(defx86reg imm2.b cl) +(defx86reg shift cl) + +(defx86reg imm1 rdx) +(defx86reg imm1.l edx) +(defx86reg imm1.w dx) +(defx86reg imm1.b dl) + +(defx86reg arg_z rsi) +(defx86reg arg_z.l esi) +(defx86reg arg_z.w si) +(defx86reg arg_z.b sil) + +(defx86reg arg_y rdi) +(defx86reg arg_y.l edi) +(defx86reg arg_y.w di) +(defx86reg arg_y.b dil) + +(defx86reg arg_x r8) +(defx86reg arg_x.l r8d) +(defx86reg arg_x.w r8w) +(defx86reg arg_x.b r8b) + +(defx86reg temp1 r9) +(defx86reg temp1.l r9d) +(defx86reg temp1.w r9w) +(defx86reg temp1.b r9b) + +(defx86reg ra0 r10) +(defx86reg ra0.l r10d) +(defx86reg ra0.w r10w) +(defx86reg ra0.b r10b) + +(defx86reg temp2 r10) +(defx86reg temp2.l r10d) +(defx86reg temp2.w r10w) +(defx86reg temp2.b r10b) + + +(defx86reg save3 r11) +(defx86reg save3.l r11d) +(defx86reg save3.w r11w) +(defx86reg save3.b r11b) + +(defx86reg save2 r12) +(defx86reg save2.l r12d) +(defx86reg save2.w r12w) +(defx86reg save2.b r12b) + +(defx86reg fn r13) +(defx86reg fn.l r13d) +(defx86reg fn.w r13w) +(defx86reg fn.b r13b) + +(defx86reg save1 r14) +(defx86reg save1.l r14d) +(defx86reg save1.w r14w) +(defx86reg save1.b r14b) + +(defx86reg save0 r15) +(defx86reg save0.l r15d) +(defx86reg save0.w r15w) +(defx86reg save0.b r15b) + +;;; Use xmm regs for floating-point. (They can also hold integer values.) +(defx86reg fp0 xmm0) +(defx86reg fp1 xmm1) +(defx86reg fp2 xmm2) +(defx86reg fp3 xmm3) +(defx86reg fp4 xmm4) +(defx86reg fp5 xmm5) +(defx86reg fp6 xmm6) +(defx86reg fp7 xmm7) +(defx86reg fp8 xmm8) +(defx86reg fp9 xmm9) +(defx86reg fp10 xmm10) +(defx86reg fp11 xmm11) +(defx86reg fp12 xmm12) +(defx86reg fp13 xmm13) +(defx86reg fp14 xmm14) +(defx86reg fpzero xmm15) +(defx86reg fp15 xmm15) + +;;; There are only 8 mmx registers, and they overlap the x87 FPU. +(defx86reg stack-temp mm7) + + +;;; NEXT-METHOD-CONTEXT is passed from gf-dispatch code to the method +;;; functions that it funcalls. FNAME is only meaningful when calling +;;; globally named functions through the function cell of a symbol. +;;; It appears that they're never live at the same time. +;;; (We can also consider passing next-method context on the stack.) + +(defx86reg fname temp0) +(defx86reg next-method-context temp0) +;;; We rely one at least one of %ra0/%fn pointing to the current function +;;; (or to a TRA that references the function) at all times. When we +;;; tail call something, we want %RA0 to point to our caller's TRA and +;;; %FN to point to the new function. Unless we go out of line to +;;; do tail calls, we need some register not involved in the calling +;;; sequence to hold the current function, since it might get GCed otherwise. +;;; (The odds of this happening are low, but non-zero.) +(defx86reg xfn temp1) + +(defx86reg ra1 fn) + +(defx86reg allocptr temp0) + + +(defconstant nbits-in-word 64) +(defconstant nbits-in-byte 8) +(defconstant ntagbits 4) +(defconstant nlisptagbits 3) +(defconstant nfixnumtagbits 3) +(defconstant num-subtag-bits 8) +(defconstant fixnumshift 3) +(defconstant fixnum-shift 3) +(defconstant fulltagmask 15) +(defconstant tagmask 7) +(defconstant fixnummask 7) +(defconstant ncharcodebits 8) +(defconstant charcode-shift 8) +(defconstant word-shift 3) +(defconstant word-size-in-bytes 8) +(defconstant node-size word-size-in-bytes) +(defconstant dnode-size 16) +(defconstant dnode-align-bits 4) +(defconstant dnode-shift dnode-align-bits) +(defconstant bitmap-shift 6) + +(defconstant fixnumone (ash 1 fixnumshift)) +(defconstant fixnum-one fixnumone) +(defconstant fixnum1 fixnumone) + +(defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits)))) +(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits))))) + +;;; 3-bit "lisptag" values + +(defconstant tag-fixnum 0) +(defconstant tag-imm-0 1) ;subtag-single-float ONLY +(defconstant tag-imm-1 2) ;subtag-character, internal markers +(defconstant tag-list 3) ;fulltag-cons or NIL +(defconstant tag-tra 4) ;tagged return-address +(defconstant tag-misc 5) ;random uvector +(defconstant tag-symbol 6) ;non-null symbol +(defconstant tag-function 7) ;function entry point + +(defconstant tag-single-float tag-imm-0) + +;;; 4-bit "fulltag" values +(defconstant fulltag-even-fixnum 0) +(defconstant fulltag-imm-0 1) ;subtag-single-float ONLY +(defconstant fulltag-imm-1 2) ;characters, markers +(defconstant fulltag-cons 3) +(defconstant fulltag-tra-0 4) ;tagged return address +(defconstant fulltag-nodeheader-0 5) +(defconstant fulltag-nodeheader-1 6) +(defconstant fulltag-immheader-0 7) +(defconstant fulltag-odd-fixnum 8) +(defconstant fulltag-immheader-1 9) +(defconstant fulltag-immheader-2 10) +(defconstant fulltag-nil 11) +(defconstant fulltag-tra-1 12) +(defconstant fulltag-misc 13) +(defconstant fulltag-symbol 14) +(defconstant fulltag-function 15) + +(defconstant fulltag-single-float fulltag-imm-0) + +(defmacro define-subtag (name tag value) + `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,value ntagbits)))) + + +(define-subtag arrayH fulltag-nodeheader-0 10) +(define-subtag vectorH fulltag-nodeheader-1 10) +(define-subtag simple-vector fulltag-nodeheader-1 11) +(defconstant min-vector-subtag subtag-vectorH) +(defconstant min-array-subtag subtag-arrayH) + +(defconstant ivector-class-64-bit fulltag-immheader-2) +(defconstant ivector-class-32-bit fulltag-immheader-1) +(defconstant ivector-class-other-bit fulltag-immheader-0) + +(define-subtag fixnum-vector ivector-class-64-bit 12) +(define-subtag s64-vector ivector-class-64-bit 13) +(define-subtag u64-vector ivector-class-64-bit 14) +(define-subtag double-float-vector ivector-class-64-bit 15) + +(define-subtag simple-base-string ivector-class-32-bit 12) +(define-subtag s32-vector ivector-class-32-bit 13) +(define-subtag u32-vector ivector-class-32-bit 14) +(define-subtag single-float-vector ivector-class-32-bit 15) + +(define-subtag s16-vector ivector-class-other-bit 10) +(define-subtag u16-vector ivector-class-other-bit 11) + +(define-subtag s8-vector ivector-class-other-bit 13) +(define-subtag u8-vector ivector-class-other-bit 14) +(defconstant min-8-bit-ivector-subtag subtag-s8-vector) +(defconstant max-8-bit-ivector-subtag subtag-u8-vector) +(define-subtag bit-vector ivector-class-other-bit 15) + + +;;; There's some room for expansion in non-array ivector space. +(define-subtag macptr ivector-class-64-bit 1) +(define-subtag dead-macptr ivector-class-64-bit 2) +(define-subtag bignum ivector-class-32-bit 1) +(define-subtag double-float ivector-class-32-bit 2) +(define-subtag xcode-vector ivector-class-32-bit 3) + + + +;;; Note the difference between (e.g) fulltag-function - which +;;; defines what the low 4 bytes of a function pointer look like - +;;; and subtag-function - which describes what the subtag byte +;;; in a function header looks like. (Likewise for fulltag-symbol +;;; and subtag-symbol) + +;;; don't use nodheader/0, since that would conflict with tag-misc +(define-subtag symbol fulltag-nodeheader-0 1) +(define-subtag catch-frame fulltag-nodeheader-0 2) +(define-subtag hash-vector fulltag-nodeheader-0 3) +(define-subtag pool fulltag-nodeheader-0 4) +(define-subtag weak fulltag-nodeheader-0 5) +(define-subtag package fulltag-nodeheader-0 6) +(define-subtag slot-vector fulltag-nodeheader-0 7) +(define-subtag basic-stream fulltag-nodeheader-0 8) +(define-subtag function fulltag-nodeheader-0 9) + +(define-subtag ratio fulltag-nodeheader-1 1) +(define-subtag complex fulltag-nodeheader-1 2) +(define-subtag struct fulltag-nodeheader-1 3) +(define-subtag istruct fulltag-nodeheader-1 4) +(define-subtag value-cell fulltag-nodeheader-1 5) +(define-subtag xfunction fulltag-nodeheader-1 6) +(define-subtag lock fulltag-nodeheader-1 7) +(define-subtag instance fulltag-nodeheader-1 8) + + +(defconstant canonical-nil-value (+ #x13000 fulltag-nil)) +(defconstant canonical-t-value (+ #x13020 fulltag-symbol)) +(defconstant misc-bias fulltag-misc) +(defconstant cons-bias fulltag-cons) +(defconstant t-offset (- canonical-t-value canonical-nil-value)) + + +(defconstant misc-header-offset (- fulltag-misc)) +(defconstant misc-data-offset (+ misc-header-offset node-size)) +(defconstant misc-subtag-offset misc-header-offset) +(defconstant misc-dfloat-offset misc-data-offset) +(defconstant misc-symbol-offset (- node-size fulltag-symbol)) +(defconstant misc-function-offset (- node-size fulltag-function)) + +(define-subtag single-float fulltag-imm-0 0) + +(define-subtag character fulltag-imm-1 0) + +(define-subtag unbound fulltag-imm-1 1) +(defconstant unbound-marker subtag-unbound) +(defconstant undefined unbound-marker) +(define-subtag slot-unbound fulltag-imm-1 2) +(defconstant slot-unbound-marker subtag-slot-unbound) +(define-subtag illegal fulltag-imm-1 3) +(defconstant illegal-marker subtag-illegal) +(define-subtag no-thread-local-binding fulltag-imm-1 4) +(defconstant no-thread-local-binding-marker subtag-no-thread-local-binding) +(define-subtag reserved-frame fulltag-imm-1 5) +(defconstant reserved-frame-marker subtag-reserved-frame) + +;;; This has two functions: it tells the link-inverting marker where the +;;; code ends and the constants start, and it ensures that the 0th constant +;;; will never be in the same memozized dnode as some (unboxed) word of +;;; machine code. I'm not sure if there's a better way to do either of those +;;; things. +;;; Depending on how you look at it, we either lose 8 bytes per function, or gain +;;; 7 bytes of otherwise unused space for debugging info. +(define-subtag function-boundary-marker fulltag-imm-1 15) +(defconstant function-boundary-marker subtag-function-boundary-marker) + +(defconstant max-64-bit-constant-index (ash (+ #x7fffffff x8664::misc-dfloat-offset) -3)) +(defconstant max-32-bit-constant-index (ash (+ #x7fffffff x8664::misc-data-offset) -2)) +(defconstant max-16-bit-constant-index (ash (+ #x7fffffff x8664::misc-data-offset) -1)) +(defconstant max-8-bit-constant-index (+ #x7fffffff x8664::misc-data-offset)) +(defconstant max-1-bit-constant-index (ash (+ #x7fffffff x8664::misc-data-offset) 3)) + +) +(defmacro define-storage-layout (name origin &rest cells) + `(progn + (ccl::defenum (:start ,origin :step 8) + ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells)) + (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells) + 8)))) + +(defmacro define-lisp-object (name tagname &rest cells) + `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells)) + +(defmacro define-fixedsized-object (name (&optional (fulltag 'fulltag-misc)) + &rest non-header-cells) + `(progn + (define-lisp-object ,name ,fulltag header ,@non-header-cells) + (ccl::defenum () + ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells)) + (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells)))) + +;;; Order of CAR and CDR doesn't seem to matter much - there aren't +;;; too many tricks to be played with predecrement/preincrement addressing. +;;; Keep them in the confusing MCL 3.0 order, to avoid confusion. +(define-lisp-object cons fulltag-cons + cdr + car) + +(define-fixedsized-object ratio () + numer + denom) + +;;; It's slightly easier (for bootstrapping reasons) +;;; to view a DOUBLE-FLOAT as being UVECTOR with 2 32-bit elements +;;; (rather than 1 64-bit element). + +(defconstant double-float.value misc-data-offset) +(defconstant double-float.value-cell 0) +(defconstant double-float.val-low double-float.value) +(defconstant double-float.val-low-cell 0) +(defconstant double-float.val-high (+ double-float.value 4)) +(defconstant double-float.val-high-cell 1) +(defconstant double-float.element-count 2) +(defconstant double-float.size 16) + +(define-fixedsized-object complex () + realpart + imagpart +) + +;;; There are two kinds of macptr; use the length field of the header if you +;;; need to distinguish between them +(define-fixedsized-object macptr () + address + domain + type +) + +(define-fixedsized-object xmacptr () + address + domain + type + flags + link +) + + +;;; Need to think about catch frames on x8664. +(define-fixedsized-object catch-frame () + catch-tag ; # -> unwind-protect, else catch + link ; tagged pointer to next older catch frame + mvflag ; 0 if single-value, 1 if uwp or multiple-value + rsp ; + rbp + foreign-sp + db-link ; value of dynamic-binding link on thread entry. + save-save3 ; saved nvrs + save-save2 + save-save1 + save-save0 + xframe ; exception-frame link + pc ; tra of catch exit/unwind cleanup +) + +(define-fixedsized-object lock () + _value ;finalizable pointer to kernel object + kind ; '0 = recursive-lock, '1 = rwlock + writer ;tcr of owning thread or 0 + name + whostate + whostate-2 + ) + + + +;;; If we're pointing at the "symbol-vector", we can use these +(define-fixedsized-object symptr () + pname + vcell + fcell + package-predicate + flags + plist + binding-index +) + +(define-fixedsized-object symbol (fulltag-symbol) + pname + vcell + fcell + package-predicate + flags + plist + binding-index +) + +(defconstant nilsym-offset (+ t-offset symbol.size)) + + +(define-fixedsized-object vectorH () + logsize ; fillpointer if it has one, physsize otherwise + physsize ; total size of (possibly displaced) data vector + data-vector ; object this header describes + displacement ; true displacement or 0 + flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector. +) + +(define-lisp-object arrayH fulltag-misc + header ; subtag = subtag-arrayH + rank ; NEVER 1 + physsize ; total size of (possibly displaced) data vector + data-vector ; object this header describes + displacement ; true displacement or 0 + flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector. + ;; Dimensions follow +) + +(defconstant arrayH.rank-cell 0) +(defconstant arrayH.physsize-cell 1) +(defconstant arrayH.data-vector-cell 2) +(defconstant arrayH.displacement-cell 3) +(defconstant arrayH.flags-cell 4) +(defconstant arrayH.dim0-cell 5) + +(defconstant arrayH.flags-cell-bits-byte (byte 8 0)) +(defconstant arrayH.flags-cell-subtag-byte (byte 8 8)) + +(define-fixedsized-object value-cell () + value) + + +(define-storage-layout lisp-frame 0 + backptr + return-address + xtra) + +(define-storage-layout tsp-frame 0 + backptr + rbp) + +(define-storage-layout csp-frame 0 + backptr + rbp) + + +(define-storage-layout xcf 0 ;"exception callback frame" + backptr + return-address ; always 0 + nominal-function + relative-pc + containing-object + xp + ra0 + foreign-sp ; value of tcr.foreign_sp + prev-xframe ; tcr.xframe before exception + ; (last 2 needed by apply-in-frame) + ) + +;;; The kernel uses these (rather generically named) structures +;;; to keep track of various memory regions it (or the lisp) is +;;; interested in. + + +(define-storage-layout area 0 + pred ; pointer to preceding area in DLL + succ ; pointer to next area in DLL + low ; low bound on area addresses + high ; high bound on area addresses. + active ; low limit on stacks, high limit on heaps + softlimit ; overflow bound + hardlimit ; another one + code ; an area-code; see below + markbits ; bit vector for GC + ndwords ; "active" size of dynamic area or stack + older ; in EGC sense + younger ; also for EGC + h ; Handle or null pointer + softprot ; protected_area structure pointer + hardprot ; another one. + owner ; fragment (library) which "owns" the area + refbits ; bitvector for intergenerational refernces + threshold ; for egc + gc-count ; generational gc count. + static-dnodes ; for honsing. etc + static-used ; bitvector +) + + +(define-storage-layout protected-area 0 + next + start ; first byte (page-aligned) that might be protected + end ; last byte (page-aligned) that could be protected + nprot ; Might be 0 + protsize ; number of bytes to protect + why) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant tcr-bias 0) +) + +(define-storage-layout tcr (- tcr-bias) + prev ; in doubly-linked list + next ; in doubly-linked list + single-float-convert ; faster to box/unbox through memory + linear + save-rbp ; lisp frame ptr for foreign code + lisp-fpscr-high + db-link ; special binding chain head + catch-top ; top catch frame + save-vsp ; SP when in foreign code + save-tsp ; TSP, at all times + foreign-sp ; SP when in lisp code + cs-area ; cstack area pointer + vs-area ; vstack area pointer + ts-area ; tstack area pointer + cs-limit ; cstack overflow limit + total-bytes-allocated + log2-allocation-quantum ; unboxed + interrupt-pending ; fixnum + xframe ; exception frame linked list + errno-loc ; thread-private, maybe + ffi-exception ; fpscr bits from ff-call. + osid ; OS thread id + valence ; odd when in foreign code + foreign-exception-status + native-thread-info + native-thread-id + last-allocptr + save-allocptr + save-allocbase + reset-completion + activate + suspend-count + suspend-context + pending-exception-context + suspend ; semaphore for suspension notify + resume ; sempahore for resumption notify + flags ; foreign, being reset, ... + gc-context + termination-semaphore + unwinding + tlb-limit + tlb-pointer + shutdown-count + next-tsp + safe-ref-address + pending-io-info + io-datum +) + +(defconstant tcr.single-float-convert.value (+ 4 tcr.single-float-convert)) + + +(defconstant interrupt-level-binding-index (ash 1 fixnumshift)) + +(define-storage-layout lockptr 0 + avail + owner + count + signal + waiting + malloced-ptr + spinlock) + +(define-storage-layout rwlock 0 + spin + state + blocked-writers + blocked-readers + writer + reader-signal + writer-signal + malloced-ptr + ) + +(defmacro define-header (name element-count subtag) + `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag))) + +(define-header double-float-header double-float.element-count subtag-double-float) + +;;; We could possibly have a one-digit bignum header when dealing +;;; with "small bignums" in some bignum code. Like other cases of +;;; non-normalized bignums, they should never escape from the lab. +(define-header one-digit-bignum-header 1 subtag-bignum) +(define-header two-digit-bignum-header 2 subtag-bignum) +(define-header three-digit-bignum-header 3 subtag-bignum) +(define-header four-digit-bignum-header 4 subtag-bignum) +(define-header five-digit-bignum-header 5 subtag-bignum) +(define-header symbol-header symbol.element-count subtag-symbol) +(define-header value-cell-header value-cell.element-count subtag-value-cell) +(define-header macptr-header macptr.element-count subtag-macptr) + + +(defconstant gf-code-size 18) + +(defun %kernel-global (sym) + (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=))) + (if pos + (- (+ fulltag-nil (* (1+ pos) node-size))) + (error "Unknown kernel global : ~s ." sym)))) + +(defmacro kernel-global (sym) + (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=))) + (if pos + (- (+ fulltag-nil (* (1+ pos) node-size))) + (error "Unknown kernel global : ~s ." sym)))) + +(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step node-size) + fd-setsize-bytes + do-fd-set + do-fd-clr + do-fd-is-set + do-fd-zero + MakeDataExecutable + GetSharedLibrary + FindSymbol + malloc + free + jvm-init + tcr-frame-ptr + register-xmacptr-dispose-function + open-debug-output + get-r-debug + restore-soft-stack-limit + egc-control + lisp-bug + NewThread + YieldToThread + DisposeThread + ThreadCurrentStackSpace + usage-exit + save-fp-context + restore-fp-context + put-altivec-registers + get-altivec-registers + new-semaphore + wait-on-semaphore + signal-semaphore + destroy-semaphore + new-recursive-lock + lock-recursive-lock + unlock-recursive-lock + destroy-recursive-lock + suspend-other-threads + resume-other-threads + suspend-tcr + resume-tcr + rwlock-new + rwlock-destroy + rwlock-rlock + rwlock-wlock + rwlock-unlock + recursive-lock-trylock + foreign-name-and-offset + lisp-read + lisp-write + lisp-open + lisp-fchmod + lisp-lseek + lisp-close + lisp-ftruncate + lisp-stat + lisp-fstat + lisp-futex + lisp-opendir + lisp-readdir + lisp-closedir + lisp-pipe + lisp-gettimeofday + lisp-sigexit +) + +(defmacro nrs-offset (name) + (let* ((pos (position name x86::*x86-nilreg-relative-symbols* :test #'eq))) + (if pos (* (1- pos) symbol.size)))) + +(defparameter *x8664-target-uvector-subtags* + `((:bignum . ,subtag-bignum) + (:ratio . ,subtag-ratio) + (:single-float . ,subtag-single-float) + (:double-float . ,subtag-double-float) + (:complex . ,subtag-complex ) + (:symbol . ,subtag-symbol) + (:function . ,subtag-function ) + (:xcode-vector . ,subtag-xcode-vector) + (:macptr . ,subtag-macptr ) + (:catch-frame . ,subtag-catch-frame) + (:struct . ,subtag-struct ) + (:istruct . ,subtag-istruct ) + (:pool . ,subtag-pool ) + (:population . ,subtag-weak ) + (:hash-vector . ,subtag-hash-vector ) + (:package . ,subtag-package ) + (:value-cell . ,subtag-value-cell) + (:instance . ,subtag-instance ) + (:lock . ,subtag-lock ) + (:basic-stream . ,subtag-basic-stream) + (:slot-vector . ,subtag-slot-vector) + (:simple-string . ,subtag-simple-base-string ) + (:bit-vector . ,subtag-bit-vector ) + (:signed-8-bit-vector . ,subtag-s8-vector ) + (:unsigned-8-bit-vector . ,subtag-u8-vector ) + (:signed-16-bit-vector . ,subtag-s16-vector ) + (:unsigned-16-bit-vector . ,subtag-u16-vector ) + (:signed-32-bit-vector . ,subtag-s32-vector ) + (:unsigned-32-bit-vector . ,subtag-u32-vector ) + (:signed-64-bit-vector . ,subtag-s64-vector) + (:fixnum-vector . ,subtag-fixnum-vector) + (:unsigned-64-bit-vector . ,subtag-u64-vector) + (:single-float-vector . ,subtag-single-float-vector) + (:double-float-vector . ,subtag-double-float-vector ) + (:simple-vector . ,subtag-simple-vector ) + (:vector-header . ,subtag-vectorH) + (:array-header . ,subtag-arrayH))) + +;;; This should return NIL unless it's sure of how the indicated +;;; type would be represented (in particular, it should return +;;; NIL if the element type is unknown or unspecified at compile-time. +(defun x8664-array-type-name-from-ctype (ctype) + (when (typep ctype 'ccl::array-ctype) + (let* ((element-type (ccl::array-ctype-element-type ctype))) + (typecase element-type + (ccl::class-ctype + (let* ((class (ccl::class-ctype-class element-type))) + (if (or (eq class ccl::*character-class*) + (eq class ccl::*base-char-class*) + (eq class ccl::*standard-char-class*)) + :simple-string + :simple-vector))) + (ccl::numeric-ctype + (if (eq (ccl::numeric-ctype-complexp element-type) :complex) + :simple-vector + (case (ccl::numeric-ctype-class element-type) + (integer + (let* ((low (ccl::numeric-ctype-low element-type)) + (high (ccl::numeric-ctype-high element-type))) + (cond ((or (null low) (null high)) + :simple-vector) + ((and (>= low 0) (<= high 1)) + :bit-vector) + ((and (>= low 0) (<= high 255)) + :unsigned-8-bit-vector) + ((and (>= low 0) (<= high 65535)) + :unsigned-16-bit-vector) + ((and (>= low 0) (<= high #xffffffff)) + :unsigned-32-bit-vector) + ((and (>= low 0) (<= high #xffffffffffffffff)) + :unsigned-64-bit-vector) + ((and (>= low -128) (<= high 127)) + :signed-8-bit-vector) + ((and (>= low -32768) (<= high 32767)) + :signed-16-bit-vector) + ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31)))) + :signed-32-bit-vector) + ((and (>= low target-most-negative-fixnum) + (<= high target-most-positive-fixnum)) + :fixnum-vector) + ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63)))) + :signed-64-bit-vector) + (t :simple-vector)))) + (float + (case (ccl::numeric-ctype-format element-type) + ((double-float long-float) :double-float-vector) + ((single-float short-float) :single-float-vector) + (t :simple-vector))) + (t :simple-vector)))) + (ccl::unknown-ctype) + (ccl::named-ctype + (if (eq element-type ccl::*universal-type*) + :simple-vector)) + (t))))) + +(defun x8664-misc-byte-count (subtag element-count) + (declare (fixnum subtag)) + (if (logbitp (logand subtag fulltagmask) + (logior (ash 1 fulltag-nodeheader-0) + (ash 1 fulltag-nodeheader-1))) + (ash element-count 3) + (case (logand subtag fulltagmask) + (#.ivector-class-64-bit (ash element-count 3)) + (#.ivector-class-32-bit (ash element-count 2)) + (t + (if (= subtag subtag-bit-vector) + (ash (+ 7 element-count) -3) + (if (>= subtag min-8-bit-ivector-subtag) + element-count + (ash element-count 1))))))) + +(defparameter *x8664-subprims-shift* 3) +(defconstant x8664-subprims-base #x15000) + + +(declaim (special *x8664-subprims*)) + +;;; For now, nothing's nailed down and we don't say anything about +;;; registers clobbered. +(let* ((origin x8664-subprims-base) + (step (ash 1 *x8664-subprims-shift*))) + (flet ((define-x8664-subprim (name) + (ccl::make-subprimitive-info :name (string name) + :offset (prog1 origin + (incf origin step))))) + (macrolet ((defx8664subprim (name) + `(define-x8664-subprim ',name))) + (defparameter *x8664-subprims* + (vector + (defx8664subprim .SPjmpsym) + (defx8664subprim .SPjmpnfn) + (defx8664subprim .SPfuncall) + (defx8664subprim .SPmkcatch1v) + (defx8664subprim .SPmkunwind) + (defx8664subprim .SPmkcatchmv) + (defx8664subprim .SPthrow) + (defx8664subprim .SPnthrowvalues) + (defx8664subprim .SPnthrow1value) + (defx8664subprim .SPbind) + (defx8664subprim .SPbind-self) + (defx8664subprim .SPbind-nil) + (defx8664subprim .SPbind-self-boundp-check) + (defx8664subprim .SPrplaca) + (defx8664subprim .SPrplacd) + (defx8664subprim .SPconslist) + (defx8664subprim .SPconslist-star) + (defx8664subprim .SPstkconslist) + (defx8664subprim .SPstkconslist-star) + (defx8664subprim .SPmkstackv) + (defx8664subprim .SPsubtag-misc-ref) + (defx8664subprim .SPsetqsym) + (defx8664subprim .SPprogvsave) + (defx8664subprim .SPstack-misc-alloc) + (defx8664subprim .SPgvector) + (defx8664subprim .SPnvalret) + (defx8664subprim .SPmvpass) + (defx8664subprim .SPrecover-values-for-mvcall) + (defx8664subprim .SPnthvalue) + (defx8664subprim .SPvalues) + (defx8664subprim .SPdefault-optional-args) + (defx8664subprim .SPopt-supplied-p) + (defx8664subprim .SPheap-rest-arg) + (defx8664subprim .SPreq-heap-rest-arg) + (defx8664subprim .SPheap-cons-rest-arg) + (defx8664subprim .SPsimple-keywords) + (defx8664subprim .SPkeyword-args) + (defx8664subprim .SPkeyword-bind) + (defx8664subprim .SPffcall) + (defx8664subprim .SParef2) + (defx8664subprim .SPksignalerr) + (defx8664subprim .SPstack-rest-arg) + (defx8664subprim .SPreq-stack-rest-arg) + (defx8664subprim .SPstack-cons-rest-arg) + (defx8664subprim .SPpoweropen-callbackX) + (defx8664subprim .SPcall-closure) + (defx8664subprim .SPgetXlong) + (defx8664subprim .SPspreadargz) + (defx8664subprim .SPtfuncallgen) + (defx8664subprim .SPtfuncallslide) + (defx8664subprim .SPtfuncallvsp) + (defx8664subprim .SPtcallsymgen) + (defx8664subprim .SPtcallsymslide) + (defx8664subprim .SPtcallsymvsp) + (defx8664subprim .SPtcallnfngen) + (defx8664subprim .SPtcallnfnslide) + (defx8664subprim .SPtcallnfnvsp) + (defx8664subprim .SPmisc-ref) + (defx8664subprim .SPmisc-set) + (defx8664subprim .SPstkconsyz) + (defx8664subprim .SPstkvcell0) + (defx8664subprim .SPstkvcellvsp) + (defx8664subprim .SPmakestackblock) + (defx8664subprim .SPmakestackblock0) + (defx8664subprim .SPmakestacklist) + (defx8664subprim .SPstkgvector) + (defx8664subprim .SPmisc-alloc) + (defx8664subprim .SPpoweropen-ffcallX) + (defx8664subprim .SPgvset) + (defx8664subprim .SPmacro-bind) + (defx8664subprim .SPdestructuring-bind) + (defx8664subprim .SPdestructuring-bind-inner) + (defx8664subprim .SPrecover-values) + (defx8664subprim .SPvpopargregs) + (defx8664subprim .SPinteger-sign) + (defx8664subprim .SPsubtag-misc-set) + (defx8664subprim .SPspread-lexpr-z) + (defx8664subprim .SPstore-node-conditional) + (defx8664subprim .SPreset) + (defx8664subprim .SPmvslide) + (defx8664subprim .SPsave-values) + (defx8664subprim .SPadd-values) + (defx8664subprim .SPcallback) + (defx8664subprim .SPmisc-alloc-init) + (defx8664subprim .SPstack-misc-alloc-init) + (defx8664subprim .SPset-hash-key) + (defx8664subprim .SPaset2) + (defx8664subprim .SPcallbuiltin) + (defx8664subprim .SPcallbuiltin0) + (defx8664subprim .SPcallbuiltin1) + (defx8664subprim .SPcallbuiltin2) + (defx8664subprim .SPcallbuiltin3) + (defx8664subprim .SPpopj) + (defx8664subprim .SPrestorefullcontext) + (defx8664subprim .SPsavecontextvsp) + (defx8664subprim .SPsavecontext0) + (defx8664subprim .SPrestorecontext) + (defx8664subprim .SPlexpr-entry) + (defx8664subprim .SPpoweropen-syscall) + (defx8664subprim .SPbuiltin-plus) + (defx8664subprim .SPbuiltin-minus) + (defx8664subprim .SPbuiltin-times) + (defx8664subprim .SPbuiltin-div) + (defx8664subprim .SPbuiltin-eq) + (defx8664subprim .SPbuiltin-ne) + (defx8664subprim .SPbuiltin-gt) + (defx8664subprim .SPbuiltin-ge) + (defx8664subprim .SPbuiltin-lt) + (defx8664subprim .SPbuiltin-le) + (defx8664subprim .SPbuiltin-eql) + (defx8664subprim .SPbuiltin-length) + (defx8664subprim .SPbuiltin-seqtype) + (defx8664subprim .SPbuiltin-assq) + (defx8664subprim .SPbuiltin-memq) + (defx8664subprim .SPbuiltin-logbitp) + (defx8664subprim .SPbuiltin-logior) + (defx8664subprim .SPbuiltin-logand) + (defx8664subprim .SPbuiltin-ash) + (defx8664subprim .SPbuiltin-negate) + (defx8664subprim .SPbuiltin-logxor) + (defx8664subprim .SPbuiltin-aref1) + (defx8664subprim .SPbuiltin-aset1) + (defx8664subprim .SPbreakpoint) + (defx8664subprim .SPeabi-ff-call) + (defx8664subprim .SPeabi-callback) + (defx8664subprim .SPsyscall) + (defx8664subprim .SPgetu64) + (defx8664subprim .SPgets64) + (defx8664subprim .SPmakeu64) + (defx8664subprim .SPmakes64) + (defx8664subprim .SPspecref) + (defx8664subprim .SPspecset) + (defx8664subprim .SPspecrefcheck) + (defx8664subprim .SPrestoreintlevel) + (defx8664subprim .SPmakes32) + (defx8664subprim .SPmakeu32) + (defx8664subprim .SPgets32) + (defx8664subprim .SPgetu32) + (defx8664subprim .SPfix-overflow) + (defx8664subprim .SPmvpasssym) + (defx8664subprim .SParef3) + (defx8664subprim .SPaset3) + (defx8664subprim .SPffcall-return-registers) + (defx8664subprim .SPunused-5) + (defx8664subprim .SPset-hash-key-conditional) + (defx8664subprim .SPunbind-interrupt-level) + (defx8664subprim .SPunbind) + (defx8664subprim .SPunbind-n) + (defx8664subprim .SPunbind-to) + (defx8664subprim .SPbind-interrupt-level-m1) + (defx8664subprim .SPbind-interrupt-level) + (defx8664subprim .SPbind-interrupt-level-0) + (defx8664subprim .SPprogvrestore) + (defx8664subprim .SPnmkunwind) + + ))))) + +(defparameter *x8664-target-arch* + (arch::make-target-arch :name :x8664 + :lisp-node-size 8 + :nil-value canonical-nil-value + :fixnum-shift fixnumshift + :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift)))) + :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift)))) + :misc-data-offset misc-data-offset + :misc-dfloat-offset misc-dfloat-offset + :nbits-in-word 64 + :ntagbits 4 + :nlisptagbits 3 + :uvector-subtags *x8664-target-uvector-subtags* + :max-64-bit-constant-index max-64-bit-constant-index + :max-32-bit-constant-index max-32-bit-constant-index + :max-16-bit-constant-index max-16-bit-constant-index + :max-8-bit-constant-index max-8-bit-constant-index + :max-1-bit-constant-index max-1-bit-constant-index + :word-shift 3 + :code-vector-prefix nil + :gvector-types '(:ratio :complex :symbol :function + :catch-frame :struct :istruct + :pool :population :hash-vector + :package :value-cell :instance + :lock :slot-vector + :simple-vector) + :1-bit-ivector-types '(:bit-vector) + :8-bit-ivector-types '(:signed-8-bit-vector + :unsigned-8-bit-vector) + :16-bit-ivector-types '(:signed-16-bit-vector + :unsigned-16-bit-vector) + :32-bit-ivector-types '(:signed-32-bit-vector + :unsigned-32-bit-vector + :single-float-vector + :double-float + :bignum + :simple-string) + :64-bit-ivector-types '(:double-float-vector + :unsigned-64-bit-vector + :signed-64-bit-vector + :fixnum-vector) + :array-type-name-from-ctype-function + #'x8664-array-type-name-from-ctype + :package-name "X8664" + :t-offset t-offset + :array-data-size-function #'x8664-misc-byte-count + :numeric-type-name-to-typecode-function + #'(lambda (type-name) + (ecase type-name + (fixnum tag-fixnum) + (bignum subtag-bignum) + ((short-float single-float) subtag-single-float) + ((long-float double-float) subtag-double-float) + (ratio subtag-ratio) + (complex subtag-complex))) + :subprims-base x8664-subprims-base + :subprims-shift x8664::*x8664-subprims-shift* + :subprims-table x8664::*x8664-subprims* + :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus x8664::*x8664-subprims*))) + :unbound-marker-value unbound-marker + :slot-unbound-marker-value slot-unbound-marker + :fixnum-tag tag-fixnum + :single-float-tag subtag-single-float + :single-float-tag-is-subtag nil + :double-float-tag subtag-double-float + :cons-tag fulltag-cons + :null-tag fulltag-nil + :symbol-tag fulltag-symbol + :symbol-tag-is-subtag nil + :function-tag fulltag-function + :function-tag-is-subtag nil + :big-endian nil + :misc-subtag-offset misc-subtag-offset + :car-offset cons.car + :cdr-offset cons.cdr + :subtag-char subtag-character + :charcode-shift charcode-shift + :fulltagmask fulltagmask + :fulltag-misc fulltag-misc + :char-code-limit #x110000 + )) + +;;; arch macros +(defmacro defx8664archmacro (name lambda-list &body body) + `(arch::defarchmacro :x8664 ,name ,lambda-list ,@body)) + +(defx8664archmacro ccl::%make-sfloat () + (error "~s shouldn't be used in code targeting :X8664" 'ccl::%make-sfloat)) + +(defx8664archmacro ccl::%make-dfloat () + `(ccl::%alloc-misc x8664::double-float.element-count x8664::subtag-double-float)) + +(defx8664archmacro ccl::%numerator (x) + `(ccl::%svref ,x x8664::ratio.numer-cell)) + +(defx8664archmacro ccl::%denominator (x) + `(ccl::%svref ,x x8664::ratio.denom-cell)) + +(defx8664archmacro ccl::%realpart (x) + `(ccl::%svref ,x x8664::complex.realpart-cell)) + +(defx8664archmacro ccl::%imagpart (x) + `(ccl::%svref ,x x8664::complex.imagpart-cell)) + +;;; +(defx8664archmacro ccl::%get-single-float-from-double-ptr (ptr offset) + `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset))) + +(defx8664archmacro ccl::codevec-header-p (word) + (declare (ignore word)) + (error "~s makes no sense on :X8664" 'ccl::codevec-header-p)) + +;;; + +(defx8664archmacro ccl::immediate-p-macro (thing) + (let* ((tag (gensym))) + `(let* ((,tag (ccl::lisptag ,thing))) + (declare (type (unsigned-byte 3) ,tag)) + (logbitp ,tag (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::tag-imm-0) + (ash 1 x8664::tag-imm-1)))))) + +(defx8664archmacro ccl::hashed-by-identity (thing) + (let* ((typecode (gensym))) + `(let* ((,typecode (ccl::typecode ,thing))) + (declare (fixnum ,typecode)) + (or (= ,typecode x8664::subtag-instance) + (and (<= ,typecode x8664::fulltag-symbol) + (logbitp (the (integer 0 #.x8664::fulltag-symbol) ,typecode) + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::tag-imm-0) + (ash 1 x8664::tag-imm-1) + (ash 1 x8664::fulltag-symbol)))))))) + +;;; +(defx8664archmacro ccl::%get-kernel-global (name) + `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value) + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name))))) + +(defx8664archmacro ccl::%get-kernel-global-ptr (name dest) + `(ccl::%setf-macptr + ,dest + (ccl::%int-to-ptr (ccl::%fixnum-ref-natural 0 (+ ,(ccl::target-nil-value) + ,(%kernel-global + (if (ccl::quoted-form-p name) + (cadr name) + name))))))) + +(defx8664archmacro ccl::%target-kernel-global (name) + `(x8664::%kernel-global ,name)) + +(defx8664archmacro ccl::lfun-vector (fun) + `(ccl::%function-to-function-vector ,fun)) + +(defx8664archmacro ccl::lfun-vector-lfun (lfv) + `(ccl::%function-vector-to-function ,lfv)) + +(defx8664archmacro ccl::area-code () + area.code) + +(defx8664archmacro ccl::area-succ () + area.succ) + +(defx8664archmacro ccl::nth-immediate (f i) + `(ccl::%nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)))) + +(defx8664archmacro ccl::set-nth-immediate (f i new) + `(ccl::%set-nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)) ,new)) + +(defx8664archmacro ccl::symptr->symvector (s) + `(ccl::%symptr->symvector ,s)) + +(defx8664archmacro ccl::symvector->symptr (s) + `(ccl::%symvector->symptr ,s)) + +(defx8664archmacro ccl::function-to-function-vector (f) + `(ccl::%function-to-function-vector ,f)) + +(defx8664archmacro ccl::function-vector-to-function (v) + `(ccl::%function-vector-to-function ,v)) + +(defx8664archmacro ccl::with-ffcall-results ((buf) &body body) + ;; Reserve space for rax,rdx,xmm0,xmm1 only. + (let* ((size (+ (* 2 8) (* 2 8)))) + `(ccl::%stack-block ((,buf ,size :clear t)) + ,@body))) + +;;; an (lea (@ disp (% rip)) (% fn)) instruction following a tagged +;;; return address helps the runtime map from the return address to +;;; the containing function. That instuction is 7 bytes long: 3 +;;; bytes of code followed by 4 bytes of displacement. The constant +;;; part of that - assuming that FN is R13 - looks like #x4c #x8d #x2d. + +(defconstant recover-fn-from-rip-length 7) +(defconstant recover-fn-from-rip-disp-offset 3) +(defconstant recover-fn-from-rip-word0 #x8d4c) +(defconstant recover-fn-from-rip-byte2 #x2d) + +;;; For backtrace: the relative PC of an argument-check trap +;;; must be less than or equal to this value. (Because of +;;; the way that we do "anchored" UUOs, it should always be =.) + +(defconstant arg-check-trap-pc-limit 7) + +(provide "X8664-ARCH") Index: /branches/qres/ccl/compiler/X86/X8664/x8664-backend.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/X8664/x8664-backend.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/X8664/x8664-backend.lisp (revision 13564) @@ -0,0 +1,664 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "BACKEND")) + +(eval-when (:compile-toplevel :execute) + (require "NXENV") + (require "X8664ENV")) + + +(defvar *x8664-vinsn-templates* (make-hash-table :test #'eq)) + + + +(defvar *known-x8664-backends* ()) + + +#+(or linuxx86-target (not x86-target)) +(defvar *linuxx8664-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :platform-syscall-mask (logior platform-os-linux platform-cpu-x86 platform-word-size-64) + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8664-vinsn-templates* + :p2-template-hash-name '*x8664-vinsn-templates* + :p2-compile 'x862-compile + :target-specific-features + '(:x8664 :x86-target :linux-target :linuxx86-target :x8664-target + :linuxx8664-target + :little-endian-target + :64-bit-target) + :target-fasl-pathname (make-pathname :type "lx64fsl") + :target-platform (logior platform-cpu-x86 + platform-os-linux + platform-word-size-64) + :target-os :linuxx86 + :name :linuxx8664 + :target-arch-name :x8664 + :target-foreign-type-data nil + + + :target-arch x8664::*x8664-target-arch* + :lisp-context-register x8664::gs + )) + + +#+darwinx86-target +(defvar *darwinx8664-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8664-vinsn-templates* + :p2-template-hash-name '*x8664-vinsn-templates* + :p2-compile 'x862-compile + :platform-syscall-mask (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) + :target-specific-features + '(:x8664 :x86-target :darwin-target :darwinx86-target :x8664-target + :darwinx8664-target + :little-endian-target + :64-bit-target) + :target-fasl-pathname (make-pathname :type "dx64fsl") + :target-platform (logior platform-cpu-x86 + platform-os-darwin + platform-word-size-64) + :target-os :darwinx86 + :name :darwinx8664 + :target-arch-name :x8664 + :target-foreign-type-data nil + :target-arch x8664::*x8664-target-arch* + ;; Overload %gs until Apple straightens things out. + ;; Whoops; they never did. + :lisp-context-register x8664::r11 + )) + +#+freebsdx86-target +(defvar *freebsdx8664-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8664-vinsn-templates* + :p2-template-hash-name '*x8664-vinsn-templates* + :p2-compile 'x862-compile + :target-specific-features + '(:x8664 :x86-target :freebsd-target :freebsdx86-target :x8664-target + :freebsdx8664-target + :little-endian-target + :64-bit-target) + :target-fasl-pathname (make-pathname :type "fx64fsl") + :target-platform (logior platform-cpu-x86 + platform-os-freebsd + platform-word-size-64) + :target-os :freebsdx86 + :name :freebsdx8664 + :target-arch-name :x8664 + :target-foreign-type-data nil + :target-arch x8664::*x8664-target-arch* + :platform-syscall-mask (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) + :lisp-context-register x8664::gs + )) + +#+solarisx86-target +(defvar *solarisx8664-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8664-vinsn-templates* + :p2-template-hash-name '*x8664-vinsn-templates* + :p2-compile 'x862-compile + :target-specific-features + '(:x8664 :x86-target :solaris-target :solarisx86-target :x8664-target + :solarisx8664-target + :solarisx64-target + :little-endian-target + :64-bit-target) + :target-fasl-pathname (make-pathname :type "sx64fsl") + :target-platform (logior platform-cpu-x86 + platform-os-solaris + platform-word-size-64) + :target-os :solarisx86 + :name :solarisx8664 + :target-arch-name :x8664 + :target-foreign-type-data nil + :target-arch x8664::*x8664-target-arch* + :platform-syscall-mask (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) + :lisp-context-register x8664::gs + )) + +#+win64-target +(defvar *win64-backend* + (make-backend :lookup-opcode 'lookup-x86-opcode + :lookup-macro #'false + :lap-opcodes x86::*x86-opcode-templates* + :define-vinsn 'define-x86-vinsn + :p2-dispatch *x862-specials* + :p2-vinsn-templates *x8664-vinsn-templates* + :p2-template-hash-name '*x8664-vinsn-templates* + :p2-compile 'x862-compile + :target-specific-features + '(:x8664 :x86-target :win64-target :windows-target :x8664-target + :winx64-target + :little-endian-target + :64-bit-target) + :target-fasl-pathname (make-pathname :type "wx64fsl") + :target-platform (logior platform-cpu-x86 + platform-os-windows + platform-word-size-64) + :target-os :win64 + :name :win64 + :target-arch-name :x8664 + :target-foreign-type-data nil + :target-arch x8664::*x8664-target-arch* + :platform-syscall-mask (logior platform-os-windows platform-cpu-x86 platform-word-size-64) + :lisp-context-register x8664::r11 + )) + +#+(or linuxx86-target (not x86-target)) +(pushnew *linuxx8664-backend* *known-x8664-backends* :key #'backend-name) + + +#+darwinx86-target +(pushnew *darwinx8664-backend* *known-x8664-backends* :key #'backend-name) + +#+freebsdx86-target +(pushnew *freebsdx8664-backend* *known-x8664-backends* :key #'backend-name) + +#+solarisx86-target +(pushnew *solarisx8664-backend* *known-x8664-backends* :key #'backend-name) + +#+win64-target +(pushnew *win64-backend* *known-x8664-backends* :key #'backend-name) + +(defvar *x8664-backend* (car *known-x8664-backends*)) + +(defun fixup-x8664-backend () + (dolist (b *known-x8664-backends*) + (setf #| (backend-lap-opcodes b) x86::*x86-opcodes* |# + (backend-p2-dispatch b) *x862-specials* + (backend-p2-vinsn-templates b) *x8664-vinsn-templates*) + (or (backend-lap-macros b) (setf (backend-lap-macros b) + (make-hash-table :test #'equalp))))) + + + +(fixup-x8664-backend) + +#+x8664-target +(setq *host-backend* *x8664-backend* *target-backend* *x8664-backend*) + +(defun setup-x8664-ftd (backend) + (or (backend-target-foreign-type-data backend) + (let* ((name (backend-name backend)) + (ftd + (case name + (:linuxx8664 + (make-ftd :interface-db-directory + (if (eq backend *host-backend*) + "ccl:x86-headers64;" + "ccl:cross-x86-headers64;") + :interface-package-name "X86-LINUX64" + :attributes '(:bits-per-word 64 + :struct-by-value t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-LINUX64") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-LINUX64") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-LINUX64") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-LINUX64"))) + (:darwinx8664 + (make-ftd :interface-db-directory + (if (eq backend *host-backend*) + "ccl:darwin-x86-headers64;" + "ccl:cross-darwin-x86-headers64;") + :interface-package-name "X86-DARWIN64" + :attributes '(:bits-per-word 64 + :signed-char t + :struct-by-value t + :prepend-underscore t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-DARWIN64") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-DARWIN64") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-DARWIN64") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-DARWIN64"))) + (:freebsdx8664 + (make-ftd :interface-db-directory + (if (eq backend *host-backend*) + "ccl:freebsd-headers64;" + "ccl:cross-freebsd-headers64;") + :interface-package-name "X86-FREEBSD64" + :attributes '(:bits-per-word 64 + :struct-by-value t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-FREEBSD64") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-FREEBSD64") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-FREEBSD64") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-FREEBSD64"))) + (:solarisx8664 + (make-ftd :interface-db-directory + (if (eq backend *host-backend*) + "ccl:solarisx64-headers;" + "ccl:cross-solarisx64-headers;") + :interface-package-name "X86-SOLARIS64" + :attributes '(:bits-per-word 64 + :struct-by-value t) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "X86-SOLARIS64") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "X86-SOLARIS64") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "X86-SOLARIS64") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-SOLARIS64"))) + (:win64 + (make-ftd :interface-db-directory + (if (eq backend *host-backend*) + "ccl:win64-headers;" + "ccl:cross-win64-headers;") + :interface-package-name "WIN64" + :attributes '(:bits-per-word 64 + :struct-by-value t + :bits-per-long 32) + :ff-call-expand-function + (intern "EXPAND-FF-CALL" "WIN64") + :ff-call-struct-return-by-implicit-arg-function + (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" + "WIN64") + :callback-bindings-function + (intern "GENERATE-CALLBACK-BINDINGS" "WIN64") + :callback-return-value-function + (intern "GENERATE-CALLBACK-RETURN-VALUE" "WIN64")))))) + (install-standard-foreign-types ftd) + (use-interface-dir :libc ftd) + (setf (backend-target-foreign-type-data backend) ftd)))) + +#-x8664-target +(setup-x8664-ftd *x8664-backend*) + +(pushnew *x8664-backend* *known-backends* :key #'backend-name) + +;;; FFI stuff. Seems to be shared by Darwin/Linux/FreeBSD. + +;;; A returned structure is passed as an invisible first argument if +;;; it's more than 2 doublewords long or if it contains unaligned fields. +;;; Not clear how the latter case can happen, so this just checks for +;;; the first. +(defun x8664::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (> (ensure-foreign-type-bits ftype) 128)))) + +;;; On x8664, structures can be passed by value: +;;; a) in memory, if they're more than 128 bits in size or if there aren't +;;; enough of the right kind of register to pass them entirely in registers. +;;; b) as a series of 64-bit chunks, passed in GPRs if any component of the +;;; chunk is a non FLOAT or in FPRs otherwise. +;;; Note that this means that a chunk consisting of two SINGLE-FLOATs would +;;; be passed in the low 64 bit of an SSE (xmm) register. + +(defun x8664::field-is-of-class-integer (field) + ;; Return true if field is of "class" integer or if it's a record + ;; type of class integer. (See the System V AMD64 ABI document for + ;; a convoluted definition of field "classes".) + (let* ((ftype (foreign-record-field-type field))) + (typecase ftype + ((or foreign-integer-type foreign-pointer-type) t) + (foreign-record-type (dolist (f (foreign-record-type-fields ftype)) + (when (x8664::field-is-of-class-integer f) + (return t)))) + (otherwise nil)))) + +(defun x8664::classify-8byte (field-list bit-limit) + ;; CDR down the fields in FIELD-LIST until we find a field of class integer, + ;; hit the end of the list, or find a field whose offset is >= BIT-LIMIT. + ;; In the first case, return :INTEGER. In other cases, return :FLOAT. + (dolist (field field-list :float) + (if (<= bit-limit (foreign-record-field-offset field)) + (return :float) + (if (x8664::field-is-of-class-integer field) + (return :integer))))) + +;;; Return a first value :memory, :integer, or::float and a second +;;; value of NIL, :integer, or :float according to how the structure +;;; RTYPE should ideally be passed or returned. Note that the caller +;;; may decide to turn this to :memory if there aren't enough +;;; available registers of the right class when passing an instance of +;;; this structure type. +(defun x8664::classify-record-type (rtype) + (let* ((nbits (ensure-foreign-type-bits rtype)) + (fields (foreign-record-type-fields rtype))) + (cond ((> nbits 128) (values :memory nil)) + ((<= nbits 64) (values (x8664::classify-8byte fields 64) nil)) + (t (values (x8664::classify-8byte fields 64) + (do* () + ((>= (foreign-record-field-offset (car fields)) 64) + (x8664::classify-8byte fields 128)) + (setq fields (cdr fields)))))))) + +(defun x8664::struct-from-regbuf-values (r rtype regbuf) + (multiple-value-bind (first second) + (x8664::classify-record-type rtype) + (let* ((gpr-offset 0) + (fpr-offset 16)) + ;; Do this 32 bits at a time, to avoid consing. + (collect ((forms)) + (case first + (:integer (forms `(setf (%get-unsigned-long ,r 0) + (%get-unsigned-long ,regbuf 0))) + (forms `(setf (%get-unsigned-long ,r 4) + (%get-unsigned-long ,regbuf 4))) + (setq gpr-offset 8)) + (:float (forms `(setf (%get-unsigned-long ,r 0) + (%get-unsigned-long ,regbuf 16))) + (forms `(setf (%get-unsigned-long ,r 4) + (%get-unsigned-long ,regbuf 20))) + (setf fpr-offset 24))) + (case second + (:integer (forms `(setf (%get-unsigned-long ,r 8) + (%get-unsigned-long ,regbuf ,gpr-offset))) + (forms `(setf (%get-unsigned-long ,r 12) + (%get-unsigned-long ,regbuf ,(+ gpr-offset 4))))) + (:float (forms `(setf (%get-unsigned-long ,r 8) + (%get-unsigned-long ,regbuf ,fpr-offset))) + (forms `(setf (%get-unsigned-long ,r 12) + (%get-unsigned-long ,regbuf ,(+ fpr-offset 4)))))) + `(progn ,@(forms)))))) + +(defun x8664::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (regbuf nil) + (result-temp nil) + (result-form nil) + (struct-result-type nil) + (structure-arg-temp nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args) + struct-result-type result-type + result-type *void-foreign-type* + result-type-spec :void) + (if (x8664::record-type-returns-structure-as-first-arg struct-result-type) + (progn + (argforms :address) + (argforms result-form)) + (progn + (setq regbuf (gensym) + result-temp (gensym)) + (argforms :registers) + (argforms regbuf)))) + (let* ((valform nil)) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args)) + (remaining-gprs 6) + (remaining-fprs 8)) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (if (or (eq arg-type-spec :double-float) + (eq arg-type-spec :single-float)) + (decf remaining-fprs) + (unless (typep arg-type-spec 'unsigned-byte) + (decf remaining-gprs))) + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (when (and (typep ftype 'foreign-record-type) + (eq (foreign-record-type-kind ftype) :transparent-union)) + (ensure-foreign-type-bits ftype) + (setq ftype (foreign-record-field-type + (car (foreign-record-type-fields ftype))) + arg-type-spec (foreign-type-to-representation-type ftype))) + (if (typep ftype 'foreign-record-type) + (multiple-value-bind (first8 second8) + (x8664::classify-record-type ftype) + (let* ((gprs remaining-gprs) + (fprs remaining-fprs)) + (case first8 + (:integer (if (< (decf gprs) 0) (setq first8 :memory))) + (:float (if (< (decf fprs) 0) (setq first8 :memory)))) + (case second8 + (:integer (if (< (decf gprs) 0) (setq first8 :memory))) + (:float (if (< (decf fprs) 0) (setq first8 :memory))))) + (if (eq first8 :memory) + (progn + (argforms (ceiling (foreign-record-type-bits ftype) 64)) + (argforms arg-value-form)) + (progn + (if second8 + (progn + (unless structure-arg-temp + (setq structure-arg-temp (gensym))) + (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form))) + (setq valform arg-value-form)) + (if (eq first8 :float) + (progn + (decf remaining-fprs) + (argforms :double-float) + (argforms `(%get-double-float ,valform 0))) + (progn + (decf remaining-gprs) + (argforms :unsigned-doubleword) + (argforms `(%%get-unsigned-longlong ,valform 0)))) + (when second8 + (setq valform structure-arg-temp) + (if (eq second8 :float) + (progn + (decf remaining-fprs) + (argforms :double-float) + (argforms `(%get-double-float ,valform 8))) + (progn + (decf remaining-gprs) + (argforms :unsigned-doubleword) + (argforms `(%%get-unsigned-longlong ,valform 8)))))))) + (let* ((rtype (foreign-type-to-representation-type ftype))) + (if (or (eq rtype :singlefloat) (eq rtype :double-float)) + (decf remaining-fprs) + (decf remaining-gprs)) + (argforms rtype) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (when structure-arg-temp + (setq call `(let* ((,structure-arg-temp (%null-ptr))) + (declare (dynamic-extent ,structure-arg-temp) + (type macptr ,structure-arg-temp)) + ,call))) + (if regbuf + `(let* ((,result-temp (%null-ptr))) + (declare (dynamic-extent ,result-temp) + (type macptr ,result-temp)) + (%setf-macptr ,result-temp ,result-form) + (%stack-block ((,regbuf (+ (* 2 8) (* 2 8)))) + ,call + ,(x8664::struct-from-regbuf-values result-temp struct-result-type regbuf))) + call))))))) + + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR + +(defun x8664::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (declare (ignore fp-args-ptr)) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec))) + (when (typep rtype 'foreign-record-type) + (if (x8664::record-type-returns-structure-as-first-arg rtype) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*) + (rlets (list struct-result-name (foreign-record-type-name rtype))))) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (gpr-arg-num 0) + (gpr-arg-offset -8) + (fpr-arg-num 0) + (fpr-arg-offset -56) + (memory-arg-offset 16) + (fp nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 8)) + (flet ((next-gpr () + (if (<= (incf gpr-arg-num) 6) + (prog1 + gpr-arg-offset + (decf gpr-arg-offset 8)) + (prog1 + memory-arg-offset + (incf memory-arg-offset 8)))) + (next-fpr () + (if (<= (incf fpr-arg-num) 8) + (prog1 + fpr-arg-offset + (decf fpr-arg-offset 8)) + (prog1 + memory-arg-offset + (incf memory-arg-offset 8))))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec)) + (bits (require-foreign-type-bits argtype))) + (if (typep argtype 'foreign-record-type) + (multiple-value-bind (first8 second8) + (x8664::classify-record-type argtype) + (let* ((gprs (- 6 gpr-arg-num)) + (fprs (- 8 fpr-arg-num))) + (case first8 + (:integer (if (< (decf gprs) 0) (setq first8 :memory))) + (:float (if (< (decf fprs) 0) (setq first8 :memory)))) + (case second8 + (:integer (if (< (decf gprs) 0) (setq first8 :memory))) + (:float (if (< (decf fprs) 0) (setq first8 :memory))))) + (if (eq first8 :memory) + (let* ((form `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset + (incf memory-arg-offset (* 8 (ceiling bits 64))))))) + (when name + (lets (list name form)) + (dynamic-extent-names name))) + (progn + (when name (rlets (list name (foreign-record-type-name argtype)))) + (let* ((init1 `(setf (%%get-unsigned-longlong ,name 0) + (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr)))))) + (when name (inits init1))) + (if second8 + (let* ((init2 `(setf (%%get-unsigned-longlong ,name 8) + (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr)))))) + (when name (inits init2 ))))))) + (let* ((form`(, + (ecase (foreign-type-to-representation-type argtype) + (:single-float (setq fp t) '%get-single-float) + (:double-float (setq fp t) '%get-double-float) + (:signed-doubleword '%%get-signed-longlong) + (:signed-fullword '%get-signed-long) + (:signed-halfword '%get-signed-word) + (:signed-byte '%get-signed-byte) + (:unsigned-doubleword '%%get-unsigned-longlong) + (:unsigned-fullword '%get-unsigned-long) + (:unsigned-halfword '%get-unsigned-word) + (:unsigned-byte '%get-unsigned-byte) + (:address + #+nil + (when name (dynamic-extent-names name)) + '%get-ptr)) + ,stack-ptr + ,(if fp (next-fpr) (next-gpr))))) + (if name (lets (list name form ))))))))))) + +(defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore fp-args-ptr)) + (unless (eq return-type *void-foreign-type*) + (let* ((gpr-offset -8) + (fpr-offset -24)) + (if (typep return-type 'foreign-record-type) + ;;; Would have been mapped to :VOID unless record-type was <= 128 bits. + (collect ((forms)) + (multiple-value-bind (first8 second8) + (x8664::classify-record-type return-type) + (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset)) + (%%get-signed-longlong ,struct-return-arg 0))) + (when second8 + (if (eq first8 :integer) (decf gpr-offset 8) (decf fpr-offset 8)) + (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset)) + (%%get-signed-longlong ,struct-return-arg 8)))) + `(progn ,@(forms)))) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (offset (case return-type-keyword + ((:single-float :double-float) fpr-offset) + (t gpr-offset)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + (:double-float '%get-double-float) + (:single-float '%get-single-float) + (:unsigned-fullword '%get-unsigned-long) + (t '%%get-signed-longlong ) + ) ,stack-ptr ,offset) ,result)))))) + + + +#+x8664-target +(require "X8664-VINSNS") + +(provide "X8664-BACKEND") Index: /branches/qres/ccl/compiler/X86/X8664/x8664-vinsns.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/X8664/x8664-vinsns.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/X8664/x8664-vinsns.lisp (revision 13564) @@ -0,0 +1,4570 @@ +;;;-*- Mode: Lisp; Package: (X86 :use CL) -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "VINSN") + (require "X8664-BACKEND")) + +(eval-when (:compile-toplevel :execute) + (require "X8664ENV")) + +(defmacro define-x8664-vinsn (vinsn-name (results args &optional temps) &body body) + (%define-vinsn *x8664-backend* vinsn-name results args temps body)) + + + +(define-x8664-vinsn scale-32bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (movq (:%q idx) (:%q dest)) + (shrq (:$1 1) (:%q dest))) + +(define-x8664-vinsn scale-16bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (movq (:%q idx) (:%q dest)) + (shrq (:$ub 2) (:%q dest))) + +(define-x8664-vinsn scale-8bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (movq (:%q idx) (:%q dest)) + (shrq (:$ub 3) (:%q dest))) + +;;; same as above, but looks better in bit vector contexts +(define-x8664-vinsn scale-1bit-misc-index (((dest :u64)) + ((idx :imm) ; A fixnum + ) + ()) + (movq (:%q idx) (:%q dest)) + (shrq (:$ub 3) (:%q dest))) + +(define-x8664-vinsn misc-ref-u64 (((dest :u64)) + ((v :lisp) + (scaled-idx :imm))) + (movq (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%q dest))) + +(define-x8664-vinsn misc-ref-double-float (((dest :double-float)) + ((v :lisp) + (scaled-idx :imm))) + (movsd (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%xmm dest))) + +(define-x8664-vinsn misc-ref-c-double-float (((dest :double-float)) + ((v :lisp) + (idx :s32const))) + (movsd (:@ (:apply + x8664::misc-data-offset (:apply ash idx x8664::word-shift)) (:%q v)) (:%xmm dest))) + + +(define-x8664-vinsn misc-ref-node (((dest :lisp)) + ((v :lisp) + (scaled-idx :imm))) + (movq (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%q dest))) + +(define-x8664-vinsn (push-misc-ref-node :push :node :vsp) (() + ((v :lisp) + (scaled-idx :imm))) + (pushq (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn misc-set-node (() + ((val :lisp) + (v :lisp) + (unscaled-idx :imm)) + ()) + (movq (:%q val) (:@ x8664::misc-data-offset (:%q v) (:%q unscaled-idx)))) + +(define-x8664-vinsn misc-set-immediate-node (() + ((val :s32const) + (v :lisp) + (unscaled-idx :imm)) + ()) + (movq (:$l val) (:@ x8664::misc-data-offset (:%q v) (:%q unscaled-idx)))) + + +(define-x8664-vinsn misc-set-double-float (() + ((val :double-float) + (v :lisp) + (unscaled-idx :imm)) + ()) + (movsd (:%xmm val) (:@ x8664::misc-data-offset (:%q v) (:%q unscaled-idx)))) + +(define-x8664-vinsn misc-ref-u8 (((dest :u8)) + ((v :lisp) + (scaled-idx :s64))) + (movzbl (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%l dest))) + +(define-x8664-vinsn misc-ref-s8 (((dest :s8)) + ((v :lisp) + (scaled-idx :s64))) + (movsbq (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%q dest))) + +(define-x8664-vinsn misc-ref-u16 (((dest :u16)) + ((v :lisp) + (scaled-idx :s64))) + (movzwl (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%l dest))) + +(define-x8664-vinsn misc-ref-u32 (((dest :u32)) + ((v :lisp) + (scaled-idx :s64))) + (movl (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%l dest))) + + +(define-x8664-vinsn misc-ref-single-float (((dest :single-float)) + ((v :lisp) + (scaled-idx :s64))) + (movss(:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%xmm dest))) + +(define-x8664-vinsn misc-ref-s32 (((dest :s32)) + ((v :lisp) + (scaled-idx :s64))) + (movslq (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%q dest))) + +(define-x8664-vinsn misc-ref-s16 (((dest :s16)) + ((v :lisp) + (scaled-idx :s64))) + (movswq (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%q dest))) + +(define-x8664-vinsn misc-ref-s64 (((dest :s64)) + ((v :lisp) + (scaled-idx :imm))) + (movq (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)) (:%q dest))) + + +(define-x8664-vinsn misc-ref-c-node (((dest :lisp)) + ((v :lisp) + (idx :u32const)) ; sic + ()) + (movq (:@ (:apply + x8664::misc-data-offset (:apply ash idx x8664::word-shift)) (:%q v)) (:%q dest))) + + +(define-x8664-vinsn (push-misc-ref-c-node :push :node :vsp) + (() + ((v :lisp) + (idx :u32const)) ; sic + ()) + (pushq (:@ (:apply + x8664::misc-data-offset (:apply ash idx x8664::word-shift)) (:%q v)))) + +(define-x8664-vinsn misc-ref-c-u64 (((dest :u64)) + ((v :lisp) + (idx :u32const)) ; sic + ()) + (movq (:@ (:apply + x8664::misc-data-offset (:apply ash idx x8664::word-shift)) (:%q v)) (:%q dest))) + + +(define-x8664-vinsn misc-ref-c-s64 (((dest :s64)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movq (:@ (:apply + x8664::misc-data-offset (:apply ash idx x8664::word-shift)) (:%q v)) (:%q dest))) + + +(define-x8664-vinsn misc-ref-c-u32 (((dest :u32)) + ((v :lisp) + (idx :u32const)) ; sic + ()) + (movl (:@ (:apply + x8664::misc-data-offset (:apply ash idx 2)) (:%q v)) (:%l dest))) + +(define-x8664-vinsn misc-ref-c-s32 (((dest :s32)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movslq (:@ (:apply + x8664::misc-data-offset (:apply ash idx x8664::word-shift)) (:%q v)) (:%q dest))) + +(define-x8664-vinsn misc-ref-c-single-float (((dest :single-float)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movss (:@ (:apply + x8664::misc-data-offset (:apply ash idx 2)) (:%q v)) (:%xmm dest))) + +(define-x8664-vinsn misc-ref-c-u8 (((dest :u64)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movzbl (:@ (:apply + x8664::misc-data-offset idx) (:%q v)) (:%l dest))) + +(define-x8664-vinsn misc-ref-c-s8 (((dest :s64)) + ((v :lisp) + (idx :s32const)) ; sic + ()) + (movsbq (:@ (:apply + x8664::misc-data-offset idx) (:%q v)) (:%q dest))) + +(define-x8664-vinsn misc-set-u64 (() + ((val :u64) + (v :lisp) + (idx :u64))) + (movq (:%q val) (:@ x8664::misc-data-offset (:%q v) (:%q idx)))) + +(define-x8664-vinsn misc-set-immediate-u64 (() + ((val :u32const) + (v :lisp) + (idx :u64))) + (movq (:$l val) (:@ x8664::misc-data-offset (:%q v) (:%q idx)))) + +(define-x8664-vinsn misc-set-c-u64 (() + ((val :u64) + (v :lisp) + (idx :u32const))) + (movq (:%q val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 3)) (:%q v)))) + +(define-x8664-vinsn misc-set-immediate-c-u64 (() + ((val :u32const) + (v :lisp) + (idx :u32const))) + (movq (:$l val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 3)) (:%q v)))) + +(define-x8664-vinsn misc-set-s64 (() + ((val :s64) + (v :lisp) + (scaled-idx :imm))) + (movq (:%q val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn misc-set-immediate-s64 (() + ((val :s32const) + (v :lisp) + (scaled-idx :imm))) + (movq (:$l val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + + +(define-x8664-vinsn misc-set-c-s64 (() + ((val :s64) + (v :lisp) + (idx :s32const))) + (movq (:%q val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 3)) (:%q v)))) + +(define-x8664-vinsn misc-set-immediate-c-s64 (() + ((val :s32const) + (v :lisp) + (idx :s32const))) + (movq (:$l val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 3)) (:%q v)))) + + +(define-x8664-vinsn misc-set-c-node (() + ((val :lisp) + (v :lisp) + (idx :s32const))) + (movq (:%q val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 3)) (:%q v)))) + +(define-x8664-vinsn misc-set-immediate-c-node (() + ((val :s32const) + (v :lisp) + (idx :s32const))) + (movq (:$l val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 3)) (:%q v)))) + +(define-x8664-vinsn set-closure-forward-reference (() + ((val :lisp) + (closure :lisp) + (idx :s32const))) + (movq (:%q val) (:@ (:apply + x8664::misc-function-offset (:apply ash idx x8664::word-shift)) (:%q closure)))) + + +(define-x8664-vinsn misc-set-c-double-float (() + ((val :double-float) + (v :lisp) + (idx :s32const))) + (movsd (:%xmm val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 3)) (:%q v)))) + + + +(define-x8664-vinsn (call-known-symbol :call) (((result (:lisp x8664::arg_z))) + () + ((entry (:label 1)))) + (:talign 4) + (call (:@ x8664::symbol.fcell (:% x8664::fname))) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + + +(define-x8664-vinsn (jump-known-symbol :jumplr) (() + ()) + + (jmp (:@ x8664::symbol.fcell (:% x8664::fname)))) + +(define-x8664-vinsn set-nargs (() + ((n :s16const))) + ((:pred = n 0) + (xorl (:%l x8664::nargs ) (:%l x8664::nargs ))) + ((:not (:pred = n 0)) + (movl (:$l (:apply ash n x8664::word-shift)) (:%l x8664::nargs )))) + +(define-x8664-vinsn check-exact-nargs (() + ((n :u16const))) + :resume + ((:pred = n 0) + (testl (:%l x8664::nargs) (:%l x8664::nargs))) + ((:not (:pred = n 0)) + ((:pred < n 16) + (cmpl (:$b (:apply ash n x8664::word-shift)) (:%l x8664::nargs))) + ((:pred >= n 16) + (cmpl (:$l (:apply ash n x8664::word-shift)) (:%l x8664::nargs)))) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-wrong-number-of-args))) + +(define-x8664-vinsn check-min-nargs (() + ((min :u16const))) + :resume + ((:pred = min 1) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (je :toofew)) + ((:not (:pred = min 1)) + ((:pred < min 16) + (rcmpl (:%l x8664::nargs) (:$b (:apply ash min x8664::word-shift)))) + ((:pred >= min 16) + (rcmpl (:%l x8664::nargs) (:$l (:apply ash min x8664::word-shift)))) + (jb :toofew)) + + (:anchored-uuo-section :resume) + :toofew + (:anchored-uuo (uuo-error-too-few-args))) + +(define-x8664-vinsn check-max-nargs (() + ((n :u16const))) + :resume + ((:pred < n 16) + (rcmpl (:%l x8664::nargs) (:$b (:apply ash n x8664::word-shift)))) + ((:pred >= n 16) + (rcmpl (:%l x8664::nargs) (:$l (:apply ash n x8664::word-shift)))) + (ja :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-too-many-args))) + + +(define-x8664-vinsn check-min-max-nargs (() + ((min :u16const) + (max :u16))) + :resume + ((:pred = min 1) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (je :toofew)) + ((:not (:pred = min 1)) + ((:pred < min 16) + (rcmpl (:%l x8664::nargs) (:$b (:apply ash min x8664::word-shift)))) + ((:pred >= min 16) + (rcmpl (:%l x8664::nargs) (:$l (:apply ash min x8664::word-shift)))) + (jb :toofew)) + ((:pred < max 16) + (rcmpl (:%l x8664::nargs) (:$b (:apply ash max x8664::word-shift)))) + ((:pred >= max 16) + (rcmpl (:%l x8664::nargs) (:$l (:apply ash max x8664::word-shift)))) + (ja :toomany) + + (:anchored-uuo-section :resume) + :toofew + (:anchored-uuo (uuo-error-too-few-args)) + (:anchored-uuo-section :resume) + :toomany + (:anchored-uuo (uuo-error-too-many-args))) + + +(define-x8664-vinsn default-1-arg (() + ((min :u16const))) + ((:pred < min 16) + (rcmpl (:%l x8664::nargs) (:$b (:apply ash min x8664::word-shift)))) + ((:pred >= min 16) + (rcmpl (:%l x8664::nargs) (:$l (:apply ash min x8664::word-shift)))) + (jne :done) + ((:pred >= min 3) + (pushq (:%q x8664::arg_x))) + ((:pred >= min 2) + (movq (:%q x8664::arg_y) (:%q x8664::arg_x))) + ((:pred >= min 1) + (movq (:%q x8664::arg_z) (:%q x8664::arg_y))) + (movq (:$l (:apply target-nil-value)) (:%q x8664::arg_z)) + :done) + + +(define-x8664-vinsn default-2-args (() + ((min :u16const))) + ((:pred < (:apply 1+ min) 16) + (rcmpl (:%l x8664::nargs ) (:$b (:apply ash (:apply 1+ min) x8664::word-shift)))) + ((:pred >= (:apply 1+ min) 16) + (rcmpl (:%l x8664::nargs ) (:$l (:apply ash (:apply 1+ min) x8664::word-shift)))) + (ja :done) + (je :one) + ;; We got "min" args; arg_y & arg_z default to nil + ((:pred >= min 3) + (pushq (:%q x8664::arg_x))) + ((:pred >= min 2) + (pushq (:%q x8664::arg_y))) + ((:pred >= min 1) + (movq (:%q x8664::arg_z) (:%q x8664::arg_x))) + (movl (:$l (:apply target-nil-value)) (:%l x8664::arg_y)) + (jmp :last) + :one + ;; We got min+1 args: arg_y was supplied, arg_z defaults to nil. + ((:pred >= min 2) + (pushq (:%q x8664::arg_x))) + ((:pred >= min 1) + (movq (:%q x8664::arg_y) (:%q x8664::arg_x))) + (movq (:%q x8664::arg_z) (:%q x8664::arg_y)) + :last + (movq (:$l (:apply target-nil-value)) (:%q x8664::arg_z)) + :done) + +(define-x8664-vinsn default-3-args (() + ((min :u16const))) + ((:pred < (:apply + 2 min) 16) + (rcmpl (:%l x8664::nargs ) (:$b (:apply ash (:apply + 2 min) x8664::word-shift)))) + ((:pred >= (:apply + 2 min) 16) + (rcmpl (:%l x8664::nargs ) (:$l (:apply ash (:apply + 2 min) x8664::word-shift)))) + (ja :done) + (je :two) + ((:pred < min 16) + (rcmpl (:%l x8664::nargs ) (:$b (:apply ash min x8664::word-shift)))) + ((:pred >= min 16) + (rcmpl (:%l x8664::nargs ) (:$l (:apply ash min x8664::word-shift)))) + (je :none) + ;; The first (of three) &optional args was supplied. + ((:pred >= min 2) + (pushq (:%q x8664::arg_x))) + ((:pred >= min 1) + (pushq (:%q x8664::arg_y))) + (movq (:%q x8664::arg_z) (:%q x8664::arg_x)) + (jmp :last-2) + :two + ;; The first two (of three) &optional args were supplied. + ((:pred >= min 1) + (pushq (:%q x8664::arg_x))) + (movq (:%q x8664::arg_y) (:%q x8664::arg_x)) + (movq (:%q x8664::arg_z) (:%q x8664::arg_y)) + (jmp :last-1) + ;; None of the three &optional args was provided. + :none + ((:pred >= min 3) + (pushq (:%q x8664::arg_x))) + ((:pred >= min 2) + (pushq (:%q x8664::arg_y))) + ((:pred >= min 1) + (pushq (:%q x8664::arg_z))) + (movl (:$l (:apply target-nil-value)) (:%l x8664::arg_x)) + :last-2 + (movl (:$l (:apply target-nil-value)) (:%l x8664::arg_y)) + :last-1 + (movl (:$l (:apply target-nil-value)) (:%l x8664::arg_z)) + :done) + + +(define-x8664-vinsn default-optionals (() + ((n :u16const)) + ((temp :u64))) + ((:pred < n 16) + (rcmpl (:%l x8664::nargs) (:$b (:apply ash n x8664::word-shift)))) + ((:pred >= n 16) + (rcmpl (:%l x8664::nargs) (:$l (:apply ash n x8664::word-shift)))) + (movl (:%l x8664::nargs) (:%l temp)) + (jae :done) + :loop + (addl (:$b x8664::fixnumone) (:%l temp)) + ((:pred < n 16) + (cmpl (:$b (:apply ash n x8664::word-shift)) (:%l temp))) + ((:pred >= n 16) + (cmpl (:$l (:apply ash n x8664::word-shift)) (:%l temp))) + (pushq (:$l (:apply target-nil-value))) + (jne :loop) + :done) + + +(define-x8664-vinsn save-lisp-context-no-stack-args (() + ()) + (pushq (:%q x8664::rbp)) + (movq (:%q x8664::rsp) (:%q x8664::rbp))) + + +(define-x8664-vinsn save-lisp-context-offset (() + ((nbytes-pushed :s32const))) + (movq (:%q x8664::rbp) (:@ (:apply + nbytes-pushed x8664::node-size) (:%q x8664::rsp))) + (leaq (:@ (:apply + nbytes-pushed x8664::node-size) (:%q x8664::rsp)) (:%q x8664::rbp)) + (popq (:@ x8664::node-size (:%q x8664::rbp)))) + +(define-x8664-vinsn save-lisp-context-variable-arg-count (() + () + ((temp :u64))) + (movl (:%l x8664::nargs) (:%l temp)) + (subq (:$b (* $numx8664argregs x8664::node-size)) (:%q temp)) + (jle :push) + (movq (:%q x8664::rbp) (:@ x8664::node-size (:%q x8664::rsp) (:%q temp))) + (leaq (:@ x8664::node-size (:%q x8664::rsp) (:%q temp)) (:%q x8664::rbp)) + (popq (:@ 8 (:%q x8664::rbp))) + (jmp :done) + :push + (pushq (:%q x8664::rbp)) + (movq (:%q x8664::rsp) (:%q x8664::rbp)) + :done) + +;;; We know that some args were pushed, but don't know how many were +;;; passed. +(define-x8664-vinsn save-lisp-context-in-frame (() + () + ((temp :u64))) + (movl (:%l x8664::nargs) (:%l temp)) + (subq (:$b (* $numx8664argregs x8664::node-size)) (:%q temp)) + (movq (:%q x8664::rbp) (:@ x8664::node-size (:%q x8664::rsp) (:%q temp))) + (leaq (:@ x8664::node-size (:%q x8664::rsp) (:%q temp)) (:%q x8664::rbp)) + (popq (:@ x8664::node-size (:%q x8664::rbp)))) + + +(define-x8664-vinsn (vpush-register :push :node :vsp) + (() + ((reg :lisp))) + (pushq (:% reg))) + +(define-x8664-vinsn (vpush-fixnum :push :node :vsp) + (() + ((const :s32const))) + ((:and (:pred < const 128) (:pred >= const -128)) + (pushq (:$b const))) + ((:not (:and (:pred < const 128) (:pred >= const -128))) + (pushq (:$l const)))) + + + +(define-x8664-vinsn vframe-load (((dest :lisp)) + ((frame-offset :u16const) + (cur-vsp :u16const))) + (movq (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)) (:%q dest))) + +(define-x8664-vinsn compare-vframe-offset-to-nil (() + ((frame-offset :u16const) + (cur-vsp :u16const))) + (cmpb (:$b x8664::fulltag-nil) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) + + +(define-x8664-vinsn compare-value-cell-to-nil (() + ((vcell :lisp))) + (cmpb (:$b x8664::fulltag-nil) (:@ x8664::value-cell.value (:%q vcell)))) + +(define-x8664-vinsn lcell-load (((dest :lisp)) + ((cell :lcell) + (top :lcell))) + (movq (:@ (:apply - (:apply + (:apply calc-lcell-offset cell) x8664::word-size-in-bytes)) (:%q x8664::rbp)) (:%q dest))) + +(define-x8664-vinsn (vframe-push :push :node :vsp) + (() + ((frame-offset :u16const) + (cur-vsp :u16const))) + (pushq (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) + +(define-x8664-vinsn vframe-store (() + ((src :lisp) + (frame-offset :u16const) + (cur-vsp :u16const))) + (movq (:%q src) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) + +(define-x8664-vinsn lcell-store (() + ((src :lisp) + (cell :lcell) + (top :lcell))) + (movq (:%q src) (:@ (:apply - (:apply + (:apply calc-lcell-offset cell) x8664::word-size-in-bytes)) (:%q x8664::rbp)))) + +(define-x8664-vinsn (popj :lispcontext :pop :csp :lrRestore :jumpLR) + (() + ()) + (leave) + (ret)) + +(define-x8664-vinsn (restore-full-lisp-context :lispcontext :pop :vsp ) + (() + ()) + (leave)) + +(define-x8664-vinsn compare-to-nil (() + ((arg0 t))) + (cmpb (:$b x8664::fulltag-nil) (:%b arg0))) + +(define-x8664-vinsn compare-to-t (() + ((arg0 t))) + (cmpq (:$l (:apply target-t-value)) (:%q arg0))) + +(define-x8664-vinsn ref-constant (((dest :lisp)) + ((lab :label))) + (movq (:@ (:^ lab) (:%q x8664::fn)) (:%q dest))) + +(define-x8664-vinsn compare-constant-to-register (() + ((lab :label) + (reg :lisp))) + (cmpq (:@ (:^ lab) (:%q x8664::fn)) (:%q reg))) + + +(define-x8664-vinsn (vpush-constant :push :node :vsp) (() + ((lab :label))) + (pushq (:@ (:^ lab) (:%q x8664::fn)))) + + +(define-x8664-vinsn (jump :jump) + (() + ((label :label))) + (jmp label)) + +(define-x8664-vinsn (cbranch-true :branch) (() + ((label :label) + (crbit :u8const))) + (jcc (:$ub crbit) label)) + +(define-x8664-vinsn (cbranch-false :branch) (() + ((label :label) + (crbit :u8const))) + (jcc (:$ub (:apply logxor 1 crbit)) label)) + + +(define-x8664-vinsn (lri :constant-ref) (((dest :imm)) + ((intval :s64const)) + ()) + ((:pred = intval 0) + (xorl (:%l dest) (:%l dest))) + ((:and (:pred /= intval 0) + (:pred >= intval -2147483648) + (:pred <= intval 2147483647)) + (movq (:$l intval) (:%q dest))) + ((:or (:pred < intval -2147483648) + (:pred > intval 2147483647)) + (movq (:$q (:apply logand #xffffffffffffffff intval)) (:%q dest)))) + +(define-x8664-vinsn (lriu :constant-ref) (((dest :imm)) + ((intval :u64const)) + ()) + ((:pred = intval 0) + (xorl (:%l dest) (:%l dest))) + ((:and (:pred /= intval 0) + (:pred >= intval -2147483648) + (:pred <= intval 2147483647)) + (movq (:$l intval) (:%q dest))) + ((:or (:pred < intval -2147483648) + (:pred > intval 2147483647)) + (movq (:$q (:apply logand #xffffffffffffffff intval)) (:%q dest)))) + +(define-x8664-vinsn trap-unless-bit (() + ((value :lisp))) + :resume + (testq (:$l (lognot x8664::fixnumone)) (:%q value)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q value) (:$ub arch::error-object-not-bit))) + ) + +(define-x8664-vinsn trap-unless-list (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-list) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-list (:%q object)))) + + + +(define-x8664-vinsn trap-unless-cons (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-cons) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::fulltag-cons)))) + +(define-x8664-vinsn set-z-flag-if-consp (() + ((object :lisp)) + ((tag :u8))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-cons) (:%l tag))) + +(define-x8664-vinsn trap-unless-uvector (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::tag-misc)))) + +(define-x8664-vinsn trap-unless-single-float (() + ((object :lisp))) + :resume + (cmpb (:$b x8664::tag-single-float) (:%b object)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::tag-single-float)))) + +(define-x8664-vinsn trap-unless-character (() + ((object :lisp))) + :resume + (cmpb (:$b x8664::subtag-character) (:%b object)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-character)))) + +(define-x8664-vinsn trap-unless-fixnum (() + ((object :lisp)) + ()) + :resume + (testb (:$b x8664::tagmask) (:%b object)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-fixnum (:%q object)))) + +(define-x8664-vinsn set-flags-from-lisptag (() + ((reg :lisp))) + (testb (:$b x8664::tagmask) (:%b reg))) + + +(define-x8664-vinsn trap-unless-typecode= (() + ((object :lisp) + (tagval :u16const)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + ;; This needs to be a sign-extending mov, since the cmpl below + ;; will sign-extend the 8-bit constant operand. + (movsbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) + :have-tag + (cmpl (:$b tagval) (:%l tag)) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub tagval)))) + +(define-x8664-vinsn trap-unless-double-float (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + (movsbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) + :have-tag + (cmpl (:$b x8664::subtag-double-float) (:%l tag)) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-double-float)))) + +(define-x8664-vinsn trap-unless-macptr (() + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) + :have-tag + (cmpb (:$b x8664::subtag-macptr) (:%b tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-macptr)))) + + +(define-x8664-vinsn check-misc-bound (() + ((idx :imm) + (v :lisp)) + ((temp :u64))) + :resume + (movq (:@ x8664::misc-header-offset (:%q v)) (:%q temp)) + (shrq (:$ub x8664::num-subtag-bits) (:%q temp)) + (shlq (:$ub x8664::fixnumshift) (:%q temp)) + (rcmpq (:%q idx) (:%q temp)) + (jae :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-vector-bounds (:%q idx) (:%q v)))) + + + +(define-x8664-vinsn %cdr (((dest :lisp)) + ((src :lisp))) + (movq (:@ x8664::cons.cdr (:%q src)) (:%q dest))) + +(define-x8664-vinsn (%vpush-cdr :push :node :vsp) + (() + ((src :lisp))) + (pushq (:@ x8664::cons.cdr (:%q src)))) + +(define-x8664-vinsn %car (((dest :lisp)) + ((src :lisp))) + (movq (:@ x8664::cons.car (:%q src)) (:%q dest))) + +(define-x8664-vinsn (%vpush-car :push :node :vsp) + (() + ((src :lisp))) + (pushq (:@ x8664::cons.car (:%q src)))) + + +(define-x8664-vinsn u32->char (((dest :lisp) + (src :u8)) + ((src :u8)) + ()) + (shll (:$ub x8664::charcode-shift) (:%l src)) + (leaq (:@ x8664::subtag-character (:%q src)) (:%q dest))) + + +(define-x8664-vinsn (load-nil :constant-ref) (((dest t)) + ()) + (movl (:$l (:apply target-nil-value)) (:%l dest))) + + +(define-x8664-vinsn (load-t :constant-ref) (((dest t)) + ()) + (movl(:$l (:apply target-t-value)) (:%l dest))) + + +(define-x8664-vinsn extract-tag (((tag :u8)) + ((object :lisp))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag))) + +(define-x8664-vinsn extract-tag-fixnum (((tag :imm)) + ((object :lisp))) + ((:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object)) + (shll (:$ub x8664::fixnumshift) (:%l object))) + ((:not (:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object))) + (imull (:$b x8664::fixnumone) (:%l object) (:%l tag))) + (andl (:$b (ash x8664::tagmask x8664::fixnumshift)) (:%l tag))) + +(define-x8664-vinsn extract-fulltag (((tag :u8)) + ((object :lisp))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag))) + +(define-x8664-vinsn extract-fulltag-fixnum (((tag :imm)) + ((object :lisp))) + ((:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object)) + (shll (:$ub x8664::fixnumshift) (:%l object))) + ((:not (:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object))) + (imull (:$b x8664::fixnumone) (:%l object) (:%l tag))) + (andl (:$b (ash x8664::fulltagmask x8664::fixnumshift)) (:%l tag))) + +(define-x8664-vinsn extract-typecode (((tag :u32)) + ((object :lisp))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) + :have-tag) + +(define-x8664-vinsn extract-typecode-fixnum (((tag :imm)) + ((object :lisp)) + ((temp :u32))) + (movl (:%l object) (:%l temp)) + (andl (:$b x8664::tagmask) (:%l temp)) + (cmpl (:$b x8664::tag-misc) (:%l temp)) + (jne :have-tag) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l temp)) + :have-tag + (imulq (:$b x8664::fixnumone) (:%q temp) (:%q tag))) + + +(define-x8664-vinsn compare-reg-to-zero (() + ((reg :imm))) + (testq (:%q reg) (:%q reg))) + +(define-x8664-vinsn compare-u8-reg-to-zero (() + ((reg :u8))) + (testb (:%b reg) (:%b reg))) + +(define-x8664-vinsn cr-bit->boolean (((dest :lisp)) + ((crbit :u8const))) + (movl (:$l (:apply target-nil-value)) (:%l dest)) + (cmovccl (:$ub crbit) (:@ (+ x8664::t-offset x8664::symbol.vcell) (:%l dest)) (:%l dest))) + + + + + +(define-x8664-vinsn compare-s32-constant (() + ((val :imm) + (const :s32const))) + ((:or (:pred < const -128) (:pred > const 127)) + (rcmpq (:%q val) (:$l const))) + ((:not (:or (:pred < const -128) (:pred > const 127))) + (rcmpq (:%q val) (:$b const)))) + +(define-x8664-vinsn compare-u31-constant (() + ((val :u64) + (const :u32const))) + ((:pred > const 127) + (rcmpq (:%q val) (:$l const))) + ((:not (:pred > const 127)) + (rcmpq (:%q val) (:$b const)))) + +(define-x8664-vinsn compare-u8-constant (() + ((val :u8) + (const :u8const))) + #| + ((:pred logbitp 7 const) + (movzbl (:%b val) (:%l val)) + (rcmpw (:%w val) (:$w const))) + ((:not (:pred logbitp 7 const)) + (rcmpb (:%b val) (:$b const))) + ||# + (rcmpb (:%b val) (:$b const)) + ) + + +(define-x8664-vinsn cons (((dest :lisp)) + ((car :lisp) + (cdr :lisp))) + (subq (:$b (- x8664::cons.size x8664::fulltag-cons)) (:rcontext x8664::tcr.save-allocptr)) + (movq (:rcontext x8664::tcr.save-allocptr) (:%q x8664::allocptr)) + (rcmpq (:%q x8664::allocptr) (:rcontext x8664::tcr.save-allocbase)) + (:byte #x77) (:byte #x02) ;(ja :no-trap) + (uuo-alloc) + :no-trap + (andb (:$b (lognot x8664::fulltagmask)) (:rcontext x8664::tcr.save-allocptr)) + (movq (:%q car) (:@ x8664::cons.car (:%q x8664::allocptr))) + (movq (:%q cdr) (:@ x8664::cons.cdr (:%q x8664::allocptr))) + (movq (:%q x8664::allocptr) (:%q dest))) + +(define-x8664-vinsn unbox-u8 (((dest :u8)) + ((src :lisp))) + :resume + (movq (:$l (lognot (ash #xff x8664::fixnumshift))) (:%q dest)) + (andq (:% src) (:% dest)) + (jne :bad) + (movq (:%q src) (:%q dest)) + (shrq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-8)))) + +(define-x8664-vinsn %unbox-u8 (((dest :u8)) + ((src :lisp))) + (movl (:%l src) (:%l dest)) + (shrl (:$ub x8664::fixnumshift) (:%l dest)) + (movzbl (:%b dest) (:%l dest))) + +(define-x8664-vinsn unbox-s8 (((dest :s8)) + ((src :lisp))) + :resume + (movq (:%q src) (:%q dest)) + (shlq (:$ub (- x8664::nbits-in-word (+ 8 x8664::fixnumshift))) (:%q dest)) + (sarq (:$ub (- x8664::nbits-in-word (+ 8 x8664::fixnumshift))) (:%q dest)) + (cmpq (:%q src) (:%q dest)) + (jne :bad) + (testb (:$b x8664::fixnummask) (:%b dest)) + (jne :bad) + (sarq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-8)))) + +(define-x8664-vinsn unbox-u16 (((dest :u16)) + ((src :lisp))) + :resume + (testq (:$l (lognot (ash #xffff x8664::fixnumshift))) (:% src)) + (movq (:%q src) (:%q dest)) + (jne :bad) + (shrq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-16)))) + +(define-x8664-vinsn %unbox-u16 (((dest :u16)) + ((src :lisp))) + (movq (:%q src) (:%q dest)) + (shrq (:$ub x8664::fixnumshift) (:%q dest))) + +(define-x8664-vinsn unbox-s16 (((dest :s16)) + ((src :lisp))) + :resume + (movq (:%q src) (:%q dest)) + (shlq (:$ub (- x8664::nbits-in-word (+ 16 x8664::fixnumshift))) (:%q dest)) + (sarq (:$ub (- x8664::nbits-in-word (+ 16 x8664::fixnumshift))) (:%q dest)) + (cmpq (:%q src) (:%q dest)) + (jne :bad) + (testb (:$b x8664::fixnummask) (:%b dest)) + (jne :bad) + (sarq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-16)))) + +(define-x8664-vinsn %unbox-s16 (((dest :s16)) + ((src :lisp))) + (movq (:%q src) (:%q dest)) + (sarq (:$ub x8664::fixnumshift) (:%q dest))) + +(define-x8664-vinsn unbox-u32 (((dest :u32)) + ((src :lisp))) + :resume + (movq (:$q (lognot (ash #xffffffff x8664::fixnumshift))) (:%q dest)) + (testq (:% src) (:% dest)) + (jne :bad) + (movq (:%q src) (:%q dest)) + (shrq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-32)))) + +(define-x8664-vinsn %unbox-u32 (((dest :u32)) + ((src :lisp))) + + (movq (:%q src) (:%q dest)) + (shrq (:$ub x8664::fixnumshift) (:%q dest))) + +(define-x8664-vinsn unbox-s32 (((dest :s32)) + ((src :lisp))) + :resume + (movq (:%q src) (:%q dest)) + (shlq (:$ub (- x8664::nbits-in-word (+ 32 x8664::fixnumshift))) (:%q dest)) + (sarq (:$ub (- x8664::nbits-in-word (+ 32 x8664::fixnumshift))) (:%q dest)) + (cmpq (:%q src) (:%q dest)) + (jne :bad) + (testb (:$b x8664::fixnummask) (:%b dest)) + (jne :bad) + (sarq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-32)))) + +(define-x8664-vinsn %unbox-s32 (((dest :s32)) + ((src :lisp))) + (movq (:%q src) (:%q dest)) + (sarq (:$ub x8664::fixnumshift) (:%q dest))) + + +(define-x8664-vinsn unbox-u64 (((dest :u64)) + ((src :lisp))) + :resume + (movq (:$q (lognot (ash x8664::target-most-positive-fixnum x8664::fixnumshift))) (:%q dest)) + (testq (:%q dest) (:%q src)) + (movq (:%q src) (:%q dest)) + (jnz :maybe-bignum) + (sarq (:$ub x8664::fixnumshift) (:%q dest)) + (jmp :done) + :maybe-bignum + (andl (:$b x8664::tagmask) (:%l dest)) + (cmpl (:$b x8664::tag-misc) (:%l dest)) + (jne :have-tag) + (movzbl (:@ x8664::misc-subtag-offset (:%q src)) (:%l dest)) + :have-tag + (cmpl (:$b x8664::subtag-bignum) (:%l dest)) + (jne :bad) + (movq (:@ x8664::misc-header-offset (:%q src)) (:%q dest)) + (cmpq (:$l x8664::three-digit-bignum-header) (:%q dest)) + (je :three) + (cmpq (:$l x8664::two-digit-bignum-header) (:%q dest)) + (jne :bad) + (movq (:@ x8664::misc-data-offset (:%q src)) (:%q dest)) + (testq (:%q dest) (:%q dest)) + (js :bad) + (jmp :done) + + :three + (movl (:@ (+ 8 x8664::misc-data-offset) (:%q src)) (:%l dest)) + (testl (:%l dest) (:%l dest)) + (movq (:@ x8664::misc-data-offset (:%q src)) (:%q dest)) + (jne :bad) + :done + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-64)))) + +(define-x8664-vinsn unbox-s64 (((dest :s64)) + ((src :lisp))) + :resume + (movq (:%q src) (:%q dest)) + (sarq (:$ub x8664::fixnumshift) (:%q dest)) + ;; Was it a fixnum ? + (testb (:$b x8664::fixnummask) (:%b src)) + (je :done) + ;; May be a 2-digit bignum + (movl (:%l src) (:%l dest)) + (andl (:$b x8664::tagmask) (:%l dest)) + (cmpl (:$b x8664::tag-misc) (:%l dest)) + (jne :bad) + (cmpq (:$l x8664::two-digit-bignum-header) (:@ x8664::misc-header-offset (:%q src))) + (movq (:@ x8664::misc-data-offset (:%q src)) (:%q dest)) + (jne :bad) + :done + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-64)))) + +(define-x8664-vinsn sign-extend-s8 (((dest :s64)) + ((src :s8))) + (movsbq (:%b src) (:%q dest))) + +(define-x8664-vinsn sign-extend-s16 (((dest :s64)) + ((src :s16))) + (movswq (:%w src) (:%q dest))) + +(define-x8664-vinsn sign-extend-s32 (((dest :s64)) + ((src :s32))) + (movslq (:%l src) (:%q dest))) + + +(define-x8664-vinsn zero-extend-u8 (((dest :s64)) + ((src :u8))) + (movzbl (:%b src) (:%l dest))) + +(define-x8664-vinsn zero-extend-u16 (((dest :s64)) + ((src :u16))) + (movzwl (:%w src) (:%l dest))) + +(define-x8664-vinsn zero-extend-u32 (((dest :s64)) + ((src :u32))) + (movl (:%l src) (:%l dest))) + +(define-x8664-vinsn (jump-subprim :jumpLR) (() + ((spno :s32const))) + (jmp (:@ spno))) + +;;; "call" a subprimitive that manipulates the stack in some way, +;;; using an lea/jmp calling convention. +(define-x8664-vinsn (lea-jmp-subprim :call) (() + ((spno :s32const)) + ((entry (:label 1)))) + (leaq (:@ (:^ :back) (:%q x8664::fn)) (:%q x8664::ra0)) + (:talign 4) + (jmp (:@ spno)) + :back + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +;;; Call a subprimitive using a tail-aligned CALL instruction. +(define-x8664-vinsn (call-subprim :call) (() + ((spno :s32const)) + ((entry (:label 1)))) + (:talign 4) + (call (:@ spno)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn fixnum-subtract-from (((dest t) + (y t)) + ((y t) + (x t))) + (subq (:%q y) (:%q x))) + +(define-x8664-vinsn %logand-c (((dest t) + (val t)) + ((val t) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (andq (:$b const) (:%q val))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (andq (:$l const) (:%q val)))) + +(define-x8664-vinsn %logior-c (((dest t) + (val t)) + ((val t) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (orq (:$b const) (:%q val))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (orq (:$l const) (:%q val)))) + +(define-x8664-vinsn %logxor-c (((dest t) + (val t)) + ((val t) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (xorq (:$b const) (:%q val))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (xorq (:$l const) (:%q val)))) + +(define-x8664-vinsn character->fixnum (((dest :lisp)) + ((src :lisp)) + ()) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movq (:%q src) (:%q dest))) + (shrq (:$ub (- x8664::charcode-shift x8664::fixnumshift)) (:%q dest))) + +(define-x8664-vinsn compare (() + ((x t) + (y t))) + (rcmpq (:%q x) (:%q y))) + +(define-x8664-vinsn negate-fixnum (((val :lisp)) + ((val :imm))) + (negq (:% val))) + +(define-x8664-vinsn handle-fixnum-overflow-inline + (() + ((val :lisp) + (no-overflow :label)) + ((header (:u64 #.x8664::imm0)) + (scaled-size (:u64 #.x8664::imm1)) + (freeptr (:lisp #.x8664::allocptr)))) + (jo :overflow) + (:uuo-section) + :overflow + (movq (:%q val) (:%q scaled-size)) + (btcq (:$ub 63) (:%q scaled-size)) + (sarq (:$ub x8664::fixnumshift) (:%q scaled-size)) + (btcq (:$ub 60) (:%q scaled-size)) + (movd (:%q scaled-size) (:%mmx x8664::mm0)) + (movq (:$l x8664::two-digit-bignum-header) (:%q header)) + (movq (:$l (- 16 x8664::fulltag-misc)) (:%q scaled-size)) + (subq (:%q scaled-size) (:rcontext x8664::tcr.save-allocptr)) + (movq (:rcontext x8664::tcr.save-allocptr) (:%q freeptr)) + (rcmpq (:%q freeptr) (:rcontext x8664::tcr.save-allocbase)) + (:byte #x77) (:byte #x02) ;(ja :no-trap) + (uuo-alloc) + :no-trap + (movq (:%q header) (:@ x8664::misc-header-offset (:%q freeptr))) + (andb (:$b (lognot x8664::fulltagmask)) (:rcontext x8664::tcr.save-allocptr)) + ((:not (:pred = freeptr + (:apply %hard-regspec-value val))) + (movq (:%q freeptr) (:%q val))) + (movq (:%mmx x8664::mm0) (:@ x8664::misc-data-offset (:%q val))) + (jmp no-overflow)) + + +;;; This handles the 1-bit overflow from addition/subtraction/unary negation +(define-x8664-vinsn set-bigits-and-header-for-fixnum-overflow + (() + ((val :lisp) + (no-overflow + :label)) + ((header (:u64 #.x8664::imm0)) + (scaled-size (:u64 #.x8664::imm1)))) + (jno no-overflow) + (movq (:%q val) (:%q scaled-size)) + (sarq (:$ub x8664::fixnumshift) (:%q scaled-size)) + (movq (:$q #xe000000000000000) (:%q header)) + (xorq (:%q header) (:%q scaled-size)) + (movd (:%q scaled-size) (:%mmx x8664::mm0)) + (movq (:$l x8664::two-digit-bignum-header) (:%q header)) + (movq (:$l (- 16 x8664::fulltag-misc)) (:%q scaled-size))) + +(define-x8664-vinsn %set-z-flag-if-s64-fits-in-fixnum (((dest :imm)) + ((src :s64)) + ((temp :s64))) + (movq (:%q src) (:%q temp)) + (shlq (:$ub x8664::fixnumshift) (:%q temp)) + (movq (:%q temp) (:%q dest)) ; tagged as a fixnum + (sarq (:$ub x8664::fixnumshift) (:%q temp)) + (cmpq (:%q src) (:%q temp))) + +(define-x8664-vinsn %set-z-flag-if-u64-fits-in-fixnum (((dest :imm)) + ((src :u64)) + ((temp :u64))) + (movq (:%q src) (:%q temp)) + (shlq (:$ub (1+ x8664::fixnumshift)) (:%q temp)) + (movq (:%q temp) (:%q dest)) ; tagged as an even fixnum + (shrq (:$ub (1+ x8664::fixnumshift)) (:%q temp)) + (shrq (:%q dest)) + (cmpq (:%q src) (:%q temp)) + :done) + + +(define-x8664-vinsn setup-bignum-alloc-for-s64-overflow (() + ((src :s64))) + (movd (:%q src) (:%mmx x8664::mm0)) + (movl (:$l x8664::two-digit-bignum-header) (:%l x8664::imm0.l)) + (movl (:$l (- 16 x8664::fulltag-misc)) (:%l x8664::imm1.l))) + + +;;; If the sign bit is set in SRC, need to make a 3-digit bignum +;;; that requires 32 bytes of aligned memory +(define-x8664-vinsn setup-bignum-alloc-for-u64-overflow (() + ((src :s64))) + (testq (:%q src) (:%q src)) + (movd (:%q src) (:%mmx x8664::mm0)) + (movl (:$l x8664::two-digit-bignum-header) (:%l x8664::imm0.l)) + (movl (:$l (- 16 x8664::fulltag-misc)) (:%l x8664::imm1.l)) + (jns :done) + (movl (:$l x8664::three-digit-bignum-header) (:%l x8664::imm0.l)) + (movl (:$l (- 32 x8664::fulltag-misc)) (:%l x8664::imm1.l)) + :done) + + + +(define-x8664-vinsn %allocate-uvector (((dest :lisp)) + () + ((header (:u64 #.x8664::imm0)) + (freeptr (:lisp #.x8664::allocptr)))) + (subq (:%q x8664::imm1) (:rcontext x8664::tcr.save-allocptr)) + (movq (:rcontext x8664::tcr.save-allocptr) (:%q freeptr)) + (rcmpq (:%q freeptr) (:rcontext x8664::tcr.save-allocbase)) + (:byte #x77) (:byte #x02) ;(ja :no-trap) + (uuo-alloc) + :no-trap + (movq (:%q header) (:@ x8664::misc-header-offset (:%q freeptr))) + (andb (:$b (lognot x8664::fulltagmask)) (:rcontext x8664::tcr.save-allocptr)) + ((:not (:pred = freeptr + (:apply %hard-regspec-value dest))) + (movq (:%q freeptr) (:%q dest)))) + +(define-x8664-vinsn set-bigits-after-fixnum-overflow (() + ((bignum :lisp))) + (movq (:%mmx x8664::mm0) (:@ x8664::misc-data-offset (:%q bignum)))) + + +(define-x8664-vinsn box-fixnum (((dest :imm)) + ((src :s8))) + (imulq (:$b x8664::fixnumone) (:%q src)(:%q dest))) + + +(define-x8664-vinsn (fix-fixnum-overflow-ool :call) + (((val :lisp)) + ((val :lisp)) + ((unboxed (:s64 #.x8664::imm1)) + (header (:u64 #.x8664::imm0)) + (entry (:label 1)))) + (jo :overflow) + :done + (:uuo-section) + ((:not (:pred = x8664::arg_z + (:apply %hard-regspec-value val))) + :overflow + (movq (:%q val) (:%q x8664::arg_z))) + (:talign 4) + ((:pred = x8664::arg_z + (:apply %hard-regspec-value val)) + :overflow) + (call (:@ .SPfix-overflow)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) + ((:not (:pred = x8664::arg_z + (:apply %hard-regspec-value val))) + (movq (:%q x8664::arg_z) (:%q val))) + (jmp :done)) + +(define-x8664-vinsn (fix-fixnum-overflow-ool-and-branch :call) + (((val :lisp)) + ((val :lisp) + (lab :label)) + ((unboxed (:s64 #.x8664::imm1)) + (header (:u64 #.x8664::imm0)) + (entry (:label 1)))) + (jo :overflow) + (jmp lab) + (:uuo-section) + ((:not (:pred = x8664::arg_z + (:apply %hard-regspec-value val))) + :overflow + (movq (:%q val) (:%q x8664::arg_z))) + (:talign 4) + ((:pred = x8664::arg_z + (:apply %hard-regspec-value val)) + :overflow) + (call (:@ .SPfix-overflow)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) + ((:not (:pred = x8664::arg_z + (:apply %hard-regspec-value val))) + (movq (:%q x8664::arg_z) (:%q val))) + (jmp lab)) + +(define-x8664-vinsn add-constant (((dest :imm)) + ((dest :imm) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (addq (:$b const) (:%q dest))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (addq (:$l const) (:%q dest)))) + +(define-x8664-vinsn add-constant3 (((dest :imm)) + ((src :imm) + (const :s32const))) + ((:pred = (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src)) + ((:and (:pred >= const -128) (:pred <= const 127)) + (addq (:$b const) (:%q dest))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (addq (:$l const) (:%q dest)))) + ((:not (:pred = (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (leaq (:@ const (:%q src)) (:%q dest)))) + + + +(define-x8664-vinsn fixnum-add2 (((dest :imm)) + ((dest :imm) + (other :imm))) + (addq (:%q other) (:%q dest))) + +(define-x8664-vinsn fixnum-sub2 (((dest :imm)) + ((x :imm) + (y :imm)) + ((temp :imm))) + (movq (:%q x) (:%q temp)) + (subq (:%q y) (:%q temp)) + (movq (:%q temp) (:%q dest))) + + + +(define-x8664-vinsn fixnum-add3 (((dest :imm)) + ((x :imm) + (y :imm))) + + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (addq (:%q y) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (addq (:%q x) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (leaq (:@ (:%q x) (:%q y)) (:%q dest))))) + +(define-x8664-vinsn copy-gpr (((dest t)) + ((src t))) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movq (:%q src) (:%q dest)))) + +(define-x8664-vinsn (vpop-register :pop :node :vsp) + (((dest :lisp)) + ()) + (popq (:%q dest))) + + +(define-x8664-vinsn (push-argregs :push :node :vsp) (() + ()) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (jz :done) + (rcmpl (:%l x8664::nargs) (:$b (* 2 x8664::node-size))) + (jb :one) + (je :two) + (pushq (:%q x8664::arg_x)) + :two + (pushq (:%q x8664::arg_y)) + :one + (pushq (:%q x8664::arg_z)) + :done) + +(define-x8664-vinsn (push-max-argregs :push :node :vsp) (() + ((max :u32const))) + ((:pred >= max 3) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (jz :done) + (rcmpl (:%l x8664::nargs) (:$b (* 2 x8664::node-size))) + (jb :one) + (je :two) + (pushq (:%q x8664::arg_x)) + :two + (pushq (:%q x8664::arg_y)) + :one + (pushq (:%q x8664::arg_z)) + :done) + ((:pred = max 2) + (rcmpl (:%l x8664::nargs) (:$b (* 1 x8664::node-size))) + (jb :done) + (je :one) + (pushq (:%q x8664::arg_y)) + :one + (pushq (:%q x8664::arg_z)) + :done) + ((:pred = max 1) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (je :done) + (pushq (:%q x8664::arg_z)) + :done)) + +(define-x8664-vinsn (call-label :call) (() + ((label :label)) + ((entry (:label 1)))) + (:talign 4) + (call label) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn double-float-compare (() + ((arg0 :double-float) + (arg1 :double-float))) + (comisd (:%xmm arg1) (:%xmm arg0))) + +(define-x8664-vinsn single-float-compare (() + ((arg0 :single-float) + (arg1 :single-float))) + (comiss (:%xmm arg1) (:%xmm arg0))) + + +(define-x8664-vinsn double-float+-2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (addsd (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (addsd (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movsd (:%xmm x) (:%xmm result)) + (addsd (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8664-vinsn double-float--2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movsd (:%xmm x) (:%xmm result))) + (subsd (:%xmm y) (:%xmm result))) + +(define-x8664-vinsn double-float*-2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (mulsd (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (mulsd (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movsd (:%xmm x) (:%xmm result)) + (mulsd (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8664-vinsn double-float/-2 (((result :double-float)) + ((x :double-float) + (y :double-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movsd (:%xmm x) (:%xmm result))) + (divsd (:%xmm y) (:%xmm result))) + +(define-x8664-vinsn single-float+-2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (addss (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (addss (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movss (:%xmm x) (:%xmm result)) + (addss (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8664-vinsn single-float--2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movss (:%xmm x) (:%xmm result))) + (subss (:%xmm y) (:%xmm result))) + +(define-x8664-vinsn single-float*-2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x)) + (mulss (:%xmm y) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y))) + (mulss (:%xmm x) (:%xmm result))) + ((:and (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (:not (:pred = + (:apply %hard-regspec-value result) + (:apply %hard-regspec-value y)))) + (movss (:%xmm x) (:%xmm result)) + (mulss (:%xmm y) (:%xmm result)))) + +;;; Caller guarantees (not (eq y result)) +(define-x8664-vinsn single-float/-2 (((result :single-float)) + ((x :single-float) + (y :single-float))) + ((:not (:pred = (:apply %hard-regspec-value result) + (:apply %hard-regspec-value x))) + (movss (:%xmm x) (:%xmm result))) + (divss (:%xmm y) (:%xmm result))) + +(define-x8664-vinsn get-single (((result :single-float)) + ((source :lisp))) + (movd (:%q source) (:%xmm result)) + (psrlq (:$ub 32) (:%xmm result))) + +(define-x8664-vinsn get-double (((result :double-float)) + ((source :lisp))) + (movsd (:@ x8664::double-float.value (:%q source)) (:%xmm result))) + +;;; Extract a double-float value, typechecking in the process. +;;; IWBNI we could simply call the "trap-unless-typecode=" vinsn here, +;;; instead of replicating it .. + +(define-x8664-vinsn get-double? (((target :double-float)) + ((source :lisp)) + ((tag :u8))) + :resume + (movl (:%l source) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + (movsbl (:@ x8664::misc-subtag-offset (:%q source)) (:%l tag)) + :have-tag + (cmpl (:$b x8664::subtag-double-float) (:%l tag)) + (jne :bad) + (movsd (:@ x8664::double-float.value (:%q source)) (:%xmm target)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q source) (:$ub x8664::subtag-double-float)))) + +(define-x8664-vinsn single->node (((result :lisp) + (source :single-float)) + ((source :single-float))) + (psllq (:$ub 32) (:%xmm source)) + (movd (:%xmm source) (:%q result)) + (movb (:$b x8664::tag-single-float) (:%b result))) + +(define-x8664-vinsn copy-double-float (((dest :double-float)) + ((src :double-float))) + (movsd (:%xmm src) (:%xmm dest))) + +(define-x8664-vinsn copy-single-float (((dest :single-float)) + ((src :single-float))) + (movss (:%xmm src) (:%xmm dest))) + + +(define-x8664-vinsn copy-single-to-double (((dest :double-float)) + ((src :single-float))) + (cvtss2sd (:%xmm src) (:%xmm dest))) + +(define-x8664-vinsn copy-double-to-single (((dest :single-float)) + ((src :double-float))) + (cvtsd2ss (:%xmm src) (:%xmm dest))) + +(define-x8664-vinsn u8->fixnum (((result :imm)) + ((val :u8)) + ()) + (leaq (:@ (:%q val) 8) (:%q result))) + +(define-x8664-vinsn fitvals (() + ((n :u16const)) + ((imm :u16))) + ((:pred = n 0) + (xorl (:%l imm) (:%l imm))) + ((:not (:pred = n 0)) + (movl (:$l (:apply ash n x8664::fixnumshift)) (:%l imm))) + (subl (:%l x8664::nargs) (:%l imm)) + (jae :push-more) + (movslq (:%l imm) (:%q imm)) + (subq (:%q imm) (:%q x8664::rsp)) + (jmp :done) + :push-loop + (pushq (:$l (:apply target-nil-value))) + (addl (:$b x8664::node-size) (:%l x8664::nargs)) + (subl (:$b x8664::node-size) (:%l imm)) + :push-more + (jne :push-loop) + :done) + +(define-x8664-vinsn (nvalret :jumpLR) (() + ()) + + (jmp (:@ .SPnvalret))) + + +(define-x8664-vinsn lisp-word-ref (((dest t)) + ((base t) + (offset t))) + (movq (:@ (:%q base) (:%q offset)) (:%q dest))) + + +(define-x8664-vinsn lisp-word-ref-c (((dest t)) + ((base t) + (offset :s32const))) + ((:pred = offset 0) + (movq (:@ (:%q base)) (:%q dest))) + ((:not (:pred = offset 0)) + (movq (:@ offset (:%q base)) (:%q dest)))) + + +(define-x8664-vinsn (vpush-label :push :node :vsp) (() + ((label :label))) + (leaq (:@ (:^ label) (:%q x8664::fn)) (:%q x8664::ra0)) + (pushq (:%q x8664::ra0))) + +;; ???? +(define-x8664-vinsn emit-aligned-label (() + ((label :label))) + (:align 3) + (:long (:^ label))) + +;;; %ra0 is pointing into %fn, so no need to copy %fn here. +(define-x8664-vinsn pass-multiple-values-symbol (() + ()) + (pushq (:@ (:apply + (:apply target-nil-value) (x8664::%kernel-global 'x86::ret1valaddr)))) + (jmp (:@ x8664::symbol.fcell (:% x8664::fname)))) + +;;; It'd be good to have a variant that deals with a known function +;;; as well as this. +(define-x8664-vinsn pass-multiple-values (() + () + ((tag :u8))) + :resume + (movl (:%l x8664::temp0) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-symbol) (:%l tag)) + (cmovgq (:%q x8664::temp0) (:%q x8664::fn)) + (jl :bad) + (cmoveq (:@ x8664::symbol.fcell (:%q x8664::fname)) (:%q x8664::fn)) + (pushq (:@ (:apply + (:apply target-nil-value) (x8664::%kernel-global 'x86::ret1valaddr)))) + (jmp (:%q x8664::fn)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable))) + + + +(define-x8664-vinsn reserve-outgoing-frame (() + ()) + (pushq (:$b x8664::reserved-frame-marker)) + (pushq (:$b x8664::reserved-frame-marker))) + + +(define-x8664-vinsn (call-known-function :call) (() + () + ((entry (:label 1)))) + (:talign 4) + (call (:%q x8664::temp0)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn (jump-known-function :jumplr) (() + ()) + (movq (:%q x8664::fn) (:%q x8664::xfn)) + (movq (:%q x8664::temp0) (:%q x8664::fn)) + (jmp (:%q x8664::fn))) + +(define-x8664-vinsn (list :call) (() + () + ((entry (:label 1)))) + (leaq (:@ (:^ :back) (:%q x8664::fn)) (:%q x8664::ra0)) + (:talign 4) + (jmp (:@ .SPconslist)) + :back + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + + +(define-x8664-vinsn make-tsp-cons (((dest :lisp)) + ((car :lisp) (cdr :lisp)) + ((temp :imm))) + (subq (:$b (+ x8664::cons.size x8664::dnode-size)) (:rcontext x8664::tcr.next-tsp)) + (movq (:rcontext x8664::tcr.next-tsp) (:%q temp)) + (movapd (:%xmm x8664::fpzero) (:@ (:%q temp))) + (movapd (:%xmm x8664::fpzero) (:@ 16 (:%q temp))) + (movq (:rcontext x8664::tcr.save-tsp) (:%mmx x8664::stack-temp)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) + (movq (:%q temp) (:rcontext x8664::tcr.save-tsp)) + (leaq (:@ (+ x8664::dnode-size x8664::fulltag-cons) (:%q temp)) (:%q temp)) + (movq (:%q car) (:@ x8664::cons.car (:%q temp))) + (movq (:%q cdr) (:@ x8664::cons.cdr (:%q temp))) + (movq (:%q temp) (:%q dest))) + +(define-x8664-vinsn make-fixed-stack-gvector (((dest :lisp)) + ((aligned-size :u32const) + (header :s32const)) + ((tempa :imm) + (tempb :imm))) + ((:and (:pred >= (:apply + aligned-size x8664::dnode-size) -128) + (:pred <= (:apply + aligned-size x8664::dnode-size) 127)) + (subq (:$b (:apply + aligned-size x8664::dnode-size)) + (:rcontext x8664::tcr.next-tsp))) + ((:not (:and (:pred >= (:apply + aligned-size x8664::dnode-size) -128) + (:pred <= (:apply + aligned-size x8664::dnode-size) 127))) + (subq (:$l (:apply + aligned-size x8664::dnode-size)) + (:rcontext x8664::tcr.next-tsp))) + (movq (:rcontext x8664::tcr.save-tsp) (:%q tempb)) + (movq (:rcontext x8664::tcr.next-tsp) (:%q tempa)) + (movd (:%q tempb) (:%mmx x8664::stack-temp)) + :loop + (movapd (:%xmm x8664::fpzero) (:@ -16 (:%q tempb))) + (subq (:$b x8664::dnode-size) (:%q tempb)) + (cmpq (:%q tempa) (:%q tempb)) + (jnz :loop) + (movq (:%mmx x8664::stack-temp) (:@ (:%q tempa))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q tempa))) + (movq (:%q tempa) (:rcontext x8664::tcr.save-tsp)) + (movl (:$l header) (:@ x8664::dnode-size (:%q tempa))) + (leaq (:@ (+ x8664::dnode-size x8664::fulltag-misc) (:%q tempa)) (:%q dest))) + + +(define-x8664-vinsn (discard-temp-frame :tsp :pop :discard) (() + () + ((temp :imm))) + (movq (:rcontext x8664::tcr.save-tsp) (:%q temp)) + (movq (:@ (:%q temp)) (:%q temp)) + (movq (:%q temp) (:rcontext x8664::tcr.save-tsp)) + (movq (:%q temp) (:rcontext x8664::tcr.next-tsp)) + ) + +(define-x8664-vinsn (discard-c-frame :csp :pop :discard) (() + () + ((temp :imm))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q temp)) + (movq (:@ (:%q temp)) (:%q temp)) + (movq (:%q temp) (:rcontext x8664::tcr.foreign-sp))) + + +(define-x8664-vinsn (vstack-discard :vsp :pop :discard) (() + ((nwords :u32const))) + ((:not (:pred = nwords 0)) + ((:pred < nwords 16) + (addq (:$b (:apply ash nwords x8664::word-shift)) (:%q x8664::rsp))) + ((:not (:pred < nwords 16)) + (addq (:$l (:apply ash nwords x8664::word-shift)) (:%q x8664::rsp))))) + + +(defmacro define-x8664-subprim-lea-jmp-vinsn ((name &rest other-attrs) spno) + `(define-x8664-vinsn (,name :call :subprim-call ,@other-attrs) (() () ((entry (:label 1)))) + (leaq (:@ (:^ :back) (:%q x8664::fn)) (:%q x8664::ra0)) + (:talign 4) + (jmp (:@ ,spno)) + :back + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)))) + +(defmacro define-x8664-subprim-call-vinsn ((name &rest other-attrs) spno) + `(define-x8664-vinsn (,name :call :subprim-call ,@other-attrs) (() () ((entry (:label 1)))) + (:talign 4) + (call (:@ ,spno)) + :back + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)))) + +(defmacro define-x8664-subprim-jump-vinsn ((name &rest other-attrs) spno) + `(define-x8664-vinsn (,name :jumpLR ,@other-attrs) (() ()) + (jmp (:@ ,spno)))) + +(define-x8664-vinsn (nthrowvalues :call :subprim-call) (() + ((lab :label))) + (leaq (:@ (:^ lab) (:%q x8664::fn)) (:%q x8664::ra0)) + (jmp (:@ .SPnthrowvalues))) + +(define-x8664-vinsn (nthrow1value :call :subprim-call) (() + ((lab :label))) + (leaq (:@ (:^ lab) (:%q x8664::fn)) (:%q x8664::ra0)) + (jmp (:@ .SPnthrow1value))) + + +(define-x8664-subprim-lea-jmp-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0) + +(define-x8664-vinsn bind-interrupt-level-0-inline (() + () + ((temp :imm))) + (movq (:rcontext x8664::tcr.tlb-pointer) (:%q temp)) + (cmpq (:$b 0) (:@ x8664::interrupt-level-binding-index (:%q temp))) + (pushq (:@ x8664::interrupt-level-binding-index (:%q temp))) + (pushq (:$b x8664::interrupt-level-binding-index)) + (pushq (:rcontext x8664::tcr.db-link)) + (movq (:$l 0) (:@ x8664::interrupt-level-binding-index (:%q temp))) + (movq (:%q x8664::rsp) (:rcontext x8664::tcr.db-link)) + (jns :done) + (btrq (:$ub 63) (:rcontext x8664::tcr.interrupt-pending)) + (jae :done) + (ud2a) + (:byte 2) + :done) + + + +(define-x8664-subprim-lea-jmp-vinsn (bind-interrupt-level-m1) .SPbind-interrupt-level-m1) + +(define-x8664-vinsn bind-interrupt-level-m1-inline (() + () + ((temp :imm))) + (movq (:rcontext x8664::tcr.tlb-pointer) (:%q temp)) + (pushq (:@ x8664::interrupt-level-binding-index (:%q temp))) + (pushq (:$b x8664::interrupt-level-binding-index)) + (pushq (:rcontext x8664::tcr.db-link)) + (movq (:$l (ash -1 x8664::fixnumshift)) (:@ x8664::interrupt-level-binding-index (:%q temp))) + (movq (:%q x8664::rsp) (:rcontext x8664::tcr.db-link))) + +(define-x8664-subprim-lea-jmp-vinsn (bind-interrupt-level) .SPbind-interrupt-level) + +(define-x8664-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level) + +(define-x8664-vinsn unbind-interrupt-level-inline (() + () + ((link :imm) + (curval :imm) + (oldval :imm) + (tlb :imm))) + (movq (:rcontext x8664::tcr.tlb-pointer) (:%q tlb)) + (movq (:rcontext x8664::tcr.db-link) (:%q link)) + (movq (:@ x8664::interrupt-level-binding-index (:%q tlb)) (:%q curval)) + (testq (:%q curval) (:%q curval)) + (movq (:@ 16 #|binding.val|# (:%q link)) (:%q oldval)) + (movq (:@ #|binding.link|# (:%q link)) (:%q link)) + (movq (:%q oldval) (:@ x8664::interrupt-level-binding-index (:%q tlb))) + (movq (:%q link) (:rcontext x8664::tcr.db-link)) + (jns :done) + (testq (:%q oldval) (:%q oldval)) + (js :done) + (btrq (:$ub 63) (:rcontext x8664::tcr.interrupt-pending)) + (jae :done) + (ud2a) + (:byte 2) + :done) + +(define-x8664-vinsn (jump-return-pc :jumpLR) + (() + ()) + (ret)) + +(define-x8664-vinsn (nmkcatchmv :call :subprim-call) (() + ((lab :label)) + ((entry (:label 1)))) + (leaq (:@ (:^ lab) (:%q x8664::fn)) (:%q x8664::xfn)) + (:talign 4) + (call (:@ .SPmkcatchmv)) + :back + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn (nmkcatch1v :call :subprim-call) (() + ((lab :label)) + ((entry (:label 1)))) + (leaq (:@ (:^ lab) (:%q x8664::fn)) (:%q x8664::xfn)) + (:talign 4) + (call (:@ .SPmkcatch1v)) + :back + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + + +(define-x8664-vinsn (make-simple-unwind :call :subprim-call) (() + ((protform-lab :label) + (cleanup-lab :label))) + (leaq (:@ (:^ protform-lab) (:%q x8664::fn)) (:%q x8664::ra0)) + (leaq (:@ (:^ cleanup-lab) (:%q x8664::fn)) (:%q x8664::xfn)) + (jmp (:@ .SPmkunwind))) + +(define-x8664-vinsn (nmkunwind :call :subprim-call) (() + ((protform-lab :label) + (cleanup-lab :label))) + (leaq (:@ (:^ protform-lab) (:%q x8664::fn)) (:%q x8664::ra0)) + (leaq (:@ (:^ cleanup-lab) (:%q x8664::fn)) (:%q x8664::xfn)) + (jmp (:@ .SPnmkunwind))) + +;;; "old" mkunwind. Used by PROGV, since the binding of *interrupt-level* +;;; on entry to the new mkunwind confuses the issue. + +(define-x8664-vinsn (mkunwind :call :subprim-call) (() + ((protform-lab :label) + (cleanup-lab :label))) + (leaq (:@ (:^ protform-lab) (:%q x8664::fn)) (:%q x8664::ra0)) + (leaq (:@ (:^ cleanup-lab) (:%q x8664::fn)) (:%q x8664::xfn)) + (jmp (:@ .SPmkunwind))) + +(define-x8664-subprim-lea-jmp-vinsn (gvector) .SPgvector) + +(define-x8664-subprim-call-vinsn (getu64) .SPgetu64) + +;;; Call something callable and obtain the single value that it +;;; returns. +(define-x8664-vinsn funcall (() + () + ((tag :u8) + (entry (:label 1)))) + :resume + (movl (:%l x8664::temp0) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-symbol) (:%l tag)) + (cmovgq (:%q x8664::temp0) (:%q x8664::xfn)) + (jl :bad) + (cmoveq (:@ x8664::symbol.fcell (:%q x8664::fname)) (:%q x8664::xfn)) + (:talign 4) + (call (:%q x8664::xfn)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable))) + +(define-x8664-vinsn tail-funcall (() + () + ((tag (:u8 #.x8664::imm0)))) + :resume + (movl (:%l x8664::temp0) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-symbol) (:%l tag)) + (cmovgq (:%q x8664::temp0) (:%q x8664::xfn)) + (jl :bad) + (cmoveq (:@ x8664::symbol.fcell (:%q x8664::fname)) (:%q x8664::xfn)) + (jmp (:%q x8664::xfn)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable))) + + + +;;; Magic numbers in here include the address of .SPcall-closure. +(define-x8664-vinsn init-nclosure (() + ((closure :lisp)) + ((imm0 :u64))) + (movq (:$q #x24fffffffff92d8d) (:%q imm0)) + (movb (:$b 4) (:@ x8664::misc-data-offset (:%q closure))) ; code word count + (movb (:$b #x4c) (:@ (+ x8664::misc-data-offset 7) (:%q closure))) ; 1st byte of lea + (movq (:%q imm0) (:@ (+ x8664::misc-data-offset 8) (:%q closure))) ; rest of lea, start of jmp + (movl (:$l #x01516825) (:@ (+ x8664::misc-data-offset 16) (:%q closure))) + (movb (:$b x8664::function-boundary-marker) (:@ (+ x8664::misc-data-offset 24) (:%q closure)))) + + +(define-x8664-vinsn finalize-closure (((closure :lisp)) + ((closure :lisp))) + (addq (:$b (- x8664::fulltag-function x8664::fulltag-misc)) (:%q closure))) + + +(define-x8664-vinsn (ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val)))) + ((entry (:label 1)))) + (:talign 4) + (call (:@ .SPspecrefcheck)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) ) + +(define-x8664-vinsn ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + :resume + (movq (:@ x8664::symbol.binding-index (:%q src)) (:%q idx)) + (rcmpq (:%q idx) (:rcontext x8664::tcr.tlb-limit)) + (movq (:rcontext x8664::tcr.tlb-pointer) (:%q table)) + (jae :symbol) + (movq (:@ (:%q table) (:%q idx)) (:%q dest)) + (cmpl (:$b x8664::subtag-no-thread-local-binding) (:%l dest)) + (jne :test) + :symbol + (movq (:@ x8664::symbol.vcell (:%q src)) (:%q dest)) + :test + (cmpl (:$b x8664::unbound-marker) (:%l dest)) + (je :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-unbound (:%q src)))) + + +(define-x8664-vinsn (%ref-symbol-value :call :subprim-call) + (((val :lisp)) + ((sym (:lisp (:ne val)))) + ((entry (:label 1)))) + (:talign 4) + (call (:@ .SPspecref)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn %ref-symbol-value-inline (((dest :lisp)) + ((src (:lisp (:ne dest)))) + ((table :imm) + (idx :imm))) + (movq (:@ x8664::symbol.binding-index (:%q src)) (:%q idx)) + (rcmpq (:%q idx) (:rcontext x8664::tcr.tlb-limit)) + (movq (:rcontext x8664::tcr.tlb-pointer) (:%q table)) + (jae :symbol) + (movq (:@ (:%q table) (:%q idx)) (:%q dest)) + (cmpb (:$b x8664::subtag-no-thread-local-binding) (:%b dest)) + (jne :done) + :symbol + (movq (:@ x8664::symbol.vcell (:%q src)) (:%q dest)) + :done) + +(define-x8664-vinsn ref-interrupt-level (((dest :imm)) + () + ((temp :u64))) + (movq (:rcontext x8664::tcr.tlb-pointer) (:%q temp)) + (movq (:@ x8664::INTERRUPT-LEVEL-BINDING-INDEX (:%q temp)) (:%q dest))) + + + + +(define-x8664-vinsn setup-double-float-allocation (() + ()) + (movl (:$l (arch::make-vheader x8664::double-float.element-count x8664::subtag-double-float)) (:%l x8664::imm0.l)) + (movl (:$l (- x8664::double-float.size x8664::fulltag-misc)) (:%l x8664::imm1.l))) + +(define-x8664-vinsn set-double-float-value (() + ((node :lisp) + (val :double-float))) + (movsd (:%xmm val) (:@ x8664::double-float.value (:%q node)))) + +(define-x8664-vinsn word-index-and-bitnum-from-index (((word-index :u64) + (bitnum :u8)) + ((index :imm))) + (movq (:%q index) (:%q word-index)) + (shrq (:$ub x8664::fixnumshift) (:%q word-index)) + (movl (:$l 63) (:%l bitnum)) + (andl (:%l word-index) (:%l bitnum)) + (shrq (:$ub 6) (:%q word-index))) + +(define-x8664-vinsn ref-bit-vector-fixnum (((dest :imm) + (bitnum :u8)) + ((bitnum :u8) + (bitvector :lisp) + (word-index :u64))) + (btq (:%q bitnum) (:@ x8664::misc-data-offset (:%q bitvector) (:%q word-index) 8)) + (setb (:%b bitnum)) + (negb (:%b bitnum)) + (andl (:$l x8664::fixnumone) (:%l bitnum)) + (movl (:%l bitnum) (:%l dest))) + +(define-x8664-vinsn nref-bit-vector-fixnum (((dest :imm) + (bitnum :s64)) + ((bitnum :s64) + (bitvector :lisp)) + ()) + (btq (:%q bitnum) (:@ x8664::misc-data-offset (:%q bitvector))) + (setc (:%b bitnum)) + (movzbl (:%b bitnum) (:%l bitnum)) + (imull (:$b x8664::fixnumone) (:%l bitnum) (:%l dest))) + + +(define-x8664-vinsn nref-bit-vector-flags (() + ((bitnum :s64) + (bitvector :lisp)) + ()) + (btq (:%q bitnum) (:@ x8664::misc-data-offset (:%q bitvector)))) + +(define-x8664-vinsn misc-ref-c-bit-fixnum (((dest :imm)) + ((src :lisp) + (idx :u64const)) + ((temp :u8))) + (btq (:$ub (:apply logand 63 idx)) + (:@ (:apply + x8664::misc-data-offset (:apply ash (:apply ash idx -6) x8664::word-shift)) (:%q src))) + (setc (:%b temp)) + (movzbl (:%b temp) (:%l temp)) + (imull (:$b x8664::fixnumone) (:%l temp) (:%l dest))) + + +(define-x8664-vinsn misc-ref-c-bit-flags (() + ((src :lisp) + (idx :u64const)) + ) + (btq (:$ub (:apply logand 63 idx)) + (:@ (:apply + x8664::misc-data-offset (:apply ash (:apply ash idx -6) x8664::word-shift)) (:%q src)))) + +(define-x8664-vinsn deref-macptr (((addr :address)) + ((src :lisp)) + ()) + (movq (:@ x8664::macptr.address (:%q src)) (:%q addr))) + +(define-x8664-vinsn (temp-push-unboxed-word :push :word :csp) + (() + ((w :u64))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:$b (* 2 x8664::dnode-size)) (:rcontext x8664::tcr.foreign-sp)) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))) + (movq (:%q w) (:@ x8664::dnode-size (:%q x8664::ra0)))) + + +(define-x8664-vinsn (temp-push-node :push :word :tsp) + (() + ((w :lisp)) + ((temp :imm))) + (subq (:$b (* 2 x8664::dnode-size)) (:rcontext x8664::tcr.next-tsp)) + (movq (:rcontext x8664::tcr.save-tsp) (:%mmx x8664::stack-temp)) + (movq (:rcontext x8664::tcr.next-tsp) (:%q temp)) + (movapd (:%xmm x8664::fpzero) (:@ (:%q temp))) + (movapd (:%xmm x8664::fpzero) (:@ 16 (:%q temp))) + (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) + (movq (:%q temp) (:rcontext x8664::tcr.save-tsp)) + (movq (:%q w) (:@ x8664::dnode-size (:%q temp)))) + +(define-x8664-vinsn (temp-push-double-float :push :word :csp) + (() + ((f :double-float))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:$b (* 2 x8664::dnode-size)) (:rcontext x8664::tcr.foreign-sp)) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))) + (movapd (:%xmm f) (:@ x8664::dnode-size (:%q x8664::ra0)))) + + +(define-x8664-vinsn (vpush-single-float :push :word :vsp) + (() + ((f :single-float))) + (pushq (:$b x8664::tag-single-float)) + (movss (:%xmm f) (:@ 4 (:%q x8664::rsp)))) + +(define-x8664-vinsn (vpop-single-float :pop :word :vsp) + (() + ((f :single-float))) + (movss (:@ 4 (:%q x8664::rsp)) (:%xmm f)) + (addq (:$b x8664::node-size) (:%q x8664::rsp))) + +(define-x8664-vinsn (temp-pop-unboxed-word :pop :word :csp) + (((w :u64)) + ()) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:@ x8664::dnode-size (:%q x8664::ra0)) (:%q w)) + (addq (:$b (* 2 x8664::dnode-size)) (:rcontext x8664::tcr.foreign-sp))) + + +(define-x8664-vinsn (temp-pop-node :pop :word :tsp) + (((w :lisp)) + () + ((temp :imm))) + (movq (:rcontext x8664::tcr.save-tsp) (:%q temp)) + (movq (:@ x8664::dnode-size (:%q temp)) (:%q w)) + (movq (:@ (:%q temp)) (:%q temp)) + (movq (:%q temp) (:rcontext x8664::tcr.save-tsp)) + (movq (:%q temp) (:rcontext x8664::tcr.next-tsp))) + +(define-x8664-vinsn (temp-pop-double-float :pop :word :csp) + (((f :double-float)) + ()) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movapd (:@ x8664::dnode-size (:%q x8664::ra0)) (:%xmm f)) + (addq (:$b (* 2 x8664::dnode-size)) (:rcontext x8664::tcr.foreign-sp))) + + + +(define-x8664-vinsn macptr->stack (((dest :lisp)) + ((ptr :address))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:$b (+ x8664::dnode-size x8664::macptr.size)) (:rcontext x8664::tcr.foreign-sp)) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))) + (leaq (:@ (+ x8664::dnode-size x8664::fulltag-misc) (:%q x8664::ra0)) (:%q dest)) + (movq (:$l x8664::macptr-header) (:@ x8664::macptr.header (:%q dest))) + (movq (:%q ptr) (:@ x8664::macptr.address (:%q dest))) + (movapd (:%xmm x8664::fpzero) (:@ x8664::macptr.domain (:%q dest)))) + +(define-x8664-vinsn fixnum->signed-natural (((dest :s64)) + ((src :imm))) + (movq (:%q src) (:%q dest)) + (sarq (:$ub x8664::fixnumshift) (:%q dest))) + +(define-x8664-vinsn mem-set-double-float (() + ((val :double-float) + (src :address) + (index :s64))) + (movsd (:%xmm val) (:@ (:%q src) (:%q index)))) + +(define-x8664-vinsn mem-set-single-float (() + ((val :single-float) + (src :address) + (index :s64))) + (movss (:%xmm val) (:@ (:%q src) (:%q index)))) + + + +(define-x8664-vinsn mem-set-c-doubleword (() + ((val :u64) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movq (:%q val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movq (:%q val) (:@ offset (:%q dest))))) + +(define-x8664-vinsn mem-set-c-fullword (() + ((val :u32) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movl (:%l val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movl (:%l val) (:@ offset (:%q dest))))) + +(define-x8664-vinsn mem-set-c-halfword (() + ((val :u16) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movw (:%w val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movw (:%w val) (:@ offset (:%q dest))))) + +(define-x8664-vinsn mem-set-c-byte (() + ((val :u8) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movb (:%b val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movb (:%b val) (:@ offset (:%q dest))))) + +(define-x8664-vinsn mem-set-c-constant-doubleword (() + ((val :s32const) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movq (:$l val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movq (:$l val) (:@ offset (:%q dest))))) + +(define-x8664-vinsn mem-set-c-constant-fullword (() + ((val :s32const) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movl (:$l val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movl (:$l val) (:@ offset (:%q dest))))) + +(define-x8664-vinsn mem-set-c-constant-halfword (() + ((val :s16const) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movw (:$w val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movw (:$w val) (:@ offset (:%q dest))))) + +(define-x8664-vinsn mem-set-c-constant-byte (() + ((val :s8const) + (dest :address) + (offset :s32const))) + ((:pred = offset 0) + (movb (:$b val) (:@ (:%q dest)))) + ((:not (:pred = offset 0)) + (movb (:$b val) (:@ offset (:%q dest))))) + + + + + + +(define-x8664-vinsn mem-ref-natural (((dest :u64)) + ((src :address) + (index :s64))) + (movq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn setup-macptr-allocation (() + ((src :address))) + (movd (:%q src) (:%mmx x8664::mm0)) + (movl (:$l x8664::macptr-header) (:%l x8664::imm0.l)) + (movl (:$l (- x8664::macptr.size x8664::fulltag-misc)) (:%l x8664::imm1.l))) + +(define-x8664-vinsn %set-new-macptr-value (() + ((ptr :lisp))) + (movq (:%mmx x8664::mm0) (:@ x8664::macptr.address (:%q ptr)))) + +(define-x8664-vinsn mem-ref-c-fullword (((dest :u32)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movl (:@ (:%q src)) (:%l dest))) + ((:not (:pred = index 0)) + (movl (:@ index (:%q src)) (:%l dest)))) + +(define-x8664-vinsn mem-ref-c-signed-fullword (((dest :s32)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movslq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movslq (:@ index (:%q src)) (:%q dest)))) + + +(define-x8664-vinsn mem-ref-c-single-float (((dest :single-float)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movss (:@ (:%q src)) (:%xmm dest))) + ((:not (:pred = index 0)) + (movss (:@ index (:%q src)) (:%xmm dest)))) + +(define-x8664-vinsn mem-set-c-single-float (() + ((val :single-float) + (src :address) + (index :s16const))) + ((:pred = index 0) + (movss (:%xmm val) (:@ (:%q src)))) + ((:not (:pred = index 0)) + (movss (:%xmm val) (:@ index (:%q src))))) + +(define-x8664-vinsn mem-ref-c-doubleword (((dest :u64)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movq (:@ index (:%q src)) (:%q dest)))) + +(define-x8664-vinsn mem-ref-c-signed-doubleword (((dest :s64)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movq (:@ index (:%q src)) (:%q dest)))) + +(define-x8664-vinsn mem-ref-c-natural (((dest :u64)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movq (:@ index (:%q src)) (:%q dest)))) + +(define-x8664-vinsn mem-ref-c-double-float (((dest :double-float)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movsd (:@ (:%q src)) (:%xmm dest))) + ((:not (:pred = index 0)) + (movsd (:@ index (:%q src)) (:%xmm dest)))) + +(define-x8664-vinsn mem-set-c-double-float (() + ((val :double-float) + (src :address) + (index :s16const))) + ((:pred = index 0) + (movsd (:%xmm val) (:@ (:%q src)))) + ((:not (:pred = index 0)) + (movsd (:%xmm val) (:@ index (:%q src))))) + +(define-x8664-vinsn mem-ref-fullword (((dest :u32)) + ((src :address) + (index :s64))) + (movl (:@ (:%q src) (:%q index)) (:%l dest))) + +(define-x8664-vinsn mem-ref-signed-fullword (((dest :s32)) + ((src :address) + (index :s64))) + (movslq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn mem-ref-doubleword (((dest :u64)) + ((src :address) + (index :s64))) + (movq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn mem-ref-natural (((dest :u64)) + ((src :address) + (index :s64))) + (movq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn mem-ref-signed-doubleword (((dest :s64)) + ((src :address) + (index :s64))) + (movq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-u16 (((dest :u16)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movzwq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movzwq (:@ index (:%q src)) (:%q dest)))) + +(define-x8664-vinsn mem-ref-u16 (((dest :u16)) + ((src :address) + (index :s64))) + (movzwq (:@ (:%q src) (:%q index)) (:%q dest))) + + +(define-x8664-vinsn mem-ref-c-s16 (((dest :s16)) + ((src :address) + (index :s32const))) + ((:pred = index 0) + (movswq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movswq (:@ index (:%q src)) (:%q dest)))) + +(define-x8664-vinsn mem-ref-s16 (((dest :s16)) + ((src :address) + (index :s32))) + (movswq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-u8 (((dest :u8)) + ((src :address) + (index :s16const))) + ((:pred = index 0) + (movzbq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movzbq (:@ index (:%q src)) (:%q dest)))) + +(define-x8664-vinsn mem-ref-u8 (((dest :u8)) + ((src :address) + (index :s32))) + (movzbq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-s8 (((dest :s8)) + ((src :address) + (index :s16const))) + ((:pred = index 0) + (movsbq (:@ (:%q src)) (:%q dest))) + ((:not (:pred = index 0)) + (movsbq (:@ index (:%q src)) (:%q dest)))) + +(define-x8664-vinsn misc-set-c-s8 (((val :s8)) + ((v :lisp) + (idx :u32const)) + ()) + (movb (:%b val) (:@ (:apply + x8664::misc-data-offset idx) (:%q v)))) + +(define-x8664-vinsn misc-set-s8 (((val :s8)) + ((v :lisp) + (scaled-idx :s64)) + ()) + (movb (:%b val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn mem-ref-s8 (((dest :s8)) + ((src :address) + (index :s32))) + (movsbq (:@ (:%q src) (:%q index)) (:%q dest))) + +(define-x8664-vinsn mem-set-constant-doubleword (() + ((val :s32const) + (ptr :address) + (offset :s64))) + (movq (:$l val) (:@ (:%q ptr) (:%q offset)))) + +(define-x8664-vinsn mem-set-constant-fullword (() + ((val :s32const) + (ptr :address) + (offset :s64))) + (movl (:$l val) (:@ (:%q ptr) (:%q offset)))) + + +(define-x8664-vinsn mem-set-constant-halfword (() + ((val :s16const) + (ptr :address) + (offset :s64))) + (movw (:$w val) (:@ (:%q ptr) (:%q offset)))) + +(define-x8664-vinsn mem-set-constant-byte (() + ((val :s8const) + (ptr :address) + (offset :s64))) + (movb (:$b val) (:@ (:%q ptr) (:%q offset)))) + +(define-x8664-vinsn misc-set-c-u8 (((val :u8)) + ((v :lisp) + (idx :u32const)) + ()) + (movb (:%b val) (:@ (:apply + x8664::misc-data-offset idx) (:%q v)))) + +(define-x8664-vinsn misc-set-u8 (((val :u8)) + ((v :lisp) + (scaled-idx :s64)) + ()) + (movb (:%b val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn misc-set-c-u8 (((val :u8)) + ((v :lisp) + (idx :s32const)) + ()) + (movb (:%b val) (:@ (:apply + x8664::misc-data-offset idx) (:%q v)))) + +(define-x8664-vinsn misc-set-u8 (() + ((val :u8) + (v :lisp) + (scaled-idx :s64)) + ()) + (movb (:%b val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn misc-set-c-u16 (() + ((val :u16) + (v :lisp) + (idx :s32const)) + ()) + (movw (:%w val) (:@ (:apply + x8664::misc-data-offset (:apply * 2 idx)) (:%q v)))) + + +(define-x8664-vinsn misc-set-u16 (() + ((val :u16) + (v :lisp) + (scaled-idx :s64)) + ()) + (movw (:%w val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn misc-set-c-s16 (() + ((val :s16) + (v :lisp) + (idx :s32const)) + ()) + (movw (:%w val) (:@ (:apply + x8664::misc-data-offset (:apply * 2 idx)) (:%q v)))) + + +(define-x8664-vinsn misc-set-s16 (() + ((val :s16) + (v :lisp) + (scaled-idx :s64)) + ()) + (movw (:%w val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn misc-set-c-u32 (() + ((val :u32) + (v :lisp) + (idx :u32const)) ; sic + ()) + (movl (:%l val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 2)) (:%q v)))) + +(define-x8664-vinsn misc-set-u32 (() + ((val :u32) + (v :lisp) + (scaled-idx :s64)) + ()) + (movl (:%l val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn misc-set-c-s32 (() + ((val :s32) + (v :lisp) + (idx :u32const)) ; sic + ()) + (movl (:%l val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 2)) (:%q v)))) + +(define-x8664-vinsn misc-set-s32 (() + ((val :s32) + (v :lisp) + (scaled-idx :s64)) + ()) + (movl (:%l val) (:@ x8664::misc-data-offset (:%q v) (:%q scaled-idx)))) + +(define-x8664-vinsn %iasr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s64) + (shiftcount (:s64 #.x8664::rcx)))) + (movq (:%q count) (:%q temp)) + (sarq (:$ub x8664::fixnumshift) (:%q temp)) + (movl (:$l 63) (:%l shiftcount)) + (rcmpq (:%q temp) (:%q shiftcount)) + (cmovbel (:%l temp) (:%l shiftcount)) + (movq (:%q src) (:%q temp)) + (sarq (:%shift x8664::cl) (:%q temp)) + (andq (:$b (lognot x8664::fixnummask)) (:%q temp)) + (movq (:%q temp) (:%q dest))) + +(define-x8664-vinsn %ilsr (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s64) + (shiftcount (:s64 #.x8664::rcx)))) + (movq (:%q count) (:%q temp)) + (sarq (:$ub x8664::fixnumshift) (:%q temp)) + (movl (:$l 63) (:%l shiftcount)) + (rcmpq (:%q temp) (:%q shiftcount)) + (cmovbel (:%l temp) (:%l shiftcount)) + (movq (:%q src) (:%q temp)) + (shrq (:%shift x8664::cl) (:%q temp)) + (andq (:$b (lognot x8664::fixnummask)) (:%q temp)) + (movq (:%q temp) (:%q dest))) + + +(define-x8664-vinsn %iasr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s64))) + (movq (:%q src) (:%q temp)) + (sarq (:$ub count) (:%q temp)) + (andq (:$b (lognot x8664::fixnummask)) (:%q temp)) + (movq (:%q temp) (:%q dest))) + +(define-x8664-vinsn %ilsr-c (((dest :imm)) + ((count :u8const) + (src :imm)) + ((temp :s64))) + (movq (:%q src) (:%q temp)) + (shrq (:$ub count) (:%q temp)) + (andb (:$b (lognot x8664::fixnummask)) (:%b temp)) + (movq (:%q temp) (:%q dest))) + +(define-x8664-vinsn %ilsl (((dest :imm)) + ((count :imm) + (src :imm)) + ((temp :s64) + (shiftcount (:s64 #.x8664::rcx)))) + (movq (:%q count) (:%q temp)) + (sarq (:$ub x8664::fixnumshift) (:%q temp)) + (rcmpq (:%q temp) (:$l 63)) + (cmovbw (:%w temp) (:%w shiftcount)) + (movq (:%q src) (:%q temp)) + (jae :shift-max) + (shlq (:%shift x8664::cl) (:%q temp)) + (jmp :done) + :shift-max + (xorq (:%q temp) (:%q temp)) + :done + (movq (:%q temp) (:%q dest))) + +(define-x8664-vinsn %ilsl-c (((dest :imm)) + ((count :u8const) + (src :imm))) + ((:not (:pred = + (:apply %hard-regspec-value src) + (:apply %hard-regspec-value dest))) + (movq (:%q src) (:%q dest))) + (shlq (:$ub count) (:%q dest))) + +;;; In safe code, something else has ensured that the value is of type +;;; BIT. +(define-x8664-vinsn set-variable-bit-to-variable-value (() + ((vec :lisp) + (word-index :s64) + (bitnum :u8) + (value :lisp))) + (testb (:%b value) (:%b value)) + (je :clr) + (btsq (:%q bitnum) (:@ x8664::misc-data-offset (:%q vec) (:%q word-index) 8)) + (jmp :done) + :clr + (btrq (:%q bitnum) (:@ x8664::misc-data-offset (:%q vec) (:%q word-index) 8)) + :done) + +(define-x8664-vinsn set-variable-bit-to-zero (() + ((vec :lisp) + (word-index :s64) + (bitnum :u8))) + (btrq (:%q bitnum) (:@ x8664::misc-data-offset (:%q vec) (:%q word-index) 8))) + +(define-x8664-vinsn set-variable-bit-to-one (() + ((vec :lisp) + (word-index :s64) + (bitnum :u8))) + (btsq (:%q bitnum) (:@ x8664::misc-data-offset (:%q vec) (:%q word-index) 8))) + +;;; In safe code, something else has ensured that the value is of type +;;; BIT. +(define-x8664-vinsn nset-variable-bit-to-variable-value (() + ((vec :lisp) + (index :s64) + (value :lisp))) + (testb (:%b value) (:%b value)) + (je :clr) + (btsq (:%q index) (:@ x8664::misc-data-offset (:%q vec))) + (jmp :done) + :clr + (btrq (:%q index) (:@ x8664::misc-data-offset (:%q vec))) + :done) + +(define-x8664-vinsn nset-variable-bit-to-zero (() + ((vec :lisp) + (index :s64))) + (btrq (:%q index) (:@ x8664::misc-data-offset (:%q vec)))) + +(define-x8664-vinsn nset-variable-bit-to-one (() + ((vec :lisp) + (index :s64))) + (btsq (:%q index) (:@ x8664::misc-data-offset (:%q vec)))) + +(define-x8664-vinsn set-constant-bit-to-zero (() + ((src :lisp) + (idx :u64const))) + (btrq (:$ub (:apply logand 63 idx)) + (:@ (:apply + x8664::misc-data-offset (:apply ash (:apply ash idx -6) x8664::word-shift)) (:%q src)))) + +(define-x8664-vinsn set-constant-bit-to-one (() + ((src :lisp) + (idx :u64const))) + (btsq (:$ub (:apply logand 63 idx)) + (:@ (:apply + x8664::misc-data-offset (:apply ash (:apply ash idx -6) x8664::word-shift)) (:%q src)))) + +(define-x8664-vinsn set-constant-bit-to-variable-value (() + ((src :lisp) + (idx :u64const) + (value :lisp))) + (testb (:%b value) (:%b value)) + (je :clr) + (btsq (:$ub (:apply logand 63 idx)) + (:@ (:apply + x8664::misc-data-offset (:apply ash (:apply ash idx -6) x8664::word-shift)) (:%q src))) + (jmp :done) + :clr + (btrq (:$ub (:apply logand 63 idx)) + (:@ (:apply + x8664::misc-data-offset (:apply ash (:apply ash idx -6) x8664::word-shift)) (:%q src))) + :done) + + +(define-x8664-vinsn require-fixnum (() + ((object :lisp))) + :again + (testl (:$l x8664::fixnummask) (:%l object)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-fixnum)))) + +(define-x8664-vinsn require-integer (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fixnummask) (:%l tag)) + (je :got-it) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8664::subtag-bignum) (:@ x8664::misc-subtag-offset (:%q object))) + (jne :bad) + :got-it + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-integer)))) + +(define-x8664-vinsn require-simple-vector (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fixnummask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8664::subtag-simple-vector) (:@ x8664::misc-subtag-offset (:%q object))) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-simple-vector)))) + +(define-x8664-vinsn require-simple-string (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fixnummask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8664::subtag-simple-base-string) (:@ x8664::misc-subtag-offset (:%q object))) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-simple-string)))) + +(define-x8664-vinsn require-real (() + ((object :lisp)) + ((tag :u8) + (mask :u64))) + (movq (:$q (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::tag-single-float) + (ash 1 x8664::subtag-double-float) + (ash 1 x8664::subtag-bignum) + (ash 1 x8664::subtag-ratio))) + (:%q mask)) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) + :have-tag + (rcmpl (:%l tag) (:$b 64)) + (jae :bad) + (btq (:%q tag) (:%q mask)) + (jae :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-real)))) + +(define-x8664-vinsn require-number (() + ((object :lisp)) + ((tag :u8) + (mask :u64))) + (movq (:$q (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::tag-single-float) + (ash 1 x8664::subtag-double-float) + (ash 1 x8664::subtag-bignum) + (ash 1 x8664::subtag-ratio) + (ash 1 x8664::subtag-complex))) + (:%q mask)) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) + :have-tag + (rcmpl (:%l tag) (:$b 64)) + (jae :bad) + (btq (:%q tag) (:%q mask)) + (jae :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-number)))) + +(define-x8664-vinsn require-list (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-list) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-list)))) + +(define-x8664-vinsn require-symbol (() + ((object :lisp)) + ((tag :u8))) + :again + (movzbl (:%b object) (:%l tag)) + (cmpl (:$b x8664::fulltag-nil) (:%l tag)) + (je :good) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-symbol) (:%l tag)) + (jne :bad) + :good + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-symbol)))) + +(define-x8664-vinsn require-character (() + ((object :lisp))) + :again + (cmpb (:$b x8664::subtag-character) (:%b object)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-character)))) + +(define-x8664-vinsn require-s8 (() + ((object :lisp)) + ((tag :u32))) + :again + (movq (:%q object) (:%q tag)) + (shlq (:$ub (- x8664::nbits-in-word (+ 8 x8664::fixnumshift))) (:%q tag)) + (sarq (:$ub (- x8664::nbits-in-word 8)) (:%q tag)) + (shlq (:$ub x8664::fixnumshift) (:%q tag)) + (cmpq (:%q object) (:%q tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-8)))) + +(define-x8664-vinsn require-u8 (() + ((object :lisp)) + ((tag :u32))) + :again + (movq (:$l (lognot (ash #xff x8664::fixnumshift))) (:%q tag)) + (andq (:% object) (:% tag)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-8)))) + +(define-x8664-vinsn require-s16 (() + ((object :lisp)) + ((tag :s64))) + :again + (movq (:%q object) (:%q tag)) + (shlq (:$ub (- x8664::nbits-in-word (+ 16 x8664::fixnumshift))) (:%q tag)) + (sarq (:$ub (- x8664::nbits-in-word 16)) (:%q tag)) + (shlq (:$ub x8664::fixnumshift) (:%q tag)) + (cmpq (:%q object) (:%q tag)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-16)))) + +(define-x8664-vinsn require-u16 (() + ((object :lisp)) + ((tag :u32))) + :again + (movq (:$l (lognot (ash #xffff x8664::fixnumshift))) (:%q tag)) + (andq (:% object) (:% tag)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-16)))) + +(define-x8664-vinsn require-s32 (() + ((object :lisp)) + ((tag :s64))) + :again + (movq (:%q object) (:%q tag)) + (shlq (:$ub (- x8664::nbits-in-word (+ 32 x8664::fixnumshift))) (:%q tag)) + (sarq (:$ub (- x8664::nbits-in-word 32)) (:%q tag)) + (shlq (:$ub x8664::fixnumshift) (:%q tag)) + (cmpq (:%q object) (:%q tag)) + (jne :bad) + (testl (:$l x8664::fixnummask) (:%l object)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-32)))) + +(define-x8664-vinsn require-u32 (() + ((object :lisp)) + ((tag :u32))) + :again + (movq (:$q (lognot (ash #xffffffff x8664::fixnumshift))) (:%q tag)) + (andq (:% object) (:% tag)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-32)))) + +(define-x8664-vinsn require-s64 (() + ((object :lisp)) + ((tag :s64))) + :again + (testl (:$l x8664::fixnummask) (:%l object)) + (movl (:%l object) (:%l tag)) + (je :ok) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-misc) (:%l tag)) + (jne :bad) + (cmpq (:$l x8664::two-digit-bignum-header) (:@ x8664::misc-header-offset (:%q object))) + (jne :bad) + :ok + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-64)))) + +(define-x8664-vinsn require-u64 (() + ((object :lisp)) + ((tag :s64))) + :again + (testl (:$l x8664::fixnummask) (:%l object)) + (movq (:%q object) (:%q tag)) + (je :ok-if-non-negative) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-misc) (:%l tag)) + (jne :bad) + (cmpq (:$l x8664::two-digit-bignum-header) (:@ x8664::misc-header-offset (:%q object))) + (je :two) + (cmpq (:$l x8664::three-digit-bignum-header) (:@ x8664::misc-header-offset (:%q object))) + (jne :bad) + (cmpl (:$b 0) (:@ (+ x8664::misc-data-offset 8) (:%q object))) + (je :ok) + (jmp :bad) + :two + (movq (:@ x8664::misc-data-offset (:%q object)) (:%q tag)) + :ok-if-non-negative + (testq (:%q tag) (:%q tag)) + (js :bad) + :ok + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-64)))) + +(define-x8664-vinsn require-char-code (() + ((object :lisp)) + ((tag :u32))) + :again + (testl (:$l x8664::fixnummask) (:%l object)) + (jne :bad) + (cmpq (:$l (ash #x110000 x8664::fixnumshift)) (:%q object)) + (jae :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-mod-char-code-limit)))) + + +;;; set DEST to +(define-x8664-vinsn mask-base-char (((dest :u8)) + ((src :lisp))) + (movzbl (:%b src) (:%l dest))) + +(define-x8664-vinsn single-float-bits (((dest :u32)) + ((src :lisp))) + (movq (:%q src) (:%q dest)) + (shrq (:$ub 32) (:%q dest))) + +(define-x8664-vinsn zero-double-float-register (((dest :double-float)) + ()) + (movsd (:%xmm x8664::fpzero) (:%xmm dest))) + +(define-x8664-vinsn zero-single-float-register (((dest :single-float)) + ()) + (movss (:%xmm x8664::fpzero) (:%xmm dest))) + +(define-x8664-subprim-lea-jmp-vinsn (heap-rest-arg) .SPheap-rest-arg) +(define-x8664-subprim-lea-jmp-vinsn (stack-rest-arg) .SPstack-rest-arg) +(define-x8664-subprim-lea-jmp-vinsn (req-stack-rest-arg) .SPreq-stack-rest-arg) + +(define-x8664-subprim-call-vinsn (stack-misc-alloc) .SPstack-misc-alloc) + +(define-x8664-vinsn misc-element-count-fixnum (((dest :imm)) + ((src :lisp)) + ((temp :u64))) + (movq (:@ x8664::misc-header-offset (:%q src)) (:%q temp)) + (shrq (:$ub x8664::num-subtag-bits) (:%q temp)) + (imulq (:$b x8664::fixnumone) (:%q temp)(:%q dest))) + +(define-x8664-vinsn %logior2 (((dest :imm)) + ((x :imm) + (y :imm))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (orq (:%q y) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (orq (:%q x) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movq (:%q x) (:%q dest)) + (orq (:%q y) (:%q dest))))) + +(define-x8664-vinsn %logand2 (((dest :imm)) + ((x :imm) + (y :imm))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (andq (:%q y) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (andq (:%q x) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movq (:%q x) (:%q dest)) + (andq (:%q y) (:%q dest))))) + +(define-x8664-vinsn %logxor2 (((dest :imm)) + ((x :imm) + (y :imm))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (xorq (:%q y) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + ((:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)) + (xorq (:%q x) (:%q dest))) + ((:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movq (:%q x) (:%q dest)) + (xorq (:%q y) (:%q dest))))) + +(define-x8664-subprim-call-vinsn (integer-sign) .SPinteger-sign) + +(define-x8664-vinsn vcell-ref (((dest :lisp)) + ((vcell :lisp))) + (movq (:@ x8664::misc-data-offset (:%q vcell)) (:%q dest))) + +(define-x8664-vinsn (call-subprim-3 :call :subprim-call) (((dest t)) + ((spno :s32const) + (x t) + (y t) + (z t)) + ((entry (:label 1)))) + (:talign 4) + (call (:@ spno)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn setup-vcell-allocation (() + ()) + (movl (:$l x8664::value-cell-header) (:%l x8664::imm0)) + (movl (:$l (- x8664::value-cell.size x8664::fulltag-misc)) (:%l x8664::imm1))) + +(define-x8664-vinsn %init-vcell (() + ((vcell :lisp) + (closed :lisp))) + (movq (:%q closed) (:@ x8664::value-cell.value (:%q vcell)))) + +(define-x8664-subprim-call-vinsn (progvsave) .SPprogvsave) + +(define-x8664-subprim-jump-vinsn (progvrestore) .SPprogvrestore) + +(define-x8664-subprim-lea-jmp-vinsn (simple-keywords) .SPsimple-keywords) + +(define-x8664-subprim-lea-jmp-vinsn (keyword-args) .SPkeyword-args) + +(define-x8664-subprim-lea-jmp-vinsn (keyword-bind) .SPkeyword-bind) + +(define-x8664-vinsn scale-nargs (() + ((nfixed :s16const))) + ((:pred > nfixed 0) + ((:pred < nfixed 16) + (subl (:$b (:apply ash nfixed x8664::word-shift)) (:%l x8664::nargs))) + ((:pred >= nfixed 16) + (subl (:$l (:apply ash nfixed x8664::word-shift)) (:%l x8664::nargs))))) + +(define-x8664-vinsn opt-supplied-p (() + ((num-opt :u16const)) + ((nargs (:u64 #.x8664::nargs)) + (imm :imm))) + (xorl (:%l imm) (:%l imm)) + (movl (:$l (:apply target-nil-value)) (:%l x8664::arg_y)) + :loop + (rcmpl (:%l imm) (:%l nargs)) + (movl (:%l x8664::arg_y) (:%l x8664::arg_z)) + (cmovll (:@ (+ x8664::t-offset x8664::symbol.vcell) (:%l x8664::arg_y)) (:%l x8664::arg_z)) + (addl (:$b x8664::node-size) (:%l imm)) + (rcmpl (:%l imm) (:$l (:apply ash num-opt x8664::fixnumshift))) + (pushq (:%q x8664::arg_z)) + (jne :loop)) + +(define-x8664-vinsn one-opt-supplied-p (() + () + ((temp :u64))) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (movl (:$l (:apply target-nil-value)) (:%l temp)) + (cmovnel (:@ (+ x8664::t-offset x8664::symbol.vcell) (:%l temp)) (:%l temp)) + (pushq (:%q temp))) + +(define-x8664-vinsn two-opt-supplied-p (() + () + ((temp0 :u64) + (temp1 :u64))) + (rcmpl (:%l x8664::nargs) (:$b x8664::node-size)) + (movl (:$l (:apply target-nil-value)) (:%l temp0)) + (movl (:%l temp0) (:%l temp1)) + (cmovael (:@ (+ x8664::t-offset x8664::symbol.vcell) (:%l temp0)) (:%l temp0)) + (cmoval (:@ (+ x8664::t-offset x8664::symbol.vcell) (:%l temp1)) (:%l temp1)) + (pushq (:%q temp0)) + (pushq (:%q temp1))) + + +(define-x8664-vinsn set-c-flag-if-constant-logbitp (() + ((bit :u8const) + (int :imm))) + (btq (:$ub bit) (:%q int))) + +(define-x8664-vinsn set-c-flag-if-variable-logbitp (() + ((bit :imm) + (int :imm)) + ((temp0 :u8) + (temp1 :u8))) + (movl (:$l 63) (:%l temp1)) + (movq (:%q bit) (:%q temp0)) + (sarq (:$ub x8664::fixnumshift) (:%q temp0)) + (addq (:$b x8664::fixnumshift) (:%q temp0)) + (rcmpq (:%q temp0) (:%q temp1)) + (cmoval (:%l temp1) (:%l temp0)) + (btq (:%q temp0) (:%q int))) + +(define-x8664-vinsn multiply-immediate (((dest :imm)) + ((src :imm) + (const :s32const))) + ((:and (:pred >= const -128) (:pred <= const 127)) + (imulq (:$b const) (:%q src) (:%q dest))) + ((:not (:and (:pred >= const -128) (:pred <= const 127))) + (imulq (:$l const) (:%q src) (:%q dest)))) + +(define-x8664-vinsn multiply-fixnums (((dest :imm)) + ((x :imm) + (y :imm)) + ((unboxed :s64))) + ((:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest)) + (movq (:%q y) (:%q unboxed)) + (sarq (:$ub x8664::fixnumshift) (:%q unboxed)) + (imulq (:%q unboxed) (:%q dest))) + ((:and (:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest))) + (movq (:%q x) (:%q unboxed)) + (sarq (:$ub x8664::fixnumshift) (:%q unboxed)) + (imulq (:%q unboxed) (:%q dest))) + ((:and (:not (:pred = + (:apply %hard-regspec-value x) + (:apply %hard-regspec-value dest))) + (:not (:pred = + (:apply %hard-regspec-value y) + (:apply %hard-regspec-value dest)))) + (movq (:%q y) (:%q dest)) + (movq (:%q x) (:%q unboxed)) + (sarq (:$ub x8664::fixnumshift) (:%q unboxed)) + (imulq (:%q unboxed) (:%q dest)))) + + +(define-x8664-vinsn save-lexpr-argregs (() + ((min-fixed :u16const))) + ((:pred >= min-fixed $numx8664argregs) + (pushq (:%q x8664::arg_x)) + (pushq (:%q x8664::arg_y)) + (pushq (:%q x8664::arg_z))) + ((:pred = min-fixed 2) ; at least 2 args + (cmpl (:$b (ash 2 x8664::word-shift)) (:%l x8664::nargs)) + (je :yz2) ; skip arg_x if exactly 2 + (pushq (:%q x8664::arg_x)) + :yz2 + (pushq (:%q x8664::arg_y)) + (pushq (:%q x8664::arg_z))) + ((:pred = min-fixed 1) ; at least one arg + (rcmpl (:%l x8664::nargs) (:$b (ash 2 x8664::word-shift))) + (jl :z1) ; branch if exactly one + (je :yz1) ; branch if exactly two + (pushq (:%q x8664::arg_x)) + :yz1 + (pushq (:%q x8664::arg_y)) + :z1 + (pushq (:%q x8664::arg_z))) + ((:pred = min-fixed 0) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (je :none) ; exactly zero + (rcmpl (:%l x8664::nargs) (:$b (ash 2 x8664::word-shift))) + (je :yz0) ; exactly two + (jl :z0) ; one + ; Three or more ... + (pushq (:%q x8664::arg_x)) + :yz0 + (pushq (:%q x8664::arg_y)) + :z0 + (pushq (:%q x8664::arg_z)) + :none + ) + ((:not (:pred = min-fixed 0)) + (leaq (:@ (:apply - (:apply ash min-fixed x8664::word-shift)) (:%q x8664::nargs)) + (:%q x8664::nargs))) + (pushq (:%q x8664::nargs)) + (movq (:%q x8664::rsp) (:%q x8664::arg_z))) + + + + +;;; The frame that was built (by SAVE-LISP-CONTEXT-VARIABLE-ARG-COUNT +;;; and SAVE-LEXPR-ARGREGS) contains an unknown number of arguments +;;; followed by the count of non-required arguments; the count is on +;;; top of the stack and its address is in %arg_z. We need to build a +;;; frame so that the function can address its arguments (copies of +;;; the required arguments and the lexpr) and locals; when the +;;; function returns, it should one or more values (depending on how +;;; it was called) and discard the hidden lexpr frame. At this point, +;;; %ra0 still contains the "real" return address. If it's not the +;;; magic multiple-value address, we can make the function return to +;;; something that does a single-value return (.SPpopj); otherwise, we +;;; need to make it return multiple values to the real caller. (Unlike +;;; the PPC, this case only involves creating one frame here, but that +;;; frame has two return addresses.) +(define-x8664-vinsn build-lexpr-frame (() + () + ((temp :imm))) + (movq (:@ (:apply + (:apply target-nil-value) (x8664::%kernel-global 'x86::ret1valaddr))) + (:%q temp)) + (cmpq (:%q temp) + (:%q x8664::ra0)) + (je :multiple) + (pushq (:@ (:apply + (:apply target-nil-value) (x8664::%kernel-global 'x86::lexpr-return1v)))) + (jmp :finish) + :multiple + (pushq (:@ (:apply + (:apply target-nil-value) (x8664::%kernel-global 'x86::lexpr-return)))) + (pushq (:%q temp)) + :finish + (pushq (:%q x8664::rbp)) + (movq (:%q x8664::rsp) (:%q x8664::rbp))) + + +(define-x8664-vinsn copy-lexpr-argument (() + ((n :u16const)) + ((temp :imm))) + (movq (:@ (:%q x8664::arg_z)) (:%q temp)) + (pushq (:@ (:apply ash n x8664::word-shift) (:%q x8664::arg_z) (:%q temp)))) + + +(define-x8664-vinsn %current-tcr (((dest :lisp)) + ()) + (movq (:rcontext x8664::tcr.linear) (:%q dest))) + +(define-x8664-vinsn (setq-special :call :subprim-call) + (() + ((sym :lisp) + (val :lisp)) + ((entry (:label 1)))) + (:talign 4) + (call (:@ .SPspecset)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn set-z-flag-if-istruct-typep (() + ((val :lisp) + (type :lisp)) + ((tag :u8) + (valtype :lisp))) + (xorl (:%l valtype) (:%l valtype)) + (movl (:%l val) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :have-tag) + (movzbl (:@ x8664::misc-subtag-offset (:%q val)) (:%l tag)) + :have-tag + (cmpl (:$b x8664::subtag-istruct) (:%l tag)) + (jne :do-compare) + (movq (:@ x8664::misc-data-offset (:%q val)) (:%q valtype)) + :do-compare + (cmpq (:%q valtype) (:%q type))) + +(define-x8664-subprim-call-vinsn (misc-ref) .SPmisc-ref) + +(define-x8664-subprim-call-vinsn (ksignalerr) .SPksignalerr) + +(define-x8664-subprim-call-vinsn (misc-alloc-init) .SPmisc-alloc-init) + +(define-x8664-subprim-call-vinsn (misc-alloc) .SPmisc-alloc) + +(define-x8664-subprim-lea-jmp-vinsn (make-stack-gvector) .SPstkgvector) + +(define-x8664-vinsn load-character-constant (((dest :lisp)) + ((code :u32const)) + ()) + (movl (:$l (:apply logior (:apply ash code 8) x8664::subtag-character)) + (:%l dest))) + +(define-x8664-vinsn %scharcode8 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u64))) + (movq (:%q idx) (:%q imm)) + (sarq (:$ub x8664::fixnumshift) (:%q imm)) + (movzbl (:@ x8664::misc-data-offset (:%q str) (:%q imm)) (:%l imm)) + (imulq (:$b x8664::fixnumone) (:%q imm)(:%q code))) + +(define-x8664-vinsn %scharcode32 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u64))) + (movq (:%q idx) (:%q imm)) + (sarq (:$ub 1) (:%q imm)) + (movl (:@ x8664::misc-data-offset (:%q str) (:%q imm)) (:%l imm)) + (imulq (:$b x8664::fixnumone) (:%q imm)(:%q code))) + +(define-x8664-subprim-jump-vinsn (tail-call-sym-slide) .SPtcallsymslide) + +(define-x8664-subprim-jump-vinsn (tail-call-sym-vsp) .SPtcallsymvsp) + + +(define-x8664-vinsn character->code (((dest :u32)) + ((src :lisp))) + (movq (:%q src) (:%q dest)) + (sarq (:$ub x8664::charcode-shift) (:%q dest))) + +(define-x8664-vinsn adjust-vsp (() + ((amount :s32const))) + ((:and (:pred >= amount -128) (:pred <= amount 127)) + (addq (:$b amount) (:%q x8664::rsp))) + ((:not (:and (:pred >= amount -128) (:pred <= amount 127))) + (addq (:$l amount) (:%q x8664::rsp)))) + +(define-x8664-vinsn (call-subprim-2 :call :subprim-call) (((dest t)) + ((spno :s32const) + (y t) + (z t)) + ((entry (:label 1)))) + (:talign 4) + (call (:@ spno)) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + + + +(define-x8664-vinsn set-macptr-address (() + ((addr :address) + (src :lisp)) + ()) + (movq (:%q addr) (:@ x8664::macptr.address (:%q src)))) + +(define-x8664-vinsn %symbol->symptr (((dest :lisp)) + ((src :lisp)) + ((tag :u8))) + :begin + (movl (:$l (:apply + (:apply target-nil-value) x8664::nilsym-offset)) (:%l tag)) + (cmpb (:$b x8664::fulltag-nil) (:%b src)) + (cmoveq (:%q tag) (:%q dest)) + (movl (:%l src) (:%l tag)) + (je :ok) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-symbol) (:%l tag)) + (jne :bad) + + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movq (:% src) (:% dest))) + :ok + (:anchored-uuo-section :begin) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q src) (:$ub x8664::fulltag-symbol)))) + +(define-x8664-vinsn symbol-function (((val :lisp)) + ((sym (:lisp (:ne val)))) + ((tag :u8))) + :anchor + (movq (:@ x8664::symbol.fcell (:%q sym)) (:%q val)) + (movl (:%l val) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-function) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-udf (:%q sym)))) + +(define-x8664-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide) + +(define-x8664-vinsn load-double-float-constant (((dest :double-float)) + ((lab :label) +)) + (movsd (:@ (:^ lab) (:%q x8664::fn)) (:%xmm dest))) + +(define-x8664-vinsn load-single-float-constant (((dest :single-float)) + ((lab :label) +)) + (movss (:@ (:^ lab) (:%q x8664::fn)) (:%xmm dest))) + +(define-x8664-subprim-call-vinsn (misc-set) .SPmisc-set) + +(define-x8664-subprim-lea-jmp-vinsn (slide-values) .SPmvslide) + +(define-x8664-subprim-lea-jmp-vinsn (spread-list) .SPspreadargz) + +;;; Even though it's implemented by calling a subprim, THROW is really +;;; a JUMP (to a possibly unknown destination). If the destination's +;;; really known, it should probably be inlined (stack-cleanup, value +;;; transfer & jump ...) +(define-x8664-vinsn (throw :jump-unknown) (() + () + ((entry (:label 1)))) + (leaq (:@ (:^ :back) (:%q x8664::fn)) (:%q x8664::ra0)) + (:talign 4) + (jmp (:@ .SPthrow)) + :back + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) + (uuo-error-reg-not-tag (:%q x8664::temp0) (:$ub x8664::subtag-catch-frame))) + + + +(define-x8664-vinsn unbox-base-char (((dest :u64)) + ((src :lisp))) + :anchor + (movq (:%q src) (:%q dest)) + (shrq (:$ub x8664::charcode-shift) (:%q dest)) + (cmpb (:$b x8664::subtag-character) (:%b src)) + (jne :bad) + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q src) (:$ub x8664::subtag-character)))) + +(define-x8664-subprim-lea-jmp-vinsn (save-values) .SPsave-values) + +(define-x8664-subprim-lea-jmp-vinsn (recover-values) .SPrecover-values) + +(define-x8664-subprim-lea-jmp-vinsn (recover-values-for-mvcall) .SPrecover-values-for-mvcall) + +(define-x8664-subprim-lea-jmp-vinsn (add-values) .SPadd-values) + +(define-x8664-subprim-call-vinsn (make-stack-block) .SPmakestackblock) + +(define-x8664-subprim-call-vinsn (make-stack-block0) .Spmakestackblock0) + +;;; "dest" is preallocated, presumably on a stack somewhere. +(define-x8664-vinsn store-double (() + ((dest :lisp) + (source :double-float)) + ()) + (movsd (:%xmm source) (:@ x8664::double-float.value (:%q dest)))) + +(define-x8664-vinsn fixnum->char (((dest :lisp)) + ((src :imm)) + ((temp :u32))) + (movl (:%l src) (:%l temp)) + (sarl (:$ub (+ x8664::fixnumshift 1)) (:%l temp)) + (cmpl (:$l (ash #xfffe -1)) (:%l temp)) + (je :bad-if-eq) + (sarl (:$ub (- 11 1)) (:%l temp)) + (cmpl (:$b (ash #xd800 -11))(:%l temp)) + :bad-if-eq + (movl (:$l (:apply target-nil-value)) (:%l temp)) + (cmovel (:%l temp) (:%l dest)) + (je :done) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movl (:%l src) (:%l dest))) + (shll (:$ub (- x8664::charcode-shift x8664::fixnumshift)) (:%l dest)) + (addl (:$b x8664::subtag-character) (:%l dest)) + :done) + +;;; src is known to be a code for which CODE-CHAR returns non-nil. +(define-x8664-vinsn code-char->char (((dest :lisp)) + ((src :imm)) + ()) + ((:not (:pred = + (:apply %hard-regspec-value dest) + (:apply %hard-regspec-value src))) + (movl (:%l src) (:%l dest))) + (shll (:$ub (- x8664::charcode-shift x8664::fixnumshift)) (:%l dest)) + (addl (:$b x8664::subtag-character) (:%l dest)) + :done) + + +(define-x8664-vinsn sign-extend-halfword (((dest :imm)) + ((src :imm))) + (movq (:%q src ) (:%q dest)) + (shlq (:$ub (- 48 x8664::fixnumshift)) (:%q dest)) + (sarq (:$ub (- 48 x8664::fixnumshift)) (:%q dest))) + +(define-x8664-subprim-jump-vinsn (tail-funcall-gen) .SPtfuncallgen) + +(define-x8664-subprim-call-vinsn (gets64) .SPgets64) + +(define-x8664-subprim-call-vinsn (getu64) .SPgetu64) + +(define-x8664-vinsn %init-gvector (() + ((v :lisp) + (nbytes :u32const)) + ((count :imm))) + (movl (:$l nbytes) (:%l count)) + (jmp :test) + :loop + (popq (:@ x8664::misc-data-offset (:%q v) (:%q count))) + :test + (subq (:$b x8664::node-size) (:%q count)) + (jge :loop)) + +(define-x8664-subprim-jump-vinsn (tail-funcall-slide) .SPtfuncallslide) + +(define-x8664-vinsn nth-value (((result :lisp)) + () + ((imm0 :u64))) + (leaq (:@ (:%q x8664::rsp) (:%q x8664::nargs)) (:%q imm0)) + (subq (:@ (:%q imm0)) (:%q x8664::nargs)) + (movl (:$l (:apply target-nil-value)) (:%l result)) + (jle :done) + ;; I -think- that a CMOV would be safe here, assuming that N wasn't + ;; extremely large. Don't know if we can assume that. + (movq (:@ (- x8664::node-size) (:%q x8664::rsp) (:%q x8664::nargs)) (:%q result)) + :done + (leaq (:@ x8664::node-size (:%q imm0)) (:%q x8664::rsp))) + + +(define-x8664-subprim-lea-jmp-vinsn (req-heap-rest-arg) .SPreq-heap-rest-arg) + +(define-x8664-subprim-call-vinsn (stack-misc-alloc-init) .SPstack-misc-alloc-init) + +(define-x8664-vinsn fixnum->unsigned-natural (((dest :u64)) + ((src :imm))) + (movq (:%q src) (:%q dest)) + (shrq (:$ub x8664::fixnumshift) (:%q dest))) + +(define-x8664-vinsn %debug-trap (() + ()) + (uuo-error-debug-trap)) + +(define-x8664-vinsn double-to-single (((result :single-float)) + ((arg :double-float))) + (cvtsd2ss (:%xmm arg) (:%xmm result))) + +(define-x8664-vinsn single-to-double (((result :double-float)) + ((arg :single-float))) + (cvtss2sd (:%xmm arg) (:%xmm result))) + + +(define-x8664-vinsn alloc-c-frame (() + ((nwords :u32const))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + ((:pred < (:apply ash (:apply logandc2 (:apply + nwords 9) 1) x8664::word-shift) 128) + (subq (:$b (:apply ash (:apply logandc2 (:apply + nwords 9) 1) x8664::word-shift)) (:rcontext x8664::tcr.foreign-sp))) + ((:not (:pred < (:apply ash (:apply logandc2 (:apply + nwords 9) 1) x8664::word-shift) 128)) + (subq (:$l (:apply ash (:apply logandc2 (:apply + nwords 9) 1) x8664::word-shift)) (:rcontext x8664::tcr.foreign-sp))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0)))) + +(define-x8664-vinsn alloc-variable-c-frame (() + ((nwords :imm)) + ((size :s64))) + (leaq (:@ (* 9 x8664::node-size) (:%q nwords)) (:%q size)) + (andb (:$b (lognot x8664::fulltagmask)) (:%b size)) + + (movq (:rcontext x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) + (subq (:%q size) (:rcontext x8664::tcr.foreign-sp)) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0)))) + +(define-x8664-vinsn set-c-arg (() + ((arg :u64) + (offset :u32const))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movq (:%q arg) (:@ (:apply + 16 (:apply ash offset 3)) (:%q x8664::ra0)))) + +(define-x8664-vinsn set-single-c-arg (() + ((arg :single-float) + (offset :u32const))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movss (:%xmm arg) (:@ (:apply + 16 (:apply ash offset 3)) (:%q x8664::ra0)))) + +(define-x8664-vinsn reload-single-c-arg (((arg :single-float)) + ((offset :u32const))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movss (:@ (:apply + 16 (:apply ash offset 3)) (:%q x8664::ra0)) (:%xmm arg))) + +(define-x8664-vinsn set-double-c-arg (() + ((arg :double-float) + (offset :u32const))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movsd (:%xmm arg) (:@ (:apply + 16 (:apply ash offset 3)) (:%q x8664::ra0)))) + +(define-x8664-vinsn reload-double-c-arg (((arg :double-float)) + ((offset :u32const))) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (movsd (:@ (:apply + 16 (:apply ash offset 3)) (:%q x8664::ra0)) (:%xmm arg))) + +(define-x8664-subprim-call-vinsn (ff-call) .SPffcall) + +(define-x8664-subprim-call-vinsn (ff-call-return-registers) .SPffcall-return-registers) + +(define-x8664-subprim-call-vinsn (syscall) .SPsyscall) + +(define-x8664-subprim-call-vinsn (setqsym) .SPsetqsym) + +(define-x8664-vinsn recover-fn-from-rip (() + ()) + (leaq (:@ (:apply - (:^ :disp)) (:%q x8664::rip)) (:%q x8664::fn)) + :disp) + + + +(define-x8664-subprim-call-vinsn (makeu64) .SPmakeu64) + +(define-x8664-subprim-call-vinsn (makes64) .SPmakes64) + +(define-x8664-subprim-lea-jmp-vinsn (stack-cons-list*) .SPstkconslist-star) + +(define-x8664-subprim-lea-jmp-vinsn (list*) .SPconslist-star) + +(define-x8664-vinsn make-tsp-vcell (((dest :lisp)) + ((closed :lisp)) + ((temp :imm))) + (subq (:$b (+ x8664::value-cell.size x8664::dnode-size)) (:rcontext x8664::tcr.next-tsp)) + (movq (:rcontext x8664::tcr.save-tsp) (:%mmx x8664::stack-temp)) + (movq (:rcontext x8664::tcr.next-tsp) (:%q temp)) + (movapd (:%xmm x8664::fpzero) (:@ (:%q temp))) + (movapd (:%xmm x8664::fpzero) (:@ x8664::dnode-size (:%q temp))) + (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) + (movq (:%q temp) (:rcontext x8664::tcr.save-tsp)) + (movq (:$l x8664::value-cell-header) (:@ x8664::dnode-size (:%q temp))) + (movq (:%q closed) (:@ (+ x8664::dnode-size x8664::node-size) (:%q temp))) + (leaq (:@ (+ x8664::dnode-size x8664::fulltag-misc) (:%q temp)) (:%q dest))) + +(define-x8664-subprim-lea-jmp-vinsn (bind-nil) .SPbind-nil) + +(define-x8664-subprim-lea-jmp-vinsn (bind-self) .SPbind-self) + +(define-x8664-subprim-lea-jmp-vinsn (bind-self-boundp-check) .SPbind-self-boundp-check) + +(define-x8664-subprim-lea-jmp-vinsn (bind) .SPbind) + +(define-x8664-vinsn (dpayback :call :subprim-call) (() + ((n :s16const)) + ((temp (:u32 #.x8664::imm0)) + (entry (:label 1)))) + ((:pred > n 0) + ((:pred > n 1) + (movl (:$l n) (:%l temp)) + (:talign 4) + (call (:@ .SPunbind-n))) + ((:pred = n 1) + (:talign 4) + (call (:@ .SPunbind))) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)))) + +(define-x8664-subprim-jump-vinsn (tail-call-sym-gen) .SPtcallsymgen) + +(define-x8664-subprim-call-vinsn (make-stack-list) .Spmakestacklist) + +(define-x8664-vinsn node-slot-ref (((dest :lisp)) + ((node :lisp) + (cellno :u32const))) + (movq (:@ (:apply + x8664::misc-data-offset (:apply ash cellno 3)) + (:%q node)) (:%q dest))) + +(define-x8664-subprim-lea-jmp-vinsn (stack-cons-list) .SPstkconslist) + + +(define-x8664-vinsn %slot-ref (((dest :lisp)) + ((instance (:lisp (:ne dest))) + (index :lisp))) + (movq (:@ x8664::misc-data-offset (:%q instance) (:%q index)) (:%q dest)) + (cmpl (:$b x8664::slot-unbound-marker) (:%l dest)) + (je :bad) + :ok + (:anchored-uuo-section :ok) + :bad + (:anchored-uuo (uuo-error-slot-unbound (:%q dest) (:%q instance) (:%q index)))) + +(define-x8664-vinsn eep.address (((dest t)) + ((src (:lisp (:ne dest ))))) + (movq (:@ (+ (ash 1 x8664::word-shift) x8664::misc-data-offset) (:%q src)) + (:%q dest)) + (cmpb (:$b x8664::fulltag-nil) (:%b dest)) + (je :bad) + :ok + (:anchored-uuo-section :ok) + :bad + (:anchored-uuo (uuo-error-eep-unresolved (:%q src) (:%q dest)))) + + +(define-x8664-subprim-lea-jmp-vinsn (heap-cons-rest-arg) .SPheap-cons-rest-arg) + +(define-x8664-subprim-lea-jmp-vinsn (stack-cons-rest-arg) .SPstack-cons-rest-arg) + +(define-x8664-subprim-lea-jmp-vinsn (make-stack-vector) .SPmkstackv) + +(define-x8664-vinsn %current-frame-ptr (((dest :imm)) + ()) + (movq (:%q x8664::rbp) (:%q dest))) + +(define-x8664-vinsn %foreign-stack-pointer (((dest :imm)) + ()) + (movq (:rcontext x8664::tcr.foreign-sp) (:%q dest))) + + +(define-x8664-vinsn %set-scharcode8 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u64) + (imm1 :u64))) + (movq (:%q code) (:%q imm1)) + (movq (:%q idx) (:%q imm)) + (shrq (:$ub x8664::fixnumshift) (:%q imm1)) + (shrq (:$ub x8664::word-shift) (:%q imm)) + (movb (:%b imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm)))) + + +(define-x8664-vinsn %set-scharcode32 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u64) + (imm1 :u64))) + (movq (:%q code) (:%q imm1)) + (movq (:%q idx) (:%q imm)) + (shrq (:$ub x8664::fixnumshift) (:%q imm1)) + (shrq (:$ub 1) (:%q imm)) + (movl (:%l imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm)))) + + + + +(define-x8664-vinsn pop-argument-registers (() + ()) + (testl (:%l x8664::nargs) (:%l x8664::nargs)) + (je :done) + (rcmpl (:%l x8664::nargs) (:$b (ash 2 x8664::word-shift))) + (popq (:%q x8664::arg_z)) + (jb :done) + (popq (:%q x8664::arg_y)) + (je :done) + (popq (:%q x8664::arg_x)) + :done) + +(define-x8664-vinsn %symptr->symvector (((target :lisp)) + ((target :lisp))) + (subb (:$b (- x8664::fulltag-symbol x8664::fulltag-misc)) (:%b target))) + +(define-x8664-vinsn %symvector->symptr (((target :lisp)) + ((target :lisp))) + (addb (:$b (- x8664::fulltag-symbol x8664::fulltag-misc)) (:%b target))) + + +(define-x8664-subprim-lea-jmp-vinsn (spread-lexpr) .SPspread-lexpr-z) + +(define-x8664-vinsn mem-ref-double-float (((dest :double-float)) + ((src :address) + (index :s64))) + (movsd (:@ (:%q src) (:%q index)) (:%xmm dest))) + +(define-x8664-vinsn mem-ref-single-float (((dest :single-float)) + ((src :address) + (index :s64))) + (movss (:@ (:%q src) (:%q index)) (:%xmm dest))) + +(define-x8664-vinsn zero-extend-nargs (() + ()) + (movzwl (:%w x8664::nargs) (:%l x8664::nargs))) + +(define-x8664-vinsn load-adl (() + ((n :u32const))) + (movl (:$l n) (:%l x8664::nargs))) + +(define-x8664-subprim-lea-jmp-vinsn (macro-bind) .SPmacro-bind) + +(define-x8664-subprim-lea-jmp-vinsn (destructuring-bind-inner) .SPdestructuring-bind-inner) + +(define-x8664-subprim-lea-jmp-vinsn (destructuring-bind) .SPdestructuring-bind) + +(define-x8664-vinsn symbol-ref (((dest :lisp)) + ((src :lisp) + (cellno :u32const))) + (movq (:@ (:apply + (- x8664::node-size x8664::fulltag-symbol) + (:apply ash cellno 3)) + (:%q src)) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-bit-fixnum (((dest :lisp)) + ((src :address) + (offset :s32const)) + ((temp :u32))) + ((:pred = 0 (:apply ash offset -6)) + (btq (:$ub (:apply logand 63 offset)) + (:@ (:%q src)))) + ((:not (:pred = 0 (:apply ash offset -6))) + (btq (:$ub (:apply logand 63 offset)) + (:@ (:apply ash (:apply ash offset -6) 3) (:%q src)))) + (movl (:$l x8664::fixnumone) (:%l temp)) + (leaq (:@ (- x8664::fixnumone) (:%q temp)) (:%q dest)) + (cmovbl (:%l temp) (:%l dest))) + +(define-x8664-vinsn mem-ref-c-bit (((dest :lisp)) + ((src :address) + (offset :s32const)) + ((temp :u32))) + ((:pred = 0 (:apply ash offset -6)) + (btq (:$ub (:apply logand 63 offset)) + (:@ (:%q src)))) + ((:not (:pred = 0 (:apply ash offset -6))) + (btq (:$ub (:apply logand 63 offset)) + (:@ (:apply ash (:apply ash offset -6) 3) (:%q src)))) + (setb (:%b temp)) + (movzbl (:%b temp) (:%l dest))) + +(define-x8664-vinsn mem-ref-bit-fixnum (((dest :lisp) + (src :address)) + ((src :address) + (offset :lisp)) + ((temp :u32))) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub (+ 6 x8664::fixnumshift)) (:%q temp)) + (leaq (:@ (:%q src) (:%q temp) 8) (:%q src)) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub x8664::fixnumshift) (:%q temp)) + (andl (:$l 63) (:%l temp)) + (btq (:%q temp) (:@ (:%q src))) + (movl (:$l x8664::fixnumone) (:%l temp)) + (leaq (:@ (- x8664::fixnumone) (:%q temp)) (:%q dest)) + (cmovbl (:%l temp) (:%l dest))) + +(define-x8664-vinsn mem-ref-bit (((dest :lisp) + (src :address)) + ((src :address) + (offset :lisp)) + ((temp :u32))) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub (+ 6 x8664::fixnumshift)) (:%q temp)) + (leaq (:@ (:%q src) (:%q temp) 8) (:%q src)) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub x8664::fixnumshift) (:%q temp)) + (andl (:$l 63) (:%l temp)) + (btq (:%q temp) (:@ (:%q src))) + (setb (:%b temp)) + (movzbl (:%b temp) (:%l dest))) + + +(define-x8664-vinsn mem-set-c-bit-0 (() + ((src :address) + (offset :s32const))) + + ((:pred = 0 (:apply ash offset -6)) + (btrq (:$ub (:apply logand 63 offset)) + (:@ (:%q src)))) + ((:not (:pred = 0 (:apply ash offset -6))) + (btrq (:$ub (:apply logand 63 offset)) + (:@ (:apply ash (:apply ash offset -6) 3) (:%q src))))) + +(define-x8664-vinsn mem-set-c-bit-1 (() + ((src :address) + (offset :s32const))) + + ((:pred = 0 (:apply ash offset -6)) + (btsq (:$ub (:apply logand 63 offset)) + (:@ (:%q src)))) + ((:not (:pred = 0 (:apply ash offset -6))) + (btsq (:$ub (:apply logand 63 offset)) + (:@ (:apply ash (:apply ash offset -6) 3) (:%q src))))) + +(define-x8664-vinsn mem-set-c-bit-variable-value (() + ((src :address) + (offset :s32const) + (value :lisp))) + (testq (:%q value) (:%q value)) + (jne :set) + ((:pred = 0 (:apply ash offset -6)) + (btrq (:$ub (:apply logand 63 offset)) + (:@ (:%q src)))) + ((:not (:pred = 0 (:apply ash offset -6))) + (btrq (:$ub (:apply logand 63 offset)) + (:@ (:apply ash (:apply ash offset -6) 3) (:%q src)))) + (jmp :done) + :set + ((:pred = 0 (:apply ash offset -6)) + (btsq (:$ub (:apply logand 63 offset)) + (:@ (:%q src)))) + ((:not (:pred = 0 (:apply ash offset -6))) + (btsq (:$ub (:apply logand 63 offset)) + (:@ (:apply ash (:apply ash offset -6) 3) (:%q src)))) + :done) + + +(define-x8664-vinsn mem-set-bit-0 (((src :address)) + ((src :address) + (offset :lisp)) + ((temp :u32))) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub (+ 6 x8664::fixnumshift)) (:%q temp)) + (leaq (:@ (:%q src) (:%q temp) 8) (:%q src)) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub x8664::fixnumshift) (:%q temp)) + (andl (:$l 63) (:%l temp)) + (btrq (:%q temp) (:@ (:%q src)))) + +(define-x8664-vinsn mem-set-bit-1 (((src :address)) + ((src :address) + (offset :lisp)) + ((temp :u32))) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub (+ 6 x8664::fixnumshift)) (:%q temp)) + (leaq (:@ (:%q src) (:%q temp) 8) (:%q src)) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub x8664::fixnumshift) (:%q temp)) + (andl (:$l 63) (:%l temp)) + (btsq (:%q temp) (:@ (:%q src)))) + + +(define-x8664-vinsn mem-set-bit-variable-value (((src :address)) + ((src :address) + (offset :lisp) + (value :lisp)) + ((temp :u32))) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub (+ 6 x8664::fixnumshift)) (:%q temp)) + (leaq (:@ (:%q src) (:%q temp) 8) (:%q src)) + (movq (:%q offset) (:%q temp)) + (shrq (:$ub x8664::fixnumshift) (:%q temp)) + (andl (:$l 63) (:%l temp)) + (testq (:%q value) (:%q value)) + (jne :set) + (btrq (:%q temp) (:@ (:%q src))) + (jmp :done) + :set + (btsq (:%q temp) (:@ (:%q src))) + :done) + +(define-x8664-vinsn %natural+ (((result :u64)) + ((result :u64) + (other :u64))) + (addq (:%q other) (:%q result))) + +(define-x8664-vinsn %natural+-c (((result :u64)) + ((result :u64) + (constant :s32const))) + (addq (:$l constant) (:%q result))) + +(define-x8664-vinsn %natural- (((result :u64)) + ((result :u64) + (other :u64))) + (subq (:%q other) (:%q result))) + +(define-x8664-vinsn %natural--c (((result :u64)) + ((result :u64) + (constant :s32const))) + (subq (:$l constant) (:%q result))) + +(define-x8664-vinsn %natural-logior (((result :u64)) + ((result :u64) + (other :u64))) + (orq (:%q other) (:%q result))) + +(define-x8664-vinsn %natural-logior-c (((result :u64)) + ((result :u64) + (constant :s32const))) + (orq (:$l constant) (:%q result))) + +(define-x8664-vinsn %natural-logand (((result :u64)) + ((result :u64) + (other :u64))) + (andq (:%q other) (:%q result))) + +(define-x8664-vinsn %natural-logand-c (((result :u64)) + ((result :u64) + (constant :s32const))) + (andq (:$l constant) (:%q result))) + +(define-x8664-vinsn %natural-logxor (((result :u64)) + ((result :u64) + (other :u64))) + (xorq (:%q other) (:%q result))) + +(define-x8664-vinsn %natural-logxor-c (((result :u64)) + ((result :u64) + (constant :s32const))) + (xorq (:$l constant) (:%q result))) + +(define-x8664-vinsn natural-shift-left (((dest :u64)) + ((dest :u64) + (amt :u8const))) + (shlq (:$ub amt) (:%q dest))) + +(define-x8664-vinsn natural-shift-right (((dest :u64)) + ((dest :u64) + (amt :u8const))) + (shrq (:$ub amt) (:%q dest))) + +(define-x8664-vinsn trap-unless-simple-array-2 (() + ((object :lisp) + (expected-flags :u32const) + (type-error :u8const)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8664::subtag-arrayH) (:@ x8664::misc-subtag-offset (:%q object))) + (jne :bad) + (cmpq (:$b (ash 2 x8664::fixnumshift)) (:@ x8664::arrayH.rank (:%q object))) + (jne :bad) + (cmpq (:$l (:apply ash expected-flags x8664::fixnumshift)) (:@ x8664::arrayH.flags (:%q object))) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub type-error)))) + +(define-x8664-vinsn trap-unless-simple-array-3 (() + ((object :lisp) + (expected-flags :u32const) + (type-error :u8const)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :bad) + (cmpb (:$b x8664::subtag-arrayH) (:@ x8664::misc-subtag-offset (:%q object))) + (jne :bad) + (cmpq (:$b (ash 3 x8664::fixnumshift)) (:@ x8664::arrayH.rank (:%q object))) + (jne :bad) + (cmpq (:$l (:apply ash expected-flags x8664::fixnumshift)) (:@ x8664::arrayH.flags (:%q object))) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub type-error)))) + +(define-x8664-vinsn trap-unless-array-header (() + ((object :lisp)) + ((tag :u8))) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :trap) + (cmpb (:$b x8664::subtag-arrayH) (:@ x8664::misc-subtag-offset (:%q object))) + (jne :trap) + + (:anchored-uuo-section :again) + :trap + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-arrayH)))) + +(define-x8664-vinsn check-arrayH-rank (() + ((header :lisp) + (expected :u32const)) + ((rank :imm))) + :anchor + (movl (:$l (:apply ash expected x8664::fixnumshift)) (:%l rank)) + (cmpq (:@ x8664::arrayH.rank (:%q header)) (:%q rank)) + (jne :bad) + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-array-rank (:%q header) (:%q rank)))) + +(define-x8664-vinsn check-arrayH-flags (() + ((header :lisp) + (expected :u32const) + (type-error :u8const))) + :anchor + (cmpq (:$l (:apply ash expected x8664::fixnumshift)) + (:@ x8664::arrayH.flags (:%q header))) + (jne :bad) + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q header) (:$ub type-error)))) + +(define-x8664-vinsn misc-ref-c-u16 (((dest :u16)) + ((v :lisp) + (idx :u32const)) + ()) + (movzwl (:@ (:apply + x8664::misc-data-offset (:apply ash idx 1)) (:%q v)) (:%l dest))) + +(define-x8664-vinsn misc-ref-c-s16 (((dest :s16)) + ((v :lisp) + (idx :u32const)) + ()) + (movswq (:@ (:apply + x8664::misc-data-offset (:apply ash idx 1)) (:%q v)) (:%q dest))) + +(define-x8664-vinsn misc-set-single-float (() + ((val :single-float) + (v :lisp) + (scaled-idx :u32))) + (movss (:%xmm val) (:@ x8664::misc-data-offset (:% v) (:% scaled-idx)))) + +(define-x8664-vinsn u16->u32 (((dest :u32)) + ((src :u16))) + (movzwl (:%w src) (:%l dest))) + +(define-x8664-vinsn u8->u32 (((dest :u32)) + ((src :u8))) + (movzbl (:%b src) (:%l dest))) + + +(define-x8664-vinsn s16->s32 (((dest :s32)) + ((src :s16))) + (movswl (:%w src) (:%l dest))) + +(define-x8664-vinsn s8->s32 (((dest :s32)) + ((src :s8))) + (movsbl (:%b src) (:%l dest))) + +(define-x8664-subprim-jump-vinsn (tail-call-fn-gen) .SPtcallnfngen) + +(define-x8664-subprim-jump-vinsn (tail-call-fn-vsp) .SPtcallnfnvsp) + +(define-x8664-vinsn set-eq-bit (() + ()) + (testb (:%b x8664::arg_z) (:%b x8664::arg_z))) + +(define-x8664-vinsn %schar8 (((char :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32))) + (movq (:%q idx) (:%q imm)) + (shrq (:$ub x8664::fixnumshift) (:%q imm)) + (movzbl (:@ x8664::misc-data-offset (:%q str) (:%q imm)) (:%l imm)) + (shll (:$ub x8664::charcode-shift) (:%l imm)) + (leaq (:@ x8664::subtag-character (:%q imm)) (:%q char))) + +(define-x8664-vinsn %schar32 (((char :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32))) + (movq (:%q idx) (:%q imm)) + (shrq (:$ub 1) (:%q imm)) + (movl (:@ x8664::misc-data-offset (:%q str) (:%q imm)) (:%l imm)) + (shll (:$ub x8664::charcode-shift) (:%l imm)) + (leaq (:@ x8664::subtag-character (:%q imm)) (:%q char))) + + +(define-x8664-vinsn %set-schar8 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm0 :u64) + (imm1 :u64))) + (movq (:%q idx) (:%q imm0)) + (movl (:%l char) (:%l imm1)) + (shrq (:$ub x8664::fixnumshift) (:%q imm0)) + (shrl (:$ub x8664::charcode-shift) (:%l imm1)) + (movb (:%b imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm0)))) + +(define-x8664-vinsn %set-schar32 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm0 :u64) + (imm1 :u64))) + (movq (:%q idx) (:%q imm0)) + (movl (:%l char) (:%l imm1)) + (shrq (:$ub 1) (:%q imm0)) + (shrl (:$ub x8664::charcode-shift) (:%l imm1)) + (movl (:%l imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm0)))) + +(define-x8664-vinsn misc-set-c-single-float (((val :single-float)) + ((v :lisp) + (idx :u32const))) + (movss (:%xmm val) (:@ (:apply + x8664::misc-data-offset (:apply ash idx 2)) (:%q v)))) + +(define-x8664-vinsn array-data-vector-ref (((dest :lisp)) + ((header :lisp))) + (movq (:@ x8664::arrayH.data-vector (:%q header)) (:%q dest))) + +(define-x8664-subprim-call-vinsn (subtag-misc-ref) .SPsubtag-misc-ref) + +(define-x8664-subprim-call-vinsn (subtag-misc-set) .SPsubtag-misc-set) + +(define-x8664-vinsn mem-ref-c-absolute-u8 (((dest :u8)) + ((addr :s32const))) + (movzbl (:@ addr) (:%l dest))) + +(define-x8664-vinsn mem-ref-c-absolute-s8 (((dest :s8)) + ((addr :s32const))) + (movsbq (:@ addr) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-absolute-u16 (((dest :u16)) + ((addr :s32const))) + (movzwl (:@ addr) (:%l dest))) + +(define-x8664-vinsn mem-ref-c-absolute-s16 (((dest :s16)) + ((addr :s32const))) + (movswq (:@ addr) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-absolute-fullword (((dest :u32)) + ((addr :s32const))) + (movl (:@ addr) (:%l dest))) + +(define-x8664-vinsn mem-ref-c-absolute-signed-fullword (((dest :s32)) + ((addr :s32const))) + (movslq (:@ addr) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-absolute-doubleword (((dest :s64)) + ((addr :s32const))) + (movq (:@ addr) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-absolute-signed-doubleword (((dest :s64)) + ((addr :s32const))) + (movq (:@ addr) (:%q dest))) + +(define-x8664-vinsn mem-ref-c-absolute-natural (((dest :u64)) + ((addr :s32const))) + (movq (:@ addr) (:%q dest))) + +(define-x8664-vinsn event-poll (() + ()) + (btrq (:$ub 63) (:rcontext x8664::tcr.interrupt-pending)) + (jae :no-interrupt) + (ud2a) + (:byte 2) + :no-interrupt) + +;;; Return dim1 (unboxed) +(define-x8664-vinsn check-2d-bound (((dim :u64)) + ((i :imm) + (j :imm) + (header :lisp))) + :anchor + (cmpq (:@ (+ x8664::misc-data-offset (* 8 x8664::arrayH.dim0-cell)) (:%q header)) (:%q i)) + (jae :bad-i) + (movq (:@ (+ x8664::misc-data-offset (* 8 (1+ x8664::arrayH.dim0-cell))) (:%q header)) + (:%q dim)) + (cmpq (:%q dim) (:%q j)) + (jae :bad-j) + (sarq (:$ub x8664::fixnumshift) (:%q dim)) + (:anchored-uuo-section :anchor) + :bad-i + (:anchored-uuo (uuo-error-array-bounds (:%q i) (:%q header))) + (:anchored-uuo-section :anchor) + :bad-j + (:anchored-uuo (uuo-error-array-bounds (:%q j) (:%q header)))) + +;;; Return dim1, dim2 (unboxed) +(define-x8664-vinsn check-3d-bound (((dim1 :u64) + (dim2 :u64)) + ((i :imm) + (j :imm) + (k :imm) + (header :lisp))) + :anchor + (cmpq (:@ (+ x8664::misc-data-offset (* 8 x8664::arrayH.dim0-cell)) (:%q header)) (:%q i)) + (jae :bad-i) + (movq (:@ (+ x8664::misc-data-offset (* 8 (1+ x8664::arrayH.dim0-cell))) (:%q header)) (:%q dim1)) + (cmpq (:%q dim1) (:%q j)) + (jae :bad-j) + (sarq (:$ub x8664::fixnumshift) (:%q dim1)) + (movq (:@ (+ x8664::misc-data-offset (* 8 (+ 2 x8664::arrayH.dim0-cell))) (:%q header)) (:%q dim2)) + (cmpq (:%q dim2) (:%q k)) + (jae :bad-k) + (sarq (:$ub x8664::fixnumshift) (:%q dim2)) + (:anchored-uuo-section :anchor) + :bad-i + (:anchored-uuo (uuo-error-array-bounds (:%q i) (:%q header))) + (:anchored-uuo-section :anchor) + :bad-j + (:anchored-uuo (uuo-error-array-bounds (:%q j) (:%q header))) + (:anchored-uuo-section :anchor) + :bad-k + (:anchored-uuo (uuo-error-array-bounds (:%q k) (:%q header))) + ) + + +(define-x8664-vinsn 2d-dim1 (((dest :u64)) + ((header :lisp))) + (movq (:@ (+ x8664::misc-data-offset (* 8 (1+ x8664::arrayH.dim0-cell))) (:%q header)) + (:%q dest)) + (sarq (:$ub x8664::fixnumshift) (:%q dest))) + + +(define-x8664-vinsn 3d-dims (((dim1 :u64) + (dim2 :u64)) + ((header :lisp))) + (movq (:@ (+ x8664::misc-data-offset (* 8 (1+ x8664::arrayH.dim0-cell))) (:%q header)) (:%q dim1)) + (movq (:@ (+ x8664::misc-data-offset (* 8 (+ 2 x8664::arrayH.dim0-cell))) (:%q header)) (:%q dim2)) + (sarq (:$ub x8664::fixnumshift) (:%q dim1)) + (sarq (:$ub x8664::fixnumshift) (:%q dim2))) + +(define-x8664-vinsn 2d-unscaled-index (((dest :imm) + (dim1 :u64)) + ((dim1 :u64) + (i :imm) + (j :imm))) + + (imulq (:%q i) (:%q dim1)) + (leaq (:@ (:%q j) (:%q dim1)) (:%q dest))) + + +;; dest <- (+ (* i dim1 dim2) (* j dim2) k) +(define-x8664-vinsn 3d-unscaled-index (((dest :imm) + (dim1 :u64) + (dim2 :u64)) + ((dim1 :u64) + (dim2 :u64) + (i :imm) + (j :imm) + (k :imm))) + (imulq (:%q dim2) (:%q dim1)) + (imulq (:%q j) (:%q dim2)) + (imulq (:%q i) (:%q dim1)) + (addq (:%q dim1) (:%q dim2)) + (leaq (:@ (:%q k) (:%q dim2)) (:%q dest))) + +(define-x8664-vinsn branch-unless-both-args-fixnums (() + ((a :lisp) + (b :lisp) + (dest :label)) + ((tag :u8))) + (movl (:%l a) (:%l tag)) + (orl (:%l b) (:%l tag)) + (testb (:$b x8664::fixnummask) (:%b tag)) + (jne dest)) + +(define-x8664-vinsn branch-unless-arg-fixnum (() + ((a :lisp) + (dest :label))) + (testb (:$b x8664::fixnummask) (:%b a)) + (jne dest)) + +(define-x8664-vinsn fixnum->single-float (((f :single-float)) + ((arg :lisp)) + ((unboxed :s64))) + (movq (:%q arg) (:%q unboxed)) + (sarq (:$ub x8664::fixnumshift) (:%q unboxed)) + (cvtsi2ssq (:%q unboxed) (:%xmm f))) + +(define-x8664-vinsn fixnum->double-float (((f :double-float)) + ((arg :lisp)) + ((unboxed :s64))) + (movq (:%q arg) (:%q unboxed)) + (sarq (:$ub x8664::fixnumshift) (:%q unboxed)) + (cvtsi2sdq (:%q unboxed) (:%xmm f))) + + +(define-x8664-vinsn xchg-registers (() + ((a t) + (b t))) + (xchgq (:%q a) (:%q b))) + +(define-x8664-vinsn establish-fn (() + () + ((entry (:label 1)))) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + +(define-x8664-vinsn align-loop-head (() + () + ())) + +(queue-fixup + (fixup-x86-vinsn-templates + *x8664-vinsn-templates* + x86::*x86-opcode-template-lists* *x8664-backend*)) + +(provide "X8664-VINSNS") + Index: /branches/qres/ccl/compiler/X86/x86-arch.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/x86-arch.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/x86-arch.lisp (revision 13564) @@ -0,0 +1,203 @@ +;;;-*- Mode: Lisp; Package: (X86 :use CL) -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage "X86" + (:use "CL")) + +(in-package "X86") + +(require "ARCH") + +;;; Kernel globals are allocated "below" nil. This list (used to map +;;; symbolic names to rnil-relative offsets) must (of course) exactly +;;; match the kernel's notion of where things are. +;;; The order here matches "ccl:lisp-kernel;lisp_globals.h" & the +;;; lisp_globals record in "ccl:lisp-kernel;constants.s" +(defparameter *x86-kernel-globals* + '(get-tcr ; callback to obtain (real) tcr + tcr-count + interrupt-signal ; used by PROCESS-INTERRUPT + kernel-imports ; some things we need to have imported for us. + objc-2-personality + emulator-registers ; Where the 68K registers are kept. + appmain ; application's (c-runtime) main() function + subprims-base ; start of dynamic subprims jump table + ret1valaddr ; magic multiple-values return address. + tcr-key ; tsd key for thread's tcr + area-lock ; serialize access to gc + exception-lock ; serialize exception handling + static-conses ; when FREEZE is in effect + default-allocation-quantum ; log2_heap_segment_size, as a fixnum. + intflag ; interrupt-pending flag + gc-inhibit-count ; for gc locking + refbits ; oldspace refbits + oldspace-dnode-count ; number of dnodes in dynamic space that are older than + ; youngest generation + altivec-present ; non-zero if cpu supports AltiVec + fwdnum ; fixnum: GC "forwarder" call count. + gc-count ; fixnum: GC call count. + gcable-pointers ; linked-list of weak macptrs. + heap-start ; start of lisp heap + heap-end ; end of lisp heap + statically-linked ; true if the lisp kernel is statically linked + stack-size ; value of --stack-size arg + objc-2-begin-catch ; objc_begin_catch + kernel-path + all-areas ; doubly-linked area list + lexpr-return ; multiple-value lexpr return address + lexpr-return1v ; single-value lexpr return address + in-gc ; non-zero when GC-ish thing active + metering-info ; kernel metering structure + objc-2-end-catch ; _objc_end_catch + short-float-zero ; low half of 1.0d0 + double-float-one ; high half of 1.0d0 + ffi-exception ; ffi fpscr[fex] bit + exception-saved-registers ; saved registers from exception frame + oldest-ephemeral ; doublenode address of oldest ephemeral object or 0 + tenured-area ; the tenured_area. + errno ; address of C lib errno + argv ; address of C lib argv + host-platform ; 0 on MacOS, 1 on PPC Linux, 2 on VxWorks ... + batch-flag ; non-zero if --batch specified + unwind-resume ; _Unwind_Resume + weak-gc-method ; weak gc algorithm. + image-name ; current image name + initial-tcr ; initial thread's context record + weakvll ; all populations as of last GC + )) + +;;; The order here matches "ccl:lisp-kernel;lisp_globals.h" and the nrs record +;;; in "ccl:lisp-kernel;constants.s". +(defparameter *x86-nil-relative-symbols* + '(t + nil + ccl::%err-disp + ccl::cmain + eval + ccl::apply-evaluated-function + error + ccl::%defun + ccl::%defvar + ccl::%defconstant + ccl::%macro + ccl::%kernel-restart + *package* + ccl::*total-bytes-freed* + :allow-other-keys + ccl::%toplevel-catch% + ccl::%toplevel-function% + ccl::%pascal-functions% + ccl::*all-metered-functions* + ccl::*total-gc-microseconds* + ccl::%builtin-functions% + ccl::%unbound-function% + ccl::%init-misc + ccl::%macro-code% + ccl::%closure-code% + ccl::%new-gcable-ptr + ccl::*gc-event-status-bits* + ccl::*post-gc-hook* + ccl::%handlers% + ccl::%all-packages% + ccl::*keyword-package* + ccl::%finalization-alist% + ccl::%foreign-thread-control + )) + +;;; Old (and slightly confusing) name; NIL used to be in a register. +(defparameter *x86-nilreg-relative-symbols* *x86-nil-relative-symbols*) + + +;;; mxcsr bits. (Unlike the convention used on the PPC, bit 0 is the +;;; least significant bit of the containing byte/word.) + +(ccl::defenum (:prefix "MXCSR-" :suffix "-BIT") + ie ;invalid exception + de ;denormal exception + ze ;divide-by-zero exception + oe ;overflow exception + ue ;underflow exception + pe ;precision exception + daz ;denorms-are-zeros (not-IEEE) + im ;invalid masked + dm ;denormals masked + zm ;divide-by-zero masked + om ;overflow masked + um ;underflow masked + pm ;precision masked + rc0 ;rounding control bit 0 + rc1 ;rounding control bit 1 + fz ;flush-to-zero (not-IEEE) +) + +(defconstant mxcsr-status-mask + (logior (ash 1 mxcsr-ie-bit) + (ash 1 mxcsr-de-bit) + (ash 1 mxcsr-ze-bit) + (ash 1 mxcsr-oe-bit) + (ash 1 mxcsr-ue-bit) + (ash 1 mxcsr-pe-bit))) + +(defconstant mxcsr-control-and-rounding-mask + (logior (ash 1 mxcsr-im-bit) + (ash 1 mxcsr-dm-bit) + (ash 1 mxcsr-zm-bit) + (ash 1 mxcsr-om-bit) + (ash 1 mxcsr-um-bit) + (ash 1 mxcsr-pm-bit) + (ash 1 mxcsr-rc0-bit) + (ash 1 mxcsr-rc1-bit))) + +;;; There's a fairly hairy method of determining which MXCSR bits are +;;; available on a given proccessor version. In practice, the bits +;;; that might not be supported are bits that select non-IEE754-compliant +;;; behavior (DenormsAreZeros and FlushtoZerop), and we don't really +;;; want to activate either of those things, anyway. + +(defconstant mxcsr-write-mask (lognot (logior (ash 1 mxcsr-daz-bit) + (ash 1 mxcsr-fz-bit)))) + + + +;;; Condition bitfields, used in jcc, cmovcc, setcc. +(defconstant x86-o-bits #x0) +(defconstant x86-no-bit #x1) +(defconstant x86-b-bits #x2) +(defconstant x86-ae-bits #x3) +(defconstant x86-e-bits #x4) +(defconstant x86-ne-bits #x5) +(defconstant x86-be-bits #x6) +(defconstant x86-a-bits #x7) +(defconstant x86-s-bits #x8) +(defconstant x86-ns-bits #x9) +(defconstant x86-pe-bits #xa) +(defconstant x86-po-bits #xb) +(defconstant x86-l-bits #xc) +(defconstant x86-ge-bits #xd) +(defconstant x86-le-bits #xe) +(defconstant x86-g-bits #xf) + +;;; Bits in the xFLAGS register +(defconstant x86-carry-flag-bit 0) +(defconstant x86-parity-flag-bit 2) +(defconstant x86-aux-carry-flag-bit 4) +(defconstant x86-zero-flag-bit 6) +(defconstant x86-sign-flag-bit 7) +(defconstant x86-direction-flag-bit 10) +(defconstant x86-overflow-flag-bit 11) + + +(provide "X86-ARCH") Index: /branches/qres/ccl/compiler/X86/x86-asm.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/x86-asm.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/x86-asm.lisp (revision 13564) @@ -0,0 +1,4851 @@ +;;;-*- Mode: Lisp; Package: (X86 :use CL) -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(eval-when (:compile-toplevel :load-toplevel :execute) +(require "X86-ARCH") +) + +(in-package "X86") + +(defconstant +MAX-OPERANDS+ 3) ; max operands per insn +(defconstant +MAX-IMMEDIATE-OPERANDS+ 2) ; max immediates per insn (lcall ljmp) +(defconstant +MAX-MEMORY-OPERANDS+ 2) ; max memory refs per insn (string ops) + +;;; Prefixes will be emitted in the order defined below. +;;; WAIT-PREFIX must be the first prefix since FWAIT is really is an +;;; instruction and so must come before any prefixes. + +(defconstant +WAIT-PREFIX+ 0) +(defconstant +LOCKREP-PREFIX+ 1) +(defconstant +ADDR-PREFIX+ 2) +(defconstant +DATA-PREFIX+ 3) +(defconstant +SEG-PREFIX+ 4) +(defconstant +REX-PREFIX+ 5) ; must come last. +(defconstant +MAX-PREFIXES+ 6) ; max prefixes per opcode + +;;; we define the syntax here (modulo base index scale syntax) +(defconstant +REGISTER-PREFIX+ #\%) +(defconstant +IMMEDIATE-PREFIX+ #\$) +(defconstant +ABSOLUTE-PREFIX+ #\*) + +(defconstant +TWO-BYTE-OPCODE-ESCAPE+ #x0f) +(defconstant +NOP-OPCODE+ #x90) + +;;; register numbers +(defconstant +EBP-REG-NUM+ 5) +(defconstant +ESP-REG-NUM+ 4) + +;;; modrm-byte.regmem for twobyte escape +(defconstant +ESCAPE-TO-TWO-BYTE-ADDRESSING+ +ESP-REG-NUM+) +;;; index-base-byte.index for no index register addressing +(defconstant +NO-INDEX-REGISTER+ +ESP-REG-NUM+) +;;; index-base-byte.base for no base register addressing +(defconstant +NO-BASE-REGISTER+ +EBP-REG-NUM+) +(defconstant +NO-BASE-REGISTER-16+ 6) + +;;; these are the instruction mnemonic suffixes. +(defconstant +WORD-MNEM-SUFFIX+ #\w) +(defconstant +BYTE-MNEM-SUFFIX+ #\b) +(defconstant +SHORT-MNEM-SUFFIX+ #\s) +(defconstant +LONG-MNEM-SUFFIX+ #\l) +(defconstant +QWORD-MNEM-SUFFIX+ #\q) +(defconstant +LONG-DOUBLE-MNEM-SUFFIX+ #\x) + +;;; modrm.mode = REGMEM-FIELD-HAS-REG when a register is in there +(defconstant +REGMEM-FIELD-HAS-REG+ #x3) ; always = #x3 +(defconstant +REGMEM-FIELD-HAS-MEM+ (lognot +REGMEM-FIELD-HAS-REG+)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +;;; By default, this returns NIL if the modifier can't be encoded. +;;; That's an error, but the caller can provide better error context. + +;;; first 16 bits for opcode modifier flags, rest for cpu +;;; features. +(defparameter *opcode-flags* + `((:jump . ,(ash 1 0)) ;special case for jump insns + (:CpuNo64 . ,(ash 1 16)) ;not supported in 64 bit mode + (:Cpu64 . ,(ash 1 17)) ;64 bit mode required + (:CpuSSE . ,(ash 1 18)) ;SSE extensions required + (:CpuSSE2 . ,(ash 1 19)) ;SSE2 extensions required + (:CpuSSE3 . ,(ash 1 20)) ;SSE3 extensions required +)) + +(defun %encode-opcode-flags (flags &optional errorp) + (flet ((encode-atomic-flag (f) + (if f + (cdr (assoc f *opcode-flags*)) + 0))) + (or + (if (atom flags) + (encode-atomic-flag flags) + (let* ((k 0)) + (dolist (f flags k) + (let* ((k0 (encode-atomic-flag f))) + (if k0 + (setq k (logior k0 k)) + (return)))))) + (if errorp (error "Unknown x86 opcode flags: ~s" flags))))) + +) + +(defmacro encode-opcode-flags (&rest flags) + (%encode-opcode-flags flags t)) + +;;; operand-types[i] bits +;;; register +(defconstant +operand-type-Reg8+ #x1) ; 8 bit reg +(defconstant +operand-type-Reg16+ #x2) ; 16 bit reg +(defconstant +operand-type-Reg32+ #x4) ; 32 bit reg +(defconstant +operand-type-Reg64+ #x8) ; 64 bit reg +;;; immediate +(defconstant +operand-type-Imm8+ #x10) ; 8 bit immediate +(defconstant +operand-type-Imm8S+ #x20) ; 8 bit immediate sign extended +(defconstant +operand-type-Imm16+ #x40) ; 16 bit immediate +(defconstant +operand-type-Imm32+ #x80) ; 32 bit immediate +(defconstant +operand-type-Imm32S+ #x100) ; 32 bit immediate sign extended +(defconstant +operand-type-Imm64+ #x200) ; 64 bit immediate +(defconstant +operand-type-Imm1+ #x400) ; 1 bit immediate +;;; memory +(defconstant +operand-type-BaseIndex+ #x800) +;;; Disp8 16 32 are used in different ways depending on the +;;; instruction. For jumps they specify the size of the PC relative +;;; displacement for baseindex type instructions they specify the +;;; size of the offset relative to the base register and for memory +;;; offset instructions such as `mov 1234 %al' they specify the size of +;;; the offset relative to the segment base. +(defconstant +operand-type-Disp8+ #x1000) ; 8 bit displacement +(defconstant +operand-type-Disp16+ #x2000) ; 16 bit displacement +(defconstant +operand-type-Disp32+ #x4000) ; 32 bit displacement +(defconstant +operand-type-Disp32S+ #x8000) ; 32 bit signed displacement +(defconstant +operand-type-Disp64+ #x10000) ; 64 bit displacement +;;; specials +(defconstant +operand-type-InOutPortReg+ #x20000) ; register to hold in/out port addr = dx +(defconstant +operand-type-ShiftCount+ #x40000) ; register to hold shift cound = cl +(defconstant +operand-type-Control+ #x80000) ; Control register +(defconstant +operand-type-Debug+ #x100000) ; Debug register +(defconstant +operand-type-Test+ #x200000) ; Test register +(defconstant +operand-type-FloatReg+ #x400000) ; Float register +(defconstant +operand-type-FloatAcc+ #x800000) ; Float stack top %st(0) +(defconstant +operand-type-SReg2+ #x1000000) ; 2 bit segment register +(defconstant +operand-type-SReg3+ #x2000000) ; 3 bit segment register +(defconstant +operand-type-Acc+ #x4000000) ; Accumulator %al or %ax or %eax +(defconstant +operand-type-JumpAbsolute+ #x8000000) +(defconstant +operand-type-RegMMX+ #x10000000) ; MMX register +(defconstant +operand-type-RegXMM+ #x20000000) ; XMM registers in PIII +(defconstant +operand-type-EsSeg+ #x40000000) ; String insn operand with fixed es segment + +;;; InvMem is for instructions with a modrm byte that only allow a +;;; general register encoding in the i.tm.mode and i.tm.regmem fields +;;; eg. control reg moves. They really ought to support a memory form +;;; but don't so we add an InvMem flag to the register operand to +;;; indicate that it should be encoded in the i.tm.regmem field. +(defconstant +operand-type-InvMem+ #x80000000) +(defconstant +operand-type-Label+ #x100000000) + +;;; 4 bytes and a :reloc; otherwise just like a 32-bit immediate +(defconstant +operand-type-Self+ #x200000000) + +(defconstant +operand-type-Reg+ (logior +operand-type-Reg8+ +operand-type-Reg16+ +operand-type-Reg32+ +operand-type-Reg64+)) ; gen'l register +(defconstant +operand-type-WordReg+ (logior +operand-type-Reg16+ +operand-type-Reg32+ +operand-type-Reg64+)) +(defconstant +operand-type-ImplicitRegister+ (logior +operand-type-InOutPortReg+ +operand-type-ShiftCount+ +operand-type-Acc+ +operand-type-FloatAcc+)) +(defconstant +operand-type-Imm+ (logior +operand-type-Imm8+ +operand-type-Imm8S+ +operand-type-Imm16+ +operand-type-Imm32S+ +operand-type-Imm32+ +operand-type-Imm64+)) ; gen'l immediate +(defconstant +operand-type-EncImm+ (logior +operand-type-Imm8+ +operand-type-Imm16+ +operand-type-Imm32+ +operand-type-Imm32S+)) ; Encodable gen'l immediate +(defconstant +operand-type-Disp+ (logior +operand-type-Disp8+ +operand-type-Disp16+ +operand-type-Disp32+ +operand-type-Disp32S+ +operand-type-Disp64+)) ; General displacement +(defconstant +operand-type-AnyMem+ (logior +operand-type-Disp8+ +operand-type-Disp16+ +operand-type-Disp32+ +operand-type-Disp32S+ +operand-type-BaseIndex+ +operand-type-InvMem+)) ; General memory +;;; The following aliases are defined because the opcode table +;;; carefully specifies the allowed memory types for each instruction. +;;; At the moment we can only tell a memory reference size by the +;;; instruction suffix so there's not much point in defining Mem8 +;;; Mem16 Mem32 and Mem64 opcode modifiers - We might as well just use +;;; the suffix directly to check memory operands. +(defconstant +operand-type-LLongMem+ +operand-type-AnyMem+); 64 bits (or more) +(defconstant +operand-type-LongMem+ +operand-type-AnyMem+) ; 32 bit memory ref +(defconstant +operand-type-ShortMem+ +operand-type-AnyMem+) ; 16 bit memory ref +(defconstant +operand-type-WordMem+ +operand-type-AnyMem+) ; 16 or 32 bit memory ref +(defconstant +operand-type-ByteMem+ +operand-type-AnyMem+) ; 8 bit memory ref + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defparameter *x86-operand-type-names* + `((:Reg8 . ,+operand-type-Reg8+) + (:Reg16 . ,+operand-type-Reg16+) + (:Reg32 . ,+operand-type-Reg32+) + (:Reg64 . ,+operand-type-Reg64+) + (:Imm8 . ,+operand-type-Imm8+) + (:Imm8S . ,+operand-type-Imm8S+) + (:Imm16 . ,+operand-type-Imm16+) + (:Imm32 . ,+operand-type-Imm32+) + (:Imm32S . ,+operand-type-Imm32S+) + (:Imm64 . ,+operand-type-Imm64+) + (:Imm1 . ,+operand-type-Imm1+) + (:BaseIndex . ,+operand-type-BaseIndex+) + (:Disp8 . ,+operand-type-Disp8+) + (:Disp16 . ,+operand-type-Disp16+) + (:Disp32 . ,+operand-type-Disp32+) + (:Disp32S . ,+operand-type-Disp32S+) + (:Disp64 . ,+operand-type-Disp64+) + (:InOutPortReg . ,+operand-type-InOutPortReg+) + (:ShiftCount . ,+operand-type-ShiftCount+) + (:Control . ,+operand-type-Control+) + (:Debug . ,+operand-type-Debug+) + (:Test . ,+operand-type-Test+) + (:FloatReg . ,+operand-type-FloatReg+) + (:FloatAcc . ,+operand-type-FloatAcc+) + (:SReg2 . ,+operand-type-SReg2+) + (:SReg3 . ,+operand-type-SReg3+) + (:Acc . ,+operand-type-Acc+) + (:JumpAbsolute . ,+operand-type-JumpAbsolute+) + (:RegMMX . ,+operand-type-RegMMX+) + (:RegXMM . ,+operand-type-RegXMM+) + (:EsSeg . ,+operand-type-EsSeg+) + (:InvMem . ,+operand-type-InvMem+) + (:Reg . ,+operand-type-Reg+) + (:WordReg . ,+operand-type-WordReg+) + (:ImplicitRegister . ,+operand-type-ImplicitRegister+) + (:Imm . ,+operand-type-Imm+) + (:EncImm . ,+operand-type-EncImm+) + (:Disp . ,+operand-type-Disp+) + (:AnyMem . ,+operand-type-AnyMem+) + (:LLongMem . ,+operand-type-LLongMem+) + (:LongMem . ,+operand-type-LongMem+) + (:ShortMem . ,+operand-type-ShortMem+) + (:WordMem . ,+operand-type-WordMem+) + (:ByteMem . ,+operand-type-ByteMem+) + (:Label . ,+operand-type-Label+) + (:Self . ,+operand-type-Self+) + )) + +(defun %encode-operand-type (optype &optional errorp) + (flet ((encode-atomic-operand-type (op) + (if op + (cdr (assoc op *x86-operand-type-names* :test #'eq)) + 0))) + (or + (if (atom optype) + (encode-atomic-operand-type optype) + (let* ((k 0)) + (dolist (op optype k) + (let* ((k0 (encode-atomic-operand-type op))) + (if k0 + (setq k (logior k k0)) + (return)))))) + (if errorp (error "Unknown x86 operand type ~s" optype))))) +) + +(defmacro encode-operand-type (&rest op) + (%encode-operand-type op t)) + + + + + +(defconstant +RegRex+ #x1) ; Extended register. +(defconstant +RegRex64+ #x2) ; Extended 8 bit register. + +(eval-when (:compile-toplevel :load-toplevel :execute) +;;; these are for register name --> number & type hash lookup +(defstruct reg-entry + reg-name + reg-type + reg-flags + reg-num ; for encoding in instruction fields + ordinal64 ; canonical, ordinal register number + ordinal32 +) + +(defmethod make-load-form ((r reg-entry) &optional env) + (declare (ignore env)) + (make-load-form-saving-slots r)) + +(defstruct seg-entry + seg-name + seg-prefix +) + +) + + +(defstruct modrm-byte + regmem ; codes register or memory operand + reg ; codes register operand (or extended opcode) + mode ; how to interpret regmem & reg +) + +;;; x86-64 extension prefix. +;; typedef int rex-byte +(defconstant +REX-OPCODE+ #x40) + +;;; Indicates 64 bit operand size. +(defconstant +REX-MODE64+ 8) +;;; High extension to reg field of modrm byte. +(defconstant +REX-EXTX+ 4) +;;; High extension to SIB index field. +(defconstant +REX-EXTY+ 2) +;;; High extension to base field of modrm or SIB or reg field of opcode. +(defconstant +REX-EXTZ+ 1) + +;;; 386 opcode byte to code indirect addressing. +(defstruct sib-byte + base + index + scale +) + + +;;; x86 arch names and features +(defstruct arch-entry + name ; arch name + flags ; cpu feature flags +) + + +;;; The SystemV/386 SVR3.2 assembler and probably all AT&T derived +;;; ix86 Unix assemblers generate floating point instructions with +;;; reversed source and destination registers in certain cases. +;;; Unfortunately gcc and possibly many other programs use this +;;; reversed syntax so we're stuck with it. +;;; +;;; eg. `fsub %st(3) %st' results in st = st - st(3) as expected but +;;;`fsub %st %st(3)' results in st(3) = st - st(3) rather than +;;; the expected st(3) = st(3) - st +;;; +;;; This happens with all the non-commutative arithmetic floating point +;;; operations with two register operands where the source register is +;;; %st and destination register is %st(i). See FloatDR below. +;;; +;;; The affected opcode map is dceX dcfX deeX defX. + +(defconstant +MOV-AX-DISP32+ #xa0) +(defconstant +POP-SEG-SHORT+ #x07) +(defconstant +JUMP-PC-RELATIVE+ #xe9) +(defconstant +INT-OPCODE+ #xcd) +(defconstant +INT3-OPCODE+ #xcc) +(defconstant +FWAIT-OPCODE+ #x9b) +(defconstant +ADDR-PREFIX-OPCODE+ #x67) +(defconstant +DATA-PREFIX-OPCODE+ #x66) +(defconstant +LOCK-PREFIX-OPCODE+ #xf0) +(defconstant +CS-PREFIX-OPCODE+ #x2e) +(defconstant +DS-PREFIX-OPCODE+ #x3e) +(defconstant +ES-PREFIX-OPCODE+ #x26) +(defconstant +FS-PREFIX-OPCODE+ #x64) +(defconstant +GS-PREFIX-OPCODE+ #x65) +(defconstant +SS-PREFIX-OPCODE+ #x36) +(defconstant +REPNE-PREFIX-OPCODE+ #xf2) +(defconstant +REPE-PREFIX-OPCODE+ #xf3) + + +(defstruct (x86-opcode-template (:constructor %make-x86-opcode-template)) + mnemonic ; fully qualified, includes suffix if applicable + flags ; opcode modifier and cpu type flags + ordinal ; unique id + operand-types ; as specific as possible + operand-classes ; describe how to insert operands in base op, modrm + prefixes ; list of 0 or more explicit prefixes + base-opcode ; 1-3 bytes + rex-prefix ; initial REX value + modrm-byte ; initial modrm vale, may be nil if no modrm byte + ) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun parse-x86-opcode-operand-types (types&classes) + (ccl::collect ((types)) + (dolist (t&c types&classes (apply #'vector (types))) + (destructuring-bind (type class) t&c + (declare (ignore class)) + (types (%encode-operand-type type t)))))) + +(defparameter *x86-operand-insert-function-keywords* + #(:insert-nothing + :insert-modrm-reg + :insert-modrm-rm + :insert-memory + :insert-opcode-reg + :insert-opcode-reg4 + :insert-cc + :insert-label + :insert-imm8-for-int + :insert-extra + :insert-imm8 + :insert-imm8s + :insert-imm16 + :insert-imm32s + :insert-imm32 + :insert-imm64 + :insert-mmx-reg + :insert-mmx-rm + :insert-xmm-reg + :insert-xmm-rm + :insert-reg4-pseudo-rm-high + :insert-reg4-pseudo-rm-low + :insert-self + )) + +(defun parse-x86-opcode-operand-classes (types&classes) + (ccl::collect ((classes)) + (dolist (t&c types&classes (apply #'vector (classes))) + (destructuring-bind (type class) t&c + (declare (ignore type)) + (classes (or (position class *x86-operand-insert-function-keywords*) + (error "Unknown operand class: ~s" class))))))) + +(defun parse-x86-opcode-name (name&flags) + (string-downcase (if (atom name&flags) name&flags (car name&flags)))) + + +(defun parse-x86-opcode-flags (name&flags) + (if (atom name&flags) + 0 + (%encode-opcode-flags (cdr name&flags)))) + +) + +;;; Any instruction with no operands. +(defstruct x86-instruction + opcode-template + rex-prefix ; ignored in 32-bit assembly + base-opcode + modrm-byte + sib-byte + seg-prefix + disp + imm + extra + ) + +(defun need-modrm-byte (instruction) + (or (x86-instruction-modrm-byte instruction) + (error "Bug: no modrm byte in ~s" instruction))) + +(defun need-rex-prefix (instruction) + (or (x86-instruction-rex-prefix instruction) + (error "Bug: no REX prefix in ~s" instruction))) + + + + +(defconstant modrm-mod-byte (byte 2 6)) +(defconstant modrm-reg-byte (byte 3 3)) +(defconstant modrm-rm-byte (byte 3 0)) + +(defconstant sib-scale-byte (byte 2 6)) +(defconstant sib-index-byte (byte 3 3)) +(defconstant sib-base-byte (byte 3 0)) + +(defun mode-from-disp-size (type) + (cond ((logtest type (x86::encode-operand-type :disp8)) 1) + ((logtest type (x86::encode-operand-type :disp16 :disp32 :disp32S)) 2) + (t 0))) + + +(defun insert-memory-operand-values (instruction + explicit-seg + disp + base + index + scale + memtype) + (declare (special *ds-segment-register* *ss-segment-register*)) ;fwd refs + (let* ((rm-byte (x86-instruction-modrm-byte instruction)) + (sib 0) + (default-seg *ds-segment-register*)) + (cond ((null base) + (setf (ldb modrm-mod-byte rm-byte) 0 + (ldb modrm-rm-byte rm-byte) +escape-to-two-byte-addressing+ + (ldb sib-base-byte sib) +no-base-register+ + memtype (encode-operand-type :disp32s)) + (cond ((null index) + ;; Just a displacement. + (setf (ldb sib-index-byte sib) +no-index-register+)) + (t + ;; No base, but index + (let* ((index-reg (reg-entry-reg-num index))) + (setf (ldb sib-index-byte sib) index-reg + (ldb sib-scale-byte sib) (or scale 0)) + (when (logtest (reg-entry-reg-flags index) +RegRex+) + (setf (x86-instruction-rex-prefix instruction) + (logior +rex-exty+ (need-rex-prefix instruction)))))))) + ((= (reg-entry-reg-type base) (encode-operand-type :baseIndex)) + ;; RIP-relative. Need a displacement if we don't already + ;; have one. + (setf (ldb modrm-rm-byte rm-byte) +no-base-register+) + (setq memtype + (logior (encode-operand-type :disp32s) + (encode-operand-type :label) + (logandc2 memtype (encode-operand-type :disp))))) + (t + ;; have a real base register (not just %rip). Maybe an + ;; index register, too. + (let* ((baseregnum (reg-entry-reg-num base))) + (setf (ldb modrm-rm-byte rm-byte) baseregnum) + (when (logtest (reg-entry-reg-flags base) +RegRex+) + (setf (x86-instruction-rex-prefix instruction) + (logior 1 (need-rex-prefix instruction)))) + (setf (ldb sib-base-byte sib) baseregnum) + (cond ((= (logand baseregnum 7) +ebp-reg-num+) + (setq default-seg *ss-segment-register*) + (unless disp + (setf memtype (logior memtype (encode-operand-type :disp8))))) + ((= baseregnum x86::+esp-reg-num+) + (setq default-seg x86::*ss-segment-register*))) + (setf (ldb sib-scale-byte sib) (or scale 0)) + (if (null index) + (setf (ldb sib-index-byte sib) +no-index-register+) + (progn + (setf (ldb sib-index-byte sib) + (reg-entry-reg-num index) + (ldb modrm-rm-byte rm-byte) +escape-to-two-byte-addressing+) + (when (logtest (reg-entry-reg-flags index) +RegRex+) + (setf (x86-instruction-rex-prefix instruction) + (logior +rex-exty+ + (need-rex-prefix instruction))))))) + (setf (ldb modrm-mod-byte rm-byte) (mode-from-disp-size memtype)))) + (setf (x86-instruction-modrm-byte instruction) rm-byte) + (when (= (ldb modrm-rm-byte rm-byte) +escape-to-two-byte-addressing+) + (setf (x86-instruction-sib-byte instruction) sib)) + (when (logtest memtype (encode-operand-type :disp)) + (unless disp (setq disp 0)) + (setf (x86-instruction-disp instruction) disp + (x86-instruction-extra instruction) memtype)) + (when (and explicit-seg + (not (eq explicit-seg default-seg))) + (setf (x86-instruction-seg-prefix instruction) + (seg-entry-seg-prefix explicit-seg))))) + +(defun insert-memory (instruction operand) + (insert-memory-operand-values instruction + (x86-memory-operand-seg operand) + (x86-memory-operand-disp operand) + (x86-memory-operand-base operand) + (x86-memory-operand-index operand) + (x86-memory-operand-scale operand) + (x86-memory-operand-type operand))) + + +(defmacro def-x86-opcode (name&flags types-and-classes base-opcode + modrm-byte rex-prefix &rest prefixes) + `(%make-x86-opcode-template + :mnemonic ,(parse-x86-opcode-name name&flags) + :flags ,(parse-x86-opcode-flags name&flags) + :operand-types ,(parse-x86-opcode-operand-types types-and-classes) + :operand-classes ,(parse-x86-opcode-operand-classes types-and-classes) + :base-opcode ,base-opcode + :prefixes ',prefixes + :rex-prefix ,rex-prefix + :modrm-byte ,modrm-byte)) + +(defparameter *x86-opcode-templates* + (vector + ;; adc + (def-x86-opcode (adcq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x11 #o300 #x48) + (def-x86-opcode (adcq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x13 #o000 #x48) + (def-x86-opcode (adcq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x11 #x00 #x48) + (def-x86-opcode (adcq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o320 #x48) + (def-x86-opcode (adcq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x15 nil #x48) + (def-x86-opcode (adcq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o320 #x48) + (def-x86-opcode (adcq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o020 #x48) + (def-x86-opcode (adcq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o020 #x48) + + (def-x86-opcode adcl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x11 #o300 #x00) + (def-x86-opcode adcl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x13 #o000 #x00) + (def-x86-opcode adcl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x11 #x00 #x00) + (def-x86-opcode adcl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o320 #x00) + (def-x86-opcode adcl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x15 nil nil) + (def-x86-opcode adcl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o320 #x00) + (def-x86-opcode adcl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o020 #x00) + (def-x86-opcode adcl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o020 #x00) + + (def-x86-opcode adcw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x11 #o300 #x00 #x66) + (def-x86-opcode adcw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x13 #o000 #x00 #x66) + (def-x86-opcode adcw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x11 #x00 #x00 #x66) + (def-x86-opcode adcw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o320 #x00 #x66) + (def-x86-opcode adcw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x15 nil nil #x66) + (def-x86-opcode adcw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o320 #x00 #x66) + (def-x86-opcode adcw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o020 #x00 #x66) + (def-x86-opcode adcw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o020 #x00 #x66) + + (def-x86-opcode adcb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x10 #o300 #x00) + (def-x86-opcode adcb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x12 #o000 #x00) + (def-x86-opcode adcb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x10 #x00 #x00) + (def-x86-opcode adcb ((:imm8 :insert-imm8) (:acc :insert-nothing)) + #x14 nil nil) + (def-x86-opcode adcb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #x80 #o320 #x00) + (def-x86-opcode adcb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #x80 #o320 #x00) + (def-x86-opcode adcb ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x80 #o020 #x00) + + ;; add + (def-x86-opcode (addq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x01 #o300 #x48) + (def-x86-opcode (addq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x03 #o000 #x48) + (def-x86-opcode (addq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x01 #x00 #x48) + (def-x86-opcode (addq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o300 #x48) + (def-x86-opcode (addq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x05 nil #x48) + (def-x86-opcode (addq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o300 #x48) + (def-x86-opcode (addq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o000 #x48) + (def-x86-opcode (addq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o000 #x48) + + (def-x86-opcode addl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x01 #o300 #x00) + (def-x86-opcode addl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x03 #o000 #x00) + (def-x86-opcode addl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x01 #x00 #x00) + (def-x86-opcode addl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o300 #x00) + (def-x86-opcode addl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x05 nil nil) + (def-x86-opcode addl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o300 #x00) + (def-x86-opcode addl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o000 #x00) + (def-x86-opcode addl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o000 #x00) + + (def-x86-opcode addw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x01 #o300 #x00 #x66) + (def-x86-opcode addw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x03 #o000 #x00 #x66) + (def-x86-opcode addw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x01 #x00 #x00 #x66) + (def-x86-opcode addw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o300 #x00 #x66) + (def-x86-opcode addw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x05 nil nil #x66) + (def-x86-opcode addw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o300 #x00 #x66) + (def-x86-opcode addw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o000 #x00 #x66) + (def-x86-opcode addw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o000 #x00 #x66) + + (def-x86-opcode addb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x00 #o300 #x00) + (def-x86-opcode addb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x02 #o000 #x00) + (def-x86-opcode addb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x00 #x00 #x00) + (def-x86-opcode addb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x04 nil nil) + (def-x86-opcode addb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o300 #x00) + (def-x86-opcode addb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o000 #x00) + + ;; and + (def-x86-opcode (andq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x21 #o300 #x48) + (def-x86-opcode (andq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x23 #o000 #x48) + (def-x86-opcode (andq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x21 #x00 #x48) + (def-x86-opcode (andq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o340 #x48) + (def-x86-opcode (andq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x25 nil #x48) + (def-x86-opcode (andq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o340 #x48) + (def-x86-opcode (andq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o040 #x48) + (def-x86-opcode (andq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o040 #x48) + + (def-x86-opcode andl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x21 #o300 #x00) + (def-x86-opcode andl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x23 #o000 #x00) + (def-x86-opcode andl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x21 #x00 #x00) + (def-x86-opcode andl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o340 #x00) + (def-x86-opcode andl (((:imm32s :imm32) :insert-imm32s) (:acc :insert-nothing)) + #x25 nil nil) + (def-x86-opcode andl (((:imm32s :imm32) :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o340 #x00) + (def-x86-opcode andl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o040 #x00) + (def-x86-opcode andl (((:imm32s :imm32) :insert-imm32s) (:anymem :insert-memory)) + #x81 #o040 #x00) + + (def-x86-opcode andw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x21 #o300 #x00 #x66) + (def-x86-opcode andw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x23 #o000 #x00 #x66) + (def-x86-opcode andw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x21 #x00 #x00 #x66) + (def-x86-opcode andw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o340 #x00 #x66) + (def-x86-opcode andw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x25 nil nil #x66) + (def-x86-opcode andw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o340 #x00 #x66) + (def-x86-opcode andw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o040 #x00 #x66) + (def-x86-opcode andw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o040 #x00 #x66) + + (def-x86-opcode andb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x20 #o300 #x00) + (def-x86-opcode andb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x22 #o000 #x00) + (def-x86-opcode andb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x20 #o000 #x00) + (def-x86-opcode andb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x24 nil nil) + (def-x86-opcode andb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o340 #x00) + (def-x86-opcode andb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o040 #x00) + + ;; bsf + (def-x86-opcode (bsfq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbc #o300 #x48) + (def-x86-opcode (bsfq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbc #o000 #x48) + + (def-x86-opcode bsfl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbc #o300 #x00) + (def-x86-opcode bsfl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbc #o000 #x00) + + (def-x86-opcode bsfw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0fbc #o300 #x00 #x66) + (def-x86-opcode bsfw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0fbc #o000 #x00 #x66) + + ;; bsr + (def-x86-opcode (bsrq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbd #o300 #x48) + (def-x86-opcode (bsrq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbd #o000 #x48) + + (def-x86-opcode bsrl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbd #o300 #x00) + (def-x86-opcode bsrl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbd #o000 #x00) + + (def-x86-opcode bsrw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0fbd #o300 #x00 #x66) + (def-x86-opcode bsrw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0fbd #o000 #x00 #x66) + + ;; bswap + (def-x86-opcode (bswapq :cpu64) ((:reg64 :insert-opcode-reg)) + #x0fc8 nil #x48) + + (def-x86-opcode bswapl ((:reg32 :insert-opcode-reg)) + #x0fc8 nil #x00) + + ;; bt + (def-x86-opcode (btq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o340 #x48) + (def-x86-opcode (btq :cpu64) ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o040 #x48) + (def-x86-opcode (btq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa3 #o300 #x48) + (def-x86-opcode (btq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa3 #o000 #x48) + + (def-x86-opcode btl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o340 #x00) + (def-x86-opcode btl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o040 #x00) + (def-x86-opcode btl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fa3 #o300 #x00) + (def-x86-opcode btl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa3 #o000 #x00) + + (def-x86-opcode btw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o340 #x00 #x66) + (def-x86-opcode btw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o040 #x00 #x66) + (def-x86-opcode btw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fa3 #o300 #x00 #x66) + (def-x86-opcode btw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa3 #o000 #x00 #x66) + + ;; btc + (def-x86-opcode (btcq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o370 #x48) + (def-x86-opcode (btcq :cpu64) ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o070 #x48) + (def-x86-opcode (btcq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fbb #o300 #x48) + (def-x86-opcode (btcq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fbb #o000 #x48) + + (def-x86-opcode btcl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o370 #x00) + (def-x86-opcode btcl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o070 #x00) + (def-x86-opcode btcl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fbb #o300 #x00) + (def-x86-opcode btcl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fbb #o000 #x00) + + (def-x86-opcode btcw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o370 #x00 #x66) + (def-x86-opcode btcw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o070 #x00 #x66) + (def-x86-opcode btcw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fbb #o300 #x00 #x66) + (def-x86-opcode btcw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fbb #o000 #x00 #x66) + + ;; btr + (def-x86-opcode (btrq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o360 #x48) + (def-x86-opcode (btrq :cpu64) ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o060 #x48) + (def-x86-opcode (btrq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fb3 #o300 #x48) + (def-x86-opcode (btrq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb3 #o000 #x48) + + (def-x86-opcode btrl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o360 #x00) + (def-x86-opcode btrl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o060 #x00) + (def-x86-opcode btrl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fb3 #o300 #x00) + (def-x86-opcode btrl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb3 #o000 #x00) + + (def-x86-opcode btrw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o360 #x00 #x66) + (def-x86-opcode btrw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o060 #x00 #x66) + (def-x86-opcode btrw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fb3 #o300 #x00 #x66) + (def-x86-opcode btrw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb3 #o000 #x00 #x66) + + ;; bts + (def-x86-opcode (btsq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #x0fba #o350 #x48) + (def-x86-opcode (btsq :cpu64) ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o050 #x48) + (def-x86-opcode (btsq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fab #o300 #x48) + (def-x86-opcode (btsq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fab #o000 #x48) + + (def-x86-opcode btsl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #x0fba #o350 #x00) + (def-x86-opcode btsl ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o050 #x00) + (def-x86-opcode btsl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fab #o300 #x00) + (def-x86-opcode btsl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fab #o000 #x00) + + (def-x86-opcode btsw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #x0fba #o350 #x00 #x66) + (def-x86-opcode btsw ((:imm8 :insert-imm8) (:anymem :insert-memory)) + #x0fba #o050 #x00 #x66) + (def-x86-opcode btsw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fab #o300 #x00 #x66) + (def-x86-opcode btsw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fab #o000 #x00 #x66) + + ;; call + ;; Probably need to align CALL instructions within the containing function, + ;; so that return addresses are tagged appropriately. + (def-x86-opcode call ((:label :insert-label)) + #xe8 nil nil) + + (def-x86-opcode (call :cpu64) ((:reg64 :insert-modrm-rm)) + #xff #o320 #x0) + (def-x86-opcode (call :cpuno64) ((:reg32 :insert-modrm-rm)) + #xff #o320 #x0) + + (def-x86-opcode call ((:anymem :insert-memory)) + #xff #o020 #x0) + + ;; cbtw + (def-x86-opcode cbtw () + #x98 nil nil #x66) + + ;; clc + (def-x86-opcode clc () + #xf8 nil nil) + + ;; cld + (def-x86-opcode cld () + #xfc nil nil) + + ;; cltd + (def-x86-opcode cltd () + #x99 nil nil) + + + ;; cltq + (def-x86-opcode (cltq :cpu64) () + #x98 nil #x48) + + ;; cmc + (def-x86-opcode cmc () + #xf5 nil nil) + + ;; cmovCC + (def-x86-opcode (cmovccq :cpu64) + ((:imm8 :insert-cc) (:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f40 #o300 #x48) + (def-x86-opcode (cmovccq :cpu64) + ((:imm8 :insert-cc) (:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f40 #o000 #x48) + (def-x86-opcode cmovccl + ((:imm8 :insert-cc) (:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f40 #o300 #x00) + (def-x86-opcode cmovccl + ((:imm8 :insert-cc) (:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f40 #o000 #x00) + (def-x86-opcode cmovccw + ((:imm8 :insert-cc) (:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f40 #o300 #x00 #x66) + (def-x86-opcode cmovccw + ((:imm8 :insert-cc) (:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f40 #o000 #x00 #x66) + + (def-x86-opcode (cmovoq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f40 #o300 #x48) + (def-x86-opcode (cmovoq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f40 #o000 #x48) + (def-x86-opcode cmovol ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f40 #o300 #x00) + (def-x86-opcode cmovol ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f40 #o000 #x00) + (def-x86-opcode cmovow ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f40 #o300 #x00 #x66) + (def-x86-opcode cmovow ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f40 #o000 #x00 #x66) + + (def-x86-opcode (cmovnoq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f41 #o300 #x48) + (def-x86-opcode (cmovnoq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f41 #o000 #x48) + (def-x86-opcode cmovnol ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f41 #o300 #x00) + (def-x86-opcode cmovnol ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f41 #o000 #x00) + (def-x86-opcode cmovnow ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f41 #o300 #x00 #x66) + (def-x86-opcode cmovnow ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f41 #o000 #x00 #x66) + + (def-x86-opcode (cmovbq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f42 #o300 #x48) + (def-x86-opcode (cmovbq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f42 #o000 #x48) + (def-x86-opcode cmovbl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f42 #o300 #x00) + (def-x86-opcode cmovbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f42 #o000 #x00) + (def-x86-opcode cmovbw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f42 #o300 #x00 #x66) + (def-x86-opcode cmovbw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f42 #o000 #x00 #x66) + + (def-x86-opcode (cmovcq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f42 #o300 #x48) + (def-x86-opcode (cmovcq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f42 #o000 #x48) + (def-x86-opcode cmovcl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f42 #o300 #x00) + (def-x86-opcode cmovcl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f42 #o000 #x00) + (def-x86-opcode cmovcw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f42 #o300 #x00 #x66) + (def-x86-opcode cmovcw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f42 #o000 #x00 #x66) + + (def-x86-opcode (cmovaeq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f43 #o300 #x48) + (def-x86-opcode (cmovaeq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f43 #o000 #x48) + (def-x86-opcode cmovael ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f43 #o300 #x00) + (def-x86-opcode cmovael ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f43 #o000 #x00) + (def-x86-opcode cmovaew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f43 #o300 #x00 #x66) + (def-x86-opcode cmovaew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f43 #o000 #x00 #x66) + + (def-x86-opcode (cmovncq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f43 #o300 #x48) + (def-x86-opcode (cmovncq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f43 #o000 #x48) + (def-x86-opcode cmovncl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f43 #o300 #x00) + (def-x86-opcode cmovncl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f43 #o000 #x00) + (def-x86-opcode cmovncw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f43 #o300 #x00 #x66) + (def-x86-opcode cmovncw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f43 #o000 #x00 #x66) + + (def-x86-opcode (cmoveq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f44 #o300 #x48) + (def-x86-opcode (cmoveq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f44 #o000 #x48) + (def-x86-opcode cmovel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f44 #o300 #x00) + (def-x86-opcode cmovel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f44 #o000 #x00) + (def-x86-opcode cmovew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f44 #o300 #x00 #x66) + (def-x86-opcode cmovew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f44 #o000 #x00 #x66) + + (def-x86-opcode (cmovzq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f44 #o300 #x48) + (def-x86-opcode (cmovzq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f44 #o000 #x48) + (def-x86-opcode cmovzl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f44 #o300 #x00) + (def-x86-opcode cmovzl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f44 #o000 #x00) + (def-x86-opcode cmovzw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f44 #o300 #x00 #x66) + (def-x86-opcode cmovzw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f44 #o000 #x00 #x66) + + (def-x86-opcode (cmovneq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f45 #o300 #x48) + (def-x86-opcode (cmovneq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f45 #o000 #x48) + (def-x86-opcode cmovnel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f45 #o300 #x00) + (def-x86-opcode cmovnel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f45 #o000 #x00) + (def-x86-opcode cmovnew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f45 #o300 #x00 #x66) + (def-x86-opcode cmovnew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f45 #o000 #x00 #x66) + + (def-x86-opcode (cmovnzq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f45 #o300 #x48) + (def-x86-opcode (cmovnzq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f45 #o000 #x48) + (def-x86-opcode cmovnzl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f45 #o300 #x00) + (def-x86-opcode cmovnzl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f45 #o000 #x00) + (def-x86-opcode cmovnzw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f45 #o300 #x00 #x66) + (def-x86-opcode cmovnzw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f45 #o000 #x00 #x66) + + (def-x86-opcode (cmovbeq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f46 #o300 #x48) + (def-x86-opcode (cmovbeq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f46 #o000 #x48) + (def-x86-opcode cmovbel ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-reg)) + #x0f46 #o300 #x00) + (def-x86-opcode cmovbel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f46 #o000 #x00) + (def-x86-opcode cmovbew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f46 #o300 #x00 #x66) + (def-x86-opcode cmovbew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f46 #o000 #x00 #x66) + + (def-x86-opcode (cmovaq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f47 #o300 #x48) + (def-x86-opcode (cmovaq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f47 #o000 #x48) + (def-x86-opcode cmoval ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f47 #o300 #x00) + (def-x86-opcode cmoval ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f47 #o000 #x00) + (def-x86-opcode cmovaw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f47 #o300 #x00 #x66) + (def-x86-opcode cmovaw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f47 #o000 #x00 #x66) + + (def-x86-opcode (cmovsq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f48 #o300 #x48) + (def-x86-opcode (cmovsq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f48 #o000 #x48) + (def-x86-opcode cmovsl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f48 #o300 #x00) + (def-x86-opcode cmovsl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f48 #o000 #x00) + (def-x86-opcode cmovsw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f48 #o300 #x00 #x66) + (def-x86-opcode cmovsw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f48 #o000 #x00 #x66) + + (def-x86-opcode (cmovnsq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f49 #o300 #x48) + (def-x86-opcode (cmovnsq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f49 #o000 #x48) + (def-x86-opcode cmovnsl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f49 #o300 #x00) + (def-x86-opcode cmovnsl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f49 #o000 #x00) + (def-x86-opcode cmovnsw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f49 #o300 #x00 #x66) + (def-x86-opcode cmovnsw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f49 #o000 #x00 #x66) + + (def-x86-opcode (cmovpeq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4a #o300 #x48) + (def-x86-opcode (cmovpeq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4a #o000 #x48) + (def-x86-opcode cmovpel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4a #o300 #x00) + (def-x86-opcode cmovpel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4a #o000 #x00) + (def-x86-opcode cmovpew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4a #o300 #x00 #x66) + (def-x86-opcode cmovpew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4a #o000 #x00 #x66) + + (def-x86-opcode (cmovpoq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4b #o300 #x48) + (def-x86-opcode (cmovpoq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4b #o000 #x48) + (def-x86-opcode cmovpol ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4b #o300 #x00) + (def-x86-opcode cmovpol ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4b #o000 #x00) + (def-x86-opcode cmovpow ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4b #o300 #x00 #x66) + (def-x86-opcode cmovpow ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4b #o000 #x00 #x66) + + (def-x86-opcode (cmovlq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4c #o300 #x48) + (def-x86-opcode (cmovlq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4c #o000 #x48) + (def-x86-opcode cmovll ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4c #o300 #x00) + (def-x86-opcode cmovll ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4c #o000 #x00) + (def-x86-opcode cmovlw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4c #o300 #x00 #x66) + (def-x86-opcode cmovlw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4c #o000 #x00 #x66) + + (def-x86-opcode (cmovgeq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4d #o300 #x48) + (def-x86-opcode (cmovgeq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4d #o000 #x48) + (def-x86-opcode cmovgel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4d #o300 #x00) + (def-x86-opcode cmovgel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4d #o000 #x00) + (def-x86-opcode cmovgew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4d #o300 #x00 #x66) + (def-x86-opcode cmovgew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4d #o000 #x00 #x66) + + (def-x86-opcode (cmovleq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4e #o300 #x48) + (def-x86-opcode (cmovleq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4e #o000 #x48) + (def-x86-opcode cmovlel ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4e #o300 #x00) + (def-x86-opcode cmovlel ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4e #o000 #x00) + (def-x86-opcode cmovlew ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4e #o300 #x00 #x66) + (def-x86-opcode cmovlew ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4e #o000 #x00 #x66) + + (def-x86-opcode (cmovgq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0f4f #o300 #x48) + (def-x86-opcode (cmovgq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f4f #o000 #x48) + (def-x86-opcode cmovgl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0f4f #o300 #x00) + (def-x86-opcode cmovgl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f4f #o000 #x00) + (def-x86-opcode cmovgw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0f4f #o300 #x00 #x66) + (def-x86-opcode cmovgw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0f4f #o000 #x00 #x66) + + + ;; cmp + + (def-x86-opcode (cmpq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x39 #o300 #x48) + (def-x86-opcode (rcmpq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x39 #o300 #x48) + (def-x86-opcode (cmpq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x3b #o000 #x48) + (def-x86-opcode (rcmpq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x3b #o000 #x48) + (def-x86-opcode (cmpq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x39 #x00 #x48) + (def-x86-opcode (rcmpq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x39 #x00 #x48) + (def-x86-opcode (cmpq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o370 #x48) + (def-x86-opcode (rcmpq :cpu64) ((:reg64 :insert-modrm-rm) (:imm8s :insert-imm8s)) + #x83 #o370 #x48) + (def-x86-opcode (cmpq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x3d nil #x48) + (def-x86-opcode (rcmpq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x3d nil #x48) + (def-x86-opcode (cmpq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o370 #x48) + (def-x86-opcode (rcmpq :cpu64) ((:reg64 :insert-modrm-rm) (:imm32s :insert-imm32s)) + #x81 #o370 #x48) + (def-x86-opcode (cmpq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o070 #x48) + (def-x86-opcode (rcmpq :cpu64) ((:anymem :insert-memory) (:imm8s :insert-imm8s)) + #x83 #o070 #x48) + (def-x86-opcode (cmpq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o070 #x48) + (def-x86-opcode (rcmpq :cpu64) ((:anymem :insert-memory) (:imm32s :insert-imm32s)) + #x81 #o070 #x48) + + (def-x86-opcode cmpl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x39 #o300 #x00) + (def-x86-opcode rcmpl ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x39 #o300 #x00) + (def-x86-opcode cmpl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x3b #o000 #x00) + (def-x86-opcode rcmpl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x3b #o000 #x00) + (def-x86-opcode cmpl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x39 #x00 #x00) + (def-x86-opcode rcmpl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x39 #x00 #x00) + (def-x86-opcode cmpl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o370 #x00) + (def-x86-opcode rcmpl ((:reg32 :insert-modrm-rm) (:imm8s :insert-imm8s)) + #x83 #o370 #x00) + (def-x86-opcode cmpl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x3d nil nil) + (def-x86-opcode rcmpl ((:acc :insert-nothing) (:imm32s :insert-imm32s)) + #x3d nil nil) + (def-x86-opcode cmpl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o370 #x00) + (def-x86-opcode rcmpl ((:reg32 :insert-modrm-rm) (:imm32s :insert-imm32s)) + #x81 #o370 #x00) + (def-x86-opcode cmpl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o070 #x00) + (def-x86-opcode rcmpl ((:anymem :insert-memory) (:imm8s :insert-imm8s)) + #x83 #o070 #x00) + (def-x86-opcode cmpl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o070 #x00) + (def-x86-opcode rcmpl ((:anymem :insert-memory) (:imm32s :insert-imm32s)) + #x81 #o070 #x00) + + (def-x86-opcode cmpw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x39 #o300 #x00 #x66) + (def-x86-opcode rcmpw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x39 #o300 #x00 #x66) + (def-x86-opcode cmpw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x3b #o000 #x00 #x66) + (def-x86-opcode rcmpw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x3b #o000 #x00 #x66) + (def-x86-opcode cmpw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x39 #x00 #x00 #x66) + (def-x86-opcode rcmpw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x39 #x00 #x00 #x66) + (def-x86-opcode cmpw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o370 #x00 #x66) + (def-x86-opcode rcmpw ((:reg16 :insert-modrm-rm) (:imm8s :insert-imm8s)) + #x83 #o370 #x00 #x66) + (def-x86-opcode cmpw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x3d nil nil #x66) + (def-x86-opcode rcmpw ((:acc :insert-nothing) (:imm16 :insert-imm16)) + #x3d nil nil #x66) + (def-x86-opcode cmpw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o370 #x00 #x66) + (def-x86-opcode rcmpw ((:reg16 :insert-modrm-rm) (:imm16 :insert-imm16)) + #x81 #o370 #x00 #x66) + (def-x86-opcode cmpw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o070 #x00 #x66) + (def-x86-opcode rcmpw ((:anymem :insert-memory) (:imm8s :insert-imm8s)) + #x83 #o070 #x00 #x66) + (def-x86-opcode cmpw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o070 #x00 #x66) + (def-x86-opcode rcmpw ((:anymem :insert-memory) (:imm16 :insert-imm16)) + #x81 #o070 #x00 #x66) + + (def-x86-opcode cmpb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x38 #o300 #x00) + (def-x86-opcode rcmpb ((:reg8 :insert-modrm-rm) (:reg8 :insert-modrm-reg)) + #x38 #o300 #x00) + (def-x86-opcode cmpb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x3a #o000 #x00) + (def-x86-opcode rcmpb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x3a #o000 #x00) + (def-x86-opcode cmpb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x38 #x00 #x00) + (def-x86-opcode rcmpb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x38 #x00 #x00) + (def-x86-opcode cmpb (((:imm8s :imm8) :insert-imm8s) (:acc :insert-nothing)) + #x3c nil nil) + (def-x86-opcode rcmpb ((:acc :insert-nothing) ((:imm8s :imm8) :insert-imm8s)) + #x3c nil nil) + (def-x86-opcode cmpb (((:imm8s :imm8) :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o370 #x00) + (def-x86-opcode rcmpb ((:reg8 :insert-modrm-rm) ((:imm8s :imm8) :insert-imm8s)) + #x80 #o370 #x00) + (def-x86-opcode cmpb (((:imm8s :imm8) :insert-imm8s) (:anymem :insert-memory)) + #x80 #o070 #x00) + (def-x86-opcode rcmpb ((:anymem :insert-memory) ((:imm8s :imm8) :insert-imm8s)) + #x80 #o070 #x00) + + ;; cmps + (def-x86-opcode (cmpsq :cpu64) () + #xa7 nil #x48) + + (def-x86-opcode cmpsl () + #xa7 nil nil) + + (def-x86-opcode cmpsw () + #xa7 nil nil #x66) + + (def-x86-opcode cmpsb () + #xa6 nil nil) + + ;; cmpxchg + (def-x86-opcode (cmpxchgq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fb1 #o300 #x48) + (def-x86-opcode (cmpxchgq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb1 #o000 #x48) + + (def-x86-opcode cmpxchgl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fb1 #o300 #x00) + (def-x86-opcode cmpxchgl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb1 #o000 #x00) + + (def-x86-opcode cmpxchgw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fb1 #o300 #x00 #x66) + (def-x86-opcode cmpxchgw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb1 #o000 #x00 #x66) + + (def-x86-opcode cmpxchgb ((:reg8 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fb0 #o300 #x00) + (def-x86-opcode cmpxchgb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fb0 #o000 #x00) + + ;; cpuid + (def-x86-opcode cpuid () + #x0fa2 nil nil) + + ;; cqto + (def-x86-opcode (cqto :cpu64) () + #x99 nil #x48) + + ;; cwtd + (def-x86-opcode cwtd () + #x99 nil nil #x66) + + ;; cwtl + (def-x86-opcode cwtl () + #x98 nil nil) + + ;; dec (not the 1-byte form). This exists on x8664, but gas doesn't + ;; know that. + (def-x86-opcode (decq :cpu64) ((:reg64 :insert-modrm-rm)) + #xff #o310 #x48) + (def-x86-opcode (decq :cpu64) ((:anymem :insert-memory)) + #xff #o010 #x48) + + (def-x86-opcode (decl :cpuno64) ((:reg32 :insert-opcode-reg)) + #x48 nil nil) + ;; This is valid in 32 bit too, but use it only on x86-64 + (def-x86-opcode (decl :cpu64) ((:reg32 :insert-modrm-rm)) + #xff #o310 #x00) + (def-x86-opcode decl ((:anymem :insert-memory)) + #xff #o010 #x00) + + (def-x86-opcode (decw :cpuno64) ((:reg16 :insert-opcode-reg)) + #x48 nil nil #x66) + ;; This is valud in 32 bit too, but use it only on x86-64 + (def-x86-opcode (decw :cpu64) ((:reg16 :insert-modrm-rm)) + #xff #o310 #x00 #x66) + (def-x86-opcode decw ((:anymem :insert-memory)) + #xff #o010 #x00 #x66) + + (def-x86-opcode decb ((:reg8 :insert-modrm-rm)) + #xfe #o310 #x00) + (def-x86-opcode decb ((:anymem :insert-memory)) + #xfe #o010 #x00) + + ;; div + (def-x86-opcode (divq :cpu64) ((:reg64 :insert-modrm-rm)) + #xf7 #o360 #x48) + (def-x86-opcode (divq :cpu64) ((:anymem :insert-memory)) + #xf7 #o060 #x48) + + (def-x86-opcode divl ((:reg32 :insert-modrm-rm)) + #xf7 #o360 #x00) + (def-x86-opcode divl ((:anymem :insert-memory)) + #xf7 #o060 #x00) + + (def-x86-opcode divw ((:reg16 :insert-modrm-rm)) + #xf7 #o360 #x00 #x66) + (def-x86-opcode divw ((:anymem :insert-memory)) + #xf7 #o060 #x00 #x66) + + (def-x86-opcode divb ((:reg8 :insert-modrm-rm)) + #xf6 #o360 #x00) + (def-x86-opcode divl ((:anymem :insert-memory)) + #xf6 #o060 #x00) + + ;; enter. + + (def-x86-opcode enter ((:imm16 :insert-imm16) (:imm8 :insert-extra)) + #xc8 nil nil) + + ;; hlt + (def-x86-opcode hlt () + #xf4 nil nil) + + ;; idiv. Note that GAS doesn't know about newer(?) idiv forms + (def-x86-opcode (idivq :cpu64) ((:reg64 :insert-modrm-rm)) + #xf7 #o370 #x48) + (def-x86-opcode (idivq :cpu64) ((:anymem :insert-memory)) + #xf7 #o070 #x48) + + (def-x86-opcode idivl ((:reg32 :insert-modrm-rm)) + #xf7 #o370 #x00) + (def-x86-opcode idivl ((:anymem :insert-memory)) + #xf7 #o070 #x00) + + (def-x86-opcode idivw ((:reg16 :insert-modrm-rm)) + #xf7 #o370 #x00 #x66) + (def-x86-opcode idivw ((:anymem :insert-memory)) + #xf7 #o070 #x00 #x66) + + (def-x86-opcode idivb ((:reg8 :insert-modrm-rm)) + #xf6 #o370 #x00) + (def-x86-opcode idivl ((:anymem :insert-memory)) + #xf6 #o070 #x00) + + ;; imul + (def-x86-opcode (imulq :cpu64) ((:reg64 :insert-modrm-rm)) + #xf7 #o350 #x48) + (def-x86-opcode (imulq :cpu64) ((:anymem :insert-memory)) + #xf7 #o050 #x48) + + (def-x86-opcode (imulq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x6b #o300 #x48) + (def-x86-opcode (imulq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x6b #o000 #x48) + (def-x86-opcode (imulq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x69 #o300 #x48) + (def-x86-opcode (imulq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x69 #o000 #x48) + (def-x86-opcode (imulq :cpu64) ((:reg64 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0faf #o300 #x48) + (def-x86-opcode (imulq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0faf #o000 #x48) + + + (def-x86-opcode imull ((:reg32 :insert-modrm-rm)) + #xf7 #o350 #x00) + (def-x86-opcode imull ((:anymem :insert-memory)) + #xf7 #o050 #x00) + + (def-x86-opcode imull ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x6b #o300 #x00) + (def-x86-opcode imull ((:imm8s :insert-imm8s) (:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x6b #o000 #x00) + (def-x86-opcode imull ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x69 #o300 #x00) + (def-x86-opcode imull ((:imm32s :insert-imm32s) (:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x69 #o000 #x00) + (def-x86-opcode imull ((:reg32 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0faf #o300 #x00) + (def-x86-opcode imull ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0faf #o000 #x00) + + (def-x86-opcode imulw ((:reg16 :insert-modrm-rm)) + #xf7 #o350 #x00 #x66) + (def-x86-opcode imulw ((:anymem :insert-memory)) + #xf7 #o050 #x00 #x66) + + (def-x86-opcode imulw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x6b #o300 #x00 #x66) + (def-x86-opcode imulw ((:imm8s :insert-imm8s) (:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x6b #o000 #x00 #x66) + (def-x86-opcode imulw ((:imm32s :insert-imm32s) (:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x69 #o300 #x00 #x66) + (def-x86-opcode imulw ((:imm32s :insert-imm32s) (:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x69 #o000 #x00 #x66) + (def-x86-opcode imulw ((:reg16 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0faf #o300 #x00 #x66) + (def-x86-opcode imulw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0faf #o000 #x00 #x66) + + (def-x86-opcode imulb ((:reg8 :insert-modrm-rm)) + #xf6 #o350 #x00) + (def-x86-opcode imulb ((:anymem :insert-memory)) + #xf6 #o050 #x00) + + ;; inc (but not the one-byte form) is available on x86-64. + (def-x86-opcode (incq :cpu64) ((:reg64 :insert-modrm-rm)) + #xff #o300 #x48) + (def-x86-opcode (incq :cpu64) ((:anymem :insert-memory)) + #xff #o000 #x48) + + (def-x86-opcode (incl :cpuno64) ((:reg32 :insert-opcode-reg)) + #x40 nil nil) + ;; This is valid in 32-bit too, but use it only on x86-64 + (def-x86-opcode (incl :cpu64) ((:reg32 :insert-modrm-rm)) + #xff #o300 #x00) + (def-x86-opcode incl ((:anymem :insert-memory)) + #xff #o000 #x00) + + (def-x86-opcode (incw :cpuno64) ((:reg16 :insert-opcode-reg)) + #x40 nil nil #x66) + ;; This is valid in 32-bit too, but use it only on x86-64 + (def-x86-opcode (incw :cpu64) ((:reg16 :insert-modrm-rm)) + #xff #o300 #x00 #x66) + (def-x86-opcode incw ((:anymem :insert-memory)) + #xff #o000 #x00 #x66) + + (def-x86-opcode incb ((:reg8 :insert-modrm-rm)) + #xfe #o300 #x00) + (def-x86-opcode incb ((:anymem :insert-memory)) + #xfe #o000 #x00) + + ;; int. See also UUOs. + (def-x86-opcode int ((:imm8 :insert-imm8-for-int)) + #xcd nil nil) + + ;; Jcc. Generate the short form here; maybe relax later. + (def-x86-opcode (jcc :jump) ((:imm8 :insert-cc) (:label :insert-label)) + #x70 nil nil) + (def-x86-opcode (jcc.pt :jump) ((:imm8 :insert-cc) (:label :insert-label)) + #x70 nil nil #x3e) + (def-x86-opcode (jcc.pn :jump) ((:imm8 :insert-cc) (:label :insert-label)) + #x70 nil nil #x2e) + + (def-x86-opcode (jo :jump) ((:label :insert-label)) + #x70 nil nil) + (def-x86-opcode (jo.pt :jump) ((:label :insert-label)) + #x70 nil nil #x3e) + (def-x86-opcode (jo.pn :jump) ((:label :insert-label)) + #x70 nil nil #x2e) + (def-x86-opcode (jno :jump) ((:label :insert-label)) + #x71 nil nil) + (def-x86-opcode (jno.pt :jump) ((:label :insert-label)) + #x71 nil nil #x3e) + (def-x86-opcode (jno.pn :jump) ((:label :insert-label)) + #x71 nil nil #x2e) + (def-x86-opcode (jb :jump) ((:label :insert-label)) + #x72 nil nil) + (def-x86-opcode (jb.pt :jump) ((:label :insert-label)) + #x72 nil nil #x3e) + (def-x86-opcode (jb.pn :jump) ((:label :insert-label)) + #x72 nil nil #x2e) + (def-x86-opcode (jc :jump) ((:label :insert-label)) + #x72 nil nil) + (def-x86-opcode (jc.pt :jump) ((:label :insert-label)) + #x72 nil nil #x3e) + (def-x86-opcode (jc.pn :jump) ((:label :insert-label)) + #x72 nil nil #x2e) + (def-x86-opcode (jae :jump) ((:label :insert-label)) + #x73 nil nil) + (def-x86-opcode (jae.pt :jump) ((:label :insert-label)) + #x73 nil nil #x3e) + (def-x86-opcode (jae.pn :jump) ((:label :insert-label)) + #x73 nil nil #x2e) + (def-x86-opcode (jnc :jump) ((:label :insert-label)) + #x73 nil nil) + (def-x86-opcode (jnc.pt :jump) ((:label :insert-label)) + #x73 nil nil #x3e) + (def-x86-opcode (jnc.pn :jump) ((:label :insert-label)) + #x73 nil nil #x2e) + (def-x86-opcode (je :jump) ((:label :insert-label)) + #x74 nil nil) + (def-x86-opcode (je.pt :jump) ((:label :insert-label)) + #x74 nil nil #x3e) + (def-x86-opcode (je.pn :jump) ((:label :insert-label)) + #x74 nil nil #x2e) + (def-x86-opcode (jz :jump) ((:label :insert-label)) + #x74 nil nil) + (def-x86-opcode (jz.pt :jump) ((:label :insert-label)) + #x74 nil nil #x3e) + (def-x86-opcode (jz.pn :jump) ((:label :insert-label)) + #x74 nil nil #x2e) + (def-x86-opcode (jne :jump) ((:label :insert-label)) + #x75 nil nil) + (def-x86-opcode (jne.pt :jump) ((:label :insert-label)) + #x75 nil nil #x3e) + (def-x86-opcode (jne.pn :jump) ((:label :insert-label)) + #x75 nil nil #x2e) + (def-x86-opcode (jnz :jump) ((:label :insert-label)) + #x75 nil nil) + (def-x86-opcode (jnz.pt :jump) ((:label :insert-label)) + #x75 nil nil #x3e) + (def-x86-opcode (jnz.pn :jump) ((:label :insert-label)) + #x75 nil nil #x2e) + (def-x86-opcode (jbe :jump) ((:label :insert-label)) + #x76 nil nil) + (def-x86-opcode (jbe.pt :jump) ((:label :insert-label)) + #x76 nil nil #x3e) + (def-x86-opcode (jbe.pn :jump) ((:label :insert-label)) + #x76 nil nil #x2e) + (def-x86-opcode (ja :jump) ((:label :insert-label)) + #x77 nil nil) + (def-x86-opcode (ja.pt :jump) ((:label :insert-label)) + #x77 nil nil #x3e) + (def-x86-opcode (ja.pn :jump) ((:label :insert-label)) + #x77 nil nil #x2e) + (def-x86-opcode (js :jump) ((:label :insert-label)) + #x78 nil nil) + (def-x86-opcode (js.pt :jump) ((:label :insert-label)) + #x78 nil nil #x3e) + (def-x86-opcode (js.pn :jump) ((:label :insert-label)) + #x78 nil nil #x2e) + (def-x86-opcode (jns :jump) ((:label :insert-label)) + #x79 nil nil) + (def-x86-opcode (jns.pt :jump) ((:label :insert-label)) + #x79 nil nil #x3e) + (def-x86-opcode (jns.pn :jump) ((:label :insert-label)) + #x79 nil nil #x2e) + (def-x86-opcode (jpe :jump) ((:label :insert-label)) + #x7a nil nil) + (def-x86-opcode (jpe.pt :jump) ((:label :insert-label)) + #x7a nil nil #x3e) + (def-x86-opcode (jpe.pn :jump) ((:label :insert-label)) + #x7a nil nil #x2e) + (def-x86-opcode (jpo :jump) ((:label :insert-label)) + #x7b nil nil) + (def-x86-opcode (jpo.pt :jump) ((:label :insert-label)) + #x7b nil nil #x3e) + (def-x86-opcode (jpo.pn :jump) ((:label :insert-label)) + #x7b nil nil #x2e) + (def-x86-opcode (jl :jump) ((:label :insert-label)) + #x7c nil nil) + (def-x86-opcode (jl.pt :jump) ((:label :insert-label)) + #x7c nil nil #x3e) + (def-x86-opcode (jl.pn :jump) ((:label :insert-label)) + #x7c nil nil #x2e) + (def-x86-opcode (jge :jump) ((:label :insert-label)) + #x7d nil nil) + (def-x86-opcode (jge.pt :jump) ((:label :insert-label)) + #x7d nil nil #x3e) + (def-x86-opcode (jge.pn :jump) ((:label :insert-label)) + #x7d nil nil #x2e) + (def-x86-opcode (jle :jump) ((:label :insert-label)) + #x7e nil nil) + (def-x86-opcode (jle.pt :jump) ((:label :insert-label)) + #x7e nil nil #x3e) + (def-x86-opcode (jle.pn :jump) ((:label :insert-label)) + #x7e nil nil #x2e) + (def-x86-opcode (jg :jump) ((:label :insert-label)) + #x7f nil nil) + (def-x86-opcode (jg.pt :jump) ((:label :insert-label)) + #x7f nil nil #x3e) + (def-x86-opcode (jg.pn :jump) ((:label :insert-label)) + #x7f nil nil #x2e) + + ;; jmp . Translating the 8-bit pc-relative version to the 32-bit + ;; pc-relative version happens during relaxation. + ;; On 32-bit, I think it's possible to use 16-bit pc-relative + ;; displacements---this would save a byte in instances where + ;; the displacement fit in 16 bits. + (def-x86-opcode (jmp :jump) ((:label :insert-label)) + #xeb nil nil) + + (def-x86-opcode (jmp :cpu64) ((:reg64 :insert-modrm-rm)) + #xff #o340 #x0) + (def-x86-opcode (jmp :cpuno64) ((:reg32 :insert-modrm-rm)) + #xff #o340 nil) + + (def-x86-opcode jmp ((:anymem :insert-memory)) + #xff #o040 #x0) + + ;; lea + (def-x86-opcode (leaq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x8d 0 #x48) + + (def-x86-opcode leal ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x8d 0 #x00) + + (def-x86-opcode leaw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x8d 0 #x00 #x66) + + ;; leave + (def-x86-opcode leave () + #xc9 nil nil) + + ;; lock + (def-x86-opcode lock () + #xf0 nil nil) + + ;; lods + (def-x86-opcode lodsq () + #xac nil #x48) + + (def-x86-opcode lodsl () + #xac nil nil) + + ;; loop + (def-x86-opcode (loopq :cpu64) ((:label :insert-label)) + #xe2 nil #x48) + + (def-x86-opcode loopl ((:label :insert-label)) + #xe2 nil nil) + + (def-x86-opcode (loopzq :cpu64) ((:label :insert-label)) + #xe1 nil #x48) + + (def-x86-opcode loopzl ((:label :insert-label)) + #xe1 nil nil) + + (def-x86-opcode (loopnzq :cpu64) ((:label :insert-label)) + #xe0 nil #x48) + + (def-x86-opcode loopnzl ((:label :insert-label)) + #xe0 nil nil) + + ;; mov, including the MMX/XMM variants. + (def-x86-opcode movq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0f6f #o300 0) + (def-x86-opcode movq ((:regmmx :insert-mmx-reg) (:anymem :insert-memory)) + #x0f7f #o0 0) + (def-x86-opcode movq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0f6f #o0 0) + (def-x86-opcode movq ((:regxmm :insert-xmm-reg) (:regxmm :insert-xmm-rm)) + #x0f7e #o300 0 #xf3) + (def-x86-opcode movq ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f7e #o000 0 #xf3) + (def-x86-opcode movq ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0fd6 #o000 0 #x66) + + (def-x86-opcode (movq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x89 #o300 #x48) + (def-x86-opcode (movq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x8b #o0 #x48) + (def-x86-opcode (movq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x89 #o0 #x48) + (def-x86-opcode (movq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #xc7 #o300 #x48) + (def-x86-opcode (movq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xc7 #o000 #x48) + (def-x86-opcode (movq :cpu64) ((:imm64 :insert-imm64) (:reg64 :insert-opcode-reg)) + #xb8 nil #x48) + + (def-x86-opcode movl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x89 #o300 #x00) + (def-x86-opcode movl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x8b #o0 #x00) + (def-x86-opcode movl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x89 #o0 #x00) + (def-x86-opcode movl ((:imm32s :insert-imm32s) (:reg32 :insert-opcode-reg)) + #xb8 nil #x00) + (def-x86-opcode movl ((:self :insert-self) (:reg32 :insert-opcode-reg)) + #xb8 nil #x00) + (def-x86-opcode movl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xc7 #o000 #x00) + + + (def-x86-opcode movw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x89 #o300 #x00 #x66) + (def-x86-opcode movw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x8b #o0 #x00 #x66) + (def-x86-opcode movw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x89 #o0 #x00 #x66) + (def-x86-opcode movw ((:imm16 :insert-imm16) (:reg16 :insert-opcode-reg)) + #xb8 nil #x00 #x66) + (def-x86-opcode movw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #xc7 #o000 #x00 #x66) + + (def-x86-opcode movb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x88 #o300 0) + (def-x86-opcode movb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x8a #o0 0) + (def-x86-opcode movb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x88 #o0 0) + (def-x86-opcode movb ((:imm8s :insert-imm8s) (:reg8 :insert-opcode-reg)) + #xb0 nil 0) + (def-x86-opcode movb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #xc6 #o000 0) + + ;; movd + (def-x86-opcode (movd :cpu64) ((:reg64 :insert-modrm-rm) (:regmmx :insert-mmx-reg)) + #x0f6e #o300 #x48) + (def-x86-opcode movd ((:reg32 :insert-modrm-rm) (:regmmx :insert-mmx-reg)) + #x0f6e #o300 0) + (def-x86-opcode movd ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0f6e #o000 0) + (def-x86-opcode movd ((:regmmx :insert-mmx-reg) (:reg64 :insert-modrm-rm)) + #x0f7e #o300 #x48) + (def-x86-opcode movd ((:regmmx :insert-mmx-reg) (:reg32 :insert-modrm-rm)) + #x0f7e #o300 #x0) + (def-x86-opcode movd ((:regmmx :insert-mmx-reg) (:anymem :insert-memory)) + #x0f7e #o000 #x0) + + (def-x86-opcode (movd :cpu64) ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f6e #o300 #x48 #x66) + (def-x86-opcode movd ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f6e #o300 0 #x66) + (def-x86-opcode movd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f6e #o000 0 #x66) + (def-x86-opcode (movd :cpu64) ((:regxmm :insert-xmm-reg) (:reg64 :insert-modrm-rm)) + #x0f7e #o300 #x48 #x66) + (def-x86-opcode movd ((:regxmm :insert-xmm-reg) (:reg32 :insert-modrm-rm)) + #x0f7e #o300 #x0 #x66) + (def-x86-opcode movd ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f7e #o000 #x0 #x66) + + ;; movdqa + (def-x86-opcode (movdqa :cpu64) ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f7f #o300 #x0 #x66) + (def-x86-opcode (movdqa :cpu64) ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f6f #o000 #x0 #x66) + + + ;; sign-extending mov + (def-x86-opcode movsbl ((:reg8 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbe #o300 0) + (def-x86-opcode movsbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbe #o000 0) + (def-x86-opcode movsbw ((:reg8 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fbe #o300 0 #x66) + (def-x86-opcode movsbw ((:anymem :insert-memory) (:reg16 :insert-modrm-rm)) + #x0fbe #o300 0 #x66) + (def-x86-opcode (movsbq :cpu64) ((:reg8 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbe #o300 #x48) + (def-x86-opcode (movsbq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbe #o000 #x48) + (def-x86-opcode movswl ((:reg16 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fbf #o300 0) + (def-x86-opcode movswl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fbf #o000 0) + (def-x86-opcode (movswq :cpu64) ((:reg16 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fbf #o300 #x48) + (def-x86-opcode (movswq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fbf #o000 #x48) + (def-x86-opcode (movslq :cpu64) ((:reg32 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x63 #o300 #x48) + (def-x86-opcode (movslq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x63 #o000 #x48) + + ;; zero-extending MOVs + (def-x86-opcode movzbl ((:reg8 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fb6 #o300 0) + (def-x86-opcode movzbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fb6 #o000 0) + (def-x86-opcode movzbw ((:reg8 :insert-modrm-rm) (:reg16 :insert-modrm-reg)) + #x0fb6 #o300 0 #x66) + (def-x86-opcode movzbw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0fb6 #o300 0 #x66) + (def-x86-opcode movzwl ((:reg16 :insert-modrm-rm) (:reg32 :insert-modrm-reg)) + #x0fb7 #o300 0) + (def-x86-opcode movzwl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0fb7 #o000 0) + (def-x86-opcode (movzbq :cpu64) ((:reg8 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fb6 #o300 #x48) + (def-x86-opcode (movzbq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fb6 #o000 #x48) + (def-x86-opcode (movzwq :cpu64) ((:reg16 :insert-modrm-rm) (:reg64 :insert-modrm-reg)) + #x0fb7 #o300 #x48) + (def-x86-opcode (movzwq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0fb7 #o000 #x48) + + ;; mul + (def-x86-opcode (mulq :cpu64) ((:reg64 :insert-modrm-rm)) + #xf7 #o340 #x48) + (def-x86-opcode (mulq :cpu64) ((:anymem :insert-memory)) + #xf7 #o040 #x48) + + (def-x86-opcode mull ((:reg32 :insert-modrm-rm)) + #xf7 #o340 #x00) + (def-x86-opcode mull ((:anymem :insert-memory)) + #xf7 #o040 #x00) + + (def-x86-opcode mulw ((:reg16 :insert-modrm-rm)) + #xf7 #o340 #x00 #x66) + (def-x86-opcode mulw ((:anymem :insert-memory)) + #xf7 #o040 #x00 #x66) + + (def-x86-opcode mulb ((:reg8 :insert-modrm-rm)) + #xf6 #o340 #x00) + (def-x86-opcode mull ((:anymem :insert-memory)) + #xf6 #o040 #x00) + + ;; neg + (def-x86-opcode (negq :cpu64) ((:reg64 :insert-modrm-rm)) + #xf7 #o330 #x48) + (def-x86-opcode (negq :cpu64) ((:anymem :insert-memory)) + #xf7 #o030 #x48) + + (def-x86-opcode negl ((:reg32 :insert-modrm-rm)) + #xf7 #o330 #x00) + (def-x86-opcode negl ((:anymem :insert-memory)) + #xf7 #o030 #x00) + + (def-x86-opcode negw ((:reg16 :insert-modrm-rm)) + #xf7 #o330 #x00 #x66) + (def-x86-opcode negw ((:anymem :insert-memory)) + #xf7 #o030 #x00 #x66) + + (def-x86-opcode negb ((:reg8 :insert-modrm-rm)) + #xf6 #o330 #x00) + (def-x86-opcode negb ((:anymem :insert-memory)) + #xf6 #o030 #x00) + + ;; nop + (def-x86-opcode nop () + #x90 nil nil) + + ;; not + (def-x86-opcode (notq :cpu64) ((:reg64 :insert-modrm-rm)) + #xf7 #o320 #x48) + (def-x86-opcode (notq :cpu64) ((:anymem :insert-memory)) + #xf7 #o020 #x48) + (def-x86-opcode notl ((:reg32 :insert-modrm-rm)) + #xf7 #o320 #x0) + (def-x86-opcode notl ((:anymem :insert-memory)) + #xf7 #o020 #x0) + (def-x86-opcode notw ((:reg16 :insert-modrm-rm)) + #xf7 #o320 #x0 #x66) + (def-x86-opcode notw ((:anymem :insert-memory)) + #xf7 #o020 #x0 #x66) + (def-x86-opcode notb ((:reg8 :insert-modrm-rm)) + #xf6 #o320 #x0) + (def-x86-opcode notb ((:anymem :insert-memory)) + #xf6 #o020 #x0) + + ;; or + (def-x86-opcode (orq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x09 #o300 #x48) + (def-x86-opcode (orq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0b #o000 #x48) + (def-x86-opcode (orq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x09 #x00 #x48) + (def-x86-opcode (orq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o310 #x48) + (def-x86-opcode (orq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x0d nil #x48) + (def-x86-opcode (orq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o310 #x48) + (def-x86-opcode (orq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o010 #x48) + (def-x86-opcode (orq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o010 #x48) + + (def-x86-opcode orl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x09 #o300 #x00) + (def-x86-opcode orl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0b #o000 #x00) + (def-x86-opcode orl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x09 #x00 #x00) + (def-x86-opcode orl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o310 #x00) + (def-x86-opcode orl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x0d nil nil) + (def-x86-opcode orl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o310 #x00) + (def-x86-opcode orl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o010 #x00) + (def-x86-opcode orl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o010 #x00) + + (def-x86-opcode orw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x09 #o300 #x00 #x66) + (def-x86-opcode orw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x0b #o000 #x00 #x66) + (def-x86-opcode orw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x09 #x00 #x00 #x66) + (def-x86-opcode orw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o310 #x00 #x66) + (def-x86-opcode orw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x0d nil nil #x66) + (def-x86-opcode orw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o310 #x00 #x66) + (def-x86-opcode orw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o010 #x00 #x66) + (def-x86-opcode orw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o010 #x00 #x66) + + (def-x86-opcode orb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x08 #o300 #x00) + (def-x86-opcode orb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x0a #o000 #x00) + (def-x86-opcode orb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x08 #x00 #x00) + (def-x86-opcode orb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x0c nil nil) + (def-x86-opcode orb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o310 #x00) + (def-x86-opcode orb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o310 #x00) + (def-x86-opcode orb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o010 #x00) + + ;; pop + (def-x86-opcode (popq :cpu64) ((:reg64 :insert-opcode-reg)) + #x58 nil #x0) + (def-x86-opcode (popq :cpu64) ((:anymem :insert-memory)) + #x8f #o000 #x0) + + (def-x86-opcode (popl :cpuno64) ((:reg32 :insert-opcode-reg)) + #x58 nil nil) + (def-x86-opcode (popl :cpuno64) ((:anymem :insert-memory)) + #x8f #o000 nil) + + (def-x86-opcode popw ((:reg16 :insert-opcode-reg)) + #x58 nil #x0 #x66) + (def-x86-opcode popw ((:anymem :insert-memory)) + #x8f #o000 #x0 #x66) + + ;; popf + (def-x86-opcode (popfq :cpu64) () + #x9d nil #x48) + (def-x86-opcode popfl () + #x9d nil nil) + + ;; push . It's not clear how "pushw $imm16" is encoded. + (def-x86-opcode (pushq :cpu64) ((:reg64 :insert-opcode-reg)) + #x50 nil #x0) + (def-x86-opcode (pushq :cpu64) ((:anymem :insert-memory)) + #xff #o060 #x0) + (def-x86-opcode (pushq :cpu64) ((:imm8s :insert-imm8s)) + #x6a nil nil) + (def-x86-opcode (pushq :cpu64) ((:imm32s :insert-imm32s)) + #x68 nil nil) + + (def-x86-opcode (pushl :cpuno64) ((:reg32 :insert-opcode-reg)) + #x50 nil nil) + (def-x86-opcode (pushl :cpuno64) ((:anymem :insert-memory)) + #xff #o060 nil) + (def-x86-opcode (pushl :cpuno64) ((:imm8s :insert-imm8s)) + #x6a nil nil) + (def-x86-opcode (pushl :cpuno64) ((:imm32s :insert-imm32s)) + #x68 nil nil) + + (def-x86-opcode pushw ((:reg16 :insert-opcode-reg)) + #x50 nil 0 #x66) + (def-x86-opcode pushw ((:anymem :insert-memory)) + #xff #o060 #x0 #x66) + + ;; pushf + (def-x86-opcode (pushfq :cpu64) () + #x9c nil nil) + (def-x86-opcode (pushfl :cpuno64) () + #x9c nil nil) + (def-x86-opcode pushfw () + #x9c nil nil #x66) + + ;; rcl. Note that the :ShiftCount operand type only matches %cl. + (def-x86-opcode (rclq :cpu64) ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o320 #x48) + (def-x86-opcode (rclq :cpu64) ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o020 #x48) + (def-x86-opcode (rclq :cpu64) ((:reg64 :insert-modrm-rm)) + #xd1 #o320 #x48) + (def-x86-opcode (rclq :cpu64) ((:anymem :insert-memory)) + #xd1 #o020 #x48) + (def-x86-opcode (rclq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o320 #x48) + (def-x86-opcode (rclq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o320 #x48) + + (def-x86-opcode rcll ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o320 #x0) + (def-x86-opcode rcll ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o020 #x0) + (def-x86-opcode rcll ((:reg32 :insert-modrm-rm)) + #xd1 #o320 #x0) + (def-x86-opcode rcll ((:anymem :insert-memory)) + #xd1 #o020 #x0) + (def-x86-opcode rcll ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o320 #x0) + (def-x86-opcode rcll ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o320 #x0) + + (def-x86-opcode rclw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o320 #x0 #x66) + (def-x86-opcode rclw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o020 #x0 #x66) + (def-x86-opcode rclw ((:reg16 :insert-modrm-rm)) + #xd1 #o320 #x0 #x66) + (def-x86-opcode rclw ((:anymem :insert-memory)) + #xd1 #o020 #x0 #x66) + (def-x86-opcode rclw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o320 #x0 #x66) + (def-x86-opcode rclw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o320 #x0 #x66) + + (def-x86-opcode rclb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o320 #x0) + (def-x86-opcode rclb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o020 #x0) + (def-x86-opcode rclb ((:reg8 :insert-modrm-rm)) + #xd0 #o320 #x0) + (def-x86-opcode rclb ((:anymem :insert-memory)) + #xd0 #o020 #x0) + (def-x86-opcode rclb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o320 #x0) + (def-x86-opcode rclb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o320 #x0) + + ;; rcr + (def-x86-opcode (rcrq :cpu64) ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o330 #x48) + (def-x86-opcode (rcrq :cpu64) ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o030 #x48) + (def-x86-opcode (rcrq :cpu64) ((:reg64 :insert-modrm-rm)) + #xd1 #o330 #x48) + (def-x86-opcode (rcrq :cpu64) ((:anymem :insert-memory)) + #xd1 #o030 #x48) + (def-x86-opcode (rcrq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o330 #x48) + (def-x86-opcode (rcrq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o330 #x48) + + (def-x86-opcode rcrl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o330 #x0) + (def-x86-opcode rcrl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o030 #x0) + (def-x86-opcode rcrl ((:reg32 :insert-modrm-rm)) + #xd1 #o330 #x0) + (def-x86-opcode rcrl ((:anymem :insert-memory)) + #xd1 #o030 #x0) + (def-x86-opcode rcrl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o330 #x0) + (def-x86-opcode rcrl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o330 #x0) + + (def-x86-opcode rcrw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o330 #x0 #x66) + (def-x86-opcode rcrw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o030 #x0 #x66) + (def-x86-opcode rcrw ((:reg16 :insert-modrm-rm)) + #xd1 #o330 #x0 #x66) + (def-x86-opcode rcrw ((:anymem :insert-memory)) + #xd1 #o030 #x0 #x66) + (def-x86-opcode rcrw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o330 #x0 #x66) + (def-x86-opcode rcrw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o330 #x0 #x66) + + (def-x86-opcode rcrb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o330 #x0) + (def-x86-opcode rcrb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o030 #x0) + (def-x86-opcode rcrb ((:reg8 :insert-modrm-rm)) + #xd0 #o330 #x0) + (def-x86-opcode rcrb ((:anymem :insert-memory)) + #xd0 #o030 #x0) + (def-x86-opcode rcrb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o330 #x0) + (def-x86-opcode rcrb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o330 #x0) + + ;; repe, repne. These are really prefixes, that should + ;; only be used before string instructions. + (def-x86-opcode repe () + #xf3 nil nil) + + (def-x86-opcode repne () + #xf2 nil nil) + + ;; ret + (def-x86-opcode ret () + #xc3 nil nil) + + (def-x86-opcode ret ((:imm16 :insert-imm16)) + #xc2 nil nil) + + ;; rol + (def-x86-opcode (rolq :cpu64) ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o300 #x48) + (def-x86-opcode (rolq :cpu64) ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o000 #x48) + (def-x86-opcode (rolq :cpu64) ((:reg64 :insert-modrm-rm)) + #xd1 #o300 #x48) + (def-x86-opcode (rolq :cpu64) ((:anymem :insert-memory)) + #xd1 #o000 #x48) + (def-x86-opcode (rolq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o300 #x48) + (def-x86-opcode (rolq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o300 #x48) + + (def-x86-opcode roll ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o300 #x0) + (def-x86-opcode roll ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o000 #x0) + (def-x86-opcode roll ((:reg32 :insert-modrm-rm)) + #xd1 #o300 #x0) + (def-x86-opcode roll ((:anymem :insert-memory)) + #xd1 #o000 #x0) + (def-x86-opcode roll ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o300 #x0) + (def-x86-opcode roll ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o300 #x0) + + (def-x86-opcode rolw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o300 #x0 #x66) + (def-x86-opcode rolw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o000 #x0 #x66) + (def-x86-opcode rolw ((:reg16 :insert-modrm-rm)) + #xd1 #o300 #x0 #x66) + (def-x86-opcode rolw ((:anymem :insert-memory)) + #xd1 #o000 #x0 #x66) + (def-x86-opcode rolw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o300 #x0 #x66) + (def-x86-opcode rolw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o300 #x0 #x66) + + (def-x86-opcode rolb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o300 #x0) + (def-x86-opcode rolb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o000 #x0) + (def-x86-opcode rolb ((:reg8 :insert-modrm-rm)) + #xd0 #o300 #x0) + (def-x86-opcode rolb ((:anymem :insert-memory)) + #xd0 #o000 #x0) + (def-x86-opcode rolb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o300 #x0) + (def-x86-opcode rolb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o300 #x0) + + ;; ror + (def-x86-opcode (rorq :cpu64) ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o310 #x48) + (def-x86-opcode (rorq :cpu64) ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o010 #x48) + (def-x86-opcode (rorq :cpu64) ((:reg64 :insert-modrm-rm)) + #xd1 #o310 #x48) + (def-x86-opcode (rorq :cpu64) ((:anymem :insert-memory)) + #xd1 #o010 #x48) + (def-x86-opcode (rorq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o310 #x48) + (def-x86-opcode (rorq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o310 #x48) + + (def-x86-opcode rorl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o310 #x0) + (def-x86-opcode rorl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o010 #x0) + (def-x86-opcode rorl ((:reg32 :insert-modrm-rm)) + #xd1 #o310 #x0) + (def-x86-opcode rorl ((:anymem :insert-memory)) + #xd1 #o010 #x0) + (def-x86-opcode rorl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o310 #x0) + (def-x86-opcode rorl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o310 #x0) + + (def-x86-opcode rorw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o310 #x0 #x66) + (def-x86-opcode rorw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o010 #x0 #x66) + (def-x86-opcode rorw ((:reg16 :insert-modrm-rm)) + #xd1 #o310 #x0 #x66) + (def-x86-opcode rorw ((:anymem :insert-memory)) + #xd1 #o010 #x0 #x66) + (def-x86-opcode rorw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o310 #x0 #x66) + (def-x86-opcode rorw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o310 #x0 #x66) + + (def-x86-opcode rorb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o310 #x0) + (def-x86-opcode rorb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o010 #x0) + (def-x86-opcode rorb ((:reg8 :insert-modrm-rm)) + #xd0 #o310 #x0) + (def-x86-opcode rorb ((:anymem :insert-memory)) + #xd0 #o010 #x0) + (def-x86-opcode rorb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o310 #x0) + (def-x86-opcode rorb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o310 #x0) + + ;; sar + (def-x86-opcode (sarq :cpu64) ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o370 #x48) + (def-x86-opcode (sarq :cpu64) ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o070 #x48) + (def-x86-opcode (sarq :cpu64) ((:reg64 :insert-modrm-rm)) + #xd1 #o370 #x48) + (def-x86-opcode (sarq :cpu64) ((:anymem :insert-memory)) + #xd1 #o070 #x48) + (def-x86-opcode (sarq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o370 #x48) + (def-x86-opcode (sarq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o370 #x48) + + (def-x86-opcode sarl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o370 #x0) + (def-x86-opcode sarl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o070 #x0) + (def-x86-opcode sarl ((:reg32 :insert-modrm-rm)) + #xd1 #o370 #x0) + (def-x86-opcode sarl ((:anymem :insert-memory)) + #xd1 #o070 #x0) + (def-x86-opcode sarl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o370 #x0) + (def-x86-opcode sarl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o370 #x0) + + (def-x86-opcode sarw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o370 #x0 #x66) + (def-x86-opcode sarw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o070 #x0 #x66) + (def-x86-opcode sarw ((:reg16 :insert-modrm-rm)) + #xd1 #o370 #x0 #x66) + (def-x86-opcode sarw ((:anymem :insert-memory)) + #xd1 #o070 #x0 #x66) + (def-x86-opcode sarw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o370 #x0 #x66) + (def-x86-opcode sarw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o370 #x0 #x66) + + (def-x86-opcode sarb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o370 #x0) + (def-x86-opcode sarb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o070 #x0) + (def-x86-opcode sarb ((:reg8 :insert-modrm-rm)) + #xd0 #o370 #x0) + (def-x86-opcode sarb ((:anymem :insert-memory)) + #xd0 #o070 #x0) + (def-x86-opcode sarb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o370 #x0) + (def-x86-opcode sarb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o370 #x0) + + ;; sbb + (def-x86-opcode (sbbq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x19 #o300 #x48) + (def-x86-opcode (sbbq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x1b #o000 #x48) + (def-x86-opcode (sbbq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x19 #x00 #x48) + (def-x86-opcode (sbbq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o330 #x48) + (def-x86-opcode (sbbq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x1d nil #x48) + (def-x86-opcode (sbbq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o330 #x48) + (def-x86-opcode (sbbq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o030 #x48) + (def-x86-opcode (sbbq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o030 #x48) + + (def-x86-opcode sbbl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x19 #o300 #x00) + (def-x86-opcode sbbl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x1b #o000 #x00) + (def-x86-opcode sbbl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x19 #x00 #x00) + (def-x86-opcode sbbl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o330 #x00) + (def-x86-opcode sbbl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x1d nil nil) + (def-x86-opcode sbbl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o330 #x00) + (def-x86-opcode sbbl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o030 #x00) + (def-x86-opcode sbbl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o030 #x00) + + (def-x86-opcode sbbw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x19 #o300 #x00 #x66) + (def-x86-opcode sbbw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x1b #o000 #x00 #x66) + (def-x86-opcode sbbw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x19 #x00 #x00 #x66) + (def-x86-opcode sbbw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o330 #x00 #x66) + (def-x86-opcode sbbw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x1d nil nil #x66) + (def-x86-opcode sbbw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o330 #x00 #x66) + (def-x86-opcode sbbw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o030 #x00 #x66) + (def-x86-opcode sbbw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o030 #x00 #x66) + + (def-x86-opcode sbbb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x18 #o300 #x00) + (def-x86-opcode sbbb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x1a #o000 #x00) + (def-x86-opcode sbbb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x18 #x00 #x00) + (def-x86-opcode sbbb ((:imm8 :insert-imm8) (:acc :insert-nothing)) + #x1c nil nil) + (def-x86-opcode sbbb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o330 #x00) + (def-x86-opcode sbbb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o330 #x00) + (def-x86-opcode sbbb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o030 #x00) + + ;; scas + (def-x86-opcode (scasq :cpu64) () + #xaf nil #x48) + (def-x86-opcode scasl () + #xaf nil nil) + (def-x86-opcode scasw () + #xaf nil nil #x66) + (def-x86-opcode scasb () + #xae nil nil) + + + ;; setcc + (def-x86-opcode setcc ((:imm8 :insert-cc) (:reg8 :insert-modrm-rm)) + #x0f90 #o300 0) + (def-x86-opcode seto ((:reg8 :insert-modrm-rm)) + #x0f90 #o300 0) + (def-x86-opcode seto ((:anymem :insert-memory)) + #x0f90 #o000 0) + (def-x86-opcode setno ((:reg8 :insert-modrm-rm)) + #x0f91 #o300 0) + (def-x86-opcode setno ((:anymem :insert-memory)) + #x0f91 #o000 0) + (def-x86-opcode setb ((:reg8 :insert-modrm-rm)) + #x0f92 #o300 0) + (def-x86-opcode setb ((:anymem :insert-memory)) + #x0f92 #o000 0) + (def-x86-opcode setc ((:reg8 :insert-modrm-rm)) + #x0f92 #o300 0) + (def-x86-opcode setc ((:anymem :insert-memory)) + #x0f92 #o000 0) + (def-x86-opcode setae ((:reg8 :insert-modrm-rm)) + #x0f93 #o300 0) + (def-x86-opcode setae ((:anymem :insert-memory)) + #x0f93 #o000 0) + (def-x86-opcode sete ((:reg8 :insert-modrm-rm)) + #x0f94 #o300 0) + (def-x86-opcode sete ((:anymem :insert-memory)) + #x0f94 #o000 0) + (def-x86-opcode setne ((:reg8 :insert-modrm-rm)) + #x0f95 #o300 0) + (def-x86-opcode setne ((:anymem :insert-memory)) + #x0f95 #o000 0) + (def-x86-opcode setbe ((:reg8 :insert-modrm-rm)) + #x0f96 #o300 0) + (def-x86-opcode setbe ((:anymem :insert-memory)) + #x0f96 #o000 0) + (def-x86-opcode seta ((:reg8 :insert-modrm-rm)) + #x0f97 #o300 0) + (def-x86-opcode seta ((:anymem :insert-memory)) + #x0f97 #o000 0) + (def-x86-opcode sets ((:reg8 :insert-modrm-rm)) + #x0f98 #o300 0) + (def-x86-opcode sets ((:anymem :insert-memory)) + #x0f98 #o000 0) + (def-x86-opcode setns ((:reg8 :insert-modrm-rm)) + #x0f99 #o300 0) + (def-x86-opcode setns ((:anymem :insert-memory)) + #x0f99 #o000 0) + (def-x86-opcode setpe ((:reg8 :insert-modrm-rm)) + #x0f9a #o300 0) + (def-x86-opcode setpe ((:anymem :insert-memory)) + #x0f9a #o000 0) + (def-x86-opcode setpo ((:reg8 :insert-modrm-rm)) + #x0f9b #o300 0) + (def-x86-opcode setpo ((:anymem :insert-memory)) + #x0f9b #o000 0) + (def-x86-opcode setl ((:reg8 :insert-modrm-rm)) + #x0f9c #o300 0) + (def-x86-opcode setl ((:anymem :insert-memory)) + #x0f9c #o000 0) + (def-x86-opcode setge ((:reg8 :insert-modrm-rm)) + #x0f9d #o300 0) + (def-x86-opcode setge ((:anymem :insert-memory)) + #x0f9d #o000 0) + (def-x86-opcode setle ((:reg8 :insert-modrm-rm)) + #x0f9e #o300 0) + (def-x86-opcode setle ((:anymem :insert-memory)) + #x0f9e #o000 0) + (def-x86-opcode setg ((:reg8 :insert-modrm-rm)) + #x0f9f #o300 0) + (def-x86-opcode setg ((:anymem :insert-memory)) + #x0f9f #o000 0) + + ;; shl + (def-x86-opcode (shlq :cpu64) ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o340 #x48) + (def-x86-opcode (shlq :cpu64) ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o040 #x48) + (def-x86-opcode (shlq :cpu64) ((:reg64 :insert-modrm-rm)) + #xd1 #o340 #x48) + (def-x86-opcode (shlq :cpu64) ((:anymem :insert-memory)) + #xd1 #o040 #x48) + (def-x86-opcode (shlq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o340 #x48) + (def-x86-opcode (shlq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o340 #x48) + + (def-x86-opcode shll ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o340 #x0) + (def-x86-opcode shll ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o040 #x0) + (def-x86-opcode shll ((:reg32 :insert-modrm-rm)) + #xd1 #o340 #x0) + (def-x86-opcode shll ((:anymem :insert-memory)) + #xd1 #o040 #x0) + (def-x86-opcode shll ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o340 #x0) + (def-x86-opcode shll ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o340 #x0) + + (def-x86-opcode shlw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o340 #x0 #x66) + (def-x86-opcode shlw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o040 #x0 #x66) + (def-x86-opcode shlw ((:reg16 :insert-modrm-rm)) + #xd1 #o340 #x0 #x66) + (def-x86-opcode shlw ((:anymem :insert-memory)) + #xd1 #o040 #x0 #x66) + (def-x86-opcode shlw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o340 #x0 #x66) + (def-x86-opcode shlw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o340 #x0 #x66) + + (def-x86-opcode shlb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o340 #x0) + (def-x86-opcode shlb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o040 #x0) + (def-x86-opcode shlb ((:reg8 :insert-modrm-rm)) + #xd0 #o340 #x0) + (def-x86-opcode shlb ((:anymem :insert-memory)) + #xd0 #o040 #x0) + (def-x86-opcode shlb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o340 #x0) + (def-x86-opcode shlb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o340 #x0) + + ;; shld + (def-x86-opcode (shldq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa4 #o300 #x48) + (def-x86-opcode (shldq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa4 #o000 #x48) + (def-x86-opcode (shldq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x48) + (def-x86-opcode (shldq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x48) + (def-x86-opcode (shldq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fa5 #o300 #x48) + (def-x86-opcode (shldq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x48) + + (def-x86-opcode shldl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fa4 #o300 #x0) + (def-x86-opcode shldl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa4 #o000 #x0) + (def-x86-opcode shldl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fa5 #o300 #x0) + (def-x86-opcode shldl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0) + (def-x86-opcode shldl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fa5 #o300 #x0) + (def-x86-opcode shldl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0) + + (def-x86-opcode shldw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fa4 #o300 #x0 #x66) + (def-x86-opcode shldw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa4 #o000 #x0 #x66) + (def-x86-opcode shldw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fa5 #o300 #x0 #x66) + (def-x86-opcode shldw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0 #x66) + (def-x86-opcode shldw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fa5 #o300 #x0 #x66) + (def-x86-opcode shldw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fa5 #o000 #x0 #x66) + + ;; shr + (def-x86-opcode (shrq :cpu64) ((:imm1 :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd1 #o350 #x48) + (def-x86-opcode (shrq :cpu64) ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o050 #x48) + (def-x86-opcode (shrq :cpu64) ((:reg64 :insert-modrm-rm)) + #xd1 #o350 #x48) + (def-x86-opcode (shrq :cpu64) ((:anymem :insert-memory)) + #xd1 #o050 #x48) + (def-x86-opcode (shrq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-rm)) + #xc1 #o350 #x48) + (def-x86-opcode (shrq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-rm)) + #xd3 #o350 #x48) + + (def-x86-opcode shrl ((:imm1 :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd1 #o350 #x0) + (def-x86-opcode shrl ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o050 #x0) + (def-x86-opcode shrl ((:reg32 :insert-modrm-rm)) + #xd1 #o350 #x0) + (def-x86-opcode shrl ((:anymem :insert-memory)) + #xd1 #o050 #x0) + (def-x86-opcode shrl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-rm)) + #xc1 #o350 #x0) + (def-x86-opcode shrl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-rm)) + #xd3 #o350 #x0) + + (def-x86-opcode shrw ((:imm1 :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd1 #o350 #x0 #x66) + (def-x86-opcode shrw ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd1 #o050 #x0 #x66) + (def-x86-opcode shrw ((:reg16 :insert-modrm-rm)) + #xd1 #o350 #x0 #x66) + (def-x86-opcode shrw ((:anymem :insert-memory)) + #xd1 #o050 #x0 #x66) + (def-x86-opcode shrw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-rm)) + #xc1 #o350 #x0 #x66) + (def-x86-opcode shrw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-rm)) + #xd3 #o350 #x0 #x66) + + (def-x86-opcode shrb ((:imm1 :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd0 #o350 #x0) + (def-x86-opcode shrb ((:imm1 :insert-nothing) (:anymem :insert-memory)) + #xd0 #o050 #x0) + (def-x86-opcode shrb ((:reg8 :insert-modrm-rm)) + #xd0 #o350 #x0) + (def-x86-opcode shrb ((:anymem :insert-memory)) + #xd0 #o050 #x0) + (def-x86-opcode shrb ((:imm8 :insert-imm8) (:reg8 :insert-modrm-rm)) + #xc0 #o350 #x0) + (def-x86-opcode shrb ((:shiftcount :insert-nothing) (:reg8 :insert-modrm-rm)) + #xd2 #o350 #x0) + + ;; shrd + (def-x86-opcode (shrdq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fac #o300 #x48) + (def-x86-opcode (shrdq :cpu64) ((:imm8 :insert-imm8) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fac #o000 #x48) + (def-x86-opcode (shrdq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x48) + (def-x86-opcode (shrdq :cpu64) ((:shiftcount :insert-nothing) (:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x48) + (def-x86-opcode (shrdq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fad #o300 #x48) + (def-x86-opcode (shrdq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x48) + + (def-x86-opcode shrdl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fac #o300 #x0) + (def-x86-opcode shrdl ((:imm8 :insert-imm8) (:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fac #o000 #x0) + (def-x86-opcode shrdl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fad #o300 #x0) + (def-x86-opcode shrdl ((:shiftcount :insert-nothing) (:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0) + (def-x86-opcode shrdl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fad #o300 #x0) + (def-x86-opcode shrdl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0) + + (def-x86-opcode shrdw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fac #o300 #x0 #x66) + (def-x86-opcode shrdw ((:imm8 :insert-imm8) (:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fac #o000 #x0 #x66) + (def-x86-opcode shrdw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fad #o300 #x0 #x66) + (def-x86-opcode shrdw ((:shiftcount :insert-nothing) (:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0 #x66) + (def-x86-opcode shrdw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fad #o300 #x0 #x66) + (def-x86-opcode shrdw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fad #o000 #x0 #x66) + + ;; stc + (def-x86-opcode stc () + #xf9 nil nil) + + ;; std + (def-x86-opcode std () + #xfd nil nil) + + ;; sub + (def-x86-opcode (subq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x29 #o300 #x48) + (def-x86-opcode (subq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x2b #o000 #x48) + (def-x86-opcode (subq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x29 #x00 #x48) + (def-x86-opcode (subq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o350 #x48) + (def-x86-opcode (subq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x2d nil #x48) + (def-x86-opcode (subq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o350 #x48) + (def-x86-opcode (subq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o050 #x48) + (def-x86-opcode (subq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o050 #x48) + + (def-x86-opcode subl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x29 #o300 #x00) + (def-x86-opcode subl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x2b #o000 #x00) + (def-x86-opcode subl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x29 #x00 #x00) + (def-x86-opcode subl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o350 #x00) + (def-x86-opcode subl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x2d nil nil) + (def-x86-opcode subl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o350 #x00) + (def-x86-opcode subl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o050 #x00) + (def-x86-opcode subl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o050 #x00) + + (def-x86-opcode subw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x29 #o300 #x00 #x66) + (def-x86-opcode subw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x2b #o000 #x00 #x66) + (def-x86-opcode subw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x29 #x00 #x00 #x66) + (def-x86-opcode subw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o350 #x00 #x66) + (def-x86-opcode subw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x2d nil nil #x66) + (def-x86-opcode subw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o350 #x00 #x66) + (def-x86-opcode subw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o050 #x00 #x66) + (def-x86-opcode subw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o050 #x00 #x66) + + (def-x86-opcode subb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x28 #o300 #x00) + (def-x86-opcode subb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x2a #o000 #x00) + (def-x86-opcode subb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x2a #x00 #x00) + (def-x86-opcode subb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x2c nil nil) + (def-x86-opcode subb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o350 #x00) + (def-x86-opcode subb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o350 #x00) + (def-x86-opcode subb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o050 #x00) + + ;; syscall + (def-x86-opcode (syscall :cpu64) () + #x0f0f nil nil) + + ;; test + (def-x86-opcode (testq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x85 #o300 #x48) + (def-x86-opcode (testq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x85 #o000 #x48) + (def-x86-opcode (testq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x85 #o000 #x48) + (def-x86-opcode (testq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #xa9 nil #x48) + (def-x86-opcode (testq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #xf7 #o300 #x48) + (def-x86-opcode (testq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xf7 #o000 #x48) + + (def-x86-opcode testl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x85 #o300 #x00) + (def-x86-opcode testl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x85 #o000 #x00) + (def-x86-opcode testl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x85 #o000 #x00) + (def-x86-opcode testl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #xa9 nil #x00) + (def-x86-opcode testl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #xf7 #o300 #x00) + (def-x86-opcode testl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #xf7 #o000 #x00) + + + (def-x86-opcode testw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x85 #o300 #x00 #x66) + (def-x86-opcode testw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x85 #o000 #x00 #x66) + (def-x86-opcode testw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x85 #o000 #x00 #x66) + (def-x86-opcode testw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #xa9 nil #x00 #x66) + (def-x86-opcode testw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #xf7 #o300 #x00 #x66) + (def-x86-opcode testw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #xf7 #o000 #x00 #x66) + + + (def-x86-opcode testb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x84 #o300 #x00) + (def-x86-opcode testb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x84 #o000 #x00) + (def-x86-opcode testb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x84 #o000 #x00) + (def-x86-opcode testb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #xa8 nil #x00) + (def-x86-opcode testb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #xf6 #o300 #x00) + (def-x86-opcode testb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #xf6 #o000 #x00) + + ;; ud2a (not to be confused with all of the other undefined/accidental + ;; instructions) is "officially undefined". + (def-x86-opcode ud2a () + #x0f0b nil nil) + + (def-x86-opcode ud2b () + #x0fb9 nil nil) + + ;; xadd + (def-x86-opcode (xaddq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x0fc1 #o300 #x48) + (def-x86-opcode (xaddq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fc1 #o000 #x48) + + (def-x86-opcode xaddl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x0fc1 #o300 #x00) + (def-x86-opcode xaddl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fc1 #o000 #x00) + + (def-x86-opcode xaddw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x0fc1 #o300 #x00 #x66) + (def-x86-opcode xaddw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fc1 #o000 #x00 #x66) + + (def-x86-opcode xaddb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x0fc0 #o300 #x00) + (def-x86-opcode xaddb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x0fc0 #o000 #x00) + + ;; xchg + ;; Allegedly, using the opcode #x9x to implement "(xchg (% eax) (% eax))" + ;; doesn't zero-extend eax to rax on x86-64. (So don't special-case + ;; :acc as source or destination, and use #x86 and a modrm byte in all cases.) + (def-x86-opcode (xchgq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x87 #o300 #x48) + (def-x86-opcode (xchgq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x87 #o000 #x48) + (def-x86-opcode (xchgq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x87 #o000 #x48) + + (def-x86-opcode xchgl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x87 #o300 #x00) + (def-x86-opcode xchgl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x87 #o000 #x00) + (def-x86-opcode xchgl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x87 #o000 #x00) + + (def-x86-opcode xchgw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x87 #o300 #x00 #x66) + (def-x86-opcode xchgw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x87 #o000 #x00 #x66) + (def-x86-opcode xchgw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x87 #o000 #x00 #x66) + + (def-x86-opcode xchgb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x86 #o300 #x00) + (def-x86-opcode xchgb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x86 #o000 #x00) + (def-x86-opcode xchgb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x86 #o000 #x00) + + ;; xlat + + (def-x86-opcode xlatb () + #xd7 nil nil) + + ;; xor + (def-x86-opcode (xorq :cpu64) ((:reg64 :insert-modrm-reg) (:reg64 :insert-modrm-rm)) + #x31 #o300 #x48) + (def-x86-opcode (xorq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x33 #o000 #x48) + (def-x86-opcode (xorq :cpu64) ((:reg64 :insert-modrm-reg) (:anymem :insert-memory)) + #x31 #x00 #x48) + (def-x86-opcode (xorq :cpu64) ((:imm8s :insert-imm8s) (:reg64 :insert-modrm-rm)) + #x83 #o360 #x48) + (def-x86-opcode (xorq :cpu64) ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x35 nil #x48) + (def-x86-opcode (xorq :cpu64) ((:imm32s :insert-imm32s) (:reg64 :insert-modrm-rm)) + #x81 #o360 #x48) + (def-x86-opcode (xorq :cpu64) ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o060 #x48) + (def-x86-opcode (xorq :cpu64) ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o060 #x48) + + (def-x86-opcode xorl ((:reg32 :insert-modrm-reg) (:reg32 :insert-modrm-rm)) + #x31 #o300 #x00) + (def-x86-opcode xorl ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x33 #o000 #x00) + (def-x86-opcode xorl ((:reg32 :insert-modrm-reg) (:anymem :insert-memory)) + #x31 #x00 #x00) + (def-x86-opcode xorl ((:imm8s :insert-imm8s) (:reg32 :insert-modrm-rm)) + #x83 #o360 #x00) + (def-x86-opcode xorl ((:imm32s :insert-imm32s) (:acc :insert-nothing)) + #x35 nil nil) + (def-x86-opcode xorl ((:imm32s :insert-imm32s) (:reg32 :insert-modrm-rm)) + #x81 #o360 #x00) + (def-x86-opcode xorl ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o060 #x00) + (def-x86-opcode xorl ((:imm32s :insert-imm32s) (:anymem :insert-memory)) + #x81 #o060 #x00) + + (def-x86-opcode xorw ((:reg16 :insert-modrm-reg) (:reg16 :insert-modrm-rm)) + #x31 #o300 #x00 #x66) + (def-x86-opcode xorw ((:anymem :insert-memory) (:reg16 :insert-modrm-reg)) + #x33 #o000 #x00 #x66) + (def-x86-opcode xorw ((:reg16 :insert-modrm-reg) (:anymem :insert-memory)) + #x31 #x00 #x00 #x66) + (def-x86-opcode xorw ((:imm8s :insert-imm8s) (:reg16 :insert-modrm-rm)) + #x83 #o360 #x00 #x66) + (def-x86-opcode xorw ((:imm16 :insert-imm16) (:acc :insert-nothing)) + #x35 nil nil #x66) + (def-x86-opcode xorw ((:imm16 :insert-imm16) (:reg16 :insert-modrm-rm)) + #x81 #o360 #x00 #x66) + (def-x86-opcode xorw ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x83 #o060 #x00 #x66) + (def-x86-opcode xorw ((:imm16 :insert-imm16) (:anymem :insert-memory)) + #x81 #o060 #x00 #x66) + + (def-x86-opcode xorb ((:reg8 :insert-modrm-reg) (:reg8 :insert-modrm-rm)) + #x30 #o300 #x00) + (def-x86-opcode xorb ((:anymem :insert-memory) (:reg8 :insert-modrm-reg)) + #x32 #o000 #x00) + (def-x86-opcode xorb ((:reg8 :insert-modrm-reg) (:anymem :insert-memory)) + #x30 #x00 #x00) + (def-x86-opcode xorb ((:imm8s :insert-imm8s) (:acc :insert-nothing)) + #x34 nil nil) + (def-x86-opcode xorb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o360 #x00) + (def-x86-opcode xorb ((:imm8s :insert-imm8s) (:reg8 :insert-modrm-rm)) + #x80 #o360 #x00) + (def-x86-opcode xorb ((:imm8s :insert-imm8s) (:anymem :insert-memory)) + #x80 #o060 #x00) + + ;; fxsave + (def-x86-opcode fxsaveq ((:anymem :insert-memory)) + #x0fae #o000 0) + + ;; fxrstor + (def-x86-opcode fxrstor ((:anymem :insert-memory)) + #x0fae #o010 0) + + ;; clflush + (def-x86-opcode clflush ((:anymem :insert-memory)) + #x0fae #o070 0) + + ;; lfence + (def-x86-opcode lfence () + #x0fae #xe8 nil) + + ;; mfence + (def-x86-opcode mfence () + #x0fae #xf0 nil) + + ;; pause + (def-x86-opcode pause () + #xf390 nil nil) + + ;; I don't want to have to define all mmx/sse/sse2 instructions at the + ;; moment, but it wouldn't hurt to define those that the lisp is + ;; likely to use. + + ;; Useful mmx/sse2 instructions, other than movd/movq: + + ;; emms + (def-x86-opcode emms () + #x0f77 nil nil) + + ;; addsd + (def-x86-opcode addsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f58 #o000 #x0 #xf2) + (def-x86-opcode addsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f58 #o300 #x0 #xf2) + + ;; addss + (def-x86-opcode addss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f58 #o000 #x0 #xf3) + (def-x86-opcode addss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f58 #o300 #x0 #xf3) + + ;; subsd + (def-x86-opcode subsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5c #o000 #x0 #xf2) + (def-x86-opcode subsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5c #o300 #x0 #xf2) + + ;; subss + (def-x86-opcode subss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5c #o000 #x0 #xf3) + (def-x86-opcode subss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5c #o300 #x0 #xf3) + + ;; movapd + (def-x86-opcode movapd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f28 #o300 #x0 #x66) + (def-x86-opcode movapd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f28 #o000 #x0 #x66) + (def-x86-opcode movapd ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f29 #o000 #x0 #x66) + + ;; movaps + (def-x86-opcode movaps ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f28 #o300 #x0) + (def-x86-opcode movaps ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f28 #o000 #x0) + (def-x86-opcode movaps ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f29 #o000 #x0) + + ;; mulsd + (def-x86-opcode mulsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f59 #o000 #x0 #xf2) + (def-x86-opcode mulsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f59 #o300 #x0 #xf2) + + ;; mulss + (def-x86-opcode mulss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f59 #o000 #x0 #xf3) + (def-x86-opcode mulss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f59 #o300 #x0 #xf3) + + ;; divsd + (def-x86-opcode divsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5e #o000 #x0 #xf2) + (def-x86-opcode divsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5e #o300 #x0 #xf2) + + ;; divss + (def-x86-opcode divss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5e #o000 #x0 #xf3) + (def-x86-opcode divss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5e #o300 #x0 #xf3) + + + ;; sqrtsd + (def-x86-opcode sqrtsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f51 #o000 #x0 #xf2) + (def-x86-opcode sqrtsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f51 #o300 #x0 #xf2) + + ;; sqrtss + (def-x86-opcode sqrtss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f51 #o000 #x0 #xf3) + (def-x86-opcode sqrtss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f51 #o300 #x0 #xf3) + + ;; comisd + (def-x86-opcode comisd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2f #o000 #x0 #x66) + (def-x86-opcode comisd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2f #o300 #x0 #x66) + + ;; ucomisd + (def-x86-opcode ucomisd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2e #o000 #x0 #x66) + (def-x86-opcode ucomisd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2e #o300 #x0 #x66) + + ;; comiss + (def-x86-opcode comiss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2f #o000 #x0) + (def-x86-opcode comiss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2f #o300 #x0) + + ;; ucomiss + (def-x86-opcode ucomiss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2e #o000 #x0) + (def-x86-opcode ucomiss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f2e #o300 #x0) + + ;; movsd + (def-x86-opcode movsd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf2) + (def-x86-opcode movsd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf2) + (def-x86-opcode movsd ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f11 #o000 #x0 #xf2) + + + + ;; movss + (def-x86-opcode movss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf3) + (def-x86-opcode movss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f10 #o300 #x0 #xf3) + (def-x86-opcode movss ((:regxmm :insert-xmm-reg) (:anymem :insert-memory)) + #x0f11 #o000 #x0 #xf3) + + +;;; cvtsd2si. This does rounding (as opposed to truncation). + (def-x86-opcode (cvtsd2siq :cpu64) ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2d #o300 #x48 #xf2) + (def-x86-opcode (cvtsd2siq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2d #o000 #x48 #xf2) + (def-x86-opcode cvtsd2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2d #o300 #x00 #xf2) + (def-x86-opcode cvtsd2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2d #o000 #x00 #xf2) + +;;; cvtss2si. This does rounding (as opposed to truncation). + (def-x86-opcode (cvtss2siq :cpu64) ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2d #o300 #x48 #xf3) + (def-x86-opcode (cvtss2siq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2d #o000 #x48 #xf3) + (def-x86-opcode cvtss2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2d #o300 #x00 #xf3) + (def-x86-opcode cvtss2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2d #o000 #x00 #xf3) + +;;; cvttsd2si. This does truncation (as opposed to rounding). + (def-x86-opcode (cvttsd2siq :cpu64) ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2c #o300 #x48 #xf2) + (def-x86-opcode (cvttsd2siq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2c #o000 #x48 #xf2) + (def-x86-opcode cvttsd2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2c #o300 #x00 #xf2) + (def-x86-opcode cvtsd2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2c #o000 #x00 #xf2) + +;;; cvttss2si. This does truncation (as opposed to rounding). + (def-x86-opcode (cvttss2siq :cpu64) ((:regxmm :insert-xmm-rm) (:reg64 :insert-modrm-reg)) + #x0f2c #o300 #x48 #xf3) + (def-x86-opcode (cvttss2siq :cpu64) ((:anymem :insert-memory) (:reg64 :insert-modrm-reg)) + #x0f2c #o000 #x48 #xf3) + (def-x86-opcode cvttss2sil ((:regxmm :insert-xmm-rm) (:reg32 :insert-modrm-reg)) + #x0f2c #o300 #x00 #xf3) + (def-x86-opcode cvttss2sil ((:anymem :insert-memory) (:reg32 :insert-modrm-reg)) + #x0f2c #o000 #x00 #xf3) + + ;; cvtsi2sd + (def-x86-opcode (cvtsi2sdq :cpu64) ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x48 #xf2) + (def-x86-opcode (cvtsi2sdq :cpu64) ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x48 #xf2) + (def-x86-opcode cvtsi2sdl ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x00 #xf2) + (def-x86-opcode cvtsi2sdl ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x00 #xf2) + + ;; cvtsd2ss + (def-x86-opcode cvtsd2ss ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5a #o300 #x0 #xf2) + (def-x86-opcode cvtsd2ss ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5a #o000 #x0 #xf2) + + ;; cvtsi2sd + (def-x86-opcode (cvtsi2sdq :cpu64) ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x48 #xf2) + (def-x86-opcode (cvtsi2sdq :cpu64) ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x48 #xf2) + (def-x86-opcode cvtsi2sdl ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x00 #xf2) + (def-x86-opcode cvtsi2sdl ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x00 #xf2) + + ;; cvtsi2ss + (def-x86-opcode (cvtsi2ssq :cpu64) ((:reg64 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x48 #xf3) + (def-x86-opcode (cvtsi2ssq :cpu64) ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x48 #xf3) + (def-x86-opcode cvtsi2ssl ((:reg32 :insert-modrm-rm) (:regxmm :insert-xmm-reg)) + #x0f2a #o300 #x00 #xf3) + (def-x86-opcode cvtsi2ssl ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f2a #o000 #x00 #xf3) + +;;; cvtss2sd + (def-x86-opcode cvtss2sd ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0f5a #o300 #x0 #xf3) + (def-x86-opcode cvtss2sd ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0f5a #o000 #x0 #xf3) + + ;; pand + (def-x86-opcode pand ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fdb #o300 #x0) + (def-x86-opcode pand ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fdb #o000 #x0) + (def-x86-opcode pand ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fef #o300 #x0 #x66) + (def-x86-opcode pand ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fdb #o000 #x0 #x66) + + ;; pandn + (def-x86-opcode pandn ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fdf #o300 #x0) + (def-x86-opcode pandn ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fdf #o000 #x0) + (def-x86-opcode pandn ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fdf #o300 #x0 #x66) + (def-x86-opcode pandn ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fdf #o000 #x0 #x66) + + ;; pcmpeqb + (def-x86-opcode pcmpeqb ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0f74 #o300 #x0 #x66) + + ;; por + (def-x86-opcode por ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0feb #o300 #x0) + (def-x86-opcode por ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0feb #o000 #x0) + (def-x86-opcode por ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0feb #o300 #x0 #x66) + (def-x86-opcode por ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0feb #o000 #x0 #x66) + + ;; pxor + (def-x86-opcode pxor ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fef #o300 #x0) + (def-x86-opcode pxor ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fef #o000 #x0) + (def-x86-opcode pxor ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fef #o300 #x0 #x66) + (def-x86-opcode pxor ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fef #o000 #x0 #x66) + + ;; psllq + (def-x86-opcode psllq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0ff3 #o300 #x0) + (def-x86-opcode psllq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0ff3 #o000 #x0) + (def-x86-opcode psllq ((:imm8 :insert-imm8) (:regmmx :insert-mmx-rm)) + #x0f73 #o360 #o0) + (def-x86-opcode psllq ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0ff3 #o300 #x0 #x66) + (def-x86-opcode psllq ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0ff3 #o000 #x0 #x66) + (def-x86-opcode psllq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o360 #o0 #x66) + + ;; psllw + + ;; pslld + (def-x86-opcode pslld ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0ff2 #o300 #x0) + (def-x86-opcode pslld ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0ff2 #o000 #x0) + (def-x86-opcode pslld ((:imm8 :insert-imm8) (:regmmx :insert-mmx-rm)) + #x0f72 #o360 #o0) + (def-x86-opcode pslld ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0ff2 #o300 #x0 #x66) + (def-x86-opcode pslld ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0ff2 #o000 #x0 #x66) + (def-x86-opcode pslld ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f72 #o360 #o0 #x66) + + ;; pslldq + (def-x86-opcode pslldq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o370 #x0 #x66) + + ;; psrlq + (def-x86-opcode psrlq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fd3 #o300 #x0) + (def-x86-opcode psrlq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fd3 #o000 #x0) + (def-x86-opcode psrlq ((:imm8 :insert-imm8) (:regmmx :insert-mmx-rm)) + #x0f73 #o320 #o0) + (def-x86-opcode psrlq ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fd3 #o300 #x0 #x66) + (def-x86-opcode psrlq ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fd3 #o000 #x0 #x66) + (def-x86-opcode psrlq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o320 #o0 #x66) + + ;; psrld + (def-x86-opcode psrld ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fd2 #o300 #x0) + (def-x86-opcode psrld ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fd2 #o000 #x0) + (def-x86-opcode psrld ((:imm8 :insert-imm8) (:regmmx :insert-mmx-rm)) + #x0f72 #o320 #o0) + (def-x86-opcode psrld ((:regxmm :insert-modrm-rm) (:regxmm :insert-modrm-reg)) + #x0fd2 #o300 #x0 #x66) + (def-x86-opcode psrld ((:anymem :insert-memory) (:regxmm :insert-modrm-reg)) + #x0fd2 #o000 #x0 #x66) + (def-x86-opcode psrld ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f72 #o320 #o0 #x66) + + ;; psrldq + (def-x86-opcode psrldq ((:imm8 :insert-imm8) (:regxmm :insert-xmm-rm)) + #x0f73 #o330 #x0 #x66) + + ;; psrlw + + ;; pmuludq + (def-x86-opcode pmuludq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0ff4 #o300 #x0) + (def-x86-opcode pmuludq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0ff4 #o000 #x0) + (def-x86-opcode pmuludq ((:regxmm :insert-xmm-rm) (:regxmm :insert-xmm-reg)) + #x0ff4 #o300 #x0 #x66) + (def-x86-opcode pmuludq ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0ff4 #o000 #x0 #x66) + + ;; paddq + (def-x86-opcode paddq ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fd4 #o300 #x0) + (def-x86-opcode paddq ((:anymem :insert-memory) (:regmmx :insert-mmx-reg)) + #x0fd4 #o000 #x0) + (def-x86-opcode paddq ((:regxmm :insert-xmm-reg) (:regxmm :insert-xmm-reg)) + #x0fd4 #o300 #x0 #x66) + (def-x86-opcode paddq ((:anymem :insert-memory) (:regxmm :insert-xmm-reg)) + #x0fd4 #o000 #x0 #x66) + + ;; psrad + (def-x86-opcode psrad ((:regmmx :insert-mmx-rm) (:regmmx :insert-mmx-reg)) + #x0fe2 #o300 #x0) + +;;; End of list of useful mmx instructions + +;;; x87 fpu instructions + + ;; fstp + (def-x86-opcode fstps ((:anymem :insert-memory)) + #xd9 #o030 nil) + (def-x86-opcode fstpl ((:anymem :insert-memory)) + #xdd #o030 nil) + +;;; end of x87 fpu instructions + + (def-x86-opcode ldmxcsr ((:anymem :insert-memory)) + #x0fae #o020 nil) + + (def-x86-opcode stmxcsr ((:anymem :insert-memory)) + #x0fae #o030 nil) + + ;; UUOs. Expect lots more, some of which may take pseudo-operands. + (def-x86-opcode uuo-error-slot-unbound ((:reg :insert-opcode-reg4) + (:reg :insert-reg4-pseudo-rm-high) + (:reg :insert-reg4-pseudo-rm-low)) + #xcd70 0 nil) + +;;; DON'T use #xcd8x: doing so will make Mach angry and confused. + + (def-x86-opcode uuo-error-unbound ((:reg :insert-opcode-reg4)) + #xcd90 nil 0) + + (def-x86-opcode uuo-error-udf ((:reg :insert-opcode-reg4)) + #xcda0 nil 0) + + (def-x86-opcode uuo-error-reg-not-type ((:reg :insert-opcode-reg4) (:imm8 :insert-imm8)) + #xcdb0 nil 0) + + (def-x86-opcode uuo-error-too-few-args () + #xcdc0 nil nil) + (def-x86-opcode uuo-error-too-many-args () + #xcdc1 nil nil) + (def-x86-opcode uuo-error-wrong-number-of-args () + #xcdc2 nil nil) + (def-x86-opcode uuo-error-array-rank ((:reg :insert-reg4-pseudo-rm-high) + (:reg :insert-reg4-pseudo-rm-low)) + #xcdc3 0 nil) + + (def-x86-opcode uuo-gc-trap () + #xcdc4 nil nil) + (def-x86-opcode uuo-alloc () + #xcdc5 nil nil) + (def-x86-opcode uuo-error-not-callable () + #xcdc6 nil nil) + (def-x86-opcode uuo-error-udf-call () + #xcdc7 nil nil) + + (def-x86-opcode uuo-error-vector-bounds ((:reg :insert-reg4-pseudo-rm-high) (:reg :insert-reg4-pseudo-rm-low)) + #xcdc8 0 nil) + + (def-x86-opcode uuo-error-call-macro-or-special-operator () + #xcdc9 nil nil) + + (def-x86-opcode uuo-error-debug-trap () + #xcdca nil nil) + + (def-x86-opcode uuo-error-array-bounds ((:reg :insert-reg4-pseudo-rm-high) (:reg :insert-reg4-pseudo-rm-low)) + #xcdcb 0 nil) + + (def-x86-opcode uuo-error-eep-unresolved ((:reg :insert-reg4-pseudo-rm-high) + (:reg :insert-reg4-pseudo-rm-low)) + #xcdcc 0 nil) + + (def-x86-opcode uuo-error-debug-trap-with-string () + #xcdcd nil nil) + + (def-x86-opcode uuo-watch-trap () + #xcdce nil nil) + + (def-x86-opcode uuo-error-reg-not-tag ((:reg :insert-opcode-reg4) (:imm8 :insert-imm8)) + #xcdd0 nil 0) + (def-x86-opcode uuo-error-reg-not-list ((:reg :insert-opcode-reg4)) + #xcde0 nil 0) + (def-x86-opcode uuo-error-reg-not-fixnum ((:reg :insert-opcode-reg4)) + #xcdf0 nil 0) + + )) + + +(dotimes (i (length *x86-opcode-templates*)) + (setf (x86-opcode-template-ordinal (svref *x86-opcode-templates* i)) i)) + + + +(defparameter *x86-opcode-template-lists* + (make-hash-table :test #'equalp)) + + +(defun initialize-x86-opcode-templates () + (flet ((setup-templates-hash (hash templates) + (clrhash hash) + (do* ((i (1- (length templates)) (1- i))) + ((< i 0) hash) + (declare (fixnum i)) + (let* ((template (svref templates i)) + (name (x86-opcode-template-mnemonic template))) + (push template (gethash name hash)))))) + (setup-templates-hash *x86-opcode-template-lists* *x86-opcode-templates*) + (when (fboundp 'ccl::fixup-x86-vinsn-templates) + (ccl::fixup-x86-vinsn-templates + (ccl::backend-p2-vinsn-templates ccl::*target-backend*) + *x86-opcode-template-lists*)) + t)) + +(defvar *x8632-registers* (make-hash-table :test #'equalp)) +(defvar *x8664-registers* (make-hash-table :test #'equalp)) +(defvar *x86-registers* nil) + +(defparameter *x86-operand-insert-functions* + #(insert-nothing + insert-modrm-reg + insert-modrm-rm + insert-memory + insert-opcode-reg + insert-opcode-reg4 + insert-cc + insert-label + insert-imm8-for-int + insert-extra + insert-imm8 + insert-imm8s + insert-imm16 + insert-imm32s + insert-imm32 + insert-imm64 + insert-mmx-reg + insert-mmx-rm + insert-xmm-reg + insert-xmm-rm + insert-reg4-pseudo-rm-high + insert-reg4-pseudo-rm-low + insert-self +)) + +(initialize-x86-opcode-templates) + + + + + +;;; 386 register table. + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defconstant +REGNAM-AL+ 1) ; Entry in i386-regtab. +(defconstant +REGNAM-AX+ 25) +(defconstant +REGNAM-EAX+ 41) + +(defvar *x86-regtab* + (vector + ;; Make %st first as we test for it. + (make-reg-entry :reg-name "st" + :reg-type (encode-operand-type :FloatReg :floatacc) + :reg-flags 0 + :reg-num 0 ) + ;; 8 bit regs + (make-reg-entry :reg-name "al" + :reg-type (encode-operand-type :Reg8 :Acc) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "cl" + :reg-type (encode-operand-type :Reg8 :ShiftCount) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "dl" + :reg-type (encode-operand-type :Reg8) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "bl" + :reg-type (encode-operand-type :Reg8) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "ah" + :reg-type (encode-operand-type :Reg8) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "ch" + :reg-type (encode-operand-type :Reg8) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "dh" + :reg-type (encode-operand-type :Reg8) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "bh" + :reg-type (encode-operand-type :Reg8) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "axl" + :reg-type (encode-operand-type :Reg8 :Acc) + :reg-flags +RegRex64+ + :reg-num 0 ) ; Must be in the "al + 8" slot. + (make-reg-entry :reg-name "cxl" + :reg-type (encode-operand-type :Reg8) + :reg-flags +RegRex64+ + :reg-num 1) + (make-reg-entry :reg-name "dxl" + :reg-type (encode-operand-type :Reg8) + :reg-flags +RegRex64+ + :reg-num 2) + (make-reg-entry :reg-name "bxl" + :reg-type (encode-operand-type :Reg8) + :reg-flags +RegRex64+ + :reg-num 3) + (make-reg-entry :reg-name "spl" + :reg-type (encode-operand-type :Reg8) + :reg-flags +RegRex64+ + :reg-num 4) + (make-reg-entry :reg-name "bpl" + :reg-type (encode-operand-type :Reg8) + :reg-flags +RegRex64+ + :reg-num 5) + (make-reg-entry :reg-name "sil" + :reg-type (encode-operand-type :Reg8) + :reg-flags +RegRex64+ + :reg-num 6) + (make-reg-entry :reg-name "dil" + :reg-type (encode-operand-type :Reg8) + :reg-flags +RegRex64+ + :reg-num 7) + (make-reg-entry :reg-name "r8b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 0 ) + (make-reg-entry :reg-name "r9b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 1) + (make-reg-entry :reg-name "r10b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 2) + (make-reg-entry :reg-name "r11b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 3) + (make-reg-entry :reg-name "r12b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 4) + (make-reg-entry :reg-name "r13b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 5) + (make-reg-entry :reg-name "r14b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 6) + (make-reg-entry :reg-name "r15b" + :reg-type (encode-operand-type :Reg8) + :reg-flags (logior +RegRex64+ +RegRex+) + :reg-num 7) + ;; 16 bit regs + (make-reg-entry :reg-name "ax" + :reg-type (encode-operand-type :Reg16 :Acc) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "cx" + :reg-type (encode-operand-type :Reg16) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "dx" + :reg-type (encode-operand-type :Reg16 :InOutPortReg) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "bx" + :reg-type (encode-operand-type :Reg16 :BaseIndex) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "sp" + :reg-type (encode-operand-type :Reg16) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "bp" + :reg-type (encode-operand-type :Reg16 :BaseIndex) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "si" + :reg-type (encode-operand-type :Reg16 :BaseIndex) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "di" + :reg-type (encode-operand-type :Reg16 :BaseIndex) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "r8w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 0 ) + (make-reg-entry :reg-name "r9w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 1) + (make-reg-entry :reg-name "r10w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 2) + (make-reg-entry :reg-name "r11w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 3) + (make-reg-entry :reg-name "r12w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 4) + (make-reg-entry :reg-name "r13w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 5) + (make-reg-entry :reg-name "r14w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 6) + (make-reg-entry :reg-name "r15w" + :reg-type (encode-operand-type :Reg16) + :reg-flags +RegRex+ + :reg-num 7) + ; 32 bit regs + (make-reg-entry :reg-name "eax" + :reg-type (encode-operand-type :Reg32 :BaseIndex :Acc) + :reg-flags 0 + :reg-num 0 ) ; Must be in ax + 16 slot. + (make-reg-entry :reg-name "ecx" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "edx" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "ebx" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "esp" + :reg-type (encode-operand-type :Reg32) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "ebp" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "esi" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "edi" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "r8d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 0 ) + (make-reg-entry :reg-name "r9d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 1) + (make-reg-entry :reg-name "r10d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 2) + (make-reg-entry :reg-name "r11d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 3) + (make-reg-entry :reg-name "r12d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 4) + (make-reg-entry :reg-name "r13d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 5) + (make-reg-entry :reg-name "r14d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 6) + (make-reg-entry :reg-name "r15d" + :reg-type (encode-operand-type :Reg32 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 7) + (make-reg-entry :reg-name "rax" + :reg-type (encode-operand-type :Reg64 :BaseIndex :Acc) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "rcx" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "rdx" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "rbx" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "rsp" + :reg-type (encode-operand-type :Reg64) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "rbp" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "rsi" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "rdi" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "r8" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 0 ) + (make-reg-entry :reg-name "r9" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 1) + (make-reg-entry :reg-name "r10" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 2) + (make-reg-entry :reg-name "r11" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 3) + (make-reg-entry :reg-name "r12" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 4) + (make-reg-entry :reg-name "r13" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 5) + (make-reg-entry :reg-name "r14" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 6) + (make-reg-entry :reg-name "r15" + :reg-type (encode-operand-type :Reg64 :BaseIndex) + :reg-flags +RegRex+ + :reg-num 7) + ; Segment registers. + (make-reg-entry :reg-name "es" + :reg-type (encode-operand-type :SReg2) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "cs" + :reg-type (encode-operand-type :SReg2) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "ss" + :reg-type (encode-operand-type :SReg2) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "ds" + :reg-type (encode-operand-type :SReg2) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "fs" + :reg-type (encode-operand-type :SReg3) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "gs" + :reg-type (encode-operand-type :SReg3) + :reg-flags 0 + :reg-num 5) + ;; Control registers. + (make-reg-entry :reg-name "cr0" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "cr1" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "cr2" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "cr3" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "cr4" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "cr5" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "cr6" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "cr7" + :reg-type (encode-operand-type :Control) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "cr8" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 0 ) + (make-reg-entry :reg-name "cr9" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 1) + (make-reg-entry :reg-name "cr10" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 2) + (make-reg-entry :reg-name "cr11" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 3) + (make-reg-entry :reg-name "cr12" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 4) + (make-reg-entry :reg-name "cr13" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 5) + (make-reg-entry :reg-name "cr14" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 6) + (make-reg-entry :reg-name "cr15" + :reg-type (encode-operand-type :Control) + :reg-flags +RegRex+ + :reg-num 7) + ;; Debug registers. + (make-reg-entry :reg-name "db0" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "db1" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "db2" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "db3" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "db4" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "db5" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "db6" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "db7" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "db8" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 0 ) + (make-reg-entry :reg-name "db9" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 1) + (make-reg-entry :reg-name "db10" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 2) + (make-reg-entry :reg-name "db11" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 3) + (make-reg-entry :reg-name "db12" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 4) + (make-reg-entry :reg-name "db13" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 5) + (make-reg-entry :reg-name "db14" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 6) + (make-reg-entry :reg-name "db15" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 7) + (make-reg-entry :reg-name "dr0" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "dr1" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "dr2" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "dr3" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "dr4" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "dr5" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "dr6" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "dr7" + :reg-type (encode-operand-type :Debug) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "dr8" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 0 ) + (make-reg-entry :reg-name "dr9" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 1) + (make-reg-entry :reg-name "dr10" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 2) + (make-reg-entry :reg-name "dr11" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 3) + (make-reg-entry :reg-name "dr12" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 4) + (make-reg-entry :reg-name "dr13" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 5) + (make-reg-entry :reg-name "dr14" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 6) + (make-reg-entry :reg-name "dr15" + :reg-type (encode-operand-type :Debug) + :reg-flags +RegRex+ + :reg-num 7) + ;; Test registers. + (make-reg-entry :reg-name "tr0" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "tr1" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "tr2" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "tr3" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "tr4" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "tr5" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "tr6" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "tr7" + :reg-type (encode-operand-type :Test) + :reg-flags 0 + :reg-num 7) + ;; MMX and simd registers. + (make-reg-entry :reg-name "mm0" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "mm1" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "mm2" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "mm3" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "mm4" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "mm5" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "mm6" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "mm7" + :reg-type (encode-operand-type :RegMMX) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "xmm0" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 0 ) + (make-reg-entry :reg-name "xmm1" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "xmm2" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "xmm3" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "xmm4" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "xmm5" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "xmm6" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "xmm7" + :reg-type (encode-operand-type :RegXMM) + :reg-flags 0 + :reg-num 7) + (make-reg-entry :reg-name "xmm8" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 0 ) + (make-reg-entry :reg-name "xmm9" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 1) + (make-reg-entry :reg-name "xmm10" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 2) + (make-reg-entry :reg-name "xmm11" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 3) + (make-reg-entry :reg-name "xmm12" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 4) + (make-reg-entry :reg-name "xmm13" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 5) + (make-reg-entry :reg-name "xmm14" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 6) + (make-reg-entry :reg-name "xmm15" + :reg-type (encode-operand-type :RegXMM) + :reg-flags +RegRex+ + :reg-num 7) + ;; No type will make this register rejected for all purposes except + ;; for addressing. This saves creating one extra type for RIP. + (make-reg-entry :reg-name "rip" + :reg-type (encode-operand-type :BaseIndex) + :reg-flags 0 + :reg-num 0 ) + )) + +(defvar *x86-float-regs* + (vector + (make-reg-entry :reg-name "st[0]" + :reg-type (encode-operand-type :FloatReg :FloatAcc) + :reg-flags 0 + :reg-num 0) + (make-reg-entry :reg-name "st[1]" + :reg-type (encode-operand-type :FloatReg) + :reg-flags 0 + :reg-num 1) + (make-reg-entry :reg-name "st[2]" + :reg-type (encode-operand-type :FloatReg) + :reg-flags 0 + :reg-num 2) + (make-reg-entry :reg-name "st[3]" + :reg-type (encode-operand-type :FloatReg) + :reg-flags 0 + :reg-num 3) + (make-reg-entry :reg-name "st[4]" + :reg-type (encode-operand-type :FloatReg) + :reg-flags 0 + :reg-num 4) + (make-reg-entry :reg-name "st[5]" + :reg-type (encode-operand-type :FloatReg) + :reg-flags 0 + :reg-num 5) + (make-reg-entry :reg-name "st[6]" + :reg-type (encode-operand-type :FloatReg) + :reg-flags 0 + :reg-num 6) + (make-reg-entry :reg-name "st[7]" + :reg-type (encode-operand-type :FloatReg) + :reg-flags 0 + :reg-num 7))) + + +;;; Segment stuff. +(defvar *cs-segment-register* (make-seg-entry :seg-name "cs" :seg-prefix #x23)) +(defvar *ds-segment-register* (make-seg-entry :seg-name "ds" :seg-prefix #x3e)) +(defvar *ss-segment-register* (make-seg-entry :seg-name "ss" :seg-prefix #x36)) +(defvar *es-segment-register* (make-seg-entry :seg-name "es" :seg-prefix #x26)) +(defvar *fs-segment-register* (make-seg-entry :seg-name "fs" :seg-prefix #x64)) +(defvar *gs-segment-register* (make-seg-entry :seg-name "gs" :seg-prefix #x65)) + +(defvar *x86-seg-entries* + (vector *es-segment-register* + *cs-segment-register* + *ss-segment-register* + *ds-segment-register* + *fs-segment-register* + *gs-segment-register*)) + + + + + +(defun init-x86-registers () + (labels ((ia32-p (entry) + (not (or (logtest (reg-entry-reg-flags entry) + (logior +regrex+ +regrex64+)) + (logtest (reg-entry-reg-type entry) + (encode-operand-type :reg64)) + ;; As a special case, exclude RIP, whose type is + ;; *exactly* :BaseIndex + (eql (reg-entry-reg-type entry) + (encode-operand-type :BaseIndex))))) + (hash-registers (vector hash 64p) + (dotimes (i (length vector)) + (let* ((entry (svref vector i))) + (if (or 64p (ia32-p entry)) + (setf (gethash (reg-entry-reg-name entry) hash) entry)))))) + (hash-registers *x86-regtab* *x8632-registers* nil) + (hash-registers *x86-float-regs* *x8632-registers* nil) + (hash-registers *x86-regtab* *x8664-registers* t) + (hash-registers *x86-float-regs* *x8664-registers* t))) + +) + +(init-x86-registers) + + + +(defstruct x86-operand + (type )) + +(defstruct (x86-immediate-operand (:include x86-operand)) + ;; The "value" of an immediate operand may be an expression (that we + ;; have to do some sort of delayed evaluation on.) It could just be + ;; a lisp form (that we call EVAL on), but there might be scoping or + ;; similar issues in that case. + value) + +(defstruct (x86-register-operand (:include x86-operand)) + entry ;the reg-entry +) + +(defstruct (x86-label-operand (:include x86-operand)) + label) + + +(defstruct (x86-memory-operand (:include x86-operand)) + ;; Any of these fields can be null. Some combinations of fields - + ;; like a segment register or scale factor by itself - make no + ;; sense. + seg ; a segment register + disp ; a signed displacement added to base + base ; a GPR + index ; another GPR + scale ; scale factor, multiplied with index + ) + + +(defun insert-nothing (instruction operand) + (declare (ignore instruction operand))) + +;;; Insert a 3-bit register value derived from OPERAND in INSN's modrm.reg +;;; field. If the register requires REX addressing, set the REX.R bit +;;; in the instruction's rex-prefix. If either the modrm or rex-prefix +;;; fields of the instruction are NIL, we're very confused; check for +;;; that explicitly until this code matures a bit. + +(defun insert-modrm-reg-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry)) + (flags (reg-entry-reg-flags entry)) + (need-rex.r (logtest +regrex+ flags))) + (setf (x86-instruction-modrm-byte instruction) + (dpb reg-num (byte 3 3) + (need-modrm-byte instruction))) + (when need-rex.r + (setf (x86-instruction-rex-prefix instruction) + (logior +rex-extx+ (need-rex-prefix instruction)))) + (when (logtest +regrex64+ flags) + (setf (x86-instruction-rex-prefix instruction) + (logior #x80 (need-rex-prefix instruction)))))) + + + +(defun insert-modrm-reg (instruction operand) + (insert-modrm-reg-entry instruction (x86-register-operand-entry operand))) + +(defun insert-mmx-reg-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry))) + (setf (x86-instruction-modrm-byte instruction) + (dpb reg-num (byte 3 3) + (need-modrm-byte instruction))))) + +(defun insert-mmx-reg (instruction operand) + (insert-mmx-reg-entry instruction (x86-register-operand-entry operand))) + +(defun insert-xmm-reg (instruction operand) + (insert-modrm-reg instruction operand)) + +(defun insert-xmm-rm (instruction operand) + (insert-modrm-rm instruction operand)) + +(defun insert-opcode-reg-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry)) + (flags (reg-entry-reg-flags entry)) + (need-rex.b (logtest +regrex+ flags))) + (setf (x86-instruction-base-opcode instruction) + (dpb reg-num (byte 3 0) + (x86-instruction-base-opcode instruction))) + (when need-rex.b + (setf (x86-instruction-rex-prefix instruction) + (logior +rex-extz+ (need-rex-prefix instruction)))) + (when (logtest +regrex64+ flags) + (setf (x86-instruction-rex-prefix instruction) + (logior #x80 (need-rex-prefix instruction)))))) + +(defun insert-opcode-reg (instruction operand) + (insert-opcode-reg-entry instruction (x86-register-operand-entry operand))) + +;;; Insert a 4-bit register number in the low 4 bits of the opcode. +;;; (This is only used in synthetic instructions, like some UUOs.) + +(defun insert-opcode-reg4-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry)) + (xreg-num (logior reg-num + (if + (ccl::target-arch-case + (:x8664 + (logtest +regrex+ (reg-entry-reg-flags entry))) + (:x8632 t)) + #x08 + #x00)))) + (setf (x86-instruction-base-opcode instruction) + (dpb xreg-num (byte 4 0) + (x86-instruction-base-opcode instruction))))) + +(defun insert-opcode-reg4 (instruction operand) + (insert-opcode-reg4-entry instruction (x86-register-operand-entry operand))) + + +(defun insert-reg4-pseudo-rm-high-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry)) + (xreg-num (logior reg-num + (if (logtest +regrex+ (reg-entry-reg-flags entry)) + #x08 + #x00)))) + (setf (x86-instruction-modrm-byte instruction) + (dpb xreg-num (byte 4 4) + (x86-instruction-modrm-byte instruction))))) + +(defun insert-reg4-pseudo-rm-high (instruction operand) + (insert-reg4-pseudo-rm-high-entry instruction (x86-register-operand-entry operand))) + + +(defun insert-reg4-pseudo-rm-low-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry)) + (xreg-num (logior reg-num + (if (logtest +regrex+ (reg-entry-reg-flags entry)) + #x08 + #x00)))) + (setf (x86-instruction-modrm-byte instruction) + (dpb xreg-num (byte 4 0) + (x86-instruction-modrm-byte instruction))))) + +(defun insert-reg4-pseudo-rm-low (instruction operand) + (insert-reg4-pseudo-rm-low-entry instruction (x86-register-operand-entry operand))) + +;;; Insert a 3-bit register value derived from OPERAND in INSN's modrm.rm +;;; field. If the register requires REX addressing, set the REX.B bit +;;; in the instruction's rex-prefix. If either the modrm or rex-prefix +;;; fields of the instruction are NIL, we're very confused; check for +;;; that explicitly until this code matures a bit. + +(defun insert-modrm-rm-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry)) + (flags (reg-entry-reg-flags entry)) + (need-rex.b (logtest +regrex+ flags))) + (setf (x86-instruction-modrm-byte instruction) + (dpb reg-num (byte 3 0) (need-modrm-byte instruction))) + (when need-rex.b + (setf (x86-instruction-rex-prefix instruction) + (logior +rex-extz+ (need-rex-prefix instruction)))) + (when (logtest +regrex64+ flags) + (setf (x86-instruction-rex-prefix instruction) + (logior #x80 (need-rex-prefix instruction)))))) + +(defun insert-modrm-rm (instruction operand) + (insert-modrm-rm-entry instruction (x86-register-operand-entry operand))) + +(defun insert-mmx-rm-entry (instruction entry) + (let* ((reg-num (reg-entry-reg-num entry))) + (setf (x86-instruction-modrm-byte instruction) + (dpb reg-num (byte 3 0) (need-modrm-byte instruction))))) + +(defun insert-mmx-rm (instruction operand) + (insert-mmx-rm-entry instruction (x86-register-operand-entry operand))) + +(defun insert-imm64 (instruction operand) + (setf (x86-immediate-operand-type operand) + (encode-operand-type :imm64)) + (setf (x86-instruction-imm instruction) operand)) + +(defun insert-imm32s (instruction operand) + (setf (x86-immediate-operand-type operand) + (encode-operand-type :imm32s)) + (setf (x86-instruction-imm instruction) operand)) + +(defun insert-imm32 (instruction operand) + (setf (x86-immediate-operand-type operand) + (encode-operand-type :imm32)) + (setf (x86-instruction-imm instruction) operand)) + +(defun insert-imm16 (instruction operand) + (setf (x86-immediate-operand-type operand) + (encode-operand-type :imm16)) + (setf (x86-instruction-imm instruction) operand)) + +(defun insert-imm8 (instruction operand) + (setf (x86-immediate-operand-type operand) + (encode-operand-type :imm8)) + (setf (x86-instruction-imm instruction) operand)) + +(defun insert-imm8s (instruction operand) + (setf (x86-immediate-operand-type operand) + (encode-operand-type :imm8s)) + (setf (x86-instruction-imm instruction) operand)) + +(defun insert-imm8-for-int (instruction operand) + (declare (ftype (function (t) t) ccl::early-x86-lap-expression-value)) + (let* ((expr (x86-immediate-operand-value operand)) + (value (ccl::early-x86-lap-expression-value expr))) + (if (eql value 3) + (setf (x86-instruction-base-opcode instruction) + +int3-opcode+) + (insert-imm8 instruction operand)))) + +(defun insert-label (instruction operand) + (setf (x86-instruction-extra instruction) + (x86::x86-label-operand-label operand))) + +(defun insert-self (instruction operand) + (setf (x86-immediate-operand-type operand) + (encode-operand-type :self)) + (setf (x86-instruction-imm instruction) operand)) + +(defparameter *x8632-register-entries* + (flet ((register-entry (name) + (let* ((r (gethash name *x8632-registers*))) + (unless r (error "unknown register ~s" name)) + r))) + (vector + ;; 32-bit registers + (register-entry "eax") + (register-entry "ecx") + (register-entry "edx") + (register-entry "ebx") + (register-entry "esp") + (register-entry "ebp") + (register-entry "esi") + (register-entry "edi") + ;; 16-bit-registers + (register-entry "ax") + (register-entry "cx") + (register-entry "dx") + (register-entry "bx") + (register-entry "sp") + (register-entry "bp") + (register-entry "si") + (register-entry "di") + ;; 8-bit registers + (register-entry "al") + (register-entry "cl") + (register-entry "dl") + (register-entry "bl") + (register-entry "ah") + (register-entry "ch") + (register-entry "dh") + (register-entry "bh") + ;;; xmm registers + (register-entry "xmm0") + (register-entry "xmm1") + (register-entry "xmm2") + (register-entry "xmm3") + (register-entry "xmm4") + (register-entry "xmm5") + (register-entry "xmm6") + (register-entry "xmm7") + ;; MMX registers + (register-entry "mm0") + (register-entry "mm1") + (register-entry "mm2") + (register-entry "mm3") + (register-entry "mm4") + (register-entry "mm5") + (register-entry "mm6") + (register-entry "mm7") + ;; x87 FP regs. May or may not be useful. + (register-entry "st[0]") + (register-entry "st[1]") + (register-entry "st[2]") + (register-entry "st[3]") + (register-entry "st[4]") + (register-entry "st[5]") + (register-entry "st[6]") + (register-entry "st[7]") + ;; Our friends, the segment registers + (register-entry "cs") + (register-entry "ds") + (register-entry "ss") + (register-entry "es") + (register-entry "fs") + (register-entry "gs") + ))) + +(dotimes (i (length *x8632-register-entries*)) + (let* ((entry (svref *x8632-register-entries* i))) + (when entry + (setf (reg-entry-ordinal32 entry) i)))) + +(defconstant +x8632-32-bit-register+ #x0) +(defconstant +x8632-16-bit-register+ #x8) +(defconstant +x8632-8-bit-register+ #x10) +(defconstant +x8632-xmm-register-offset+ #x18) +(defconstant +x8632-mmx-register-offset+ #x20) +(defconstant +x8632-fpu-register-offset+ #x28) +(defconstant +x8632-segment-register-offset+ #x30) + +(defparameter *x8664-register-entries* + (flet ((register-entry (name) + (let* ((r (gethash name *x8664-registers*))) + (unless r (error "unknown register ~s" name)) + r))) + (vector + ;; 64-bit general-purpose registers + (register-entry "rax") + (register-entry "rcx") + (register-entry "rdx") + (register-entry "rbx") + (register-entry "rsp") + (register-entry "rbp") + (register-entry "rsi") + (register-entry "rdi") + (register-entry "r8") + (register-entry "r9") + (register-entry "r10") + (register-entry "r11") + (register-entry "r12") + (register-entry "r13") + (register-entry "r14") + (register-entry "r15") + ;; 32-bit registers + (register-entry "eax") + (register-entry "ecx") + (register-entry "edx") + (register-entry "ebx") + (register-entry "esp") + (register-entry "ebp") + (register-entry "esi") + (register-entry "edi") + (register-entry "r8d") + (register-entry "r9d") + (register-entry "r10d") + (register-entry "r11d") + (register-entry "r12d") + (register-entry "r13d") + (register-entry "r14d") + (register-entry "r15d") + ;; 16-bit-registers + (register-entry "ax") + (register-entry "cx") + (register-entry "dx") + (register-entry "bx") + (register-entry "sp") + (register-entry "bp") + (register-entry "si") + (register-entry "di") + (register-entry "r8w") + (register-entry "r9w") + (register-entry "r10w") + (register-entry "r11w") + (register-entry "r12w") + (register-entry "r13w") + (register-entry "r14w") + (register-entry "r15w") + ;; 8-bit registers + (register-entry "al") + (register-entry "cl") + (register-entry "dl") + (register-entry "bl") + (register-entry "spl") + (register-entry "bpl") + (register-entry "sil") + (register-entry "dil") + (register-entry "r8b") + (register-entry "r9b") + (register-entry "r10b") + (register-entry "r11b") + (register-entry "r12b") + (register-entry "r13b") + (register-entry "r14b") + (register-entry "r15b") + ;;; xmm registers + (register-entry "xmm0") + (register-entry "xmm1") + (register-entry "xmm2") + (register-entry "xmm3") + (register-entry "xmm4") + (register-entry "xmm5") + (register-entry "xmm6") + (register-entry "xmm7") + (register-entry "xmm8") + (register-entry "xmm9") + (register-entry "xmm10") + (register-entry "xmm11") + (register-entry "xmm12") + (register-entry "xmm13") + (register-entry "xmm14") + (register-entry "xmm15") + ;; MMX registers + (register-entry "mm0") + (register-entry "mm1") + (register-entry "mm2") + (register-entry "mm3") + (register-entry "mm4") + (register-entry "mm5") + (register-entry "mm6") + (register-entry "mm7") + ;; x87 FP regs. May or may not be useful. + (register-entry "st[0]") + (register-entry "st[1]") + (register-entry "st[2]") + (register-entry "st[3]") + (register-entry "st[4]") + (register-entry "st[5]") + (register-entry "st[6]") + (register-entry "st[7]") + ;; Our friends, the segment registers + (register-entry "cs") + (register-entry "ds") + (register-entry "ss") + (register-entry "es") + (register-entry "fs") + (register-entry "gs") + (register-entry "rip") + ))) + +(dotimes (i (length *x8664-register-entries*)) + (let* ((entry (svref *x8664-register-entries* i))) + (when entry + (setf (reg-entry-ordinal64 entry) i)))) + +(defconstant +x8664-64-bit-register+ #x00) +(defconstant +x8664-32-bit-register+ #x10) +(defconstant +x8664-16-bit-register+ #x20) +(defconstant +x8664-8-bit-register+ #x30) +(defconstant +x8664-xmm-register-offset+ #x40) +(defconstant +x8664-mmx-register-offset+ #x50) +(defconstant +x8664-fpu-register-offset+ #x58) +(defconstant +x8664-segment-register-offset+ #x60) + +(defun x86-segment-register (i) + (if (and (typep i 'unsigned-byte) + (< i 6)) + (ccl::target-arch-case + (:x8632 + (svref *x8632-register-entries* (+ +x8632-segment-register-offset+ i))) + (:x8664 + (svref *x8664-register-entries* (+ +x8664-segment-register-offset+ i)))))) + +(defun x86-xmm-register (i) + (ccl::target-arch-case + (:x8632 + (if (typep i '(mod 8)) + (svref *x8632-register-entries* (+ +x8632-xmm-register-offset+ i)))) + (:x8664 + (if (typep i '(mod 16)) + (svref *x8664-register-entries* (+ +x8664-xmm-register-offset+ i)))))) + +(defun x86-mmx-register (i) + (if (typep i '(mod 8)) + (ccl::target-arch-case + (:x8632 + (svref *x8632-register-entries* (+ +x8632-mmx-register-offset+ i))) + (:x8664 + (svref *x8664-register-entries* (+ +x8664-mmx-register-offset+ i)))))) + + +(defun gpr-ordinal (r) + (ccl::target-arch-case + (:x8632 + (or + (etypecase r + ((mod 24) r) + ((or string symbol) + (let* ((entry (gethash r *x8632-registers*))) + (if entry + (reg-entry-ordinal32 entry)))) + (reg-entry (reg-entry-ordinal32 r)) + (x86-register-operand + (reg-entry-ordinal32 (x86-register-operand-entry r)))) + (error "Can't determine register ordinal of ~s" r))) + (:x8664 + (or + (etypecase r + ((mod 64) r) + ((or string symbol) + (let* ((entry (gethash r *x8664-registers*))) + (if entry + (reg-entry-ordinal64 entry)))) + (reg-entry (reg-entry-ordinal64 r)) + (x86-register-operand + (reg-entry-ordinal64 (x86-register-operand-entry r)))) + (error "Can't determine register ordinal of ~s" r))))) + + +(defun x86-reg8 (r) + (ccl::target-arch-case + (:x8632 + (svref *x8632-register-entries* (dpb (gpr-ordinal r) + (byte 3 0) + +x8632-8-bit-register+))) + (:x8664 + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x8664-8-bit-register+))))) + +(defun x86-reg16 (r) + (ccl::target-arch-case + (:x8632 + (svref *x8632-register-entries* (dpb (gpr-ordinal r) + (byte 3 0) + +x8632-16-bit-register+))) + (:x8664 + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x8664-16-bit-register+))))) + +(defun x86-reg32 (r) + (ccl::target-arch-case + (:x8632 + (svref *x8632-register-entries* (dpb (gpr-ordinal r) + (byte 3 0) + +x8632-32-bit-register+))) + (:x8664 + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x8664-32-bit-register+))))) + +(defun x86-reg64 (r) + (ccl::target-arch-case + (:x8632 + (error "x8632 doesn't have 64 bit register ~s" r)) + (:x8664 + (svref *x8664-register-entries* (dpb (gpr-ordinal r) + (byte 4 0) + +x8664-64-bit-register+))))) + +;;; This returns true if the template's operand types "match" the +;;; types of the actual operands. +(defun match-template-types (template type0 type1 type2 &optional (backend ccl::*target-backend*)) + #+debug + (format t "~& template = ~s, operand types = ~s" template (list type0 type1 type2)) + (case (ccl::backend-target-arch-name backend) + (:x8632 + (if (logtest (encode-opcode-flags :cpu64) (x86-opcode-template-flags template)) + (return-from match-template-types nil))) + (:x8664 + (if (logtest (encode-opcode-flags :cpuno64) (x86-opcode-template-flags template)) + (return-from match-template-types nil)))) + (flet ((match (overlap given) + (and + (not (zerop (logandc2 overlap (encode-operand-type :jumpabsolute)))) + (= (logand given (encode-operand-type :baseindex :jumpabsolute)) + (logand overlap (encode-operand-type :baseindex :jumpabsolute))))) + (consistent-register-match (m0 g0 t0 m1 g1 t1) + (let* ((g0® (logand g0 (encode-operand-type :reg))) + (g1® (logand g1 (encode-operand-type :reg)))) + (or (zerop g0®) + (zerop g1®) + (= g0® g1®) + (not + (logtest + (if (logtest m0 (encode-operand-type :acc)) + (encode-operand-type :reg) + t0) + (if (logtest m1 (encode-operand-type :acc)) + (encode-operand-type :reg) + t1))))))) + (let* ((nops (if type2 3 (if type1 2 (if type0 1 0))))) + (declare (fixnum nops)) + (let* ((template-types + (x86-opcode-template-operand-types template))) + (when (= nops (the fixnum (length template-types))) + (or (zerop nops) + (let* ((template-type0 (svref template-types 0)) + (overlap0 + (logand type0 template-type0)) + (match0 (match overlap0 type0))) + (if match0 + (or (= nops 1) + ;; 2 or 3 operands. + (let* ((template-type1 (svref template-types 1)) + (overlap1 (logand type1 template-type1)) + (match1 (match overlap1 type1))) + (if (and + match1 + (consistent-register-match + overlap0 + type0 + template-type0 + overlap1 + type1 + template-type1)) + (or (= nops 2) + ;; 3 operands + (let* ((template-type2 (svref template-types 2)) + (overlap2 (logand type2 template-type2))) + (and (match overlap2 type2) + (consistent-register-match + overlap1 + type1 + template-type1 + overlap2 + type2 + template-type2))))))))))))))) + +;;; the format of operands in lap and in vinsns differs +;;; #'x86-encode-vinsn-operand-type is for vinsns +;;; #'x86-operand-type is for lap +(defun match-template (template parsed-operands) + (let* ((flags (x86-opcode-template-flags template)) + (operand-types (mapcar #'x86-operand-type parsed-operands)) + (type0 (pop operand-types)) + (type1 (pop operand-types)) + (type2 (car operand-types))) + #+debug + (format t "~& template = ~s, operand types = ~s" template operand-types) + (ccl::target-arch-case + (:x8632 + (if (not (logtest (encode-opcode-flags :cpu64) flags)) + (match-template-types template type0 type1 type2))) + (:x8664 + (if (not (logtest (encode-opcode-flags :cpuno64) flags)) + (match-template-types template type0 type1 type2)))))) + + +(provide "X86-ASM") Index: /branches/qres/ccl/compiler/X86/x86-backend.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/x86-backend.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/x86-backend.lisp (revision 13564) @@ -0,0 +1,392 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(next-nx-defops) +(defvar *x862-specials* nil) +(let* ((newsize (%i+ (next-nx-num-ops) 10)) + (old *x862-specials*) + (oldsize (length old))) + (declare (fixnum newsize oldsize)) + (unless (>= oldsize newsize) + (let* ((v (make-array newsize :initial-element nil))) + (dotimes (i oldsize (setq *x862-specials* v)) + (setf (svref v i) (svref old i)))))) + +(defun x86-encode-vinsn-operand-type (thing backend) + (when thing + (if (atom thing) + (x86::encode-operand-type :label) + (ecase (car thing) + (:% (ecase (arch::target-lisp-node-size (backend-target-arch backend)) + (8 (x86::encode-operand-type :reg64)) + (4 (x86::encode-operand-type :reg32)))) + (:%acc (ecase (arch::target-lisp-node-size (backend-target-arch backend)) + (8 (x86::encode-operand-type :reg64 :acc)) + (4 (x86::encode-operand-type :reg32 :acc)))) + (:%q (x86::encode-operand-type :reg64)) + (:%accq (x86::encode-operand-type :reg64 :acc)) + (:%l (x86::encode-operand-type :reg32)) + (:%accl (x86::encode-operand-type :reg32 :acc)) + (:%w (x86::encode-operand-type :reg16)) + (:%accw (x86::encode-operand-type :reg16 :acc)) + (:%b (x86::encode-operand-type :reg8)) + (:%accb (x86::encode-operand-type :reg8 :acc)) + (:%xmm (x86::encode-operand-type :regxmm)) + (:%mmx (x86::encode-operand-type :regmmx)) + (:@ (x86::encode-operand-type :anymem)) + (:rcontext (x86::encode-operand-type :anymem)) + (:$1 (x86::encode-operand-type :imm1) ) + (:$b (x86::encode-operand-type :imm8s )) + (:$ub (x86::encode-operand-type :imm8)) + (:$w (x86::encode-operand-type :imm16)) + (:$l (x86::encode-operand-type :imm32s)) + (:$ul (x86::encode-operand-type :imm32)) + (:$q (x86::encode-operand-type :imm64)) + (:%shift (x86::encode-operand-type :shiftcount :reg8)) + (:$self (x86::encode-operand-type :self)))))) + +(defun lookup-x86-opcode (form backend) + (when (consp form) + (let* ((name (string (car form))) + (templates (gethash name x86::*x86-opcode-template-lists*))) + (when templates + (flet ((optype (thing) + (x86-encode-vinsn-operand-type thing backend))) + (let* ((operands (cdr form)) + (type0 (optype (pop operands))) + (type1 (optype (pop operands))) + (type2 (optype (car operands)))) + (dolist (template templates) + (when (x86::match-template-types template type0 type1 type2 backend) + (collect ((types)) + (if type0 (types type0)) + (if type1 (types type1)) + (if type2 (types type2)) + (return (values (x86::x86-opcode-template-ordinal template) + (types)))))))))))) + +(defun fixup-opcode-ordinals (vinsn-template opcode-templates &optional (backend *target-backend*)) + (let* ((changed ())) + (dolist (vinsn-opcode (vinsn-template-opcode-alist vinsn-template)) + (destructuring-bind (old-ordinal name &optional type0 type1 type2) vinsn-opcode + (let* ((opcode-templates (gethash name opcode-templates))) + (unless opcode-templates + (error "Unknown X86 instruction - ~a. Odd, because it was once a known instruction." name)) + (let* ((new-ordinal (dolist (template opcode-templates) + (when (x86::match-template-types template type0 type1 type2 backend) + (return (x86::x86-opcode-template-ordinal template)))))) + (unless new-ordinal + (error "No match for opcode ~s in ~s" vinsn-opcode vinsn-template)) + (unless (eql old-ordinal new-ordinal) + (setf (car vinsn-opcode) new-ordinal) + (push (cons old-ordinal new-ordinal) changed)))))) + (when changed + ;;(format t "~& opcode ordinals changed in ~s: ~s" vinsn-template changed) + (flet ((update-instruction (i) + (when (consp i) + ;; An :ANCHORED-UUO directive contains a real + ;; (vinsn-encoded) instruction (typically a UUO) in + ;; its cadr. Other directives won't contain embedded + ;; instructions and whatever's in their CARs won't + ;; match in the assoc below. + (when (eq (car i) :anchored-uuo) + (setq i (cadr i))) + (let* ((pair (assoc (car i) changed :test #'eq))) + (when pair + (setf (car i) (cdr pair))))))) + (labels ((fixup-form (form) + (unless (atom form) + (if (atom (car form)) + (update-instruction form) + (dolist (f (cdr form)) + (fixup-form f)))))) + (dolist (form (vinsn-template-body vinsn-template)) + (fixup-form form))))))) + +(defparameter *report-missing-vinsns* nil) + +(defun fixup-x86-vinsn-templates (template-hash opcode-templates &optional (backend *target-backend*)) + (maphash #'(lambda (name vinsn-template) + (if (not (cdr vinsn-template)) + (when *report-missing-vinsns* + (warn "Reference to undefined vinsn ~s" name)) + (fixup-opcode-ordinals (cdr vinsn-template) opcode-templates backend))) + template-hash)) + + + +;;; This defines a template. All expressions in the body must be +;;; evaluable at macroexpansion time. +(defun define-x86-vinsn (backend vinsn-name results args temps body) + (let* ((opcode-lookup (backend-lookup-opcode backend)) + (backend-name (backend-name backend)) + (arch-name (backend-target-arch-name backend)) + (template-hash (backend-p2-template-hash-name backend)) + (name-list ()) + (attrs 0) + (nhybrids 0) + (local-labels ()) + (referenced-labels ()) + (source-indicator (form-symbol arch-name "-VINSN")) + (opcode-alist ())) + (flet ((valid-spec-name (x) + (or (and (consp x) + (consp (cdr x)) + (null (cddr x)) + (atom (car x)) + (or (assoc (cadr x) *vreg-specifier-constant-constraints* :test #'eq) + (assoc (cadr x) *spec-class-storage-class-alist* :test #'eq) + (eq (cadr x) :label) + (and (consp (cadr x)) (eq (caadr x) :label) (consp (cdadr x)) (null (cddadr x))) + (and (consp (cadr x)) + (or + (assoc (caadr x) *vreg-specifier-constant-constraints* :test #'eq) + (assoc (caadr x) *spec-class-storage-class-alist* :test #'eq)))) + (car x)) + (error "Invalid vreg spec: ~s" x))) + (add-spec-name (vname) + (if (member vname name-list :test #'eq) + (error "Duplicate name ~s in vinsn ~s" vname vinsn-name) + (push vname name-list)))) + (declare (dynamic-extent #'valid-spec-name #'add-spec-name)) + (when (consp vinsn-name) + (setq attrs (encode-vinsn-attributes (cdr vinsn-name)) + vinsn-name (car vinsn-name))) + (unless (and (symbolp vinsn-name) (eq *CCL-PACKAGE* (symbol-package vinsn-name))) + (setq vinsn-name (intern (string vinsn-name) *CCL-PACKAGE*))) + (dolist (n (append args temps)) + (add-spec-name (valid-spec-name n))) + (dolist (form body) + (if (atom form) + (add-spec-name form))) + (setq name-list (nreverse name-list)) + ;; We now know that "args" is an alist; we don't know if + ;; "results" is. First, make sure that there are no duplicate + ;; result names (and validate "results".) + (do* ((res results tail) + (tail (cdr res) (cdr tail))) + ((null res)) + (let* ((name (valid-spec-name (car res)))) + (if (assoc name tail :test #'eq) + (error "Duplicate result name ~s in ~s." name results)))) + (let* ((non-hybrid-results ()) + (match-args args)) + (dolist (res results) + (let* ((res-name (car res))) + (if (not (assoc res-name args :test #'eq)) + (if (not (= nhybrids 0)) + (error "result ~s should also name an argument. " res-name) + (push res-name non-hybrid-results)) + (if (eq res-name (caar match-args)) + (setf nhybrids (1+ nhybrids) + match-args (cdr match-args)) + (error "~S - hybrid results should appear in same order as arguments." res-name))))) + (dolist (name non-hybrid-results) + (add-spec-name name))) + (let* ((k -1)) + (declare (fixnum k)) + (let* ((name-alist (mapcar #'(lambda (n) (cons n (list (incf k)))) name-list))) + (flet ((find-name (n) + (let* ((pair (assoc n name-alist :test #'eq))) + (declare (list pair)) + (if pair + (cdr pair) + (or (subprim-name->offset n backend) + (error "Unknown name ~s" n)))))) + (labels ((simplify-simple-operand (op) + (if (atom op) + (if (typep op 'fixnum) + op + (if (eq op :rcontext) + op + (if (constantp op) + (progn + (if (keywordp op) + (pushnew op referenced-labels)) + (eval op)) + (find-name op)))) + (if (eq (car op) :^) + (list :^ (simplify-simple-operand (cadr op))) + (if (eq (car op) :apply) + `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))) + (if (member (car op) + '(:tra :align :byte :word :long :quad :talign)) + `(,(car op) ,(simplify-operand (cadr op))) + (simplify-operand (eval op))))))) ; Handler-case this? + (simplify-memory-operand (op) + ;; This happens to be the only place that + ;; we allow segment registers. + (let* ((seg nil) + (disp nil) + (base nil) + (index nil) + (scale nil)) + (do* ((form op (cdr form))) + ((null form) (list seg disp base index scale)) + (let* ((head (car form))) + (if (consp head) + (case (car head) + (:%seg + (if (eq form op) + (setq seg (simplify-operand (cadr head))) + (error "Bad :%seg in ~s" op))) + ((:%q :% :%l) + (let* ((r (simplify-operand head))) + (if base + (if index + (error "Extra register ~s in ~s" + head op) + (setq index r)) + (setq base r)))) + (t + (if (and (null (cdr form)) + (or disp base index)) + (progn + (setq scale (simplify-simple-operand head)) + (if (and base (not index)) + (setq index base base nil))) + (if (not (or disp base index)) + (setq disp (simplify-simple-operand head)) + (error "~s not expected in ~s" head op))))) + (if (and (null (cdr form)) + (or disp base index)) + (progn + (setq scale (simplify-simple-operand head)) + (if (and base (not index)) + (setq index base base nil))) + (if (not (or disp base index)) + (setq disp (simplify-simple-operand head)) + (error "~s not expected in ~s" head op)))))))) + (simplify-operand (op) + (cond ((atom op) + (simplify-simple-operand op)) + ((eq (car op) :@) + (cons :@ + (simplify-memory-operand (cdr op)))) + ((eq (car op) :rcontext) + (list :rcontext + (simplify-simple-operand (cadr op)))) + ((member (car op) + '(:% :%q :%l :%w :%b + :%acc :%accq :%accl :%accw :%accb + :$ :$1 :$b :$ub :$w :$l + :$ul :$q :%mmx :%xmm :%shift :$self)) + (simplify-simple-operand (cadr op))) + (t + (simplify-simple-operand op))))) + (labels ((simplify-constraint (guard) + ;; A constraint is one of + + ;; (:eq|:lt|:gt vreg-name constant) ; "value" + ;; of vreg relop constant + + ;; (:pred * ; + ;; unquoted, each + ;; is a vreg-name or constant expression. + + ;; (:type vreg-name typeval) ; vreg is of + ;; "type" typeval + ;; + ;;(:not ) ; constraint is false + ;; (:and ...) ; conjuntion + ;; (:or ...) ; disjunction + ;; There's no "else"; we'll see how ugly it + ;; is without one. + (destructuring-bind (guardname &rest others) guard + (ecase guardname + (:not + (destructuring-bind (negation) others + `(:not ,(simplify-constraint negation)))) + (:pred + (destructuring-bind (predicate &rest operands) others + `(:pred ,predicate ,@(mapcar #'simplify-operand operands)))) + ((:eq :lt :gt :type) + (destructuring-bind (vreg constant) others + (unless (constantp constant) + (error "~S : not constant in constraint ~s ." constant guard)) + `(,guardname ,(find-name vreg) ,(eval constant)))) + ((:or :and) + (unless others (error "Missing constraint list in ~s ." guard)) + `(,guardname ,(mapcar #'simplify-constraint others)))))) + (simplify-form (form) + (if (atom form) + (progn + (if (keywordp form) (push form local-labels) ) + form) + (destructuring-bind (&whole w opname &rest opvals) form + (if (consp opname) ; A constraint, we presume ... + (cons (simplify-constraint opname) + (mapcar #'simplify-form opvals)) + (if (keywordp opname) + (progn + (list opname + (if (eq opname :anchored-uuo) + (simplify-form (car opvals)) + (simplify-operand (car opvals))))) + (let* ((name (string opname))) + (multiple-value-bind (opnum types) + (funcall opcode-lookup form backend) + (if (not opnum) + (error "Unknown ~A instruction in ~s" backend-name form) + (let* ((opvals (mapcar #'simplify-operand opvals))) + (setf (assq opnum opcode-alist) (cons name types)) + `(,opnum ,@opvals))))))))))) + (let* ((template (make-vinsn-template :name vinsn-name + :result-vreg-specs results + :argument-vreg-specs args + :temp-vreg-specs temps + :nhybrids nhybrids + :results&args (append results (nthcdr nhybrids args)) + :nvp (- (+ (length results) (length args) (length temps)) + nhybrids) + :body (prog1 (mapcar #'simplify-form body) + (dolist (ref referenced-labels) + (unless (memq ref local-labels) + (error + "local-label ~S was referenced but ~ + never defined in VINSN-TEMPLATE definition for ~s" + ref vinsn-name)))) + :local-labels local-labels + :attributes attrs + :opcode-alist opcode-alist))) + + `(progn + (set-vinsn-template ',vinsn-name ,template ,template-hash) + (record-source-file ',vinsn-name ',source-indicator) + ',vinsn-name)))))))))) + + + +#+x8632-target +(require "X8632-BACKEND") +#+x8664-target +(require "X8664-BACKEND") + +(defparameter *x86-backend* + #+x8632-target *x8632-backend* + #+x8664-target *x8664-backend* + #-x86-target nil) + + +(defun fixup-x86-backend (&rest args) + #+x8632-target (apply #'fixup-x8632-backend args) + #+x8664-target (apply #'fixup-x8664-backend args) + #-x86-target (declare (ignore args)) + ) + +(provide "X86-BACKEND") Index: /branches/qres/ccl/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/x86-disassemble.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/x86-disassemble.lisp (revision 13564) @@ -0,0 +1,2982 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "NXENV") + (require "DLL-NODE") + (require "X86-ASM") + (require "X86-LAP")) + +(defstruct (x86-disassembled-instruction (:include dll-node) + (:conc-name x86-di-)) + address + labeled + prefixes ;explicit prefixes + mnemonic + op0 + op1 + op2 + ) + +(defmethod print-object ((xdi x86-disassembled-instruction) stream) + (print-unreadable-object (xdi stream :type t :identity t) + (dolist (p (x86-di-prefixes xdi)) + (format stream "(~a) " p)) + (format stream "(~a" (x86-di-mnemonic xdi)) + (let* ((op0 (x86-di-op0 xdi)) + (op1 (x86-di-op1 xdi)) + (op2 (x86-di-op2 xdi)) + (ds (make-x86-disassembly-state :mode-64 #+x8664-target t + #+x8632-target nil + :code-vector nil + :code-pointer 0))) + (when op0 + (write-x86-lap-operand stream op0 ds) + (when op1 + (write-x86-lap-operand stream op1 ds) + (when op2 + (write-x86-lap-operand stream op2 ds))))) + (format stream ")"))) + +(defstruct (x86-disassembly-state (:conc-name x86-ds-)) + (mode-64 t) + (prefixes 0) + (used-prefixes 0) + (rex 0) + (rex-used 0) + (need-modrm nil) + (mod 0) + (reg 0) + (rm 0) + (blocks (make-dll-header)) + (insn-start 0) ; offset of first prefix byte + (opcode-start 0) ; offset of first opcode byte + code-vector + code-pointer + code-limit + constants-vector + pending-labels + (entry-point 0) + current-instruction + (string-buffer (make-array 16 :element-type 'character + :fill-pointer 0 + :adjustable t)) + (symbolic-names ()) +) + +(defun badop (ds) + (setf (x86-ds-code-pointer ds) (1+ (x86-ds-opcode-start ds))) + ;;; Do more here. + ) + +(defun x86-ds-peek-u8 (ds) + (aref (x86-ds-code-vector ds) (x86-ds-code-pointer ds))) + +(defun x86-ds-skip (ds &optional (n 1)) + (incf (x86-ds-code-pointer ds) n)) + +(defun x86-ds-next-u8 (ds) + (let* ((idx (x86-ds-code-pointer ds))) + (incf (x86-ds-code-pointer ds)) + (aref (x86-ds-code-vector ds) idx))) + +(defun x86-ds-next-s8 (ds) + (let* ((u8 (x86-ds-next-u8 ds))) + (if (logbitp 7 u8) + (- u8 #x100) + u8))) + +(defun x86-ds-next-u16 (ds) + (let* ((low (x86-ds-next-u8 ds)) + (high (x86-ds-next-u8 ds))) + (declare (type (unsigned-byte 8) low high)) + (logior (the fixnum (ash high 8)) low))) + +(defun x86-ds-next-s16 (ds) + (let* ((low (x86-ds-next-u8 ds)) + (high (x86-ds-next-s8 ds))) + (declare (type (unsigned-byte 8) low) + (type (signed-byte 8) high)) + (logior (the fixnum (ash high 8)) low))) + +(defun x86-ds-next-u32 (ds) + (let* ((low (x86-ds-next-u16 ds)) + (high (x86-ds-next-u16 ds))) + (declare (type (unsigned-byte 16) low high)) + (logior (ash high 16) low))) + +(defun x86-ds-next-s32 (ds) + (let* ((low (x86-ds-next-u16 ds)) + (high (x86-ds-next-s16 ds))) + (declare (type (unsigned-byte 16) low) + (type (signed-byte 16) high)) + (logior (ash high 16) low))) + +(defun x86-ds-next-u64 (ds) + (let* ((low (x86-ds-next-u32 ds)) + (high (x86-ds-next-u32 ds))) + (logior (ash high 32) low))) + +(defun x86-ds-next-s64 (ds) + (let* ((low (x86-ds-next-u32 ds)) + (high (x86-ds-next-s32 ds))) + (logior (ash high 32) low))) + +(defun used-rex (ds value) + (if (not (zerop value)) + (setf (x86-ds-rex-used ds) + (logior (x86-ds-rex-used ds) + (if (logtest (x86-ds-rex ds) value) + #x40 + 0))) + (setf (x86-ds-rex-used ds) + (logior (x86-ds-rex-used ds) #x40)))) + +(defun used-prefix (ds mask) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) + (logand (x86-ds-prefixes ds) mask)))) + + + +;;; An x86-disassembly-block is -something- like a basic block in a +;;; compiler flow graph; it ends with an unconditional jump and it's +;;; either the entry node in that graph or it's reachable via a jump +;;; or branch from some other reachable block. There may, however, be +;;; internal labels that are referenced from within the block's +;;; instructions, from some other block, or both. Each disassembled +;;; instruction within a block keeps track of its address and whether +;;; or not it's a label (a branch or jump target or a tagged return +;;; address.) The first instruction in each block is a label; others +;;; (initally) aren't. Whenever we encounter a branch or jmp +;;; instruction (or a manipulation of a tagged return address, which +;;; is a kind of jmp) and determine the address of the label, we add +;;; that address to the disassembly-state's PENDING-LABELS set. When +;;; we're through processing the block (having encountered an +;;; unconditional jmp), we remove a pending label from that set. If +;;; it's within a block that's already been processed, we ensure that +;;; the instruction at that address is marked as a label; otherwise, +;;; we process the new block which starts at that address. +;;; Eventually, this'll terminate with all reachable code having been +;;; processed. There's embedded data and alignment padding in Clozure CL +;;; x86 functions and this approach means that we won't try to +;;; disassemble any of that; if the compiler generates any unreachable +;;; code, we won't see that, either. + +;;; There might be a large number of blocks, in which case +;;; keeping them in a search tree might be a better idea. +(defstruct (x86-dis-block (:include dll-node)) + start-address + end-address + (instructions (make-dll-header)) +) + +;;; Insert the block before the first existing block whose +;;; start address is greater than or equal to this block's +;;; end address. (Yes, they can be equal; no, there should +;;; never be any overlap.) +(defun insert-x86-block (block blocks) + (let* ((this-end (x86-dis-block-end-address block))) + (declare (fixnum this-end)) + (do-dll-nodes (other blocks (append-dll-node block blocks)) + (when (>= (the fixnum (x86-dis-block-start-address other)) + this-end) + (return (insert-dll-node-before block other)))))) + +(defun x86-dis-find-label (address blocks) + (declare (fixnum address)) + (do-dll-nodes (block blocks) + (when (and (>= address (the fixnum (x86-dis-block-start-address block))) + (< address (the fixnum (x86-dis-block-end-address block)))) + (let* ((instruction + (do-dll-nodes (i (x86-dis-block-instructions block)) + (when (= (x86-di-address i) address) + (return i))))) + (unless instruction + (error "Bug: no instruction at address #x~x" address)) + (return (or (x86-di-labeled instruction) + (setf (x86-di-labeled instruction) t))))))) + + +;;; Flags stored in PREFIXES +(defconstant +PREFIX-REPZ+ 1) +(defconstant +PREFIX-REPNZ+ 2) +(defconstant +PREFIX-LOCK+ 4) +(defconstant +PREFIX-CS+ 8) +(defconstant +PREFIX-SS+ #x10) +(defconstant +PREFIX-DS+ #x20) +(defconstant +PREFIX-ES+ #x40) +(defconstant +PREFIX-FS+ #x80) +(defconstant +PREFIX-GS+ #x100) +(defconstant +PREFIX-DATA+ #x200) +(defconstant +PREFIX-ADDR+ #x400) +(defconstant +PREFIX-FWAIT+ #x800) + + + + +(defstruct (x86-dis (:constructor %make-x86-dis)) + mnemonic ; may be nil + flags ; extra info + op1 ; function to obtain 1st operand + bytemode1 ; flags associated with operand1 + op2 ; function for second operand + bytemode2 ; flags for operand2 + op3 ; function, + bytemode3 ; flags for operand3 + ) + +(defconstant +SUFFIX-ALWAYS+ 4) +(defconstant +AFLAG+ 2) +(defconstant +DFLAG+ 1) + +(defconstant +b-mode+ 1) ; byte operand +(defconstant +v-mode+ 2) ; operand size depends on prefixes +(defconstant +w-mode+ 3) ; word operand +(defconstant +d-mode+ 4) ; double word operand +(defconstant +q-mode+ 5) ; quad word operand +(defconstant +t-mode+ 6) ; ten-byte operand +(defconstant +x-mode+ 7) ; 16-byte XMM operand +(defconstant +m-mode+ 8) ; d-mode in 32bit, q-mode in 64bit mode. +(defconstant +cond-jump-mode+ 9) +(defconstant +loop-jcxz-mode+ 10) +(defconstant +dq-mode+ 11) ; operand size depends on REX prefixes. +(defconstant +dqw-mode+ 12) ; registers like dq-mode, memory like w-mode. +(defconstant +f-mode+ 13) ; 4- or 6-byte pointer operand +(defconstant +const-1-mode+ 14) + +(defconstant +es-reg+ 100) +(defconstant +cs-reg+ 101) +(defconstant +ss-reg+ 102) +(defconstant +ds-reg+ 103) +(defconstant +fs-reg+ 104) +(defconstant +gs-reg+ 105) + +(defconstant +eAX-reg+ 108) +(defconstant +eCX-reg+ 109) +(defconstant +eDX-reg+ 110) +(defconstant +eBX-reg+ 111) +(defconstant +eSP-reg+ 112) +(defconstant +eBP-reg+ 113) +(defconstant +eSI-reg+ 114) +(defconstant +eDI-reg+ 115) + +(defconstant +al-reg+ 116) +(defconstant +cl-reg+ 117) +(defconstant +dl-reg+ 118) +(defconstant +bl-reg+ 119) +(defconstant +ah-reg+ 120) +(defconstant +ch-reg+ 121) +(defconstant +dh-reg+ 122) +(defconstant +bh-reg+ 123) + +(defconstant +ax-reg+ 124) +(defconstant +cx-reg+ 125) +(defconstant +dx-reg+ 126) +(defconstant +bx-reg+ 127) +(defconstant +sp-reg+ 128) +(defconstant +bp-reg+ 129) +(defconstant +si-reg+ 130) +(defconstant +di-reg+ 131) + +(defconstant +rAX-reg+ 132) +(defconstant +rCX-reg+ 133) +(defconstant +rDX-reg+ 134) +(defconstant +rBX-reg+ 135) +(defconstant +rSP-reg+ 136) +(defconstant +rBP-reg+ 137) +(defconstant +rSI-reg+ 138) +(defconstant +rDI-reg+ 139) + +(defconstant +indir-dx-reg+ 150) + +(defconstant +FLOATCODE+ 1) +(defconstant +USE-GROUPS+ 2) +(defconstant +USE-PREFIX-USER-TABLE+ 3) +(defconstant +X86-64-SPECIAL+ 4) +(defconstant +UUOCODE+ 5) + +(defconstant +REX-MODE64+ 8) +(defconstant +REX-EXTX+ 4) +(defconstant +REX-EXTY+ 2) +(defconstant +REX-EXTZ+ 1) + +(defparameter *x86-segment-prefix-alist* + `((,+prefix-cs+ . "cs") + (,+prefix-ds+ . "ds") + (,+prefix-ss+ . "ss") + (,+prefix-es+ . "es") + (,+prefix-fs+ . "fs") + (,+prefix-gs+ . "gs"))) + + +(defun segment-register-from-prefixes (ds) + (let* ((prefixes (x86-ds-prefixes ds))) + (dolist (pair *x86-segment-prefix-alist*) + (when (logtest (car pair) prefixes) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) + (car pair))) + (return (parse-x86-register-operand (cdr pair) :%)))))) + +(defun x86-dis-make-reg-operand (r) + (x86::make-x86-register-operand + :type (logandc2 (x86::reg-entry-reg-type r) + (x86::encode-operand-type :baseIndex)) + :entry r)) + +(defun op-st (ds bytemode sizeflag) + (declare (ignore ds bytemode sizeflag)) + (parse-x86-register-operand "st" :%)) + +(defun op-sti (ds bytemode sizeflag) + (declare (ignore bytemode sizeflag)) + (x86-dis-make-reg-operand (svref x86::*x86-float-regs* (x86-ds-rm ds)))) + +(defun op-indire (ds bytemode sizeflag) + (when (and (x86-ds-mode-64 ds) + (zerop (x86-ds-prefixes ds))) + (setf (x86-ds-rex ds) (logior #x48 (x86-ds-rex ds)))) + (op-e ds bytemode sizeflag)) + + +(defun op-e (ds bytemode sizeflag) + (let* ((add 0) + (riprel nil)) + (used-rex ds +rex-extz+) + (if (logtest (x86-ds-rex ds) +rex-extz+) + (setq add 8)) + (x86-ds-skip ds) ;skip MODRM byte + (cond ((eql (x86-ds-mod ds) 3) ; EA is just a register + (cond ((eql bytemode +b-mode+) + (used-rex ds 0) + ;; This is wrong: if we don't have an REX prefix, + ;; we should use the old byte register names + ;; (dh, ah, ...) instead of the new ones (bpl, sil ...) + ;; That'll matter if Lisp code ever needs to + ;; access the #xff00 byte, but that seems unlikely + (x86-dis-make-reg-operand (x86::x86-reg8 (+ (x86-ds-rm ds) + add)))) + ((eql bytemode +w-mode+) + (x86-dis-make-reg-operand (x86::x86-reg16 (+ (x86-ds-rm ds) + add)))) + ((eql bytemode +d-mode+) + (x86-dis-make-reg-operand (x86::x86-reg32 (+ (x86-ds-rm ds) + add)))) + ((eql bytemode +q-mode+) + (x86-dis-make-reg-operand (x86::x86-reg64 (+ (x86-ds-rm ds) + add)))) + ((eql bytemode +m-mode+) + (if (x86-ds-mode-64 ds) + (x86-dis-make-reg-operand (x86::x86-reg64 (+ (x86-ds-rm ds) + add))) + (x86-dis-make-reg-operand (x86::x86-reg32 (+ (x86-ds-rm ds) + add))))) + ((or (eql bytemode +v-mode+) + (eql bytemode +dq-mode+) + (eql bytemode +dqw-mode+)) + (used-rex ds +rex-mode64+) + (used-prefix ds +prefix-data+) + (cond ((logtest (x86-ds-rex ds) +rex-mode64+) + (x86-dis-make-reg-operand (x86::x86-reg64 (+ (x86-ds-rm ds) + add)))) + ((or (logtest sizeflag +dflag+) + (not (eql bytemode +v-mode+))) + (x86-dis-make-reg-operand (x86::x86-reg32 (+ (x86-ds-rm ds) + add)))) + (t + (x86-dis-make-reg-operand (x86::x86-reg16 (+ (x86-ds-rm ds) + add)))))) + ((eql bytemode 0) nil) + (t (error "Disassembly error")))) + (t ; memory operand + (let* ((disp nil) + (base (x86-ds-rm ds)) + (index nil) + (scale nil) + (have-base t) + (have-sib nil) + (memop (x86::make-x86-memory-operand))) + (setf (x86::x86-memory-operand-seg memop) + (segment-register-from-prefixes ds)) + (when (= base 4) + (setq have-sib t) + (let* ((sib (x86-ds-next-u8 ds))) + (setq index (ldb (byte 3 3) sib)) + (if (or (x86-ds-mode-64 ds) + (not (eql index 4))) + (setq scale (ldb (byte 2 6) sib))) + (setq base (ldb (byte 3 0) sib)) + (used-rex ds +rex-exty+) + (used-rex ds +rex-extz+) + (when (logtest (x86-ds-rex ds) +rex-exty+) + (incf index 8)) + (when (logtest (x86-ds-rex ds) +rex-extz+) + (incf base 8)))) + (case (x86-ds-mod ds) + (0 + (when (= 5 (logand base 7)) + (setq have-base nil) + (if (and (x86-ds-mode-64 ds) (not have-sib)) + (setq riprel t)) + (setq disp (x86-ds-next-s32 ds)))) + (1 + (setq disp (x86-ds-next-s8 ds))) + (2 + (setq disp (x86-ds-next-s32 ds)))) + (when (or (not (eql (x86-ds-mod ds) 0)) + (eql 5 (logand base 7))) + (setf (x86::x86-memory-operand-disp memop) + (parse-x86-lap-expression disp)) + (when riprel + (setf (x86::x86-memory-operand-base memop) + (parse-x86-register-operand "rip" :%)))) + (when (or have-base + (and have-sib + (or (not (eql index 4)) + (not (eql scale 0))))) + (used-rex ds +rex-extz+) + (if (and (not have-sib) + (logtest (x86-ds-rex ds) +rex-extz+)) + (incf base 8)) + (if have-base + (setf (x86::x86-memory-operand-base memop) + (if (and (x86-ds-mode-64 ds) + (logtest sizeflag +aflag+)) + (x86-dis-make-reg-operand (x86::x86-reg64 base)) + (x86-dis-make-reg-operand (x86::x86-reg32 base))))) + (when have-sib + (unless (= index 4) + (setf (x86::x86-memory-operand-index memop) + (if (and (x86-ds-mode-64 ds) + (logtest sizeflag +aflag+)) + (x86-dis-make-reg-operand (x86::x86-reg64 index)) + (x86-dis-make-reg-operand (x86::x86-reg32 index))))) + (unless scale + (setq scale 0)) + (when (or (not (eql scale 0)) + (not (eql index 4))) + (setf (x86::x86-memory-operand-scale memop) scale)))) + memop))))) + + +(defun op-g (ds bytemode sizeflag) + (let* ((add 0) + (reg (x86-ds-reg ds))) + (used-rex ds +rex-extx+) + (if (logtest (x86-ds-rex ds) +rex-extx+) + (setq add 8)) + (cond ((eql bytemode +b-mode+) + (used-rex ds 0) + ;; This is wrong: if we don't have an REX prefix, + ;; we should use the old byte register names + ;; (dh, ah, ...) instead of the new ones (bpl, sil ...) + ;; That'll matter if Lisp code ever needs to + ;; access the #xff00 byte, but that seems unlikely + (x86-dis-make-reg-operand (x86::x86-reg8 (+ reg add)))) + ((eql bytemode +w-mode+) + (x86-dis-make-reg-operand (x86::x86-reg16 (+ reg add)))) + ((eql bytemode +d-mode+) + (x86-dis-make-reg-operand (x86::x86-reg32 (+ reg add)))) + ((eql bytemode +q-mode+) + (x86-dis-make-reg-operand (x86::x86-reg64 (+ reg add)))) + ((eql bytemode +m-mode+) + (if (x86-ds-mode-64 ds) + (x86-dis-make-reg-operand (x86::x86-reg64 (+ reg add))) + (x86-dis-make-reg-operand (x86::x86-reg32 (+ reg add))))) + ((or (eql bytemode +v-mode+) + (eql bytemode +dq-mode+) + (eql bytemode +dqw-mode+)) + (used-rex ds +rex-mode64+) + (used-prefix ds +prefix-data+) + (cond ((logtest (x86-ds-rex ds) +rex-mode64+) + (x86-dis-make-reg-operand (x86::x86-reg64 (+ reg add)))) + ((or (logtest sizeflag +dflag+) + (not (eql bytemode +v-mode+))) + (x86-dis-make-reg-operand (x86::x86-reg32 (+ reg add)))) + (t + (x86-dis-make-reg-operand (x86::x86-reg16 (+ reg add)))))) + ((eql bytemode 0) nil) + (t (error "Disassembly error"))))) + +(defun op-reg (ds code sizeflag) + (declare (fixnum code)) + (let* ((add 0)) + (used-rex ds +rex-extz+) + (if (logtest (x86-ds-rex ds) +rex-extz+) + (setq add 8)) + (cond ((= code +indir-dx-reg+) + (x86::make-x86-memory-operand + :base (parse-x86-register-operand "dx" :%))) + (t + (let* ((r (cond ((and (>= code +ax-reg+) + (<= code +di-reg+)) + (x86::x86-reg16 (+ (- code +ax-reg+) add))) + ((= code +es-reg+) (lookup-x86-register "es" :%)) + ((= code +cs-reg+) (lookup-x86-register "cs" :%)) + ((= code +ds-reg+) (lookup-x86-register "ds" :%)) + ((= code +ss-reg+) (lookup-x86-register "ss" :%)) + ((= code +fs-reg+) (lookup-x86-register "fs" :%)) + ((= code +gs-reg+) (lookup-x86-register "gs" :%)) + ((and (>= code +al-reg+) + (<= code +dh-reg+)) + ;; Again, this is wrong if there's no REX + ;; prefix. + (used-rex ds 0) + (x86::x86-reg8 (+ add (- code +al-reg+)))) + ((and (>= code +rax-reg+) + (<= code +rdi-reg+) + (or (x86-ds-mode-64 ds) + (progn + (setq code (+ code (- +eax-reg+ +rax-reg+))) + nil))) + (x86::x86-reg64 (+ add (- code +rax-reg+)))) + ((and (>= code +eax-reg+) + (<= code +edi-reg+)) + (used-rex ds +rex-mode64+) + (used-prefix ds +prefix-data+) + (if (logtest (x86-ds-rex ds) +rex-mode64+) + (x86::x86-reg64 (+ add (- code +eax-reg+))) + (if (logtest sizeflag +dflag+) + (x86::x86-reg32 (+ add (- code +eax-reg+))) + (x86::x86-reg16 (+ add (- code +eax-reg+)))))) + ((and (>= code +al-reg+) + (<= code +bh-reg+)) + (x86::x86-reg8 (+ add (- code +al-reg+)))) + (t (error "Disassembly error: code = ~s" code))))) + (x86-dis-make-reg-operand r)))))) + +;;; Like OP-REG, but doesn't deal with extended 64-bit registers. +(defun op-imreg (ds code sizeflag) + (declare (fixnum code)) + (cond ((= code +indir-dx-reg+) + (x86::make-x86-memory-operand + :base (parse-x86-register-operand "dx" :%))) + (t + (let* ((r (cond ((and (>= code +ax-reg+) + (<= code +di-reg+)) + (x86::x86-reg16 (- code +ax-reg+))) + ((= code +es-reg+) (lookup-x86-register "es" :%)) + ((= code +cs-reg+) (lookup-x86-register "cs" :%)) + ((= code +ds-reg+) (lookup-x86-register "ds" :%)) + ((= code +ss-reg+) (lookup-x86-register "ss" :%)) + ((= code +fs-reg+) (lookup-x86-register "fs" :%)) + ((= code +gs-reg+) (lookup-x86-register "gs" :%)) + ((and (>= code +al-reg+) + (<= code +dh-reg+)) + ;; Again, this is wrong if there's no REX + ;; prefix. + (used-rex ds 0) + (x86::x86-reg8 (- code +al-reg+))) + + ((and (>= code +eax-reg+) + (<= code +edi-reg+)) + (used-rex ds +rex-mode64+) + (used-prefix ds +prefix-data+) + (if (logtest (x86-ds-rex ds) +rex-mode64+) + (x86::x86-reg64 (- code +eax-reg+)) + (if (logtest sizeflag +dflag+) + (x86::x86-reg32 (- code +eax-reg+)) + (x86::x86-reg16 (- code +eax-reg+))))) + (t (error "Disassembly error"))))) + (x86-dis-make-reg-operand r))))) + +;;; A (possibly unsigned) immediate. +(defun op-i (ds bytemode sizeflag) + (let* ((mask -1) + (op (cond ((= bytemode +b-mode+) + (setq mask #xff) + (x86-ds-next-u8 ds)) + ((and (= bytemode +q-mode+) + (x86-ds-mode-64 ds)) + (x86-ds-next-s32 ds)) + ((or (= bytemode +q-mode+) + (= bytemode +v-mode+)) + (used-rex ds +rex-mode64+) + (used-prefix ds +prefix-data+) + (if (logtest (x86-ds-rex ds) +rex-mode64+) + (x86-ds-next-s32 ds) + (if (logtest sizeflag +dflag+) + (progn + (setq mask #xffffffff) + (x86-ds-next-u32 ds)) + (progn + (setq mask #xfffff) + (x86-ds-next-u16 ds))))) + ((= bytemode +w-mode+) + (setq mask #xfffff) + (x86-ds-next-u16 ds)) + ((= bytemode +const-1-mode+) + nil)))) + (when op + (setq op (logand op mask)) + (x86::make-x86-immediate-operand :value (parse-x86-lap-expression op))))) + +(defun op-i64 (ds bytemode sizeflag) + (if (not (x86-ds-mode-64 ds)) + (op-i ds bytemode sizeflag) + (let* ((op (cond ((= bytemode +b-mode+) + (x86-ds-next-u8 ds)) + ((= bytemode +v-mode+) + (used-rex ds +rex-mode64+) + (used-prefix ds +prefix-data+) + (if (logtest (x86-ds-rex ds) +rex-mode64+) + (x86-ds-next-u64 ds) + (if (logtest sizeflag +dflag+) + (x86-ds-next-u32 ds) + (x86-ds-next-u16 ds)))) + ((= bytemode +w-mode+) + (x86-ds-next-u16 ds)) + (t (error "Disassembly error"))))) + (when op + (x86::make-x86-immediate-operand :value (parse-x86-lap-expression op)))))) + +(defun op-si (ds bytemode sizeflag) + (let* ((op + (cond ((= bytemode +b-mode+) + (x86-ds-next-s8 ds)) + ((= bytemode +v-mode+) + (used-rex ds +rex-mode64+) + (used-prefix ds +prefix-data+) + (if (logtest (x86-ds-rex ds) +rex-mode64+) + (x86-ds-next-s32 ds) + (if (logtest sizeflag +dflag+) + (x86-ds-next-s32 ds) + (x86-ds-next-s16 ds)))) + ((= bytemode +w-mode+) + (x86-ds-next-s16 ds)) + (t (error "Disassembly error"))))) + (x86::make-x86-immediate-operand :value (parse-x86-lap-expression op)))) + +(defun op-j (ds bytemode sizeflag) + (let* ((mask -1) + (disp (cond ((= bytemode +b-mode+) + (x86-ds-next-s8 ds)) + ((= bytemode +v-mode+) + (if (logtest sizeflag +dflag+) + (x86-ds-next-s32 ds) + (progn + (setq mask #xffff) + (x86-ds-next-u16 ds)))) + (t (error "Disassembly error")))) + (label-address (logand (+ (x86-ds-code-pointer ds) disp) + mask))) + (push label-address (x86-ds-pending-labels ds)) + (x86::make-x86-label-operand :label label-address))) + +(defun op-seg (ds x y) + (declare (ignore x y)) + (x86-dis-make-reg-operand (x86::x86-segment-register (x86-ds-reg ds)))) + +(defun op-dir (ds x sizeflag) + (declare (ignore x)) + (let* ((offset (if (logtest sizeflag +dflag+) + (x86-ds-next-u32 ds) + (x86-ds-next-u16 ds))) + (seg (x86-ds-next-u16 ds))) + (list (x86::make-x86-immediate-operand :value (parse-x86-lap-expression seg)) + (x86::make-x86-memory-operand :disp (parse-x86-lap-expression offset))))) + +(defun op-off (ds x sizeflag) + (declare (ignore x)) + (x86::make-x86-memory-operand + :seg (segment-register-from-prefixes ds) + :disp (parse-x86-lap-expression (cond ((or (x86-ds-mode-64 ds) + (logtest sizeflag +aflag+)) + (x86-ds-next-u32 ds)) + (t (x86-ds-next-u16 ds)))))) + + +(defun op-off64 (ds bytemode sizeflag) + (if (not (x86-ds-mode-64 ds)) + (op-off ds bytemode sizeflag) + (x86::make-x86-memory-operand + :seg (segment-register-from-prefixes ds) + :disp (parse-x86-lap-expression (x86-ds-next-u64 ds))))) + + +(defun %ptr-reg (ds code sizeflag) + (used-prefix ds +prefix-addr+) + (let* ((idx (- code +eax-reg+)) + (r (if (x86-ds-mode-64 ds) + (if (not (logtest sizeflag +aflag+)) + (x86::x86-reg32 idx) + (x86::x86-reg64 idx)) + (if (logtest sizeflag +aflag+) + (x86::x86-reg32 idx) + (x86::x86-reg16 idx))))) + (x86-dis-make-reg-operand r))) + +(defun op-esreg (ds code sizeflag) + (x86::make-x86-memory-operand + :seg (parse-x86-register-operand "es" :%) + :base (%ptr-reg ds code sizeflag))) + +(defun op-dsreg (ds code sizeflag) + (unless (logtest (x86-ds-prefixes ds) + (logior +prefix-cs+ + +prefix-ds+ + +prefix-ss+ + +prefix-es+ + +prefix-fs+ + +prefix-gs+)) + (setf (x86-ds-prefixes ds) + (logior (x86-ds-prefixes ds) +prefix-ds+))) + (x86::make-x86-memory-operand + :seg (segment-register-from-prefixes ds) + :base (%ptr-reg ds code sizeflag))) + +;;; Control-register reference. +(defun op-c (ds x sizeflag) + (declare (ignore x sizeflag)) + (let* ((add (cond ((logtest (x86-ds-rex ds) +rex-extx+) + (used-rex ds +rex-extx+) + 8) + ((and (not (x86-ds-mode-64 ds)) + (logtest (x86-ds-prefixes ds) +prefix-lock+)) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) +prefix-lock+)) + 8) + (t 0))) + (regname (format nil "cr~d" (+ (x86-ds-reg ds) add)))) + (parse-x86-register-operand regname :%))) + +;;; Debug-register reference. +(defun op-d (ds x sizeflag) + (declare (ignore x sizeflag)) + (used-rex ds +rex-extx+) + (let* ((add (if (logtest (x86-ds-rex ds) +rex-extx+) + 8 + 0)) + (regname (format nil "db~d" (+ (x86-ds-reg ds) add)))) + (parse-x86-register-operand regname :%))) + +;;; Test-register. There are only 8 of them, even on x86-64. +(defun op-t (ds x y) + (declare (ignore x y)) + (parse-x86-register-operand (format nil "tr~d" (x86-ds-reg ds)) :%)) + +(defun op-rd (ds bytemode sizeflag) + (if (= (x86-ds-mod ds) 3) + (op-e ds bytemode sizeflag) + (badop ds))) + + +;;; A data prefix causes a reference to an xmm register instead of +;;; the (default) case of referencing an mmx register. +(defun op-mmx (ds x sizeflag) + (declare (ignore x sizeflag)) + (let* ((prefixes (x86-ds-prefixes ds))) + (used-prefix ds +prefix-data+) + (if (logtest prefixes +prefix-data+) + (let* ((add (progn (used-rex ds +rex-extx+) + (if (logtest (x86-ds-rex ds) +rex-extx+) + 8 + 0)))) + (x86-dis-make-reg-operand (x86::x86-xmm-register (+ (x86-ds-reg ds) add)))) + (x86-dis-make-reg-operand (x86::x86-mmx-register (x86-ds-reg ds)))))) + + +(defun op-xmm (ds bytemode sizeflag) + (declare (ignore bytemode sizeflag)) + (used-rex ds +rex-extx+) + (let* ((add (if (logtest (x86-ds-rex ds) +rex-extx+) 8 0))) + (x86-dis-make-reg-operand (x86::x86-xmm-register (+ (x86-ds-reg ds) add))))) + +(defun op-em (ds bytemode sizeflag) + (if (not (eql (x86-ds-mod ds) 3)) + (op-e ds bytemode sizeflag) + (let* ((prefixes (x86-ds-prefixes ds))) + (x86-ds-skip ds) ; skip modrm + (used-prefix ds +prefix-data+) + (cond ((logtest prefixes +prefix-data+) + (used-rex ds +rex-extz+) + (let* ((add (if (logtest (x86-ds-rex ds) +rex-extz+) + 8 + 0))) + (x86-dis-make-reg-operand + (x86::x86-xmm-register (+ (x86-ds-rm ds) add))))) + (t + (x86-dis-make-reg-operand + (x86::x86-mmx-register (x86-ds-rm ds)))))))) + +(defun op-ex (ds bytemode sizeflag) + (if (not (eql (x86-ds-mod ds) 3)) + (op-e ds bytemode sizeflag) + (let* ((add (if (logtest (x86-ds-rex ds) +rex-extz+) 8 0))) + (used-rex ds +rex-extz+) + (x86-ds-skip ds) ; skip modrm + (x86-dis-make-reg-operand (x86::x86-xmm-register (+ (x86-ds-rm ds) add)))))) + +(defun op-ms (ds bytemode sizeflag) + (if (eql (x86-ds-mod ds) 3) + (op-em ds bytemode sizeflag) + (badop ds))) + +(defun op-xs (ds bytemode sizeflag) + (if (eql (x86-ds-mod ds) 3) + (op-ex ds bytemode sizeflag) + (badop ds))) + +(defun op-m (ds bytemode sizeflag) + (if (eql (x86-ds-mod ds) 3) + (badop ds) + (op-e ds bytemode sizeflag))) + +(defun op-0f07 (ds bytemode sizeflag) + (if (or (not (eql (x86-ds-mod ds) 3)) + (not (eql (x86-ds-rm ds) 0))) + (badop ds) + (op-e ds bytemode sizeflag))) + +(defun nop-fixup (ds bytemode sizeflag) + (declare (ignore bytemode sizeflag) + (ignorable ds)) + #+nothing + (if (logtest (x86-ds-prefixes ds) +prefix-repz+) + (break "should be PAUSE"))) + +;;; + +(defun make-x86-dis (opstring &optional + op1-fun + (op1-byte 0) + op2-fun + (op2-byte 0) + op3-fun + (op3-byte 0)) + (let* ((flags nil)) + (if (consp opstring) + (setq flags (cdr opstring) opstring (car opstring))) + (%make-x86-dis :mnemonic opstring + :flags flags + :op1 op1-fun + :bytemode1 op1-byte + :op2 op2-fun + :bytemode2 op2-byte + :op3 op3-fun + :bytemode3 op3-byte))) + + +;;; The root of all evil, unless the first byte of the opcode +;;; is #xf +(defparameter *disx86* + (vector + ;; #x00 + (make-x86-dis "addB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "addS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "addB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "addS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "addB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "addS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis '(("pushT" . "(bad)")) 'op-reg +es-reg+) + (make-x86-dis '(("popT" . "(bad)")) 'op-reg +es-reg+) + ;; #x08 + (make-x86-dis "orB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "orS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "orB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "orS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "orB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "orS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis '(("pushT" . "(bad)")) 'op-reg +cs-reg+) + (make-x86-dis "(bad)") ; #x0f extended opcode escape + ;; #x10 + (make-x86-dis "adcB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "adcS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "adcB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "adcS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "adcB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "adcS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis '(("pushT" . "(bad)")) 'op-reg +ss-reg+) + (make-x86-dis '(("popT" . "(bad)")) 'op-reg +ss-reg+) + ;; #x18 + (make-x86-dis "sbbB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "sbbS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "sbbB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "sbbS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "sbbB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "sbbS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis '(("pushT" . "(bad)")) 'op-reg +ds-reg+) + (make-x86-dis '(("popT" . "(bad)")) 'op-reg +ds-reg+) + ;; #x20 + (make-x86-dis "andB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "andS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "andB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "andS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "andB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "andS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis "(bad)") ; SEG ES prefix + (make-x86-dis '(("daa" . "(bad)"))) + ;; #x28 + (make-x86-dis "subB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "subS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "subB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "subS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "subB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "subS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis "(bad)") ; SEG CS prefix + (make-x86-dis '(("das" . "(bad)"))) + ;; #x30 + (make-x86-dis "xorB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "xorS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "xorB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "xorS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "xorB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "xorS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis "(bad)") ; SEG SS prefix + (make-x86-dis '(("aaa" . "(bad)"))) + ;; #x38 + (make-x86-dis "cmpB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "cmpS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "cmpB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "cmpS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmpB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "cmpS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis "(bad)") ; SEG DS prefix + (make-x86-dis '(("aas" . "(bad)"))) + ;; #x40 + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +eax-reg+) + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +ecx-reg+) + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +edx-reg+) + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +ebx-reg+) + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +esp-reg+) + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +ebp-reg+) + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +esi-reg+) + (make-x86-dis '(("incS" . "(bad)")) 'op-reg +edi-reg+) + ;; #x48 + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +eax-reg+) + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +ecx-reg+) + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +edx-reg+) + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +ebx-reg+) + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +esp-reg+) + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +ebp-reg+) + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +esi-reg+) + (make-x86-dis '(("decS" . "(bad)")) 'op-reg +edi-reg+) + ;; #x50 + (make-x86-dis "pushT" 'op-reg +rax-reg+) + (make-x86-dis "pushT" 'op-reg +rcx-reg+) + (make-x86-dis "pushT" 'op-reg +rdx-reg+) + (make-x86-dis "pushT" 'op-reg +rbx-reg+) + (make-x86-dis "pushT" 'op-reg +rsp-reg+) + (make-x86-dis "pushT" 'op-reg +rbp-reg+) + (make-x86-dis "pushT" 'op-reg +rsi-reg+) + (make-x86-dis "pushT" 'op-reg +rdi-reg+) + ;; #x58 + (make-x86-dis "popT" 'op-reg +rax-reg+) + (make-x86-dis "popT" 'op-reg +rcx-reg+) + (make-x86-dis "popT" 'op-reg +rdx-reg+) + (make-x86-dis "popT" 'op-reg +rbx-reg+) + (make-x86-dis "popT" 'op-reg +rsp-reg+) + (make-x86-dis "popT" 'op-reg +rbp-reg+) + (make-x86-dis "popT" 'op-reg +rsi-reg+) + (make-x86-dis "popT" 'op-reg +rdi-reg+) + ;; #x60 + (make-x86-dis '(("pushaP" . "(bad)"))) + (make-x86-dis '(("popaP" . "(bad)"))) + (make-x86-dis '(("boundS" . "(bad)")) 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis nil nil +x86-64-special+) + (make-x86-dis "(bad)") ; seg fs + (make-x86-dis "(bad)") ; seg gs + (make-x86-dis "(bad)") ; op size prefix + (make-x86-dis "(bad)") ; adr size prefix + ;; #x68 + (make-x86-dis "pushT" 'op-i +q-mode+) + (make-x86-dis "imulS" 'op-g +v-mode+ 'op-e +v-mode+ 'op-i +v-mode+ ) + (make-x86-dis "pushT" 'op-si +b-mode+) + (make-x86-dis "imulS" 'op-g +v-mode+ 'op-e +v-mode+ 'op-si +b-mode+ ) + (make-x86-dis "insb" 'op-dsreg +esi-reg+ 'op-imreg +indir-dx-reg+) + (make-x86-dis "insR" 'op-esreg +edi-reg+ 'op-imreg +indir-dx-reg+) + (make-x86-dis "outsb" 'op-imreg +indir-dx-reg+ 'op-dsreg +esi-reg+) + (make-x86-dis "outsR" 'op-imreg +indir-dx-reg+ 'op-dsreg +esi-reg+) + ;; #x70 + (make-x86-dis "joH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jnoH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jbH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jaeH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jeH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jneH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jbeH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jaH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + ;; #x78 + (make-x86-dis "jsH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jnsH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jpH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jnpH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jlH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jgeH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jleH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + (make-x86-dis "jgH" 'op-j +b-mode+ nil +cond-jump-mode+ ) + ;; #x80 + (make-x86-dis nil nil +use-groups+ nil 0) + (make-x86-dis nil nil +use-groups+ nil 1) + (make-x86-dis "(bad)") + (make-x86-dis nil nil +use-groups+ nil 2 ) + (make-x86-dis "testB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "testS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "xchgB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "xchgS" 'op-e +v-mode+ 'op-g +v-mode+) + ;; #x88 + (make-x86-dis "movB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "movS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "movB" 'op-g +b-mode+ 'op-e +b-mode+) + (make-x86-dis "movS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "movQ" 'op-e +v-mode+ 'op-seg +w-mode+) + (make-x86-dis '("leaS" . :lea) 'op-g +v-mode+ 'op-m 0) + (make-x86-dis "movQ" 'op-seg +w-mode+ 'op-e +v-mode+) + (make-x86-dis "popU" 'op-e +v-mode+) + ;; #x90 + (make-x86-dis "nop" 'nop-fixup 0) + (make-x86-dis "xchgS" 'op-reg +ecx-reg+ 'op-imreg +eax-reg+) + (make-x86-dis "xchgS" 'op-reg +edx-reg+ 'op-imreg +eax-reg+) + (make-x86-dis "xchgS" 'op-reg +ebx-reg+ 'op-imreg +eax-reg+) + (make-x86-dis "xchgS" 'op-reg +esp-reg+ 'op-imreg +eax-reg+) + (make-x86-dis "xchgS" 'op-reg +ebp-reg+ 'op-imreg +eax-reg+) + (make-x86-dis "xchgS" 'op-reg +esi-reg+ 'op-imreg +eax-reg+) + (make-x86-dis "xchgS" 'op-reg +edi-reg+ 'op-imreg +eax-reg+) + ;; #x98 + (make-x86-dis "cWtR") + (make-x86-dis "cRtO") + (make-x86-dis '(("JcallT" . "(bad)")) 'op-dir 0) + (make-x86-dis "(bad)") ; fwait + (make-x86-dis "pushfT") + (make-x86-dis "popfT") + ;; "sahf" and "lahf" are unimplemented on some Intel EM64T + ;; steppings, allegedly because an early AMD64 manual + ;; accidentally omitted them. It makes sense to disassemble + ;; them in 64-bit mode, but it may require some thought + ;; before using them in compiled code. + (make-x86-dis "sahf") + (make-x86-dis "lahf") + ;; #xa0 + (make-x86-dis "movB" 'op-imreg +al-reg+ 'op-off64 +b-mode+) + (make-x86-dis "movS" 'op-imreg +eax-reg+ 'op-off64 +v-mode+) + (make-x86-dis "movB" 'op-off64 +b-mode+ 'op-imreg +al-reg+) + (make-x86-dis "movS" 'op-off64 +v-mode+ 'op-imreg +eax-reg+) + (make-x86-dis "movsb" 'op-dsreg +esi-reg+ 'op-dsreg +esi-reg+) + (make-x86-dis "movsR" 'op-esreg +edi-reg+ 'op-dsreg +esi-reg+) + (make-x86-dis "cmpsb" 'op-dsreg +esi-reg+ 'op-dsreg +esi-reg+) + (make-x86-dis "cmpsR" 'op-dsreg +esi-reg+ 'op-esreg +edi-reg+) + ;; #xa8 + (make-x86-dis "testB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "testS" 'op-imreg +eax-reg+ 'op-i +v-mode+) + (make-x86-dis "stosB" 'op-dsreg +esi-reg+ 'op-imreg +al-reg+) + (make-x86-dis "stosS" 'op-esreg +edi-reg+ 'op-imreg +eax-reg+) + (make-x86-dis "lodsB" 'op-imreg +al-reg+ 'op-dsreg +esi-reg+) + (make-x86-dis "lodsS" 'op-imreg +eax-reg+ 'op-dsreg +esi-reg+) + (make-x86-dis "scasB" 'op-imreg +al-reg+ 'op-dsreg +esi-reg+) + (make-x86-dis "scasS" 'op-imreg +eax-reg+ 'op-esreg +edi-reg+) + ;; #xb0 + (make-x86-dis "movB" 'op-reg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "movB" 'op-reg +cl-reg+ 'op-i +b-mode+) + (make-x86-dis "movB" 'op-reg +dl-reg+ 'op-i +b-mode+) + (make-x86-dis "movB" 'op-reg +bl-reg+ 'op-i +b-mode+) + (make-x86-dis "movB" 'op-reg +ah-reg+ 'op-i +b-mode+) + (make-x86-dis "movB" 'op-reg +ch-reg+ 'op-i +b-mode+) + (make-x86-dis "movB" 'op-reg +dh-reg+ 'op-i +b-mode+) + (make-x86-dis "movB" 'op-reg +bh-reg+ 'op-i +b-mode+) + ;; #xb8 + (make-x86-dis "movS" 'op-reg +eax-reg+ 'op-i64 +v-mode+) + (make-x86-dis "movS" 'op-reg +ecx-reg+ 'op-i64 +v-mode+) + (make-x86-dis "movS" 'op-reg +edx-reg+ 'op-i64 +v-mode+) + (make-x86-dis "movS" 'op-reg +ebx-reg+ 'op-i64 +v-mode+) + (make-x86-dis "movS" 'op-reg +esp-reg+ 'op-i64 +v-mode+) + (make-x86-dis "movS" 'op-reg +ebp-reg+ 'op-i64 +v-mode+) + (make-x86-dis "movS" 'op-reg +esi-reg+ 'op-i64 +v-mode+) + (make-x86-dis "movS" 'op-reg +edi-reg+ 'op-i64 +v-mode+) + ;; #xc0 + (make-x86-dis nil nil +use-groups+ nil 3) + (make-x86-dis nil nil +use-groups+ nil 4) + (make-x86-dis '("retT" . :jump) 'op-i +w-mode+) + (make-x86-dis '("retT" . :jump)) + (make-x86-dis '(("lesS" . "(bad)")) 'op-g +v-mode+ 'op-m +f-mode+) + (make-x86-dis "ldsS" 'op-g +v-mode+ 'op-m +f-mode+) + (make-x86-dis "movA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "movQ" 'op-e +v-mode+ 'op-i +v-mode+) + ;; #xc8 + (make-x86-dis "enterT" 'op-i +w-mode+ 'op-i +b-mode+) + (make-x86-dis "leaveT") + (make-x86-dis "lretP" 'op-i +w-mode+) + (make-x86-dis "lretP") + (make-x86-dis "int3") + (make-x86-dis nil nil +uuocode+) + (make-x86-dis '(("into" . "(bad)"))) + (make-x86-dis "iretP") + ;; #xd0 + (make-x86-dis nil nil +use-groups+ nil 5) + (make-x86-dis nil nil +use-groups+ nil 6) + (make-x86-dis nil nil +use-groups+ nil 7) + (make-x86-dis nil nil +use-groups+ nil 8) + (make-x86-dis '(("aam" . "(bad)")) 'op-si +b-mode+) + (make-x86-dis '(("aad" . "(bad)")) 'op-si +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "xlat" 'op-dsreg +ebx-reg+) + ;; #xd8 + (make-x86-dis nil nil +floatcode+) + (make-x86-dis nil nil +floatcode+) + (make-x86-dis nil nil +floatcode+) + (make-x86-dis nil nil +floatcode+) + (make-x86-dis nil nil +floatcode+) + (make-x86-dis nil nil +floatcode+) + (make-x86-dis nil nil +floatcode+) + (make-x86-dis nil nil +floatcode+) + ;; #xe0 + (make-x86-dis "loopneFH" 'op-j +b-mode+ nil +loop-jcxz-mode+ ) + (make-x86-dis "loopeFH" 'op-j +b-mode+ nil +loop-jcxz-mode+ ) + (make-x86-dis "loopFH" 'op-j +b-mode+ nil +loop-jcxz-mode+ ) + (make-x86-dis "jEcxzH" 'op-j +b-mode+ nil +loop-jcxz-mode+ ) + (make-x86-dis "inB" 'op-imreg +al-reg+ 'op-i +b-mode+) + (make-x86-dis "inS" 'op-imreg +eax-reg+ 'op-i +b-mode+) + (make-x86-dis "outB" 'op-i +b-mode+ 'op-imreg +al-reg+) + (make-x86-dis "outS" 'op-i +b-mode+ 'op-imreg +eax-reg+) + ;; #xe8 + (make-x86-dis '("callT" . :call) 'op-j +v-mode+) + (make-x86-dis '("jmpT" . :jump) 'op-j +v-mode+) + (make-x86-dis '(("JjmpT" . "(bad)") . :jump) 'op-dir 0) + (make-x86-dis '("jmp" . :jump) 'op-j +b-mode+) + (make-x86-dis "inB" 'op-imreg +al-reg+ 'op-imreg +indir-dx-reg+) + (make-x86-dis "inS" 'op-imreg +eax-reg+ 'op-imreg +indir-dx-reg+) + (make-x86-dis "outB" 'op-imreg +indir-dx-reg+ 'op-imreg +al-reg+) + (make-x86-dis "outS" 'op-imreg +indir-dx-reg+ 'op-imreg +eax-reg+) + ;; #xf0 + (make-x86-dis "(bad)") ; lock prefix + (make-x86-dis "icebp") + (make-x86-dis "(bad)") ; repne + (make-x86-dis "(bad)") ; repz + (make-x86-dis "hlt") + (make-x86-dis "cmc") + (make-x86-dis nil nil +use-groups+ nil 9) + (make-x86-dis nil nil +use-groups+ nil 10) + ;; #xf8 + (make-x86-dis "clc") + (make-x86-dis "stc") + (make-x86-dis "cli") + (make-x86-dis "sti") + (make-x86-dis "cld") + (make-x86-dis "std") + (make-x86-dis nil nil +use-groups+ nil 11) + (make-x86-dis nil nil +use-groups+ nil 12) + )) + +(defparameter *disx86-twobyte* + (vector + ;; #x00 + (make-x86-dis nil nil +use-groups+ nil 13) + (make-x86-dis nil nil +use-groups+ nil 14) + (make-x86-dis "larS" 'op-g +v-mode+ 'op-e +w-mode+) + (make-x86-dis "lslS" 'op-g +v-mode+ 'op-e +w-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "syscall") + (make-x86-dis "clts") + (make-x86-dis "sysretP") + ;; #x08 + (make-x86-dis "invd") + (make-x86-dis "wbinvd") + (make-x86-dis "(bad)") + (make-x86-dis "ud2a" 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis nil nil +use-groups+ nil 22) + (make-x86-dis "femms") + (make-x86-dis "" 'op-mmx 0 'op-em +v-mode+ 'op-3dnowsuffix 0) ; See OP-3DNowSuffix. + ;; #x10 + (make-x86-dis nil nil +use-prefix-user-table+ nil 8) + (make-x86-dis nil nil +use-prefix-user-table+ nil 9) + (make-x86-dis nil nil +use-prefix-user-table+ nil 30) + (make-x86-dis "movlpX" 'op-ex +v-mode+ 'op-xmm 0 'SIMD-Fixup #\h) + (make-x86-dis "unpcklpX" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "unpckhpX" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 31) + (make-x86-dis "movhpX" 'op-ex +v-mode+ 'op-xmm 0 'SIMD-Fixup #\l) + ;; #x18 + (make-x86-dis nil nil +use-groups+ nil 21) + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + ;; #x20 + (make-x86-dis "movL" 'op-rd +m-mode+ 'op-c +m-mode+) + (make-x86-dis "movL" 'op-rd +m-mode+ 'op-d +m-mode+) + (make-x86-dis "movL" 'op-c +m-mode+ 'op-rd +m-mode+) + (make-x86-dis "movL" 'op-d +m-mode+ 'op-rd +m-mode+) + (make-x86-dis "movL" 'op-rd +d-mode+ 'op-t +d-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "movL" 'op-t +d-mode+ 'op-rd +d-mode+) + (make-x86-dis "(bad)") + ;; #x28 + (make-x86-dis "movapX" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movapX" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis nil nil +use-prefix-user-table+ nil 2) + (make-x86-dis "movntpX" 'op-e +v-mode+ 'op-xmm 0) + (make-x86-dis nil nil +use-prefix-user-table+ nil 4) + (make-x86-dis nil nil +use-prefix-user-table+ nil 3) + (make-x86-dis "ucomisX" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "comisX" 'op-xmm 0 'op-ex +v-mode+) + ;; #x30 + (make-x86-dis "wrmsr") + (make-x86-dis "rdtsc") + (make-x86-dis "rdmsr") + (make-x86-dis "rdpmc") + (make-x86-dis "sysenter") + (make-x86-dis "sysexit") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + ;; #x38 + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + ;; #x40 + (make-x86-dis "cmovoS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovnoS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovbS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovaeS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmoveS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovneS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovbeS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovaS" 'op-g +v-mode+ 'op-e +v-mode+) + ;; #x48 + (make-x86-dis "cmovsS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovnsS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovpS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovnpS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovlS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovgeS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovleS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "cmovgS" 'op-g +v-mode+ 'op-e +v-mode+) + ;; #x50 + (make-x86-dis "movmskpX" 'op-g +dq-mode+ 'op-xs +v-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 13) + (make-x86-dis nil nil +use-prefix-user-table+ nil 12) + (make-x86-dis nil nil +use-prefix-user-table+ nil 11) + (make-x86-dis "andpX" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "andnpX" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "orpX" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "xorpX" 'op-xmm 0 'op-ex +v-mode+) + ;; #x58 + (make-x86-dis nil nil +use-prefix-user-table+ nil 0) + (make-x86-dis nil nil +use-prefix-user-table+ nil 10) + (make-x86-dis nil nil +use-prefix-user-table+ nil 17) + (make-x86-dis nil nil +use-prefix-user-table+ nil 16) + (make-x86-dis nil nil +use-prefix-user-table+ nil 14) + (make-x86-dis nil nil +use-prefix-user-table+ nil 7) + (make-x86-dis nil nil +use-prefix-user-table+ nil 5) + (make-x86-dis nil nil +use-prefix-user-table+ nil 6) + ;; #x60 + (make-x86-dis "punpcklbw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "punpcklwd" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "punpckldq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "packsswb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pcmpgtb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pcmpgtw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pcmpgtd" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "packuswb" 'op-mmx 0 'op-em +v-mode+) + ;; #x68 + (make-x86-dis "punpckhbw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "punpckhwd" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "punpckhdq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "packssdw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 26) + (make-x86-dis nil nil +use-prefix-user-table+ nil 24) + (make-x86-dis "movd" 'op-mmx 0 'op-e +dq-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 19) + ;; #x70 + (make-x86-dis nil nil +use-prefix-user-table+ nil 22) + (make-x86-dis nil nil +use-groups+ nil 17) + (make-x86-dis nil nil +use-groups+ nil 18) + (make-x86-dis nil nil +use-groups+ nil 19) + (make-x86-dis "pcmpeqb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pcmpeqw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pcmpeqd" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "emms") + ;; #x78 + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis nil nil +use-prefix-user-table+ nil 28) + (make-x86-dis nil nil +use-prefix-user-table+ nil 29) + (make-x86-dis nil nil +use-prefix-user-table+ nil 23) + (make-x86-dis nil nil +use-prefix-user-table+ nil 20) + ;; #x80 + (make-x86-dis "joH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jnoH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jbH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jaeH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jeH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jneH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jbeH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jaH" 'op-j +v-mode+ nil +cond-jump-mode+) + ;; #x88 + (make-x86-dis "jsH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jnsH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jpH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jnpH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jlH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jgeH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jleH" 'op-j +v-mode+ nil +cond-jump-mode+) + (make-x86-dis "jgH" 'op-j +v-mode+ nil +cond-jump-mode+) + ;; #x90 + (make-x86-dis "seto" 'op-e +b-mode+) + (make-x86-dis "setno" 'op-e +b-mode+) + (make-x86-dis "setb" 'op-e +b-mode+) + (make-x86-dis "setae" 'op-e +b-mode+) + (make-x86-dis "sete" 'op-e +b-mode+) + (make-x86-dis "setne" 'op-e +b-mode+) + (make-x86-dis "setbe" 'op-e +b-mode+) + (make-x86-dis "seta" 'op-e +b-mode+) + ;; #x98 + (make-x86-dis "sets" 'op-e +b-mode+) + (make-x86-dis "setns" 'op-e +b-mode+) + (make-x86-dis "setp" 'op-e +b-mode+) + (make-x86-dis "setnp" 'op-e +b-mode+) + (make-x86-dis "setl" 'op-e +b-mode+) + (make-x86-dis "setge" 'op-e +b-mode+) + (make-x86-dis "setle" 'op-e +b-mode+) + (make-x86-dis "setg" 'op-e +b-mode+) + ;; #xa0 + (make-x86-dis "pushT" 'op-reg +fs-reg+) + (make-x86-dis "popT" 'op-reg +fs-reg+) + (make-x86-dis "cpuid") + (make-x86-dis "btS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "shldS" 'op-e +v-mode+ 'op-g +v-mode+ 'op-i +b-mode+) + (make-x86-dis "shldS" 'op-e +v-mode+ 'op-g +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis nil nil +use-groups+ nil 24) + (make-x86-dis nil nil +use-groups+ nil 23) + ;; #xa8 + (make-x86-dis "pushT" 'op-reg +gs-reg+) + (make-x86-dis "popT" 'op-reg +gs-reg+) + (make-x86-dis "rsm") + (make-x86-dis "btsS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "shrdS" 'op-e +v-mode+ 'op-g +v-mode+ 'op-i +b-mode+) + (make-x86-dis "shrdS" 'op-e +v-mode+ 'op-g +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis nil nil +use-groups+ nil 20) + (make-x86-dis "imulS" 'op-g +v-mode+ 'op-e +v-mode+) + ;; #xb0 + (make-x86-dis "cmpxchgB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "cmpxchgS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "lssS" 'op-g +v-mode+ 'op-m +f-mode+) + (make-x86-dis "btrS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "lfsS" 'op-g +v-mode+ 'op-m +f-mode+) + (make-x86-dis "lgsS" 'op-g +v-mode+ 'op-m +f-mode+) + (make-x86-dis "movzbR" 'op-g +v-mode+ 'op-e +b-mode+) + (make-x86-dis "movzwR" 'op-g +v-mode+ 'op-e +w-mode+) ; yes there really is movzww ! + ;; #xb8 + (make-x86-dis "(bad)") + (make-x86-dis "ud2b") + (make-x86-dis nil nil +use-groups+ nil 15) + (make-x86-dis "btcS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "bsfS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "bsrS" 'op-g +v-mode+ 'op-e +v-mode+) + (make-x86-dis "movsbR" 'op-g +v-mode+ 'op-e +b-mode+) + (make-x86-dis "movswR" 'op-g +v-mode+ 'op-e +w-mode+) ; yes there really is movsww ! + ;; #xc0 + (make-x86-dis "xaddB" 'op-e +b-mode+ 'op-g +b-mode+) + (make-x86-dis "xaddS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 1) + (make-x86-dis "movntiS" 'op-e +v-mode+ 'op-g +v-mode+) + (make-x86-dis "pinsrw" 'op-mmx 0 'op-e +dqw-mode+ 'op-i +b-mode+) + (make-x86-dis "pextrw" 'op-g +dq-mode+ 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "shufpX" 'op-xmm 0 'op-ex +v-mode+ 'op-i +b-mode+) + (make-x86-dis nil nil +use-groups+ nil 16) + ;; #xc8 + (make-x86-dis "bswap" 'op-reg +eax-reg+) + (make-x86-dis "bswap" 'op-reg +ecx-reg+) + (make-x86-dis "bswap" 'op-reg +edx-reg+) + (make-x86-dis "bswap" 'op-reg +ebx-reg+) + (make-x86-dis "bswap" 'op-reg +esp-reg+) + (make-x86-dis "bswap" 'op-reg +ebp-reg+) + (make-x86-dis "bswap" 'op-reg +esi-reg+) + (make-x86-dis "bswap" 'op-reg +edi-reg+) + ;; #xd0 + (make-x86-dis nil nil +use-prefix-user-table+ nil 27) + (make-x86-dis "psrlw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psrld" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psrlq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pmullw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 21) + (make-x86-dis "pmovmskb" 'op-g +dq-mode+ 'op-ms +v-mode+) + ;; #xd8 + (make-x86-dis "psubusb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psubusw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pminub" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pand" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddusb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddusw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pmaxub" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pandn" 'op-mmx 0 'op-em +v-mode+) + ;; #xe0 + (make-x86-dis "pavgb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psraw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psrad" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pavgw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pmulhuw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pmulhw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 15) + (make-x86-dis nil nil +use-prefix-user-table+ nil 25) + ;; #xe8 + (make-x86-dis "psubsb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psubsw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pminsw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "por" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddsb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddsw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pmaxsw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pxor" 'op-mmx 0 'op-em +v-mode+) + ;; #xf0 + (make-x86-dis nil nil +use-prefix-user-table+ nil 32) + (make-x86-dis "psllw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pslld" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psllq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pmuludq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "pmaddwd" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psadbw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis nil nil +use-prefix-user-table+ nil 18) + ;; #xf8 + (make-x86-dis "psubb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psubw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psubd" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "psubq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddb" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddw" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "paddd" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "(bad)") + )) + +(defparameter *onebyte-has-modrm* + (make-array 256 :element-type 'bit + :initial-contents '( + #| 0 1 2 3 4 5 6 7 8 9 a b c d e f |# + #| ------------------------------- |# + #| 00 |# 1 1 1 1 0 0 0 0 1 1 1 1 0 0 0 0 #| 00 |# + #| 10 |# 1 1 1 1 0 0 0 0 1 1 1 1 0 0 0 0 #| 10 |# + #| 20 |# 1 1 1 1 0 0 0 0 1 1 1 1 0 0 0 0 #| 20 |# + #| 30 |# 1 1 1 1 0 0 0 0 1 1 1 1 0 0 0 0 #| 30 |# + #| 40 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 40 |# + #| 50 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 50 |# + #| 60 |# 0 0 1 1 0 0 0 0 0 1 0 1 0 0 0 0 #| 60 |# + #| 70 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 70 |# + #| 80 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 #| 80 |# + #| 90 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 90 |# + #| a0 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| a0 |# + #| b0 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| b0 |# + #| c0 |# 1 1 0 0 1 1 1 1 0 0 0 0 0 0 0 0 #| c0 |# + #| d0 |# 1 1 1 1 0 0 0 0 1 1 1 1 1 1 1 1 #| d0 |# + #| e0 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| e0 |# + #| f0 |# 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 #| f0 |# + #| ------------------------------- |# + #| 0 1 2 3 4 5 6 7 8 9 a b c d e f |# +))) + + +(defparameter *twobyte-has-modrm* + (make-array 256 :element-type 'bit + :initial-contents '( + #| 0 1 2 3 4 5 6 7 8 9 a b c d e f |# + #| ------------------------------- |# + #| 00 |# 1 1 1 1 0 0 0 0 0 0 0 0 0 1 0 1 #| 0f |# + #| 10 |# 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 #| 1f |# + #| 20 |# 1 1 1 1 1 0 1 0 1 1 1 1 1 1 1 1 #| 2f |# + #| 30 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 3f |# + #| 40 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 #| 4f |# + #| 50 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 #| 5f |# + #| 60 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 #| 6f |# + #| 70 |# 1 1 1 1 1 1 1 0 0 0 0 0 1 1 1 1 #| 7f |# + #| 80 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 8f |# + #| 90 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 #| 9f |# + #| a0 |# 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 #| af |# + #| b0 |# 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 #| bf |# + #| c0 |# 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 #| cf |# + #| d0 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 #| df |# + #| e0 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 #| ef |# + #| f0 |# 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 #| ff |# + #| ------------------------------- |# + #| 0 1 2 3 4 5 6 7 8 9 a b c d e f |# +))) + +(defparameter *twobyte-uses-sse-prefix* + (make-array 256 :element-type 'bit + :initial-contents '( + #| 0 1 2 3 4 5 6 7 8 9 a b c d e f |# + #| ------------------------------- |# + #| 00 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 0f |# + #| 10 |# 1 1 1 0 0 0 1 0 0 0 0 0 0 0 0 0 #| 1f |# + #| 20 |# 0 0 0 0 0 0 0 0 0 0 1 0 1 1 0 0 #| 2f |# + #| 30 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 3f |# + #| 40 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 4f |# + #| 50 |# 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 1 #| 5f |# + #| 60 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 #| 6f |# + #| 70 |# 1 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 #| 7f |# + #| 80 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 8f |# + #| 90 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| 9f |# + #| a0 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| af |# + #| b0 |# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #| bf |# + #| c0 |# 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 #| cf |# + #| d0 |# 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 #| df |# + #| e0 |# 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 #| ef |# + #| f0 |# 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 #| ff |# + #| ------------------------------- |# + #| 0 1 2 3 4 5 6 7 8 9 a b c d e f |# +))) + + + +(defparameter *grps* + (vector + ;; GRP1b + (vector + (make-x86-dis "addA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "orA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "adcA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "sbbA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "andA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "subA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "xorA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "cmpA" 'op-e +b-mode+ 'op-i +b-mode+)) + ;; GRP1S + (vector + (make-x86-dis '("addQ" . :addi32) 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis "orQ" 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis "adcQ" 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis "sbbQ" 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis "andQ" 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis '("subQ" . :subi32) 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis "xorQ" 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis "cmpQ" 'op-e +v-mode+ 'op-i +v-mode+)) + ;; GRP1Ss + (vector + (make-x86-dis '("addQ" . :addi64) 'op-e +v-mode+ 'op-si +b-mode+) + (make-x86-dis "orQ" 'op-e +v-mode+ 'op-si +b-mode+) + (make-x86-dis "adcQ" 'op-e +v-mode+ 'op-si +b-mode+) + (make-x86-dis "sbbQ" 'op-e +v-mode+ 'op-si +b-mode+) + (make-x86-dis "andQ" 'op-e +v-mode+ 'op-si +b-mode+) + (make-x86-dis '("subQ" . :subi64) 'op-e +v-mode+ 'op-si +b-mode+) + (make-x86-dis "xorQ" 'op-e +v-mode+ 'op-si +b-mode+) + (make-x86-dis "cmpQ" 'op-e +v-mode+ 'op-si +b-mode+)) + ;; GRP2b + (vector + (make-x86-dis "rolA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "rorA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "rclA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "rcrA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "shlA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "shrA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "sarA" 'op-e +b-mode+ 'op-i +b-mode+)) + ;; GRP2S + (vector + (make-x86-dis "rolQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "rorQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "rclQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "rcrQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "shlQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "shrQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "sarQ" 'op-e +v-mode+ 'op-i +b-mode+)) + ;; GRP2b-one + (vector + (make-x86-dis "rolA" 'op-e +b-mode+ 'op-i +const-1-mode+) + (make-x86-dis "rorA" 'op-e +b-mode+ 'op-i +const-1-mode+) + (make-x86-dis "rclA" 'op-e +b-mode+ 'op-i +const-1-mode+) + (make-x86-dis "rcrA" 'op-e +b-mode+ 'op-i +const-1-mode+) + (make-x86-dis "shlA" 'op-e +b-mode+ 'op-i +const-1-mode+) + (make-x86-dis "shrA" 'op-e +b-mode+ 'op-i +const-1-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "sarA" 'op-e +b-mode+ 'op-i +const-1-mode+)) + ;; GRP2S-one + (vector + (make-x86-dis "rolQ" 'op-e +v-mode+ 'op-i +const-1-mode+) + (make-x86-dis "rorQ" 'op-e +v-mode+ 'op-i +const-1-mode+) + (make-x86-dis "rclQ" 'op-e +v-mode+ 'op-i +const-1-mode+) + (make-x86-dis "rcrQ" 'op-e +v-mode+ 'op-i +const-1-mode+) + (make-x86-dis "shlQ" 'op-e +v-mode+ 'op-i +const-1-mode+) + (make-x86-dis "shrQ" 'op-e +v-mode+ 'op-i +const-1-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "sarQ" 'op-e +v-mode+ 'op-i +const-1-mode+)) + ;; GRP2b-cl + (vector + (make-x86-dis "rolA" 'op-e +b-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "rorA" 'op-e +b-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "rclA" 'op-e +b-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "rcrA" 'op-e +b-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "shlA" 'op-e +b-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "shrA" 'op-e +b-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "(bad)") + (make-x86-dis "sarA" 'op-e +b-mode+ 'op-imreg +cl-reg+)) + ;; GRP2S-cl + (vector + (make-x86-dis "rolQ" 'op-e +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "rorQ" 'op-e +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "rclQ" 'op-e +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "rcrQ" 'op-e +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "shlQ" 'op-e +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "shrQ" 'op-e +v-mode+ 'op-imreg +cl-reg+) + (make-x86-dis "(bad)") + (make-x86-dis "sarQ" 'op-e +v-mode+ 'op-imreg +cl-reg+)) + ;; GRP3b + (vector + (make-x86-dis "testA" 'op-e +b-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)" 'op-e +b-mode+) + (make-x86-dis "notA" 'op-e +b-mode+) + (make-x86-dis "negA" 'op-e +b-mode+) + (make-x86-dis "mulA" 'op-e +b-mode+) ; Don't print the implicit %al register + (make-x86-dis "imulA" 'op-e +b-mode+) ; to distinguish these opcodes from other + (make-x86-dis "divA" 'op-e +b-mode+) ; mul/imul opcodes. Do the same for div + (make-x86-dis "idivA" 'op-e +b-mode+) ; and idiv for consistency. + ) + ;; GRP3S + (vector + (make-x86-dis "testQ" 'op-e +v-mode+ 'op-i +v-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "notQ" 'op-e +v-mode+) + (make-x86-dis "negQ" 'op-e +v-mode+) + (make-x86-dis "mulQ" 'op-e +v-mode+) ; Don't print the implicit register. + (make-x86-dis "imulQ" 'op-e +v-mode+) + (make-x86-dis "divQ" 'op-e +v-mode+) + (make-x86-dis "idivQ" 'op-e +v-mode+)) + ;; GRP4 + (vector + (make-x86-dis "incA" 'op-e +b-mode+) + (make-x86-dis "decA" 'op-e +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)")) + ;; GRP5 + (vector + (make-x86-dis "incQ" 'op-e +v-mode+) + (make-x86-dis "decQ" 'op-e +v-mode+) + (make-x86-dis '("callT" . :call) 'op-indire +v-mode+) + (make-x86-dis '("JcallT" . :call) 'op-indire +f-mode+) + (make-x86-dis '("jmpT" . :jump) 'op-indire +v-mode+) + (make-x86-dis '("JjmpT" . :jump) 'op-indire +f-mode+) + (make-x86-dis "pushU" 'op-e +v-mode+) + (make-x86-dis "(bad)")) + ;; GRP6 + (vector + (make-x86-dis "sldtQ" 'op-e +v-mode+) + (make-x86-dis "strQ" 'op-e +v-mode+) + (make-x86-dis "lldt" 'op-e +w-mode+) + (make-x86-dis "ltr" 'op-e +w-mode+) + (make-x86-dis "verr" 'op-e +w-mode+) + (make-x86-dis "verw" 'op-e +w-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "(bad)")) + ;; GRP7 + (vector + (make-x86-dis "sgdtQ" 'op-m 0) + (make-x86-dis "sidtQ" 'pni-fixup 0) + (make-x86-dis '(("lgdtQ" . "lgdt")) 'op-m 0) + (make-x86-dis '(("lidtQ" . "lidt")) 'op-m 0) + (make-x86-dis "smswQ" 'op-e +v-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "lmsw" 'op-e +w-mode+) + (make-x86-dis "invlpg" 'INVLPG-Fixup +w-mode+)) + ;; GRP8 + (vector + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "btQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "btsQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "btrQ" 'op-e +v-mode+ 'op-i +b-mode+) + (make-x86-dis "btcQ" 'op-e +v-mode+ 'op-i +b-mode+)) + ;; GRP9 + (vector + (make-x86-dis "(bad)") + (make-x86-dis "cmpxchg8b" 'op-e +q-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)")) + ;; GRP10 + (vector + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "psrlw" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "psraw" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "psllw" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)")) + ;; GRP11 + (vector + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "psrld" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "psrad" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "pslld" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)")) + ;; GRP12 + (vector + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "psrlq" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "psrldq" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "psllq" 'op-ms +v-mode+ 'op-i +b-mode+) + (make-x86-dis "pslldq" 'op-ms +v-mode+ 'op-i +b-mode+)) + ;; GRP13 + (vector + (make-x86-dis "fxsave" 'op-e +v-mode+) + (make-x86-dis "fxrstor" 'op-e +v-mode+) + (make-x86-dis "ldmxcsr" 'op-e +v-mode+) + (make-x86-dis "stmxcsr" 'op-e +v-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "lfence" 'OP-0fae 0) + (make-x86-dis "mfence" 'OP-0fae 0) + (make-x86-dis "clflush" 'OP-0fae 0)) + ;; GRP14 + (vector + (make-x86-dis "prefetchnta" 'op-e +v-mode+) + (make-x86-dis "prefetcht0" 'op-e +v-mode+) + (make-x86-dis "prefetcht1" 'op-e +v-mode+) + (make-x86-dis "prefetcht2" 'op-e +v-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)")) + ;; GRPAMD + (vector + (make-x86-dis "prefetch" 'op-e +b-mode+) + (make-x86-dis "prefetchw" 'op-e +b-mode+) + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)") + (make-x86-dis "(bad)")) + ;; GRPPADLCK1 + (vector + (make-x86-dis "xstorerng" 'op-0f07 0) + (make-x86-dis "xcryptecb" 'op-0f07 0) + (make-x86-dis "xcryptcbc" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0) + (make-x86-dis "xcryptcfb" 'op-0f07 0) + (make-x86-dis "xcryptofb" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0)) + ;; GRPPADLCK2 + (vector + (make-x86-dis "montmul" 'op-0f07 0) + (make-x86-dis "xsha1" 'op-0f07 0) + (make-x86-dis "xsha256" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0) + (make-x86-dis "(bad)" 'op-0f07 0)))) + +(defparameter *prefix-user-table* + (vector + ;; PREGRP0 + (vector + (make-x86-dis "addps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "addss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "addpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "addsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP1 + (vector + (make-x86-dis "" 'op-xmm 0 'op-ex +v-mode+ 'op-simd-suffix 0);; See OP-SIMD-SUFFIX. + (make-x86-dis "" 'op-xmm 0 'op-ex +v-mode+ 'op-simd-suffix 0) + (make-x86-dis "" 'op-xmm 0 'op-ex +v-mode+ 'op-simd-suffix 0) + (make-x86-dis "" 'op-xmm 0 'op-ex +v-mode+ 'op-simd-suffix 0)) + ;; PREGRP2 + (vector + (make-x86-dis "cvtpi2ps" 'op-xmm 0 'op-em +v-mode+) + (make-x86-dis "cvtsi2ssY" 'op-xmm 0 'op-e +v-mode+) + (make-x86-dis "cvtpi2pd" 'op-xmm 0 'op-em +v-mode+) + (make-x86-dis "cvtsi2sdY" 'op-xmm 0 'op-e +v-mode+)) + ;; PREGRP3 + (vector + (make-x86-dis "cvtps2pi" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "cvtss2siY" 'op-g +v-mode+ 'op-ex +v-mode+) + (make-x86-dis "cvtpd2pi" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "cvtsd2siY" 'op-g +v-mode+ 'op-ex +v-mode+)) + ;; PREGRP4 + (vector + (make-x86-dis "cvttps2pi" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "cvttss2siY" 'op-g +v-mode+ 'op-ex +v-mode+) + (make-x86-dis "cvttpd2pi" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "cvttsd2siY" 'op-g +v-mode+ 'op-ex +v-mode+)) + ;; PREGRP5 + (vector + (make-x86-dis "divps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "divss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "divpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "divsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP6 + (vector + (make-x86-dis "maxps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "maxss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "maxpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "maxsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP7 + (vector + (make-x86-dis "minps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "minss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "minpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "minsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP8 + (vector + (make-x86-dis "movups" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movupd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP9 + (vector + (make-x86-dis "movups" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis "movss" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis "movupd" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis "movsd" 'op-ex +v-mode+ 'op-xmm 0)) + ;; PREGRP10 + (vector + (make-x86-dis "mulps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "mulss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "mulpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "mulsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP11 + (vector + (make-x86-dis "rcpps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "rcpss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP12 + (vector + (make-x86-dis "rsqrtps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "rsqrtss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP13 + (vector + (make-x86-dis "sqrtps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "sqrtss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "sqrtpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "sqrtsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP14 + (vector + (make-x86-dis "subps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "subss" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "subpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "subsd" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP15 + (vector + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvtdq2pd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvttpd2dq" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvtpd2dq" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP16 + (vector + (make-x86-dis "cvtdq2ps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvttps2dq" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvtps2dq" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP17 + (vector + (make-x86-dis "cvtps2pd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvtss2sd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvtpd2ps" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "cvtsd2ss" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP18 + (vector + (make-x86-dis "maskmovq" 'op-mmx 0 'op-s +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "maskmovdqu" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP19 + (vector + (make-x86-dis "movq" 'op-mmx 0 'op-em +v-mode+) + (make-x86-dis "movdqu" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movdqa" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP20 + (vector + (make-x86-dis "movq" 'op-em +v-mode+ 'op-mmx 0) + (make-x86-dis "movdqu" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis "movdqa" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis "(bad)" 'op-ex +v-mode+ 'op-xmm 0)) + ;; PREGRP21 + (vector + (make-x86-dis "(bad)" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis "movq2dq" 'op-xmm 0 'op-s +v-mode+) + (make-x86-dis "movq" 'op-ex +v-mode+ 'op-xmm 0) + (make-x86-dis "movdq2q" 'op-mmx 0 'op-xs +v-mode+)) + ;; PREGRP22 + (vector + (make-x86-dis "pshufw" 'op-mmx 0 'op-em +v-mode+ 'op-i +b-mode+) + (make-x86-dis "pshufhw" 'op-xmm 0 'op-ex +v-mode+ 'op-i +b-mode+) + (make-x86-dis "pshufd" 'op-xmm 0 'op-ex +v-mode+ 'op-i +b-mode+) + (make-x86-dis "pshuflw" 'op-xmm 0 'op-ex +v-mode+ 'op-i +b-mode+)) + ;; PREGRP23 + (vector + (make-x86-dis "movd" 'op-e +dq-mode+ 'op-mmx 0) + (make-x86-dis "movq" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movd" 'op-e +dq-mode+ 'op-xmm 0) + (make-x86-dis "(bad)" 'op-e +d-mode+ 'op-xmm 0)) + ;; PREGRP24 + (vector + (make-x86-dis "(bad)" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "punpckhqdq" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP25 + (vector + (make-x86-dis "movntq" 'op-em +v-mode+ 'op-mmx 0) + (make-x86-dis "(bad)" 'op-em +v-mode+ 'op-xmm 0) + (make-x86-dis "movntdq" 'op-em +v-mode+ 'op-xmm 0) + (make-x86-dis "(bad)" 'op-em +v-mode+ 'op-xmm 0)) + ;; PREGRP26 + (vector + (make-x86-dis "(bad)" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "punpcklqdq" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP27 + (vector + (make-x86-dis "(bad)" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "addsubpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "addsubps" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP28 + (vector + (make-x86-dis "(bad)" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "haddpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "haddps" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP29 + (vector + (make-x86-dis "(bad)" 'op-mmx 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "hsubpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "hsubps" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP30 + (vector + (make-x86-dis "movlpX" 'op-xmm 0 'op-ex +v-mode+ 'SIMD-Fixup #\h);; really only 2 operands + (make-x86-dis "movsldup" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movlpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movddup" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP31 + (vector + (make-x86-dis "movhpX" 'op-xmm 0 'op-ex +v-mode+ 'SIMD-Fixup #\l) + (make-x86-dis "movshdup" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "movhpd" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+)) + ;; PREGRP32 + (vector + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "(bad)" 'op-xmm 0 'op-ex +v-mode+) + (make-x86-dis "lddqu" 'op-xmm 0 'op-m 0)))) + +(defparameter *x86-64-table* + (vector + (vector + (make-x86-dis "arpl" 'op-e +w-mode+ 'op-g +w-mode+) + (make-x86-dis "movslq" 'op-g +v-mode+ 'op-e +d-mode+)))) + + +(defun prefix-name (ds b sizeflag) + (case b + (#x40 "rex") + (#x41 "rexZ") + (#x42 "rexY") + (#x43 "rexYZ") + (#x44 "rexX") + (#x45 "rexXZ") + (#x46 "rexYZ") + (#x47 "rexXYZ") + (#x48 "rex64") + (#x49 "rex64Z") + (#x4a "rex64Y") + (#x4b "rex64YZ") + (#x4c "rex64X") + (#x4d "rex64XZ") + (#x4e "rex64XY") + (#x4f "rex64XYZ") + (#xf3 "repz") + (#xf2 "repnz") + (#xf0 "lock") + (#x2e "cs") + (#x36 "ss") + (#x3e "ds") + (#x26 "es") + (#x64 "fs") + (#x65 "gs") + (#x66 (if (logtest sizeflag +dflag+) "data16" "data32")) + (#x67 (if (x86-ds-mode-64 ds) + (if (logtest sizeflag +aflag+) "addr32" "addr64") + (if (logtest sizeflag +aflag+) "addr16" "addr32"))) + + (#x9b "fwait"))) + +(defun scan-prefixes (ds instruction) + (setf (x86-ds-prefixes ds) 0 + (x86-ds-used-prefixes ds) 0 + (x86-ds-rex ds) 0 + (x86-ds-rex-used ds) 0) + (let* ((newrex 0) + (prefixes 0)) + (declare (fixnum prefixes)) + (do* ((b (x86-ds-peek-u8 ds) + (progn (x86-ds-skip ds) + (x86-ds-peek-u8 ds)))) + () + (declare (type (unsigned-byte 8) b)) + (setq newrex 0) + (cond ((and (>= b #x40) + (<= b #x4f)) + (if (x86-ds-mode-64 ds) + (setq newrex b) + (return))) + ((= b #xf3) + (setq prefixes (logior prefixes +prefix-repz+))) + ((= b #xf2) + (setq prefixes (logior prefixes +prefix-repnz+))) + ((= b #xf0) + (setq prefixes (logior prefixes +prefix-lock+))) + ((= b #x2e) + (setq prefixes (logior prefixes +prefix-cs+))) + ((= b #x36) + (setq prefixes (logior prefixes +prefix-ss+))) + ((= b #x3e) + (setq prefixes (logior prefixes +prefix-ds+))) + ((= b #x26) + (setq prefixes (logior prefixes +prefix-es+))) + ((= b #x64) + (setq prefixes (logior prefixes +prefix-fs+))) + ((= b #x65) + (setq prefixes (logior prefixes +prefix-gs+))) + ((= b #x66) + (setq prefixes (logior prefixes +prefix-data+))) + ((= b #x67) + (setq prefixes (logior prefixes +prefix-addr+))) + ((= b #x9b) + ;; FWAIT. If there are already some prefixes, + ;; we've found the opcode. + (if (= prefixes 0) + (progn + (setq prefixes +prefix-fwait+) + (return)) + (setq prefixes (logior prefixes +prefix-fwait+)))) + (t (return))) + (unless (zerop (x86-ds-rex ds)) + (let* ((prefix-name (prefix-name ds (x86-ds-rex ds) 0))) + (when prefix-name + (push prefix-name + (x86-di-prefixes instruction))))) + (setf (x86-ds-rex ds) newrex)) + (setf (x86-ds-prefixes ds) prefixes))) + + +(defun x86-putop (ds template sizeflag instruction) + (let* ((ok t)) + (when (consp template) + (if (x86-ds-mode-64 ds) + (setq template (cdr template)) + (setq template (car template)))) + (if (dotimes (i (length template) t) + (unless (lower-case-p (schar template i)) + (return nil))) + (setf (x86-di-mnemonic instruction) template) + (let* ((string-buffer (x86-ds-string-buffer ds)) + (mod (x86-ds-mod ds)) + (rex (x86-ds-rex ds)) + (prefixes (x86-ds-prefixes ds)) + (mode64 (x86-ds-mode-64 ds))) + (declare (fixnum rex prefixes)) + (setf (fill-pointer string-buffer) 0) + (dotimes (i (length template)) + (let* ((c (schar template i)) + (b + (case c + (#\) (setq ok nil)) + (#\A (if (or (not (eql mod 3)) + (logtest sizeflag +suffix-always+)) + #\b)) + (#\B (if (logtest sizeflag +suffix-always+) + #\b)) + (#\C (when (or (logtest prefixes +prefix-data+) + (logtest sizeflag +suffix-always+)) + (used-prefix ds +prefix-data+) + (if (logtest sizeflag +dflag+) + #\l + #\s))) + (#\E (used-prefix ds +prefix-addr+) + (if mode64 + (if (logtest sizeflag +aflag+) + #\r + #\e) + (if (logtest sizeflag +aflag+) + #\e))) + (#\F (when (or (logtest prefixes +prefix-addr+) + (logtest sizeflag +suffix-always+)) + (used-prefix ds +prefix-addr+) + (if (logtest sizeflag +aflag+) + (if mode64 #\q #\l) + (if mode64 #\l #\w)))) + (#\H (let* ((ds-or-cs + (logand prefixes + (logior +prefix-ds+ +prefix-ds+))) + (ds-only (= ds-or-cs +prefix-ds+)) + (cs-only (= ds-or-cs +prefix-cs+))) + (when (or ds-only cs-only) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) + ds-or-cs)) + (if ds-only ".pt" ".pn")))) + (#\J #\l) + (#\L (if (logtest sizeflag +suffix-always+) #\l)) + (#\N (if (logtest prefixes +prefix-fwait+) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) + +prefix-fwait+)) + #\n)) + (#\O (used-rex ds +rex-mode64+) + (if (logtest rex +rex-mode64+) + #\o + #\d)) + ((#\T #\P) + (if (and (eql c #\T) mode64) + #\q + (when (or (logtest prefixes +prefix-data+) + (logtest rex +rex-mode64+) + (logtest sizeflag +suffix-always+)) + (used-rex ds +rex-mode64+) + (if (logtest rex +rex-mode64+) + #\q + (progn + (used-prefix ds +prefix-data+) + (if (logtest sizeflag +dflag+) + #\l + #\w)))))) + ((#\U #\Q) + (if (and (eql c #\U) mode64) + #\q + (progn + (used-rex ds +rex-mode64+) + (when (or (not (eql mod 3)) + (logtest sizeflag +suffix-always+)) + (if (logtest rex +rex-mode64+) + #\q + (progn + (used-prefix ds +prefix-data+) + (if (logtest sizeflag +dflag+) + #\l + #\w))))))) + (#\R + (used-rex ds +rex-mode64+) + (if (logtest rex +rex-mode64+) + #\q + (if (logtest sizeflag +dflag+) + #\l + #\w))) + (#\S + (when (logtest sizeflag +suffix-always+) + (if (logtest rex +rex-mode64+) + #\q + (progn + (used-prefix ds +prefix-data+) + (if (logtest sizeflag +dflag+) + #\l + #\w))))) + (#\X + (used-prefix ds +prefix-data+) + (if (logtest prefixes +prefix-data+) + #\d + #\s)) + (#\Y + (when (logtest rex +rex-mode64+) + (used-rex ds +rex-mode64+) + #\q)) + (#\W + (used-rex ds 0) + (if (not (eql rex 0)) + #\l + (progn + (used-prefix ds +prefix-data+) + (if (logtest sizeflag +dflag+) + #\w + #\b)))) + (t c)))) + (if b + (if (typep b 'character) + (vector-push-extend b string-buffer) + (dotimes (i (length b)) + (vector-push-extend (schar b i) string-buffer)))))) + (setf (x86-di-mnemonic instruction) (subseq string-buffer 0)))) + ok)) + +(defparameter *x86-dissassemble-always-print-suffix* t) + +(defun x86-dis-do-float (ds instruction floatop sizeflag) + (declare (ignore floatop sizeflag)) + ;; Later; we want to make minimal use of the x87 fpu. + (setf (x86-di-mnemonic instruction) "x87-fpu-op") + (x86-ds-skip ds)) + +(defun x86-dis-do-uuo (ds instruction intop) + (declare (type (unsigned-byte 8) intop)) + (let* ((stop t) + (regmask (if (x86-ds-mode-64 ds) #xf #x7))) + (cond ((and (>= intop #x70) (< intop #x80)) + (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds))) + (setf (x86-di-mnemonic instruction) + "uuo-error-slot-unbound" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%)) + (x86-di-op1 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (ldb (byte 4 4) + pseudo-modrm-byte) :%)) + (x86-di-op2 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (ldb (byte 4 0) + pseudo-modrm-byte) :%))))) + ((< intop #x90) + (setf (x86-di-mnemonic instruction) "int" + (x86-di-op0 instruction) + (x86::make-x86-immediate-operand :value (parse-x86-lap-expression intop)))) + ((< intop #xa0) + (setf (x86-di-mnemonic instruction) + "uuo-error-unbound" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%)))) + ((< intop #xb0) + (setf (x86-di-mnemonic instruction) + "uuo-error-udf" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%)))) + + ((< intop #xc0) + (setf (x86-di-mnemonic instruction) + "uuo-error-reg-not-type" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%)) + (x86-di-op1 instruction) + (x86::make-x86-immediate-operand :value (parse-x86-lap-expression (x86-ds-next-u8 ds))))) + ((< intop #xc8) + (if (= intop #xc3) + (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds))) + (setf (x86-di-mnemonic instruction) + "uuo-error-array-rank" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (ldb (byte 4 4) + pseudo-modrm-byte) :%)) + (x86-di-op1 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (ldb (byte 4 0) + pseudo-modrm-byte) :%)))) + + (setf (x86-di-mnemonic instruction) + (case intop + (#xc0 "uuo-error-too-few-args") + (#xc1 "uuo-error-too-many-args") + (#xc2 "uuo-error-wrong-number-of-args") + (#xc4 (progn (setq stop nil) "uuo-gc-trap")) + (#xc5 "uuo-alloc") + (#xc6 "uuo-error-not-callable") + (#xc7 "uuo-udf-call") + (t "unknown-UUO"))))) + ((= intop #xc8) + (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds))) + (declare (type (unsigned-byte 8) pseudo-modrm-byte)) + (setf (x86-di-op0 instruction) + (x86-dis-make-reg-operand + (lookup-x86-register (ldb (byte 4 4) pseudo-modrm-byte) :%)) + (x86-di-op1 instruction) + (x86-dis-make-reg-operand + (lookup-x86-register (ldb (byte 4 0) pseudo-modrm-byte) :%)) + (x86-di-mnemonic instruction) "uuo-error-vector-bounds"))) + ((< intop #xd0) + (cond ((= intop #xcb) + (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds))) + (setf (x86-di-mnemonic instruction) + "uuo-error-array-bounds" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand + (lookup-x86-register (ldb (byte 4 4) + pseudo-modrm-byte) :%)) + (x86-di-op1 instruction) + (x86-dis-make-reg-operand + (lookup-x86-register (ldb (byte 4 0) + pseudo-modrm-byte) :%))))) + ((= intop #xcc) + (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds))) + (setf (x86-di-mnemonic instruction) + "uuo-error-eep-unresolved" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand + (lookup-x86-register (ldb (byte 4 4) + pseudo-modrm-byte) :%)) + (x86-di-op1 instruction) + (x86-dis-make-reg-operand + (lookup-x86-register (ldb (byte 4 0) + pseudo-modrm-byte) :%))))) + (t (setf (x86-di-mnemonic instruction) + (case intop + (#xc9 "uuo-error-call-macro-or-special-operator") + (#xca (setq stop nil) "uuo-error-debug-trap") + (#xcd (setq stop nil) "uuo-error-debug-trap-with-string") + (t "unknown-UUO")))))) + ((< intop #xe0) + (setf (x86-di-mnemonic instruction) + "uuo-error-reg-not-tag" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%)) + (x86-di-op1 instruction) + (x86::make-x86-immediate-operand :value (parse-x86-lap-expression (x86-ds-next-u8 ds))))) + ((< intop #xf0) + (setf (x86-di-mnemonic instruction) + "uuo-error-reg-not-list" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%)))) + (t + (setf (x86-di-mnemonic instruction) + "uuo-error-reg-not-fixnum" + (x86-di-op0 instruction) + (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%))))) + stop)) + + + +(defun x86-dis-analyze-operands (ds instruction flag) + ;; If instruction is adding a positive displacement to the FN + ;; register, note the effective address as a label reference + ;; and modify the operand(s). + ;; If the instruction is a MOV or PUSH whose source operand + ;; is relative to the FN register, generate a constant reference. + ;; If the instruction is adding a displacement to RIP, note + ;; the effective address as a label reference. + ;; On ia32, if op0 is a 32-bit immediate and op1 is (% fn), + ;; treat the immediate as :self. + (let* ((op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (entry-ea (x86-ds-entry-point ds))) + (flet ((is-fn (thing) + (if (typep thing 'x86::x86-register-operand) + (let* ((entry (x86::x86-register-operand-entry thing))) + (eq entry (if (x86-ds-mode-64 ds) + (x86::x86-reg64 13) + (x86::x86-reg32 x8632::fn)))))) + (is-rip (thing) + (if (and (typep thing 'x86::x86-register-operand) + (x86-ds-mode-64 ds)) + (let* ((entry (x86::x86-register-operand-entry thing))) + (eq entry (svref x86::*x8664-register-entries* 102))))) + (is-ra0 (thing) + (if (typep thing 'x86::x86-register-operand) + (let* ((entry (x86::x86-register-operand-entry thing))) + (eq entry (if (x86-ds-mode-64 ds) + (x86::x86-reg64 10) + (x86::x86-reg32 7)))))) + (is-disp-only (thing) + (and (typep thing 'x86::x86-memory-operand) + (null (x86::x86-memory-operand-base thing)) + (null (x86::x86-memory-operand-index thing)) + (x86::x86-memory-operand-disp thing)))) + (flet ((is-fn-ea (thing) + (and (typep thing 'x86::x86-memory-operand) + (is-fn (x86::x86-memory-operand-base thing)) + (null (x86::x86-memory-operand-index thing)) + (let* ((scale (x86::x86-memory-operand-scale thing))) + (or (null scale) (eql 0 scale))) + (let* ((disp (x86::x86-memory-operand-disp thing))) + (and disp (early-x86-lap-expression-value disp))))) + (is-ra0-ea (thing) + (and (typep thing 'x86::x86-memory-operand) + (is-ra0 (x86::x86-memory-operand-base thing)) + (null (x86::x86-memory-operand-index thing)) + (let* ((scale (x86::x86-memory-operand-scale thing))) + (or (null scale) (eql 0 scale))) + (let* ((disp (x86::x86-memory-operand-disp thing))) + (and disp (early-x86-lap-expression-value disp))))) + (is-rip-ea (thing) + (and (typep thing 'x86::x86-memory-operand) + (is-rip (x86::x86-memory-operand-base thing)) + (null (x86::x86-memory-operand-index thing)) + (let* ((scale (x86::x86-memory-operand-scale thing))) + (or (null scale) (eql 0 scale))) + (let* ((disp (x86::x86-memory-operand-disp thing))) + (and disp (early-x86-lap-expression-value disp)))))) + (case flag + ;; Should also check alignment here, and check + + (:lea + (let* ((disp )) + (if (or (and (setq disp (is-fn-ea op0)) (> disp 0)) + (and (setq disp (is-ra0-ea op0)) (< disp 0) (is-fn op1))) + (let* ((label-ea (+ entry-ea (abs disp)))) + (when (< label-ea (x86-ds-code-limit ds)) + (setf (x86::x86-memory-operand-disp op0) + (parse-x86-lap-expression + (if (< disp 0) + `(- (:^ ,label-ea)) + `(:^ ,label-ea)))) + (push label-ea (x86-ds-pending-labels ds)))) + (if (and (setq disp (is-rip-ea op0)) (< disp 0) (is-fn op1)) + (progn + (setf (x86::x86-memory-operand-disp op0) + (parse-x86-lap-expression `(:^ ,entry-ea))) + (push entry-ea (x86-ds-pending-labels ds))))))) + ((:jump :call) + (let* ((disp (is-disp-only op0))) + (when disp + (let* ((info (find (early-x86-lap-expression-value disp) + (if (x86-ds-mode-64 ds) + x8664::*x8664-subprims* + x8632::*x8632-subprims*) + :key #'subprimitive-info-offset))) + (when info (setf (x86::x86-memory-operand-disp op0) + (subprimitive-info-name info))))))) + (t + (unless (x86-ds-mode-64 ds) + (when (and (is-fn op1) + (typep op0 'x86::x86-immediate-operand) + ;; Not sure what else would have an + ;; immediate source and %fn as destination, + ;; but check for this. + (equal (x86-di-mnemonic instruction) "movl")) + (setf (x86-di-mnemonic instruction) "recover-fn" + (x86-di-op0 instruction) nil + (x86-di-op0 instruction) nil)))) + + ))) + instruction)) + +(defun x86-disassemble-instruction (ds labeled) + (let* ((addr (x86-ds-code-pointer ds)) + (sizeflag (logior +aflag+ +dflag+ + (if *x86-dissassemble-always-print-suffix* + +suffix-always+ + 0))) + (instruction (make-x86-disassembled-instruction :address addr + :labeled labeled)) + (stop nil)) + (setf (x86-ds-insn-start ds) addr + (x86-ds-current-instruction ds) instruction) + (scan-prefixes ds instruction) + (setf (x86-ds-opcode-start ds) (x86-ds-code-pointer ds)) + (let* ((primary-opcode (x86-ds-next-u8 ds)) + (two-source-ops (or (= primary-opcode #x62) + (= primary-opcode #xc8))) + (prefixes (x86-ds-prefixes ds)) + (need-modrm nil) + (uses-sse-prefix nil) + (uses-lock-prefix nil) + (dp nil)) + (declare (type (unsigned-byte 8) primary-opcode) + (fixnum prefixes)) + (if (= primary-opcode #x0f) ;two-byte opcode + (setq primary-opcode (x86-ds-next-u8 ds) + dp (svref *disx86-twobyte* primary-opcode) + need-modrm (eql 1 (sbit *twobyte-has-modrm* primary-opcode)) + uses-sse-prefix (eql 1 (sbit *twobyte-uses-sse-prefix* primary-opcode)) + uses-lock-prefix (= #x20 (logandc2 primary-opcode 2))) + (setq dp (svref *disx86* primary-opcode) + need-modrm (eql 1 (sbit *onebyte-has-modrm* primary-opcode)))) + (when (and (not uses-sse-prefix) + (logtest prefixes +prefix-repz+)) + (push "repz" (x86-di-prefixes instruction)) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) +prefix-repz+))) + (when (and (not uses-sse-prefix) + (logtest prefixes +prefix-repnz+)) + (push "repnz" (x86-di-prefixes instruction)) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) +prefix-repnz+))) + (when (and (not uses-lock-prefix) + (logtest prefixes +prefix-lock+)) + (push "lock" (x86-di-prefixes instruction)) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) +prefix-lock+))) + (when (logtest prefixes +prefix-addr+) + (setq sizeflag (logxor sizeflag +aflag+)) + (unless (= (x86-dis-bytemode3 dp) +loop-jcxz-mode+) + (if (or (x86-ds-mode-64 ds) + (logtest sizeflag +aflag+)) + (push "addr32" (x86-di-prefixes instruction)) + (push "addr16" (x86-di-prefixes instruction))) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) +prefix-addr+)))) + (when (and (not uses-sse-prefix) + (logtest prefixes +prefix-data+)) + (setq sizeflag (logxor sizeflag +dflag+)) + (when (and (= (x86-dis-bytemode3 dp) +cond-jump-mode+) + (= (x86-dis-bytemode1 dp) +v-mode+)) + (if (logtest sizeflag +dflag+) + (push "data32" (x86-di-prefixes instruction)) + (push "data16" (x86-di-prefixes instruction))) + (setf (x86-ds-used-prefixes ds) + (logior (x86-ds-used-prefixes ds) +prefix-data+)))) + (when need-modrm + (let* ((modrm-byte (x86-ds-peek-u8 ds))) + (declare (type (unsigned-byte 8) modrm-byte)) + (setf (x86-ds-mod ds) (ldb (byte 2 6) modrm-byte) + (x86-ds-reg ds) (ldb (byte 3 3) modrm-byte) + (x86-ds-rm ds) (ldb (byte 3 0) modrm-byte)))) + (if (and (null (x86-dis-mnemonic dp)) + (eql (x86-dis-bytemode1 dp) +floatcode+)) + (x86-dis-do-float ds instruction primary-opcode sizeflag) + (if (and (null (x86-dis-mnemonic dp)) + (eql (x86-dis-bytemode1 dp) +uuocode+)) + (progn + (setq stop + (x86-dis-do-uuo ds instruction (x86-ds-next-u8 ds)))) + (progn + (when (null (x86-dis-mnemonic dp)) + (let* ((bytemode1 (x86-dis-bytemode1 dp))) + (declare (fixnum bytemode1)) + (cond ((= bytemode1 +use-groups+) + (setq dp (svref (svref *grps* (x86-dis-bytemode2 dp)) + (x86-ds-reg ds)))) + ((= bytemode1 +use-prefix-user-table+) + (let* ((index 0)) + (used-prefix ds +prefix-repz+) + (if (logtest prefixes +prefix-repz+) + (setq index 1) + (progn + (used-prefix ds +prefix-data+) + (if (logtest prefixes +prefix-data+) + (setq index 2) + (progn + (used-prefix ds +prefix-repnz+) + (if (logtest prefixes +prefix-repnz+) + (setq index 3)))))) + (setq dp (svref (svref *prefix-user-table* + (x86-dis-bytemode2 dp)) + index)))) + ((= bytemode1 +x86-64-special+) + (setq dp (svref (svref *x86-64-table* + (x86-dis-bytemode2 dp)) + (if (x86-ds-mode-64 ds) 1 0)))) + (t (error "Disassembly error"))))) + (when (x86-putop ds (x86-dis-mnemonic dp) sizeflag instruction) + (let* ((operands ()) + (op1 (x86-dis-op1 dp)) + (op2 (x86-dis-op2 dp)) + (op3 (x86-dis-op3 dp)) + (operand nil)) + (when op1 + ;(format t "~& op1 = ~s" op1) + (setq operand (funcall op1 ds (x86-dis-bytemode1 dp) sizeflag)) + (if operand + (push operand operands))) + (when op2 + ;(format t "~& op2 = ~s" op2) + (setq operand (funcall op2 ds (x86-dis-bytemode2 dp) sizeflag)) + (if operand + (push operand operands))) + (when op3 + ;(format t "~& op3 = ~s" op3) + (setq operand (funcall op3 ds (x86-dis-bytemode3 dp) sizeflag)) + (if operand + (push operand operands))) + (if two-source-ops + (setf (x86-di-op1 instruction) (pop operands) + (x86-di-op0 instruction) (pop operands)) + (setf (x86-di-op0 instruction) (pop operands) + (x86-di-op1 instruction) (pop operands) + (x86-di-op2 instruction) (pop operands)))))))) + (values (x86-dis-analyze-operands ds instruction (x86-dis-flags dp)) + (or stop (eq (x86-dis-flags dp) :jump)))))) + +(defun x86-disassemble-new-block (ds addr) + (setf (x86-ds-code-pointer ds) addr) + (let* ((limit (do-dll-nodes (b (x86-ds-blocks ds) (x86-ds-code-limit ds)) + (when (> (x86-dis-block-start-address b) addr) + (return (x86-dis-block-start-address b))))) + (block (make-x86-dis-block :start-address addr)) + (instructions (x86-dis-block-instructions block)) + (labeled (not (eql addr (x86-ds-entry-point ds))))) + (loop + (multiple-value-bind (instruction stop) + (x86-disassemble-instruction ds labeled) + (setq labeled nil) + (append-dll-node instruction instructions) + (if stop (return)) + (if (>= (x86-ds-code-pointer ds) limit) + (if (= (x86-ds-code-pointer ds) limit) + (return) + (error "Internal disassembly error"))))) + (setf (x86-dis-block-end-address block) (x86-ds-code-pointer ds)) + (insert-x86-block block (x86-ds-blocks ds)))) + +(defmethod unparse-x86-lap-expression ((exp t) + ds) + (declare (ignore ds)) + exp) + +(defmethod unparse-x86-lap-expression ((exp constant-x86-lap-expression) + ds) + (declare (ignore ds)) + (constant-x86-lap-expression-value exp)) + +(defmethod unparse-x86-lap-expression ((exp label-x86-lap-expression) + ds) + (let* ((label (label-x86-lap-expression-label exp)) + (name (x86-lap-label-name label)) + (entry (x86-ds-entry-point ds))) + `(":^" , (if (typep name 'fixnum) + (format nil "L~d" (- name entry)) + name)))) + +(defmethod unparse-x86-lap-expression ((exp unary-x86-lap-expression) + ds) + `(,(unary-x86-lap-expression-operator exp) + ,(unparse-x86-lap-expression (unary-x86-lap-expression-operand exp) ds))) + +(defmethod unparse-x86-lap-expression ((exp binary-x86-lap-expression) + ds) + `(,(binary-x86-lap-expression-operator exp) + ,(unparse-x86-lap-expression (binary-x86-lap-expression-operand0 exp) ds) + ,(unparse-x86-lap-expression (binary-x86-lap-expression-operand1 exp) ds))) + +(defmethod unparse-x86-lap-expression ((exp n-ary-x86-lap-expression) + ds) + `(,(n-ary-x86-lap-expression-operator exp) + ,@(mapcar #'(lambda (x) + (unparse-x86-lap-expression x ds)) + (n-ary-x86-lap-expression-operands exp)))) + +(defmethod unparse-x86-lap-operand ((op x86::x86-register-operand) + ds) + (let* ((r (x86::x86-register-operand-entry op)) + (symbolic-names (x86-ds-symbolic-names ds)) + (reg-name (x86::reg-entry-reg-name r)) + (name (or (if symbolic-names + (gethash reg-name symbolic-names)) + reg-name))) + `(% ,name))) + +(defmethod unparse-x86-lap-operand ((op x86::x86-immediate-operand) + ds) + `($ ,(unparse-x86-lap-expression (x86::x86-immediate-operand-value op) + ds))) + +(defmethod unparse-x86-lap-operand ((op x86::x86-label-operand) + ds) + (let* ((addr (x86::x86-label-operand-label op)) + (entrypoint (x86-ds-entry-point ds))) + (format nil "L~d" (- addr entrypoint)))) + + +(defmethod x86-lap-operand-constant-offset (op ds) + (declare (ignore op ds)) + nil) + +(defmethod x86-lap-operand-constant-offset ((op x86::x86-memory-operand) ds) + (let* ((disp (x86::x86-memory-operand-disp op)) + (base (x86::x86-memory-operand-base op)) + (index (x86::x86-memory-operand-index op)) + (scale (x86::x86-memory-operand-scale op)) + (code-limit (x86-ds-code-limit ds)) + (val (and base + (eq (x86::x86-register-operand-entry base) + (if (x86-ds-mode-64 ds) + (x86::x86-reg64 13) + (x86::x86-reg32 x8632::fn))) + (null index) + (or (eql scale 0) (null scale)) + (typecase disp + (constant-x86-lap-expression + (+ (x86-ds-entry-point ds) + (constant-x86-lap-expression-value disp))) + (integer + (+ (x86-ds-entry-point ds) disp)) + (t nil))))) + (when (and val (>= val code-limit)) + (- val code-limit)))) + +(defun x86-lap-operand-constant (op ds) + (let ((diff (x86-lap-operand-constant-offset op ds))) + (when diff + (values (uvref (x86-ds-constants-vector ds) + (1+ (ash diff (if (x86-ds-mode-64 ds) + (- x8664::word-shift) + (- x8632::word-shift))))) + t)))) + + +(defmethod unparse-x86-lap-operand ((x x86::x86-memory-operand) ds) + (multiple-value-bind (constant foundp) (x86-lap-operand-constant x ds) + (if foundp + `(@ ',constant ,(unparse-x86-lap-operand (x86::x86-memory-operand-base x) ds)) + (let* ((seg (x86::x86-memory-operand-seg x)) + (disp (x86::x86-memory-operand-disp x)) + (base (x86::x86-memory-operand-base x)) + (index (x86::x86-memory-operand-index x)) + (scale (x86::x86-memory-operand-scale x))) + (collect ((subforms)) + (subforms '@) + (if seg + (subforms (unparse-x86-lap-operand seg ds))) + (if disp + (subforms (unparse-x86-lap-expression disp ds))) + (if base + (subforms (unparse-x86-lap-operand base ds))) + (if index + (subforms (unparse-x86-lap-operand index ds))) + (if (and scale (not (eql scale 0))) + (subforms (ash 1 scale))) + (subforms)))))) + +(defmethod unparse-x86-lap-operand :around ((op x86::x86-operand) + ds) + (declare (ignore ds)) + (let* ((usual (call-next-method)) + (type (or (x86::x86-operand-type op) 0))) + (if (logtest (x86::encode-operand-type :jumpabsolute) type) + `(* ,usual) + usual))) + +(defun write-x86-lap-operand (stream op ds) + ;; Basically, have to princ because some parts are already stringified, + ;; plus don't want package prefixes on assembler syntax. But want to + ;; prin1 immediates. + (let ((expr (unparse-x86-lap-operand op ds))) + (format stream " ") + (labels ((out (stream expr) + (cond ((atom expr) + (format stream "~a" expr)) + ((quoted-form-p expr) + (format stream "'~s" (cadr expr))) + (t + (loop for item in expr as pre = "(" then " " + do (format stream pre) + do (out stream item)) + (format stream ")"))))) + (out stream expr)))) + +(defvar *previous-source-note*) + +(defun x86-print-disassembled-instruction (ds instruction seq function) + (let* ((addr (x86-di-address instruction)) + (entry (x86-ds-entry-point ds)) + (pc (- addr entry))) + (let ((source-note (find-source-note-at-pc function pc))) + (unless (eql (source-note-file-range source-note) + (source-note-file-range *previous-source-note*)) + (setf *previous-source-note* source-note) + (let* ((source-text (source-note-text source-note)) + (text (if source-text + (string-sans-most-whitespace source-text 100) + "#"))) + (format t "~&~%;;; ~A" text)))) + (when (x86-di-labeled instruction) + (format t "~&L~d~%" pc) + (setq seq 0)) + (format t "~& [~D]~8T" pc) + (dolist (p (x86-di-prefixes instruction)) + (format t "~& (~a)~%" p)) + (format t " (~a" (x86-di-mnemonic instruction)) + (let* ((op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when op0 + (write-x86-lap-operand t op0 ds) + (when op1 + (write-x86-lap-operand t op1 ds) + (when op2 + (write-x86-lap-operand t op2 ds))))) + (format t ")") + (format t "~%") + (1+ seq))) + +(defun x86-print-disassembled-function-header (function xfunction) + (declare (ignore xfunction)) + (let ((source-note (function-source-note function))) + (when source-note + (ensure-source-note-text source-note) + (if (source-note-filename source-note) + (format t ";; ~S:~D-~D" + (source-note-filename source-note) + (source-note-start-pos source-note) + (source-note-end-pos source-note)) + (let* ((source-text (source-note-text source-note))) + (when source-text + (format t ";;; ~A" (string-sans-most-whitespace source-text 100)))))))) + +(defun x86-disassemble-xfunction (function xfunction + &key (symbolic-names #+x8664-target target::*x8664-symbolic-register-names* + #+x8632-target target::*x8632-symbolic-register-names*) + (collect-function #'x86-print-disassembled-instruction) + (header-function #'x86-print-disassembled-function-header)) + (check-type xfunction xfunction) + (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*))) + (let* ((entry-point #+x8664-target 7 #+x8632-target 2) + (ds (make-x86-disassembly-state + :mode-64 #+x8664-target t #+x8632-target nil + :code-vector (uvref xfunction 0) + :constants-vector xfunction + :entry-point entry-point + :code-pointer 0 ; for next-u32/next-u16 below + :symbolic-names symbolic-names + :pending-labels (list entry-point))) + (blocks (x86-ds-blocks ds))) + (setf (x86-ds-code-limit ds) + #+x8664-target (ash (x86-ds-next-u32 ds) 3) + #+x8632-target (ash (x86-ds-next-u16 ds) 2)) + (do* () + ((null (x86-ds-pending-labels ds))) + (let* ((lab (pop (x86-ds-pending-labels ds)))) + (or (x86-dis-find-label lab blocks) + (x86-disassemble-new-block ds lab)))) + (when (and header-function + blocks + (let ((something-to-disassemble nil)) + (do-dll-nodes (block blocks) + (do-dll-nodes (instruction (x86-dis-block-instructions block)) + (setf something-to-disassemble t))) + something-to-disassemble)) + (funcall header-function function xfunction)) + (let* ((seq 0) + (*previous-source-note* nil)) + (declare (special *previous-source-note*)) + (do-dll-nodes (block blocks) + (do-dll-nodes (instruction (x86-dis-block-instructions block)) + (setq seq (funcall collect-function ds instruction seq function))))))) + +(defun x86-xdisassemble (function + &optional (collect-function #'x86-print-disassembled-instruction) + (header-function #'x86-print-disassembled-function-header)) + (let* ((fv (function-to-function-vector function)) + (function-size-in-words (uvsize fv)) + (code-words (%function-code-words function)) + (ncode-bytes (ash function-size-in-words target::word-shift)) + (code-bytes (make-array ncode-bytes + :element-type '(unsigned-byte 8))) + (numimms (- function-size-in-words code-words)) + (xfunction (%alloc-misc (the fixnum (1+ numimms)) target::subtag-xfunction))) + (declare (fixnum code-words ncode-bytes numimms)) + (%copy-ivector-to-ivector fv 0 code-bytes 0 ncode-bytes) + (setf (uvref xfunction 0) code-bytes) + (do* ((k code-words (1+ k)) + (j 1 (1+ j))) + ((= k function-size-in-words) + (x86-disassemble-xfunction function xfunction + :collect-function collect-function + :header-function header-function)) + (declare (fixnum j k)) + (setf (uvref xfunction j) (uvref fv k))))) + +(defun disassemble-list (function) + (collect ((instructions)) + (x86-xdisassemble + function + #'(lambda (ds instruction seq function) + (declare (ignore function)) + (collect ((insn)) + (let* ((addr (x86-di-address instruction)) + (entry (x86-ds-entry-point ds)) + (rpc (- addr entry))) + (if (x86-di-labeled instruction) + (progn + (insn `(label ,rpc)) + (setq seq 0)) + (insn rpc)) + (dolist (p (x86-di-prefixes instruction)) + (insn p)) + (insn (x86-di-mnemonic instruction)) + (let* ((op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when op0 + (insn (unparse-x86-lap-operand op0 ds)) + (when op1 + (insn (unparse-x86-lap-operand op1 ds)) + (when op2 + (insn (unparse-x86-lap-operand op2 ds)) )))) + (instructions (insn)) + (1+ seq)))) + nil) + (instructions))) + +(defun x86-disassembled-instruction-line (ds instruction function &optional string-stream) + (if (null string-stream) + (with-output-to-string (stream) + (return-from x86-disassembled-instruction-line + (x86-disassembled-instruction-line ds instruction function stream))) + (let* ((addr (x86-di-address instruction)) + (entry (x86-ds-entry-point ds)) + (pc (- addr entry)) + (op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction)) + (label (if (x86-di-labeled instruction) (list :label pc) pc)) + (instr (progn + (dolist (p (x86-di-prefixes instruction)) + (format string-stream "(~a) " p)) + (format string-stream "(~a" (x86-di-mnemonic instruction)) + (when op0 (write-x86-lap-operand string-stream op0 ds)) + (when op1 (write-x86-lap-operand string-stream op1 ds)) + (when op2 (write-x86-lap-operand string-stream op2 ds)) + (format string-stream ")") + (get-output-stream-string string-stream))) + (comment (let ((source-note (find-source-note-at-pc function pc))) + (unless (eql (source-note-file-range source-note) + (source-note-file-range *previous-source-note*)) + (setf *previous-source-note* source-note) + (let* ((source-text (source-note-text source-note)) + (text (if source-text + (string-sans-most-whitespace source-text 100) + "#"))) + (format string-stream ";;; ~A" text) + (get-output-stream-string string-stream))))) + (imms (let ((imms nil)) + (multiple-value-bind (imm foundp) (x86-lap-operand-constant op2 ds) + (when foundp (push imm imms))) + (multiple-value-bind (imm foundp) (x86-lap-operand-constant op1 ds) + (when foundp (push imm imms))) + (multiple-value-bind (imm foundp) (x86-lap-operand-constant op0 ds) + (when foundp (push imm imms))) + imms))) + ;; Subtle difference between no imms and a single NIL imm, so if anybody ever + ;; cares for some reason, they could distinguish the two cases. + (if imms + (values comment label instr (if (cdr imms) (coerce imms 'vector) (car imms))) + (values comment label instr))))) + +(defun disassemble-lines (function) + (let ((source-note (function-source-note function))) + (when source-note + ;; Fetch source from file if don't already have it. + (ensure-source-note-text source-note))) + (let ((lines (make-array 20 :adjustable t :fill-pointer 0))) + (with-output-to-string (stream) + (x86-xdisassemble + function + #'(lambda (ds instruction seq function) + (declare (ignore seq)) + (multiple-value-bind (comment label instr object) + (x86-disassembled-instruction-line ds instruction function stream) + (when comment + (vector-push-extend comment lines)) + (vector-push-extend (list object label instr) lines))) + nil)) + (coerce lines 'simple-vector))) Index: /branches/qres/ccl/compiler/X86/x86-lap.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/x86-lap.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/x86-lap.lisp (revision 13564) @@ -0,0 +1,1665 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(require "X86-ASM") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "DLL-NODE")) + +(def-standard-initial-binding *x86-lap-label-freelist* (make-dll-node-freelist)) + +(def-standard-initial-binding *x86-lap-frag-vector-freelist* (%cons-pool)) + +(defun %allocate-vector-list-segment () + (without-interrupts + (let* ((data (pool.data *x86-lap-frag-vector-freelist*))) + (if data + (progn + (when (null (list-length data)) + (compiler-bug "frag-vector freelist is circular")) + (setf (pool.data *x86-lap-frag-vector-freelist*) (cdr data)) + (rplacd data nil)) + (cons (make-array 24 :element-type '(unsigned-byte 8)) nil))))) + +(defun %free-vector-list-segment (segment) + (without-interrupts + (setf (pool.data *x86-lap-frag-vector-freelist*) + (nconc segment (pool.data *x86-lap-frag-vector-freelist*))))) + +(defun %vector-list-ref (vector-list index) + (do* ((i index (- i len)) + (vl vector-list (cdr vl)) + (v (car vl) (car vl)) + (len (length v) (length v))) + ((null vl) (error "Index ~s is out of bounds for ~s" index vector-list)) + (if (< i len) + (return (aref v i))))) + +(defun (setf %vector-list-ref) (new vector-list index) + (do* ((i index (- i len)) + (vl vector-list (cdr vl)) + (v (car vl) (car vl)) + (len (length v) (length v))) + ((< i len) (setf (aref v i) new)) + (when (null (cdr vl)) + (setf (cdr vl) (%allocate-vector-list-segment))))) + +(defun %truncate-vector-list (vector-list newlen) + (do* ((vl vector-list (cdr vl)) + (v (car vl) (car vl)) + (len (length v) (length v)) + (total len (+ total len))) + ((null (cdr vl))) + (when (> total newlen) + (%free-vector-list-segment (cdr vl)) + (return (setf (cdr vl) nil))))) + + + + + +(eval-when (:execute :load-toplevel) + + (defstruct (x86-lap-note (:include ccl::dll-node)) + peer + id) + + (defstruct (x86-lap-note-begin (:include x86-lap-note))) + (defstruct (x86-lap-note-end (:include x86-lap-note))) + + (defstruct (x86-lap-label (:constructor %%make-x86-lap-label (name))) + name + frag + offset + ) + + (defstruct (frag (:include ccl::dll-node) + (:constructor %make-frag)) + address + last-address ; address may change during relax + type ; nil, or (:TYPE &rest args) + relocs ; relocations against this frag + (position 0) ; position in code-buffer + (code-buffer (%allocate-vector-list-segment)) ; a VECTOR-LIST + labels ; labels defined in this frag + )) + +(def-standard-initial-binding *frag-freelist* (make-dll-node-freelist)) + + +(defun frag-push-byte (frag b) + (let* ((pos (frag-position frag))) + (setf (%vector-list-ref (frag-code-buffer frag) pos) b + (frag-position frag) (1+ pos)) + b)) + +(defun frag-ref (frag index) + (%vector-list-ref (frag-code-buffer frag) index)) + +(defun (setf frag-ref) (new frag index) + (setf (%vector-list-ref (frag-code-buffer frag) index) new)) + +;;; get/set little-endian 32 bit word in frag at index +(defun frag-ref-32 (frag index) + (let ((result 0)) + (setf (ldb (byte 8 0) result) (frag-ref frag index) + (ldb (byte 8 8) result) (frag-ref frag (+ index 1)) + (ldb (byte 8 16) result) (frag-ref frag (+ index 2)) + (ldb (byte 8 24) result) (frag-ref frag (+ index 3))) + result)) + +(defun (setf frag-ref-32) (new frag index) + (setf (frag-ref frag index) (ldb (byte 8 0) new) + (frag-ref frag (+ index 1)) (ldb (byte 8 8) new) + (frag-ref frag (+ index 2)) (ldb (byte 8 16) new) + (frag-ref frag (+ index 3)) (ldb (byte 8 24) new))) + +(defun frag-length (frag) + (frag-position frag)) + +(defun (setf frag-length) (new frag) + (%truncate-vector-list (frag-code-buffer frag) new) + (setf (frag-position frag) new)) + + +;;; Push 1, 2, 4, or 8 bytes onto the frag-list's current-frag's buffer. +;;; (If pushing more than one byte, do so in little-endian order.) +(defun frag-list-push-byte (frag-list b) + (frag-push-byte (frag-list-current frag-list) b)) + +(defun frag-list-push-16 (frag-list w) + (let* ((frag (frag-list-current frag-list))) + (frag-push-byte frag (ldb (byte 8 0) w)) + (frag-push-byte frag (ldb (byte 8 8) w)))) + +(defun frag-list-push-32 (frag-list w) + (let* ((frag (frag-list-current frag-list))) + (frag-push-byte frag (ldb (byte 8 0) w)) + (frag-push-byte frag (ldb (byte 8 8) w)) + (frag-push-byte frag (ldb (byte 8 16) w)) + (frag-push-byte frag (ldb (byte 8 24) w)) + w)) + +(defun frag-list-push-64 (frag-list w) + (let* ((frag (frag-list-current frag-list))) + (frag-push-byte frag (ldb (byte 8 0) w)) + (frag-push-byte frag (ldb (byte 8 8) w)) + (frag-push-byte frag (ldb (byte 8 16) w)) + (frag-push-byte frag (ldb (byte 8 24) w)) + (frag-push-byte frag (ldb (byte 8 32) w)) + (frag-push-byte frag (ldb (byte 8 40) w)) + (frag-push-byte frag (ldb (byte 8 48) w)) + (frag-push-byte frag (ldb (byte 8 56) w)) + w)) + +;;; Returns the length of the current frag +(defun frag-list-position (frag-list) + (frag-length (frag-list-current frag-list))) + +(defun frag-output-bytes (frag target target-offset) + (let* ((buffer (frag-code-buffer frag)) + (n (frag-length frag)) + (remain n)) + (loop + (when (zerop remain) (return n)) + (let* ((v (pop buffer)) + (len (length v)) + (nout (min remain len))) + (%copy-ivector-to-ivector v + 0 + target + target-offset + nout) + (incf target-offset nout) + (decf remain nout))))) + +(defun make-frag () + (let* ((frag (alloc-dll-node *frag-freelist*))) + (if frag + (let* ((buffer (frag-code-buffer frag))) + (when buffer + (setf (frag-length frag) 0)) + (setf (frag-address frag) nil + (frag-last-address frag) nil + (frag-type frag) nil + (frag-relocs frag) nil + (frag-labels frag) nil) + frag) + (%make-frag)))) + + +;;; Intentionally very similar to RISC-LAP, but with some extensions +;;; to deal with alignment and with variable-length and/or span- +;;; dependent instructions. + +(defvar *x86-lap-labels* ()) +(defvar *x86-lap-constants* ()) +(defparameter *x86-lap-entry-offset* nil) +(defparameter *x86-lap-fixed-code-words* nil) +(defvar *x86-lap-lfun-bits* 0) + +(defun x86-lap-macro-function (name) + (gethash (string name) (backend-lap-macros *target-backend*))) + +(defun (setf x86-lap-macro-function) (def name) + (let* ((s (string name))) + (when (gethash s x86::*x86-opcode-template-lists*) + (error "~s already defines an x86 instruction." name)) + (setf (gethash s (backend-lap-macros *target-backend*)) def))) + +(defmacro defx86lapmacro (name arglist &body body) + `(progn + (setf (x86-lap-macro-function ',name) + (nfunction (x86-lap-macro ,name) ,(ccl::parse-macro name arglist body))) + (record-source-file ',name 'x86-lap) + ',name)) + +(defun x86-lap-macroexpand-1 (form) + (unless (and (consp form) (atom (car form))) + (values form nil)) + (let* ((expander (x86-lap-macro-function (car form)))) + (if expander + (values (funcall expander form nil) t) + (values form nil)))) + + +(defmethod print-object ((l x86-lap-label) stream) + (print-unreadable-object (l stream :type t) + (format stream "~a" (x86-lap-label-name l)))) + +;;; Labels + +(defun %make-x86-lap-label (name) + (let* ((lab (alloc-dll-node *x86-lap-label-freelist*))) + (if lab + (progn + (setf (x86-lap-label-frag lab) nil + (x86-lap-label-offset lab) nil + (x86-lap-label-name lab) name) + lab) + (%%make-x86-lap-label name)))) + +(defun make-x86-lap-label (name) + (let* ((lab (%make-x86-lap-label name))) + (if (typep *x86-lap-labels* 'hash-table) + (setf (gethash name *x86-lap-labels*) lab) + (progn + (push lab *x86-lap-labels*) + (if (> (length *x86-lap-labels*) 255) + (let* ((hash (make-hash-table :size 512 :test #'eq))) + (dolist (l *x86-lap-labels* (setq *x86-lap-labels* hash)) + (setf (gethash (x86-lap-label-name l) hash) l)))))) + lab)) + +(defun find-x86-lap-label (name) + (if (typep *x86-lap-labels* 'hash-table) + (gethash name *x86-lap-labels*) + (car (member name *x86-lap-labels* :test #'eq :key #'x86-lap-label-name)))) + +(defun find-or-create-x86-lap-label (name) + (or (find-x86-lap-label name) + (make-x86-lap-label name))) + + +;;; A label can only be emitted once. Once it's been emitted, its frag +;;; slot will be non-nil. + +(defun x86-lap-label-emitted-p (lab) + (not (null (x86-lap-label-frag lab)))) + +(defun emit-x86-lap-label (frag-list name) + (let* ((lab (find-or-create-x86-lap-label name)) + (current (frag-list-current frag-list))) + (when (x86-lap-label-emitted-p lab) + (error "Label ~s: multiply defined." name)) + (setf (x86-lap-label-frag lab) current + (x86-lap-label-offset lab) (frag-list-position frag-list)) + (push lab (frag-labels current)) + lab)) + + + + + +(defstruct reloc + type ; a keyword + arg ; a label-operand or an expression, etc. + frag ; the (redundant) containing frag + pos ; octet position withing frag + ) + + + + +(defstruct (frag-list (:include ccl::dll-header) (:constructor nil))) + +;;; ccl::dll-header-last is unit-time +(defun frag-list-current (frag-list) + (ccl::dll-header-last frag-list)) + +;;; Add a new (empty) frag to the end of FRAG-LIST and make the new frag +;;; current +(defun new-frag (frag-list) + (ccl::append-dll-node (make-frag) frag-list)) + +;;; Make a frag list, and make an empty frag be its current frag. +(defun make-frag-list () + (let* ((header (ccl::make-dll-header))) + (new-frag header) + header)) + + + +;;; Finish the current frag, marking it as containing a PC-relative +;;; branch to the indicated label, with a one-byte opcode and +;;; one byte of displacement. +(defun finish-frag-for-branch (frag-list opcode label) + (let* ((frag (frag-list-current frag-list))) + (frag-push-byte frag opcode) + (let* ((pos (frag-length frag)) + (reloc (make-reloc :type :branch8 + :arg label + :pos pos))) + (push reloc (frag-relocs frag)) + (frag-push-byte frag 0) + (setf (frag-type frag) (list (if (eql opcode #xeb) + :assumed-short-branch + :assumed-short-conditional-branch) + label + pos + reloc)) + (new-frag frag-list)))) + +;;; Mark the current frag as -ending- with an align directive. +;;; p2align is the power of 2 at which code in the next frag +;;; should be aligned. +;;; Start a new frag. +(defun finish-frag-for-align (frag-list p2align) + (let* ((frag (frag-list-current frag-list))) + (setf (frag-type frag) (list :align p2align)) + (new-frag frag-list))) + +;;; Make the current frag be of type :talign; set that frag-type's +;;; argument to NIL initially. Start a new frag of type :pending-talign; +;;; that frag will contain at most one instruction. When an +;;; instuction is ouput in the pending-talign frag, adjust the preceding +;;; :talign frag's argument and set the type of the :pending-talign +;;; frag to NIL. (The :talign frag will have 0-7 NOPs of some form +;;; appended to it, so the first instruction in the successor will end +;;; on an address that matches the argument below.) +;;; That instruction can not be a relaxable branch. +(defun finish-frag-for-talign (frag-list arg) + (let* ((current (frag-list-current frag-list)) + (new (new-frag frag-list))) + (setf (frag-type current) (list :talign nil)) + (setf (frag-type new) (list :pending-talign arg)))) + +;;; Having generated an instruction in a :pending-talign frag, set the +;;; frag-type argument of the preceding :talign frag to the :pendint-talign +;;; frag's argument - the length of the pending-talign's first instruction +;;; mod 8, and clear the type of the "pending" frag. +;;; cadr of the frag-type +(defun finish-pending-talign-frag (frag-list) + (let* ((frag (frag-list-current frag-list)) + (pred (frag-pred frag)) + (arg (cadr (frag-type frag))) + (pred-arg (frag-type pred))) + (setf (cadr pred-arg) (logand 7 (- arg (frag-length frag))) + (frag-type frag) nil) + (new-frag frag-list))) + +(defun finish-frag-for-org (frag-list org) + (let* ((frag (frag-list-current frag-list))) + (setf (frag-type frag) (list :org org)) + (new-frag frag-list))) + + +(defun lookup-x86-register (regname designator) + (let* ((registers (target-arch-case (:x8632 x86::*x8632-registers*) + (:x8664 x86::*x8664-registers*))) + (register-entries (target-arch-case (:x8632 x86::*x8632-register-entries*) + (:x8664 x86::*x8664-register-entries*))) + (r (typecase regname + (symbol (or (gethash (string regname) registers) + (if (eq regname :rcontext) + (svref register-entries + (ccl::backend-lisp-context-register *target-backend*))) + (and (boundp regname) + (let* ((val (symbol-value regname))) + (and (typep val 'fixnum) + (>= val 0) + (< val (length register-entries)) + (svref register-entries val)))))) + (string (gethash regname registers)) + (fixnum (if (and (typep regname 'fixnum) + (>= regname 0) + (< regname (length register-entries))) + (svref register-entries regname)))))) + + (when r + (if (eq designator :%) + r + (let* ((regtype (x86::reg-entry-reg-type r)) + (oktypes (target-arch-case + (:x8632 (x86::encode-operand-type :reg8 :reg16 :reg32)) + (:x8664 (x86::encode-operand-type :reg8 :reg16 :reg32 :reg64))))) + (unless (logtest regtype oktypes) + (error "Designator ~a can't be used with register ~a" + designator (x86::reg-entry-reg-name r))) + (case designator + (:%b (if (x86-byte-reg-p (x86::reg-entry-reg-name r)) + (x86::x86-reg8 r) + (error "Designator ~a can't be used with register ~a" + designator (x86::reg-entry-reg-name r)))) + (:%w (x86::x86-reg16 r)) + (:%l (x86::x86-reg32 r)) + (:%q (x86::x86-reg64 r)))))))) + +(defun x86-register-ordinal-or-expression (form) + (let* ((r (if (typep form 'symbol) + (lookup-x86-register form :%)))) + (if r + (target-arch-case (:x8632 (x86::reg-entry-ordinal32 r)) + (:x8664 (x86::reg-entry-ordinal64 r))) + (multiple-value-bind (val condition) + (ignore-errors (eval form)) + (if condition + (error "Condition ~a signaled during assembly-time evalation of ~s." + condition form) + val))))) + +(defun x86-acc-reg-p (regname) + (let ((r (lookup-x86-register regname :%))) + (if r + (logtest (x86::encode-operand-type :acc) (x86::reg-entry-reg-type r))))) + +(defun x86-byte-reg-p (regname) + (let ((r (lookup-x86-register regname :%))) + (if r + (target-arch-case + (:x8632 + (or (<= (x86::reg-entry-reg-num r) x8632::ebx) + (member (x86::reg-entry-reg-name r) '("ah" "ch" "dh" "bh") :test #'string=))) + (:x8664 t))))) + +;;; It may seem strange to have an expression language in a lisp-based +;;; assembler, since lisp is itself a fairly reasonable expression +;;; language and EVAL is (in this context, at least) an adequate evaluation +;;; mechanism. This may indeed be overkill, but there are reasons for +;;; wanting something beyond EVAL. +;;; This assumes that any expression that doesn't involve label addresses +;;; will always evaluate to the same value (in "the same" execution context). +;;; Expressions that do involve label references might only be evaluable +;;; after all labels are defined, and the value of such an expression may +;;; change (as label addresses are adjusted.) + +;;; A "label address expression" looks like (:^ lab), syntactically. Tree-walk +;;; FORM, and return T if it contains a label address expression. + +(defun label-address-expression-p (form) + (and (consp form) + (eq (car form) :^) + (consp (cdr form)) + (null (cddr form)))) + +(defun contains-label-address-expression (form) + (cond ((label-address-expression-p form) t) + ((typep form 'application-x86-lap-expression) t) + ((atom form) nil) + (t (dolist (sub (cdr form)) + (when (contains-label-address-expression sub) + (return t)))))) + +(defstruct x86-lap-expression + ) + + +(defstruct (label-x86-lap-expression (:include x86-lap-expression)) + label) + + +;;; Represents a constant +(defstruct (constant-x86-lap-expression (:include x86-lap-expression)) + value) + + + +;;; Also support 0, 1, 2, and many args, where at least one of those args +;;; is or contains a label reference. +(defstruct (application-x86-lap-expression (:include x86-lap-expression)) + operator) + + +(defstruct (unary-x86-lap-expression (:include application-x86-lap-expression)) + operand) + + +(defstruct (binary-x86-lap-expression (:include application-x86-lap-expression)) + operand0 + operand1) + +(defstruct (n-ary-x86-lap-expression (:include application-x86-lap-expression)) + operands) + +;;; Looks like a job for DEFMETHOD. +(defun x86-lap-expression-value (exp) + (typecase exp + (label-x86-lap-expression (- (x86-lap-label-address (label-x86-lap-expression-label exp)) *x86-lap-entry-offset*)) + (unary-x86-lap-expression (funcall (unary-x86-lap-expression-operator exp) + (x86-lap-expression-value (unary-x86-lap-expression-operand exp)))) + (binary-x86-lap-expression (funcall (binary-x86-lap-expression-operator exp) + (x86-lap-expression-value (binary-x86-lap-expression-operand0 exp)) + (x86-lap-expression-value (binary-x86-lap-expression-operand1 exp)))) + (n-ary-x86-lap-expression (apply (n-ary-x86-lap-expression-operator exp) + (mapcar #'x86-lap-expression-value (n-ary-x86-lap-expression-operands exp)))) + (constant-x86-lap-expression (constant-x86-lap-expression-value exp)) + (t exp))) + +;;; Expression might contain unresolved labels. Return nil if so (even +;;; if everything -could- be resolved.) +(defun early-x86-lap-expression-value (expression) + (typecase expression + (constant-x86-lap-expression (constant-x86-lap-expression-value expression)) + (x86-lap-expression nil) + (t expression))) + +(define-condition undefined-x86-lap-label (simple-program-error) + ((label-name :initarg :label-name)) + (:report (lambda (c s) + (format s "Label ~s was referenced but not defined." + (slot-value c 'label-name))))) + +(defun x86-lap-label-address (lab) + (let* ((frag (or (x86-lap-label-frag lab) + (error 'undefined-x86-lap-label :label-name (x86-lap-label-name lab))))) + (+ (frag-address frag) + (x86-lap-label-offset lab)))) + + +(defun ensure-x86-lap-constant-label (val) + (or (cdr (assoc val *x86-lap-constants* + :test #'eq)) + (let* ((label (make-x86-lap-label + (gensym))) + (pair (cons val label))) + (push pair *x86-lap-constants*) + label))) + +(defun parse-x86-lap-expression (form) + (if (typep form 'x86-lap-expression) + form + (progn + (when (quoted-form-p form) + (let* ((val (cadr form))) + (if (typep val 'fixnum) + (setq form (ash val (arch::target-fixnum-shift (backend-target-arch *target-backend*)))) + (let* ((constant-label (ensure-x86-lap-constant-label val ))) + (setq form `(:^ ,(x86-lap-label-name constant-label))))))) + (if (null form) + (setq form (arch::target-nil-value (backend-target-arch *target-backend*))) + (if (eq form t) + (setq form + (+ (arch::target-nil-value (backend-target-arch *target-backend*)) + (arch::target-t-offset (backend-target-arch *target-backend*)))))) + + (if (label-address-expression-p form) + (make-label-x86-lap-expression :label (find-or-create-x86-lap-label (cadr form))) + (if (contains-label-address-expression form) + (destructuring-bind (op &rest args) form + (case (length args) + (1 (make-unary-x86-lap-expression :operator op :operand (parse-x86-lap-expression (car args)))) + (2 (make-binary-x86-lap-expression :operator op :operand0 (parse-x86-lap-expression (car args)) + :operand1 (parse-x86-lap-expression (cadr args)))) + (t (make-n-ary-x86-lap-expression :operator op :operands (mapcar #'parse-x86-lap-expression args))))) + (multiple-value-bind (value condition) + (ignore-errors + (eval (if (atom form) + form + (cons (car form) + (mapcar #'(lambda (x) + (if (typep x 'constant-x86-lap-expression) + (constant-x86-lap-expression-value + x) + x)) + (cdr form)))))) + (if condition + (error "~a signaled during assembly-time evaluation of form ~s" condition form) + value #|(make-constant-x86-lap-expression :value value)|#))))))) + +(defun parse-x86-register-operand (regname designator) + (let* ((r (lookup-x86-register regname designator))) + (if r + (x86::make-x86-register-operand :type (logandc2 (x86::reg-entry-reg-type r) + (x86::encode-operand-type :baseIndex)) + :entry r) + (error "Unknown X86 register ~s" regname)))) + +(defun parse-x86-label-reference (name) + (let* ((lab (find-or-create-x86-lap-label name))) + (x86::make-x86-label-operand :type (x86::encode-operand-type :label) + :label lab))) + + + +(defun x86-register-designator (form) + (when (and (consp form) + (symbolp (car form))) + (let* ((sym (car form))) + (cond ((string= sym '%) :%) + ((string= sym '%b) :%b) + ((string= sym '%w) :%w) + ((string= sym '%l) :%l) + ((string= sym '%q) :%q))))) + + +;;; Syntax is: +;;; ([seg] [disp] [base] [index] [scale]) +;;; A [seg] by itself isn't too meaningful; the same is true +;;; of a few other combinations. +(defun parse-x86-memory-operand (form) + (flet ((register-operand-p (form) + (let* ((designator (x86-register-designator form))) + (when designator + (destructuring-bind (regname) (cdr form) + (or (lookup-x86-register regname designator) + (error "Unknown register ~s" regname))))))) + (let* ((seg nil) + (disp nil) + (base nil) + (index nil) + (scale nil)) + (do* ((f form (cdr f))) + ((null f) + (if (or disp base index) + (progn + ;;(check-base-and-index-regs instruction base index) + (x86::make-x86-memory-operand + :type (if (or base index) + (if disp + (logior (optimize-displacement-type disp) + (x86::encode-operand-type :baseindex)) + (x86::encode-operand-type :baseindex)) + (optimize-displacement-type disp)) + :seg seg + :disp disp + :base base + :index index + :scale scale)) + (error "No displacement, base, or index in ~s" form))) + (let* ((head (car f)) + (r (register-operand-p head))) + (if r + (if (logtest (x86::reg-entry-reg-type r) + (x86::encode-operand-type :sreg2 :sreg3)) + ;; A segment register - if present - must be first + (if (eq f form) + (setq seg (svref x86::*x86-seg-entries* (x86::reg-entry-reg-num r))) + (error "Segment register ~s not valid in ~s" head form)) + ;; Some other register. Assume base if this is the + ;; first gpr. If we find only one gpr and a significant + ;; scale factor, make that single gpr be the index. + (if base + (if index + (error "Extra register ~s in memory address ~s" head form) + (setq index r)) + (setq base r))) + ;; Not a register, so head is either a displacement or + ;; a scale factor. + (if (and (null (cdr f)) + (or disp base index)) + (let* ((exp (parse-x86-lap-expression head)) + (val (if (or (typep exp 'constant-x86-lap-expression) + (not (x86-lap-expression-p exp))) + (x86-lap-expression-value exp)))) + (case val + ((1 2 4 8) + (if (and base (not index)) + (setq index base base nil)) + (setq scale (1- (integer-length val)))) + (t + (error "Invalid scale factor ~s in ~s" head form)))) + (if (not (or disp base index)) + (setq disp (parse-x86-lap-expression head)) + (error "~&~s not expected in ~s" head form))))))))) + + + + +;;; Operand syntax: +;;; (% x) -> register +;;; ($ x) -> immediate +;;; (@ x) -> memory operand +;;; (:rcontext x) -> memory operand, using segment register or gpr +;;; (:self fn) -> self-reference +;;; x -> labelref +(defun parse-x86-operand (form) + (if (consp form) + (let* ((head (car form)) + (designator nil)) + (if (symbolp head) + (cond ((string= head '$) + (destructuring-bind (immval) (cdr form) + (let* ((expr (parse-x86-lap-expression immval)) + (val (early-x86-lap-expression-value expr)) + (type (if val + (smallest-imm-type val) + (x86::encode-operand-type :imm32s)))) + ;; special case + (when (eq val :self) + (setq type (x86::encode-operand-type :self))) + (x86::make-x86-immediate-operand :type type + :value expr)))) + ((eq head :rcontext) + (if (>= (backend-lisp-context-register *target-backend*) + (target-arch-case + (:x8632 x86::+x8632-segment-register-offset+) + (:x8664 x86::+x8664-segment-register-offset+))) + (parse-x86-memory-operand `((% :rcontext) ,(cadr form))) + (parse-x86-memory-operand `(,(cadr form) (% :rcontext))))) + ((setq designator (x86-register-designator form)) + (destructuring-bind (reg) (cdr form) + (parse-x86-register-operand reg designator))) + ((string= head '@) + (parse-x86-memory-operand (cdr form))) + (t (error "unknown X86 operand: ~s" form))) + (error "unknown X86 operand: ~s" form))) + ;; Treat an atom as a label. + (parse-x86-label-reference form))) + + + + +;;; Initialize some fields in the instruction from the template; +;;; set other fields (which depend on operand values) to NIL. +(defun set-x86-instruction-template (i template) + (setf (x86::x86-instruction-opcode-template i) template + (x86::x86-instruction-base-opcode i) (x86::x86-opcode-template-base-opcode template) + (x86::x86-instruction-modrm-byte i) (x86::x86-opcode-template-modrm-byte template) + (x86::x86-instruction-rex-prefix i) (target-arch-case + (:x8632 nil) + (:x8664 + (x86::x86-opcode-template-rex-prefix template))) + (x86::x86-instruction-sib-byte i) nil + (x86::x86-instruction-seg-prefix i) nil + (x86::x86-instruction-disp i) nil + (x86::x86-instruction-imm i) nil + (x86::x86-instruction-extra i) nil)) + + +(defun init-x86-instruction (instruction template parsed-operands) + (set-x86-instruction-template instruction template) + (let* ((insert-classes (x86::x86-opcode-template-operand-classes template)) + (insert-functions x86::*x86-operand-insert-functions*)) + (dotimes (i (length parsed-operands) instruction) + (funcall (svref insert-functions (svref insert-classes i)) + instruction + (pop parsed-operands))))) + + + +(defun smallest-imm-type (val) + (if (eql val 1) + (x86::encode-operand-type :Imm1 :Imm8 :Imm8S :Imm16 :Imm32 :Imm32S :Imm64) + (typecase val + ((signed-byte 8) + (x86::encode-operand-type :Imm8S :imm8 :Imm16 :Imm32 :Imm32S :Imm64)) + ((unsigned-byte 8) + (x86::encode-operand-type :imm8 :Imm16 :Imm32 :Imm32S :Imm64)) + ((signed-byte 16) + (x86::encode-operand-type :Imm16 :Imm32 :Imm32S :Imm64)) + ((unsigned-byte 16) + (x86::encode-operand-type :Imm16 :Imm32 :Imm32S :Imm64)) + ((signed-byte 32) + (x86::encode-operand-type :Imm32 :Imm32S :Imm64)) + ((unsigned-byte 32) + (x86::encode-operand-type :Imm32 :Imm64)) + (t (x86::encode-operand-type :Imm64))))) + + +(defun x86-optimize-imm (operands suffix) + (unless suffix + ;; See if we can determine an implied suffix from operands. + (do* ((i (1- (length operands)) (1- i))) + ((< i 0)) + (declare (fixnum i)) + (let* ((op (svref operands i)) + (optype (x86::x86-operand-type op))) + (when (logtest optype (x86::encode-operand-type :reg)) + (cond ((logtest optype (x86::encode-operand-type :reg8)) + (setq suffix #\b)) + ((logtest optype (x86::encode-operand-type :reg16)) + (setq suffix #\w)) + ((logtest optype (x86::encode-operand-type :reg32)) + (setq suffix #\l)) + ((logtest optype (x86::encode-operand-type :reg64)) + (setq suffix #\q))) + (return))))) + (dotimes (i (length operands)) + (let* ((op (svref operands i)) + (optype (x86::x86-operand-type op))) + (when (logtest optype (x86::encode-operand-type :imm)) + (let* ((val (x86::x86-immediate-operand-value op))) + (cond ((typep val 'constant-x86-lap-expression) + (case suffix + (#\l (setf (x86::x86-operand-type op) + (logior optype (x86::encode-operand-type + :imm32 :imm64)))) + (#\w (setf (x86::x86-operand-type op) + (logior optype (x86::encode-operand-type + :imm16 :imm32S :imm32 :imm64)))) + (#\b (setf (x86::x86-operand-type op) + (logior optype (x86::encode-operand-type + :imm8 :imm16 :imm32S :imm32 :imm64))))) + (setf (x86::x86-operand-type op) + (logior (x86::x86-operand-type op) + (smallest-imm-type (x86-lap-expression-value val)))) + (when (eql suffix #\q) + (setf (x86::x86-operand-type op) + (logandc2 (x86::x86-operand-type op) + (x86::encode-operand-type :imm32))))) + (t ; immediate value not constant + (case suffix + (#\q (setf (x86::x86-operand-type op) + (logior optype + (x86::encode-operand-type :imm64 :imm32S)))) + (#\l (setf (x86::x86-operand-type op) + (logior optype + (x86::encode-operand-type :imm32)))) + (#\w (setf (x86::x86-operand-type op) + (logior optype + (x86::encode-operand-type :imm16)))) + (#\b (setf (x86::x86-operand-type op) + (logior optype + (x86::encode-operand-type :imm8)))))))))))) + +(defun get-x86-opcode-templates (form) + (let* ((name (string (car form)))) + (or + (gethash name x86::*x86-opcode-template-lists*) + ;; Try to determine a suffix, based on the size of the last + ;; register argument (if any.) If that can be determined, + ;; tack it on to the end of NAME and try again. + (let* ((suffix nil)) + (dolist (arg (cdr form)) + (let* ((designator (x86-register-designator arg))) + (when designator + (destructuring-bind (regname) (cdr arg) + (let* ((reg (lookup-x86-register regname designator))) + (when reg + (let* ((type (x86::reg-entry-reg-type reg))) + (cond ((logtest type (x86::encode-operand-type :reg8)) + (setq suffix #\b)) + ((logtest type (x86::encode-operand-type :reg16)) + (setq suffix #\w)) + ((logtest type (x86::encode-operand-type :reg32)) + (setq suffix #\l)) + ((logtest type (x86::encode-operand-type :reg64)) + (setq suffix #\q)))))))))) + (when suffix + (let* ((n (length name)) + (m (1+ n)) + (s (make-string m))) + (declare (fixnum n m) (dynamic-extent s)) + (dotimes (i n) (setf (schar s i) (char name i))) + (setf (schar s n) suffix) + (gethash s x86::*x86-opcode-template-lists*))))))) + + + + + +;;; FORM is a list; its car doesn't name a macro or pseudo op. If we +;;; can find a matching opcode template, initialize the +;;; x86-instruction with that template and these operands. +;;; Note that this doesn't handle "prefix" instructions at all. +;;; Things that would change the operand or address size are +;;; of limited utility, as are REP* prefixes on string instructions +;;; (because of the way that the lisp used %[E|R]DI and %[E|R]SI). +;;; LOCK can be used in the preceding instruction. +(defun parse-x86-instruction (form instruction) + (let* ((templates (or + (get-x86-opcode-templates form) + (error "Unknown X86 instruction ~s" form))) + (operands (cdr form))) + (let* ((parsed-operands (if operands + (mapcar #'parse-x86-operand operands))) + (operand-types (mapcar #'x86::x86-operand-type parsed-operands)) + (type0 (pop operand-types)) + (type1 (pop operand-types)) + (type2 (car operand-types))) + + ;; (x86-optimize-imm parsed-operands suffix) + (dolist (template templates (error "Operands or suffix invalid in ~s" form)) + (when (x86::match-template-types template type0 type1 type2) + (init-x86-instruction instruction template parsed-operands) + ;(check-suffix instruction form) + ;(x86-finalize-operand-types instruction) + (return instruction)))))) + + + + + +;;; xxx - might want to omit disp64 when doing 32 bit code +(defun optimize-displacement-type (disp) + (if disp + (let* ((value (early-x86-lap-expression-value disp))) + (if value + (if (typep value '(signed-byte 8)) + (x86::encode-operand-type :disp8 :disp32 :disp32s :disp64) + (if (typep value '(signed-byte 32)) + (x86::encode-operand-type :disp32s :disp64) + (if (typep value '(unsigned-byte 32)) + (x86::encode-operand-type :disp32 :disp64) + (x86::encode-operand-type :disp64)))) + (x86::encode-operand-type :disp32s :disp64))) + 0)) + +(defun optimize-displacements (operands) + (dotimes (i (length operands)) + (let* ((op (svref operands i))) + (when (typep op 'x86::x86-memory-operand) + (let* ((disp (x86::x86-memory-operand-disp op)) + (val (if disp (early-x86-lap-expression-value disp)))) + (if (typep val '(signed-byte 32)) + (setf (x86::x86-operand-type op) + (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32s)))) + (if (typep val '(unsigned-byte 32)) + (setf (x86::x86-operand-type op) + (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32)))) + (if (and (logtest (x86::x86-operand-type op) + (x86::encode-operand-type :disp32 :disp32S :disp16)) + (typep val '(signed-byte 8))) + (setf (x86::x86-operand-type op) + (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp8))))))))) + +(defun x86-output-branch (frag-list insn) + (dolist (b (x86::x86-opcode-template-prefixes + (x86::x86-instruction-opcode-template insn))) + (when (or (= b x86::+data-prefix-opcode+) + (= b x86::+cs-prefix-opcode+) + (= b x86::+ds-prefix-opcode+)) + (frag-list-push-byte frag-list b))) + (finish-frag-for-branch frag-list + (x86::x86-instruction-base-opcode insn) + (x86::x86-instruction-extra insn))) + +(defun x86-generate-instruction-code (frag-list insn) + (let* ((template (x86::x86-instruction-opcode-template insn)) + (flags (x86::x86-opcode-template-flags template)) + (prefixes (x86::x86-opcode-template-prefixes template))) + (let* ((explicit-seg-prefix (x86::x86-instruction-seg-prefix insn))) + (when explicit-seg-prefix + (push explicit-seg-prefix prefixes))) + (cond + ((logtest (x86::encode-opcode-flags :jump) flags) + ;; a variable-length pc-relative branch, possibly preceded + ;; by prefixes (used for branch prediction, mostly.) + (x86-output-branch frag-list insn)) + (t + (let* ((base-opcode (x86::x86-instruction-base-opcode insn))) + (declare (fixnum base-opcode)) + (dolist (b prefixes) + (frag-list-push-byte frag-list b)) + (let* ((rex-bits (logand #x8f + (or (x86::x86-instruction-rex-prefix insn) + 0)))) + (declare (fixnum rex-bits)) + (unless (= 0 rex-bits) + (frag-list-push-byte frag-list (logior #x40 (logand rex-bits #xf))))) + (when (logtest base-opcode #xff00) + (frag-list-push-byte frag-list (ldb (byte 8 8) base-opcode))) + (frag-list-push-byte frag-list (ldb (byte 8 0) base-opcode))) + (let* ((modrm (x86::x86-instruction-modrm-byte insn))) + (when modrm + (frag-list-push-byte frag-list modrm) + (let* ((sib (x86::x86-instruction-sib-byte insn))) + (when sib + (frag-list-push-byte frag-list sib))))) + (let* ((operands (x86::x86-opcode-template-operand-types template))) + (if (and (= (length operands) 1) + (= (x86::encode-operand-type :label) (aref operands 0))) + (let* ((label (x86::x86-instruction-extra insn)) + (frag (frag-list-current frag-list)) + (pos (frag-list-position frag-list))) + (push (make-reloc :type :branch32 + :arg label + :frag frag + :pos pos) + (frag-relocs frag)) + (frag-list-push-32 frag-list 0)) + (let* ((disp (x86::x86-instruction-disp insn))) + (when disp + (let* ((optype (x86::x86-instruction-extra insn)) + (pcrel (and (logtest (x86::encode-operand-type :label) optype) + (typep disp 'label-x86-lap-expression))) + (val (unless pcrel (early-x86-lap-expression-value disp)))) + (if (null val) + ;; We can do better job here, but (for now) + ;; generate a 32-bit relocation + (let* ((frag (frag-list-current frag-list)) + (pos (frag-list-position frag-list))) + (push (make-reloc :type (if pcrel :branch32 :expr32) + :arg (if pcrel (label-x86-lap-expression-label disp) disp) + :frag frag + :pos pos) + (frag-relocs frag)) + (frag-list-push-32 frag-list 0)) + (if (logtest optype (x86::encode-operand-type :disp8)) + (frag-list-push-byte frag-list (logand val #xff)) + (if (logtest optype (x86::encode-operand-type :disp32 :disp32s)) + (frag-list-push-32 frag-list val) + (frag-list-push-64 frag-list val))))))))) + ;; Emit immediate operand(s). + (let* ((op (x86::x86-instruction-imm insn))) + (when op + (let* ((optype (x86::x86-operand-type op)) + (expr (x86::x86-immediate-operand-value op)) + (val (early-x86-lap-expression-value expr))) + (if (null val) + (let* ((frag (frag-list-current frag-list)) + (pos (frag-list-position frag-list)) + (size 4) + (reloctype :expr32)) + (when (logtest optype + (x86::encode-operand-type + :imm8 :imm8S :imm16 :imm64)) + (setq size 2 reloctype :expr16) + (if (logtest optype (x86::encode-operand-type + :imm8 :imm8s)) + (setq size 1 reloctype :expr8) + (if (logtest optype (x86::encode-operand-type :imm64)) + (setq size 8 reloctype :expr64)))) + (push (make-reloc :type reloctype + :arg expr + :frag frag + :pos pos) + (frag-relocs frag)) + (dotimes (b size) + (frag-list-push-byte frag-list 0))) + (if (logtest optype (x86::encode-operand-type :imm8 :imm8s)) + (frag-list-push-byte frag-list (logand val #xff)) + (if (logtest optype (x86::encode-operand-type :imm16)) + (frag-list-push-16 frag-list (logand val #xffff)) + (if (logtest optype (x86::encode-operand-type :imm64)) + (frag-list-push-64 frag-list val) + ;; magic value denoting function object's + ;; actual runtime address + (if (logtest optype (x86::encode-operand-type :self)) + (let* ((frag (frag-list-current frag-list)) + (pos (frag-list-position frag-list))) + (frag-list-push-32 frag-list 0) + (push (make-reloc :type :self + :arg 0 + :frag frag + :pos pos) + (frag-relocs frag))) + (frag-list-push-32 frag-list val))))))))))) + (let* ((frag (frag-list-current frag-list))) + (if (eq (car (frag-type frag)) :pending-talign) + (finish-pending-talign-frag frag-list))))) + +;;; Returns the active frag list after processing directive(s). +(defun x86-lap-directive (frag-list directive arg &optional main-frag-list exception-frag-list) + (declare (ignorable main-frag-list exception-frag-list)) + (case directive + (:tra + (finish-frag-for-align frag-list 3) + (x86-lap-directive frag-list :long `(:^ ,arg)) + (emit-x86-lap-label frag-list arg)) + (:fixed-constants + (dolist (constant arg) + (ensure-x86-lap-constant-label constant))) + (:arglist (setq *x86-lap-lfun-bits* (encode-lambda-list arg))) + ((:uuo :uuo-section) + (if exception-frag-list + (progn + (setq frag-list exception-frag-list) + (finish-frag-for-align frag-list 2)))) + ((:main :main-section) + (when main-frag-list (setq frag-list main-frag-list))) + (:anchored-uuo-section + (setq frag-list (x86-lap-directive frag-list :uuo-section nil main-frag-list exception-frag-list)) + (setq frag-list (x86-lap-directive frag-list :long `(:^ ,arg) main-frag-list exception-frag-list))) + (t (let* ((exp (parse-x86-lap-expression arg)) + (constantp (or (constant-x86-lap-expression-p exp) + (not (x86-lap-expression-p exp))))) + + (if constantp + (let* ((val (x86-lap-expression-value exp))) + (ecase directive + (:code-size + (if *x86-lap-fixed-code-words* + (error "Duplicate :CODE-SIZE directive") + (setq *x86-lap-fixed-code-words* val))) + (:byte (frag-list-push-byte frag-list val)) + (:short (frag-list-push-16 frag-list val)) + (:long (frag-list-push-32 frag-list val)) + (:quad (frag-list-push-64 frag-list val)) + (:align (finish-frag-for-align frag-list val)) + (:talign (finish-frag-for-talign frag-list val)) + (:org (finish-frag-for-org frag-list val)))) + (let* ((pos (frag-list-position frag-list)) + (frag (frag-list-current frag-list)) + (reloctype nil)) + (ecase directive + (:byte (frag-list-push-byte frag-list 0) + (setq reloctype :expr8)) + (:short (frag-list-push-16 frag-list 0) + (setq reloctype :expr16)) + (:long (frag-list-push-32 frag-list 0) + (setq reloctype :expr32)) + (:quad (frag-list-push-64 frag-list 0) + (setq reloctype :expr64)) + (:align (error ":align expression ~s not constant" arg)) + (:talign (error ":talign expression ~s not constant" arg))) + (when reloctype + (push + (make-reloc :type reloctype + :arg exp + :pos pos + :frag frag) + (frag-relocs frag)))))))) + frag-list) + + +(defun x862-lap-process-regsave-info (frag-list regsave-label regsave-mask regsave-addr) + (when regsave-label + (let* ((label-diff (min (- (x86-lap-label-address regsave-label) + *x86-lap-entry-offset*) + 255)) + (first-frag (frag-list-succ frag-list))) + (setf (frag-ref first-frag 4) label-diff + (frag-ref first-frag 5) regsave-addr + (frag-ref first-frag 6) regsave-mask)) + t)) + + + +(defun x86-lap-form (form frag-list instruction main-frag-list exception-frag-list) + (if (and form (symbolp form)) + (emit-x86-lap-label frag-list form) + (if (or (atom form) (not (symbolp (car form)))) + (error "Unknown X86-LAP form ~s ." form) + (multiple-value-bind (expansion expanded) + (x86-lap-macroexpand-1 form) + (if expanded + (x86-lap-form expansion frag-list instruction main-frag-list exception-frag-list) + (if (typep (car form) 'keyword) + (destructuring-bind (op &optional arg) form + (setq frag-list (x86-lap-directive frag-list op arg main-frag-list exception-frag-list))) + (case (car form) + (progn + (dolist (f (cdr form)) + (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))) + (let + (destructuring-bind (equates &body body) + (cdr form) + (setq frag-list (x86-lap-equate-form equates frag-list instruction body main-frag-list exception-frag-list)))) + (t + (parse-x86-instruction form instruction) + (x86-generate-instruction-code frag-list instruction)))))))) + frag-list) + +(defun relax-align (address bits) + (let* ((mask (1- (ash 1 bits)))) + (- (logandc2 (+ address mask) mask) address))) + +(defun relax-talign (address mask) + (do* ((i 0 (1+ i))) + ((= (logand address 7) mask) i) + (incf address))) + + +(defun relax-frag-list (frag-list) + ;; First, assign tentative addresses to all frags, assuming that + ;; span-dependent instructions have short displacements. + ;; While doing that, find branches to the next instruction and + ;; remove them. In some cases, that'll cause the containing + ;; frag to become empty; that could introduce branches to the + ;; next instruction, so we repeat this process until we can + ;; make it all the way through the frag-list. + (loop + (let* ((address (target-arch-case (:x8632 4) (:x8664 8)))) ;after header + (declare (fixnum address)) + (when (do-dll-nodes (frag frag-list t) + (setf (frag-address frag) address) + (incf address (frag-length frag)) + (case (car (frag-type frag)) + (:org + ;; Do nothing, for now + ) + (:align + (incf address (relax-align address (cadr (frag-type frag))))) + (:talign + (let* ((arg (cadr (frag-type frag)))) + (if (null arg) + ;;; Never generated code in :pending-talign frag + (setf (frag-type frag) nil) + (incf address (relax-talign address arg))))) + ((:assumed-short-branch :assumed-short-conditional-branch) + (destructuring-bind (label pos reloc) (cdr (frag-type frag)) + (let* ((next (frag-succ frag))) + (when (and (eq (x86-lap-label-frag label) next) + (eql (x86-lap-label-offset label) 0)) + ;; Delete the reloc associated with this branch. + (setf (frag-relocs frag) + (delete reloc (frag-relocs frag))) + ;; This will be a "normal" frag + (setf (frag-type frag) nil) + ;; Remove the (short) branch, and remove the frag + ;; if it becomes empty. If the frag does become + ;; empty, migrate any labels to the next frag. + (when (zerop (setf (frag-length frag) + (1- pos))) + + (do* ((labels (frag-labels frag))) + ((null labels)) + (let* ((lab (pop labels))) + (setf (x86-lap-label-frag lab) next + (x86-lap-label-offset lab) 0) + (push lab (frag-labels next)))) + (remove-dll-node frag)) + (return nil))))))) + (return)))) + ;; Repeatedly "stretch" frags containing span-dependent instructions + ;; until nothing's stretched. It may take several iterations to + ;; converge; is convergence guaranteed ? + (loop + (let* ((stretch 0) ;cumulative growth in frag sizes + (stretched nil)) ;any change on this pass ? + (do-dll-nodes (frag frag-list) + (let* ((growth 0) + (fragtype (frag-type frag)) + (was-address (frag-address frag)) + (address (incf (frag-address frag) stretch))) + (case (car fragtype) + (:org + (let* ((target (cadr (frag-type frag))) + (next-address (frag-address (frag-succ frag)))) + (setq growth (- target next-address)) + (if (< growth 0) + (error "Code size exceeds :CODE-SIZE constraint ~s" + (ash target -3)) + (decf growth stretch)))) + (:align + (let* ((bits (cadr fragtype)) + (len (frag-length frag)) + (oldoff (relax-align (+ was-address len) bits)) + (newoff (relax-align (+ address len) bits))) + (setq growth (- newoff oldoff)))) + (:talign + (let* ((arg (cadr fragtype)) + (len (frag-length frag)) + (oldoff (relax-talign (+ was-address len) arg)) + (newoff (relax-talign (+ address len) arg))) + (setq growth (- newoff oldoff)))) + ;; If we discover - on any iteration - that a short + ;; branch doesn't fit, we change the type (and the reloc) + ;; destructively to a wide branch indicator and will + ;; never change our minds about that, so we only have + ;; to look here at conditional branches that may still + ;; be able to use a 1-byte displacement. + ((:assumed-short-branch :assumed-short-conditional-branch) + (destructuring-bind (label pos reloc) (cdr (frag-type frag)) + (declare (fixnum pos)) + (let* ((label-address (x86-lap-label-address label)) + (branch-pos (+ address (1+ pos))) + (diff (- label-address branch-pos))) + (unless (typep diff '(signed-byte 8)) + (cond ((eq (car fragtype) :assumed-short-branch) + ;; replace the opcode byte + (setf (frag-ref frag (the fixnum (1- pos))) + x86::+jump-pc-relative+) + (frag-push-byte frag 0) + (frag-push-byte frag 0) + (frag-push-byte frag 0) + (setf (reloc-type reloc) :branch32) + (setf (car fragtype) :long-branch) + (setq growth 3)) + (t + ;; Conditional branch: must change + ;; 1-byte opcode to 2 bytes, add 4-byte + ;; displacement + (let* ((old-opcode (frag-ref frag (1- pos)))) + (setf (frag-ref frag (1- pos)) #x0f + (frag-ref frag pos) (+ old-opcode #x10)) + (frag-push-byte frag 0) + (frag-push-byte frag 0) + (frag-push-byte frag 0) + (frag-push-byte frag 0) + (setf (reloc-type reloc) :branch32 + (reloc-pos reloc) (1+ pos)) + (setf (car fragtype) :long-conditional-branch + (caddr fragtype) (1+ pos)) + (setq growth 4))))))))) + (unless (eql 0 growth) + (incf stretch growth) + (setq stretched t)))) + (unless stretched (return))))) + +(defun apply-relocs (frag-list) + (flet ((emit-byte (frag pos b) + (setf (frag-ref frag pos) (logand b #xff)))) + (flet ((emit-short (frag pos s) + (setf (frag-ref frag pos) (ldb (byte 8 0) s) + (frag-ref frag (1+ pos)) (ldb (byte 8 8) s)))) + (flet ((emit-long (frag pos l) + (emit-short frag pos (ldb (byte 16 0) l)) + (emit-short frag (+ pos 2) (ldb (byte 16 16) l)))) + (flet ((emit-quad (frag pos q) + (emit-long frag pos (ldb (byte 32 0) q)) + (emit-long frag (+ pos 4) (ldb (byte 32 32) q)))) + (do-dll-nodes (frag frag-list) + (let* ((address (frag-address frag))) + (dolist (reloc (frag-relocs frag)) + (let* ((pos (reloc-pos reloc)) + (arg (reloc-arg reloc))) + (ecase (reloc-type reloc) + (:branch8 (let* ((target (x86-lap-label-address arg)) + (refpos (+ address (1+ pos)))) + (emit-byte frag pos (- target refpos)))) + (:branch32 (let* ((target (x86-lap-label-address arg)) + (refpos (+ address pos 4))) + (emit-long frag pos (- target refpos)))) + (:expr8 (emit-byte frag pos (x86-lap-expression-value arg))) + (:expr16 (emit-short frag pos (x86-lap-expression-value arg))) + (:expr32 (emit-long frag pos (x86-lap-expression-value arg))) + (:expr64 (emit-quad frag pos (x86-lap-expression-value arg))) + (:self (emit-long frag pos (x86-lap-expression-value arg))))))))))))) + +(defstatic *x86-32-bit-lap-nops* + #( + #() + #(#x90) ; nop + #(#x89 #xf6) ; movl %esi,%esi + #(#x8d #x76 #x00) ; leal 0(%esi),%esi + #(#x8d #x74 #x26 #x00) ; leal 0(%esi,1),%esi + #(#x90 #x8d #x74 #x26 #x00) ; nop ; leal 0(%esi,1),%esi + #(#x8d #xb6 #x00 #x00 #x00 #x00) ; leal 0L(%esi),%esi + #(#x8d #xb4 #x26 #x00 #x00 #x00 #x00) ; leal 0L(%esi,1),%esi + ) + "Allegedly, many implementations recognize these instructions and +execute them very quickly.") + +(defstatic *x86-32-bit-lap-nops-8* + #(#x90 #x8d #xb4 #x26 #x00 #x00 #x00 #x00)) + +(defun frag-emit-nops (frag count) + (target-word-size-case + (32 + (do* ((c count (- c 8))) + ((< c 8) + (let* ((v (svref *x86-32-bit-lap-nops* c))) + (dotimes (i c) + (frag-push-byte frag (svref v i))))) + (dotimes (i 8) + (frag-push-byte frag (svref *x86-32-bit-lap-nops-8* i))))) + (64 + (let* ((nnops (ash (+ count 3) -2)) + (len (floor count nnops)) + (remains (- count (* nnops len)))) + (dotimes (i remains) + (dotimes (k len) (frag-push-byte frag #x66)) + (frag-push-byte frag #x90)) + (do* ((i remains (1+ i))) + ((= i nnops)) + (dotimes (k (1- len)) (frag-push-byte frag #x66)) + (frag-push-byte frag #x90)))))) + +(defun fill-for-alignment (frag-list) + (ccl::do-dll-nodes (frag frag-list) + (let* ((next (ccl::dll-node-succ frag))) + (unless (eq next frag-list) + (let* ((addr (frag-address frag)) + (nextaddr (frag-address next)) + (pad (- nextaddr (+ addr (frag-length frag))))) + (unless (eql 0 pad) + (frag-emit-nops frag pad))))))) + +(defun show-frag-bytes (frag-list) + (ccl::do-dll-nodes (frag frag-list) + (format t "~& frag at #x~x" (frag-address frag)) + (dotimes (i (frag-length frag)) + (unless (logtest 15 i) + (format t "~&")) + (format t "~2,'0x " (frag-ref frag i))))) + +(defun x86-lap-equate-form (eqlist fraglist instruction body main-frag exception-frag) + (let* ((symbols (mapcar #'(lambda (x) + (let* ((name (car x))) + (or + (and name + (symbolp name) + (not (constant-symbol-p name)) + (or (not (gethash (string name) + (target-arch-case + (:x8632 x86::*x8632-registers*) + (:x8664 x86::*x8664-registers*)))) + (error "Symbol ~s already names an x86 register" name)) + name) + (error + "~S is not a bindable symbol name ." name)))) + eqlist)) + (values (mapcar #'(lambda (x) (x86-register-ordinal-or-expression + (cadr x))) + eqlist))) + (progv symbols values + (dolist (form body fraglist) + (setq fraglist (x86-lap-form form fraglist instruction main-frag exception-frag)))))) + +(defun cross-create-x86-function (name frag-list constants bits debug-info) + (let* ((constants-vector (%alloc-misc (+ (length constants) + (+ 2 + (if name 1 0) + (if debug-info 1 0))) + target::subtag-xfunction))) + (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit)))) + (let* ((last (1- (uvsize constants-vector)))) + (declare (fixnum last)) + (setf (uvref constants-vector last) bits) + (when name + (setf (uvref constants-vector (decf last)) name)) + (when debug-info + (setf (uvref constants-vector (decf last)) debug-info)) + (dolist (c constants) + (setf (uvref constants-vector (decf last)) (car c))) + (let* ((nbytes 0)) + (do-dll-nodes (frag frag-list) + (incf nbytes (frag-length frag))) + #+x8632-target + (when (>= nbytes (ash 1 18)) (compiler-function-overflow)) + (let* ((code-vector (make-array nbytes + :element-type '(unsigned-byte 8))) + (target-offset 0)) + (declare (fixnum target-offset)) + (setf (uvref constants-vector 0) code-vector) + (do-dll-nodes (frag frag-list) + (incf target-offset (frag-output-bytes frag code-vector target-offset))) + constants-vector))))) + +#+x86-target +(defun create-x86-function (name frag-list constants bits debug-info) + (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit)))) + (let* ((code-bytes (let* ((nbytes 0)) + (do-dll-nodes (frag frag-list nbytes) + (incf nbytes (frag-length frag))))) + (code-words (ash code-bytes (- target::word-shift))) + (function-vector (allocate-typed-vector :function code-words)) + (nconstants (length constants))) + (declare (fixnum code-bytes code-words)) + (when name (incf nconstants)) + (when debug-info (incf nconstants)) + (incf nconstants) + + #+x8632-target + (let* ((ncode (- code-words nconstants))) + (when (>= ncode #x8000) + (if (>= nconstants #x8000) + (compiler-function-overflow) + (let* ((buf (car (frag-code-buffer (dll-header-first frag-list)))) + (new-word (logior #x8000 nconstants))) + (setf (aref buf 0) (ldb (byte 8 0) new-word) + (aref buf 1) (ldb (byte 8 8) new-word)))))) + (let* ((target-offset 0)) + (declare (fixnum target-offset)) + (do-dll-nodes (frag frag-list) + (incf target-offset (frag-output-bytes frag function-vector target-offset)))) + (let* ((last (1- (uvsize function-vector)))) + (declare (fixnum last)) + (setf (uvref function-vector last) bits) + (when name + (setf (uvref function-vector (decf last)) name)) + (when debug-info + (setf (uvref function-vector (decf last)) debug-info)) + (dolist (c constants) + (setf (uvref function-vector (decf last)) (car c))) + #+x8632-target + (%update-self-references function-vector) + (function-vector-to-function function-vector)))) + +(defun %define-x86-lap-function (name forms &optional (bits 0)) + (target-arch-case + (:x8632 + (%define-x8632-lap-function name forms bits)) + (:x8664 + (%define-x8664-lap-function name forms bits)))) + +(defun %define-x8664-lap-function (name forms &optional (bits 0)) + (let* ((*x86-lap-labels* ()) + (*x86-lap-constants* ()) + (*x86-lap-entry-offset* x8664::fulltag-function) + (*x86-lap-fixed-code-words* nil) + (*x86-lap-lfun-bits* bits) + (end-code-tag (gensym)) + (entry-code-tag (gensym)) + (instruction (x86::make-x86-instruction)) + (main-frag-list (make-frag-list)) + (exception-frag-list (make-frag-list)) + (frag-list main-frag-list)) + (make-x86-lap-label end-code-tag) + (make-x86-lap-label entry-code-tag) + (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8) + *x86-lap-entry-offset*) -3)) + (x86-lap-directive frag-list :byte 0) ;regsave pc + (x86-lap-directive frag-list :byte 0) ;regsave ea + (x86-lap-directive frag-list :byte 0) ;regsave mask + (emit-x86-lap-label frag-list entry-code-tag) + + (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list) + (dolist (f forms) + (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))) + (setq frag-list main-frag-list) + (merge-dll-nodes frag-list exception-frag-list) + (x86-lap-directive frag-list :align 3) + (when *x86-lap-fixed-code-words* + (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 3))) + (x86-lap-directive frag-list :quad x8664::function-boundary-marker) + (emit-x86-lap-label frag-list end-code-tag) + (dolist (c (reverse *x86-lap-constants*)) + (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c))) + (x86-lap-directive frag-list :quad 0)) + (when name + (x86-lap-directive frag-list :quad 0)) + ;; room for lfun-bits + (x86-lap-directive frag-list :quad 0) + (relax-frag-list frag-list) + (apply-relocs frag-list) + (fill-for-alignment frag-list) + ;;(show-frag-bytes frag-list) + (funcall #-x86-target #'cross-create-x86-function + #+x86-target (if (eq *target-backend* *host-backend*) + #'create-x86-function + #'cross-create-x86-function) + name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil))) + +(defun %define-x8632-lap-function (name forms &optional (bits 0)) + (let* ((*x86-lap-labels* ()) + (*x86-lap-constants* ()) + (*x86-lap-entry-offset* x8632::fulltag-misc) + (*x86-lap-fixed-code-words* nil) + (*x86-lap-lfun-bits* bits) + (srt-tag (gensym)) + (end-code-tag (gensym)) + (entry-code-tag (gensym)) + (instruction (x86::make-x86-instruction)) + (main-frag-list (make-frag-list)) + (exception-frag-list (make-frag-list)) + (frag-list main-frag-list)) + (make-x86-lap-label entry-code-tag) + (make-x86-lap-label srt-tag) + (make-x86-lap-label end-code-tag) + ;; count of 32-bit words from header to function boundary + ;; marker, inclusive. + (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4) + *x86-lap-entry-offset*) -2)) + (emit-x86-lap-label frag-list entry-code-tag) + (x86-lap-form '(movl ($ :self) (% x8632::fn)) frag-list instruction main-frag-list exception-frag-list) + (dolist (f forms) + (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))) + (setq frag-list main-frag-list) + (merge-dll-nodes frag-list exception-frag-list) + (x86-lap-directive frag-list :align 2) + (when *x86-lap-fixed-code-words* + ;; We have a code-size that we're trying to get to. We need to + ;; include the self-reference table in the code-size, so decrement + ;; the size of the padding we would otherwise insert by the srt size. + (let ((srt-words 1)) ;for zero between end of code and srt + (do-dll-nodes (frag frag-list) + (dolist (reloc (frag-relocs frag)) + (when (eq (reloc-type reloc) :self) + (incf srt-words)))) + (decf *x86-lap-fixed-code-words* srt-words) + (if (plusp *x86-lap-fixed-code-words*) + (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 2))))) + ;; self reference table + (x86-lap-directive frag-list :long 0) + (emit-x86-lap-label frag-list srt-tag) + ;; reserve space for self-reference offsets + (do-dll-nodes (frag frag-list) + (dolist (reloc (frag-relocs frag)) + (when (eq (reloc-type reloc) :self) + (x86-lap-directive frag-list :long 0)))) + (x86-lap-directive frag-list :long x8632::function-boundary-marker) + (emit-x86-lap-label frag-list end-code-tag) + (dolist (c (reverse *x86-lap-constants*)) + (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c))) + (x86-lap-directive frag-list :long 0)) + (when name + (x86-lap-directive frag-list :long 0)) + ;; room for lfun-bits + (x86-lap-directive frag-list :long 0) + (relax-frag-list frag-list) + (apply-relocs frag-list) + (fill-for-alignment frag-list) + ;; determine start of self-reference-table + (let* ((label (find srt-tag *x86-lap-labels* :test #'eq + :key #'x86-lap-label-name)) + (srt-frag (x86-lap-label-frag label)) + (srt-index (x86-lap-label-offset label))) + ;; fill in self-reference offsets + (do-dll-nodes (frag frag-list) + (dolist (reloc (frag-relocs frag)) + (when (eq (reloc-type reloc) :self) + (setf (frag-ref-32 srt-frag srt-index) + (+ (frag-address frag) (reloc-pos reloc))) + (incf srt-index 4))))) + ;;(show-frag-bytes frag-list) + (funcall #-x8632-target #'cross-create-x86-function + #+x8632-target (if (eq *target-backend* *host-backend*) + #'create-x86-function + #'cross-create-x86-function) + name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil))) + +(defmacro defx86lapfunction (&environment env name arglist &body body + &aux doc) + (if (not (endp body)) + (and (stringp (car body)) + (cdr body) + (setq doc (car body)) + (setq body (cdr body)))) + `(progn + (eval-when (:compile-toplevel) + (note-function-info ',name t ,env)) + #-x8664-target + (progn + (eval-when (:load-toplevel) + (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)) + (eval-when (:execute) + (%define-x86-lap-function ',name '((let ,arglist ,@body))))) + #+x8664-target ; just shorthand for defun + (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))) + +(defmacro defx8632lapfunction (&environment env name arglist &body body + &aux doc) + (if (not (endp body)) + (and (stringp (car body)) + (cdr body) + (setq doc (car body)) + (setq body (cdr body)))) + `(progn + (eval-when (:compile-toplevel) + (note-function-info ',name t ,env)) + #-x8632-target + (progn + (eval-when (:load-toplevel) + (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)) + (eval-when (:execute) + (%define-x8632-lap-function ',name '((let ,arglist ,@body))))) + #+x8632-target + (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))) Index: /branches/qres/ccl/compiler/X86/x86-lapmacros.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/x86-lapmacros.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/x86-lapmacros.lisp (revision 13564) @@ -0,0 +1,649 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Comparisons make more sense if arg order is "dest, src", instead +;;; of the gas/ATT arg order. + +(defx86lapmacro rcmp (src dest) + `(cmp ,dest ,src)) + +(defx86lapmacro clrl (reg) + `(xorl (% ,reg) (% ,reg))) + +(defx86lapmacro clrq (reg) + `(xorq (% ,reg) (% ,reg))) + +(defx86lapmacro set-nargs (n) + (cond ((= n 0) `(xorl (% nargs) (% nargs))) + (t `(movl ($ ',n) (% nargs))))) + +(defx86lapmacro anchored-uuo (form) + `(progn + ,form + (:byte 0))) + +(defx86lapmacro check-nargs (min &optional (max min)) + (let* ((anchor (gensym)) + (bad (gensym))) + (if (and max (= max min)) + `(progn + ,anchor + ,(if (eql min 0) + `(testl (% nargs) (% nargs)) + `(rcmp (% nargs) ($ ',min))) + (jne ,bad) + (:anchored-uuo-section ,anchor) + ,bad + (anchored-uuo (uuo-error-wrong-number-of-args)) + (:main-section nil)) + (if (null max) + (unless (zerop min) + `(progn + ,anchor + (rcmp (% nargs) ($ ',min)) + (jb ,bad) + (:anchored-uuo-section ,anchor) + ,bad + (anchored-uuo (uuo-error-too-few-args)) + (:main-section nil))) + (if (zerop min) + `(progn + ,anchor + (rcmp (% nargs) ($ ',max)) + (ja ,bad) + (:anchored-uuo-section ,anchor) + ,bad + (anchored-uuo (uuo-error-too-many-args)) + (:main-section nil)) + (let* ((toofew (gensym)) + (toomany (gensym))) + `(progn + ,anchor + (rcmp (% nargs) ($ ',min)) + (jb ,toofew) + (rcmp (% nargs) ($ ',max)) + (ja ,toomany) + (:anchored-uuo-section ,anchor) + ,toofew + (anchored-uuo (uuo-error-too-few-args)) + (:anchored-uuo-section ,anchor) + ,toomany + (anchored-uuo (uuo-error-too-many-args))))))))) + + +(defx86lapmacro extract-lisptag (node dest) + (target-arch-case + (:x8632 + `(progn + (movl ($ x8632::tagmask) (% ,dest)) + (andl (%l ,node) (%l ,dest)))) + (:x8664 + `(progn + (movb ($ x8664::tagmask) (%b ,dest)) + (andb (%b ,node) (%b ,dest)))))) + +(defx86lapmacro extract-fulltag (node dest) + (target-arch-case + (:x8632 + `(progn + (movl ($ x8632::fulltagmask) (%l ,dest)) + (andl (%l ,node) (%l ,dest)))) + (:x8664 + `(progn + (movb ($ x8664::fulltagmask) (%b ,dest)) + (andb (%b ,node) (%b ,dest)))))) + +(defx86lapmacro extract-subtag (node dest) + (target-arch-case + (:x8632 + `(movb (@ x8632::misc-subtag-offset (% ,node)) (%b ,dest))) + (:x8664 + `(movb (@ x8664::misc-subtag-offset (% ,node)) (%b ,dest))))) + +(defx86lapmacro extract-typecode (node dest) + ;;; In general, these things are only defined to affect the low + ;;; byte of the destination register. This can also affect + ;;; the #xff00 byte. + (let* ((done (gensym))) + (target-arch-case + (:x8632 + `(progn + (extract-lisptag ,node ,dest) + (rcmp (%b ,dest) ($ x8632::tag-misc)) + (jne ,done) + (movb (@ x8632::misc-subtag-offset (% ,node)) (%b ,dest)) + ,done)) + (:x8664 + `(progn + (extract-lisptag ,node ,dest) + (rcmp (%b ,dest) ($ x8664::tag-misc)) + (jne ,done) + (movb (@ x8664::misc-subtag-offset (% ,node)) (%b ,dest)) + ,done))))) + +(defx86lapmacro trap-unless-typecode= (node tag &optional (immreg 'imm0)) + (let* ((bad (gensym)) + (anchor (gensym))) + `(progn + ,anchor + (extract-typecode ,node ,immreg) + (cmpb ($ ,tag) (%b ,immreg)) + (jne ,bad) + (:anchored-uuo-section ,anchor) + ,bad + (:anchored-uuo (uuo-error-reg-not-tag (% ,node) ($ ,tag))) + (:main-section nil)))) + +(defx86lapmacro trap-unless-fulltag= (node tag &optional (immreg 'imm0)) + (let* ((ok (gensym))) + `(progn + (extract-fulltag ,node ,immreg) + (cmpb ($ ,tag) (%b ,immreg)) + (je.pt ,ok) + (uuo-error-reg-not-tag (% ,node) ($ ,tag)) + ,ok))) + +(defx86lapmacro trap-unless-lisptag= (node tag &optional (immreg 'imm0)) + (let* ((ok (gensym))) + `(progn + (extract-lisptag ,node ,immreg) + (cmpb ($ ,tag) (%b ,immreg)) + (je.pt ,ok) + (uuo-error-reg-not-tag (% ,node) ($ ,tag)) + ,ok))) + +(defx86lapmacro trap-unless-fixnum (node) + (let* ((ok (gensym))) + (target-arch-case + (:x8632 + `(progn + (test ($ x8632::tagmask) (% ,node)) + (je.pt ,ok) + (uuo-error-reg-not-fixnum (% ,node)) + ,ok)) + (:x8664 + `(progn + (testb ($ x8664::tagmask) (%b ,node)) + (je.pt ,ok) + (uuo-error-reg-not-fixnum (% ,node)) + ,ok))))) + +;;; On x8664, NIL has its own tag, so no other lisp object can +;;; have the same low byte as NIL. On x8632, NIL is a just +;;; a distiguished CONS. +(defx86lapmacro cmp-reg-to-nil (reg) + (target-arch-case + (:x8632 + `(cmpl ($ (target-nil-value)) (%l ,reg))) + (:x8664 + `(cmpb ($ (logand #xff (target-nil-value))) (%b ,reg))))) + +(defx86lapmacro unbox-fixnum (src dest) + (target-arch-case + (:x8632 + `(progn + (mov (% ,src) (% ,dest)) + (sar ($ x8632::fixnumshift) (% ,dest)))) + (:x8664 + `(progn + (mov (% ,src) (% ,dest)) + (sar ($ x8664::fixnumshift) (% ,dest)))))) + +(defx86lapmacro box-fixnum (src dest) + (target-arch-case + (:x8632 + `(imull ($ x8632::fixnumone) (% ,src) (% ,dest))) + (:x8664 + `(imulq ($ x8664::fixnumone) (% ,src) (% ,dest))))) + +(defx86lapmacro get-single-float (node dest) + (target-arch-case + (:x8632 + `(movss (@ x8632::single-float.value (% ,node)) (% ,dest))) + (:x8664 + `(progn + (movd (% ,node) (% ,dest)) + (psrlq ($ 32) (% ,dest)))))) + +;;; Note that this modifies the src argument in the x8664 case. +(defx86lapmacro put-single-float (src node) + (target-arch-case + (:x8632 + `(movss (% ,src) (@ x8632::single-float.value (% ,node)))) + (:x8664 + `(progn + (psllq ($ 32) (% ,src)) + (movd (% ,src) (% ,node)) + (movb ($ x8664::tag-single-float) (%b ,node)))))) + +(defx86lapmacro get-double-float (src fpreg) + (target-arch-case + (:x8632 + `(movsd (@ x8632::double-float.value (% ,src)) (% ,fpreg))) + (:x8664 + `(movsd (@ x8664::double-float.value (% ,src)) (% ,fpreg))))) + +(defx86lapmacro put-double-float (fpreg dest) + (target-arch-case + (:x8632 + `(movsd (% ,fpreg) (@ x8632::double-float.value (% ,dest)))) + (:x8664 + `(movsd (% ,fpreg) (@ x8664::double-float.value (% ,dest)))))) + +(defx86lapmacro getvheader (src dest) + (target-arch-case + (:x8632 + `(movl (@ x8632::misc-header-offset (% ,src)) (% ,dest))) + (:x8664 + `(movq (@ x8664::misc-header-offset (% ,src)) (% ,dest))))) + +;;; "Size" is unboxed element-count. vheader and dest should +;;; both be immediate registers +(defx86lapmacro header-size (vheader dest) + (target-arch-case + (:x8632 + `(progn + (mov (% ,vheader) (% ,dest)) + (shr ($ x8632::num-subtag-bits) (% ,dest)))) + (:x8664 + `(progn + (mov (% ,vheader) (% ,dest)) + (shr ($ x8664::num-subtag-bits) (% ,dest)))))) + +;;; "Length" is fixnum element-count. +(defx86lapmacro header-length (vheader dest) + (target-arch-case + (:x8632 + `(progn + (movl ($ (lognot 255)) (% ,dest)) + (andl (% ,vheader) (% ,dest)) + (shr ($ (- x8632::num-subtag-bits x8632::fixnumshift)) (% ,dest)))) + (:x8664 + `(progn + (movq ($ (lognot 255)) (% ,dest)) + (andq (% ,vheader) (% ,dest)) + (shr ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% ,dest)))))) + +(defx86lapmacro header-subtag[fixnum] (vheader dest) + `(progn + (lea (@ (% ,vheader) 8) (% ,dest)) + (andl ($ '255) (%l ,dest)))) + +(defx86lapmacro vector-size (vector vheader dest) + `(progn + (getvheader ,vector ,vheader) + (header-size ,vheader ,dest))) + +(defx86lapmacro vector-length (vector dest) + (target-arch-case + (:x8632 + `(progn + (movl ($ (lognot 255)) (% ,dest)) + (andl (@ x8632::misc-header-offset (% ,vector)) (% ,dest)) + (shr ($ (- x8632::num-subtag-bits x8632::fixnumshift)) (% ,dest)))) + (:x8664 + `(progn + (movq ($ (lognot 255)) (% ,dest)) + (andq (@ x8664::misc-header-offset (% ,vector)) (% ,dest)) + (shr ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% ,dest)))))) + +(defx86lapmacro int-to-double (int temp double) + (target-arch-case + (:x8632 + `(progn + (unbox-fixnum ,int ,temp) + (cvtsi2sdl (% ,temp) (% ,double)))) + (:x8664 + `(progn + (unbox-fixnum ,int ,temp) + (cvtsi2sdq (% ,temp) (% ,double)))))) + +(defx86lapmacro int-to-single (int temp single) + (target-arch-case + (:x8632 + `(progn + (unbox-fixnum ,int ,temp) + (cvtsi2ssl (% ,temp) (% ,single)))) + (:x8664 + `(progn + (unbox-fixnum ,int ,temp) + (cvtsi2ssq (% ,temp) (% ,single)))))) + +(defx86lapmacro ref-global (global reg) + (target-arch-case + (:x8632 + `(movl (@ (+ (target-nil-value) ,(x8632::%kernel-global global))) (% ,reg))) + (:x8664 + `(movq (@ (+ (target-nil-value) ,(x8664::%kernel-global global))) (% ,reg))))) + +(defx86lapmacro ref-global.l (global reg) + (target-arch-case + (:x8632 + `(movl (@ (+ (target-nil-value) ,(x8632::%kernel-global global))) (%l ,reg))) + (:x8664 + `(movl (@ (+ (target-nil-value) ,(x8664::%kernel-global global))) (%l ,reg))))) + +(defx86lapmacro set-global (reg global) + (target-arch-case + (:x8632 + `(movl (% ,reg) (@ (+ (target-nil-value) ,(x8632::%kernel-global global))))) + (:x8664 + `(movq (% ,reg) (@ (+ (target-nil-value) ,(x8664::%kernel-global global))))))) + +(defx86lapmacro macptr-ptr (src dest) + (target-arch-case + (:x8632 + `(movl (@ x8632::macptr.address (% ,src)) (% ,dest))) + (:x8664 + `(movq (@ x8664::macptr.address (% ,src)) (% ,dest))))) + +;;; CODE is unboxed char-code (in low 8 bits); CHAR needs to be boxed. +(defx86lapmacro box-character (code char) + (target-arch-case + (:x8632 + `(progn + (box-fixnum ,code ,char) + (shl ($ (- x8632::charcode-shift x8632::fixnumshift)) (% ,char)) + (movb ($ x8632::subtag-character) (%b ,char)))) + (:x8664 + `(progn + (box-fixnum ,code ,char) + (shl ($ (- x8664::charcode-shift x8664::fixnumshift)) (% ,char)) + (movb ($ x8664::subtag-character) (%b ,char)))))) + +;;; index is a constant +(defx86lapmacro svref (vector index dest) + (target-arch-case + (:x8632 + `(movl (@ (+ x8632::misc-data-offset (* ,index 4)) (% ,vector)) (% ,dest))) + (:x8664 + `(movq (@ (+ x8664::misc-data-offset (* ,index 8)) (% ,vector)) (% ,dest))))) + +;;; Index is still a constant +(defx86lapmacro svset (vector index new) + (target-arch-case + (:x8632 + `(movl (% ,new) (@ (+ x8632::misc-data-offset (* ,index 4)) (% ,vector)))) + (:x8664 + `(movq (% ,new) (@ (+ x8664::misc-data-offset (* ,index 8)) (% ,vector)))))) + + +;;; Frames, function entry and exit. + + +;;; Simple frame, since the caller didn't reserve space for it. +(defx86lapmacro save-simple-frame () + (target-arch-case + (:x8632 + `(progn + (pushl (% ebp)) + (movl (% esp) (% ebp)))) + (:x8664 + `(progn + (pushq (% rbp)) + (movq (% rsp) (% rbp)))))) + +(defx86lapmacro save-stackargs-frame (nstackargs) + (target-arch-case + (:x8632 + `(progn + (movl (% ebp) (@ ,(* (1+ nstackargs) x8632::node-size) (% esp))) + (leal (@ ,(* (1+ nstackargs) x8632::node-size) (% esp)) (% ebp)) + (popl (@ x8632::node-size (% ebp))))) + (:x8664 + `(progn + (movq (% rbp) (@ ,(* (1+ nstackargs) x8664::node-size) (% rsp))) + (leaq (@ ,(* (1+ nstackargs) x8664::node-size) (% rsp)) (% rbp)) + (popq (@ x8632::node-size (% rbp))))))) + +(defx86lapmacro save-frame-variable-arg-count () + (let* ((push (gensym)) + (done (gensym))) + (target-arch-case + (:x8632 + `(progn + (movl (% nargs) (% imm0)) + (subl ($ (* $numx8632argregs x8632::node-size)) (% imm0)) + (jle ,push) + (movl (% ebp) (@ 4 (% esp) (% imm0))) + (leal (@ 4 (% esp) (% imm0)) (% ebp)) + (popl (@ 4 (% ebp))) + (jmp ,done) + ,push + (save-simple-frame) + ,done)) + (:x8664 + `(progn + (movl (% nargs) (%l imm0)) + (subq ($ (* $numx8664argregs x8664::node-size)) (% imm0)) + (jle ,push) + (movq (% rbp) (@ 8 (% rsp) (% imm0))) + (leaq (@ 8 (% rsp) (% imm0)) (% rbp)) + (popq (@ 8 (% rbp))) + (jmp ,done) + ,push + (save-simple-frame) + ,done))))) + + +(defx86lapmacro restore-simple-frame () + `(progn + (leave))) + +(defx86lapmacro discard-reserved-frame () + (target-arch-case + (:x8632 + `(add ($ '2) (% esp))) + (:x8664 + `(add ($ '2) (% rsp))))) + +;;; Return to caller. +(defx86lapmacro single-value-return (&optional (words-to-discard 0)) + (target-arch-case + (:x8632 + (if (zerop words-to-discard) + `(ret) + `(ret ($ ,(* x8632::node-size words-to-discard))))) + (:x8664 + (if (zerop words-to-discard) + `(ret) + `(ret ($ ,(* x8664::node-size words-to-discard))))))) + +(defun x86-subprim-offset (name) + (let* ((info (find name (arch::target-subprims-table (backend-target-arch *target-backend*)) :test #'string-equal :key #'subprimitive-info-name)) + (offset (when info + (subprimitive-info-offset info)))) + (or offset + (error "Unknown subprim: ~s" name)))) + +(defx86lapmacro jmp-subprim (name) + `(jmp (@ ,(x86-subprim-offset name)))) + +(defx86lapmacro recover-fn () + `(movl ($ :self) (% fn))) + +(defx86lapmacro call-subprim (name) + (target-arch-case + (:x8632 + `(progn + (:talign x8632::fulltag-tra) + (call (@ ,(x86-subprim-offset name))) + (recover-fn))) + (:x8664 + `(progn + (:talign 4) + (call (@ ,(x86-subprim-offset name))) + (recover-fn-from-rip))))) + + (defx86lapmacro %car (src dest) + (target-arch-case + (:x8632 + `(movl (@ x8632::cons.car (% ,src)) (% ,dest))) + (:x8664 + `(movq (@ x8664::cons.car (% ,src)) (% ,dest))))) + +(defx86lapmacro %cdr (src dest) + (target-arch-case + (:x8632 + `(movl (@ x8632::cons.cdr (% ,src)) (% ,dest))) + (:x8664 + `(movq (@ x8664::cons.cdr (% ,src)) (% ,dest))))) + +(defx86lapmacro stack-probe () + (target-arch-case + (:x8632 + (let* ((ok (gensym))) + `(progn + (rcmp (% esp) (@ (% rcontext) x8632::tcr.cs-limit)) + (jae.pt ,ok) + (uuo-stack-overflow) + ,ok))) + (:x8664 + (let* ((ok (gensym))) + `(progn + (rcmp (% rsp) (@ (% rcontext) x8664::tcr.cs-limit)) + (jae.pt ,ok) + (uuo-stack-overflow) + ,ok))))) + +(defx86lapmacro load-constant (constant dest &optional (fn 'fn)) + (target-arch-case + (:x8632 + `(movl (@ ',constant (% ,fn)) (% ,dest))) + (:x8664 + `(movq (@ ',constant (% ,fn)) (% ,dest))))) + +(defx86lapmacro recover-fn-from-rip () + (let* ((next (gensym))) + `(progn + (lea (@ (- (:^ ,next)) (% rip)) (% fn)) + ,next))) + +;;; call symbol named NAME, setting nargs to NARGS. Do the TRA +;;; hair. Args should already be in arg regs, and we expect +;;; to return a single value. +(defx86lapmacro call-symbol (name nargs) + (target-arch-case + (:x8632 + `(progn + (load-constant ,name fname) + (set-nargs ,nargs) + (:talign 5) + (call (@ x8632::symbol.fcell (% fname))) + (recover-fn))) + (:x8664 + `(progn + (load-constant ,name fname) + (set-nargs ,nargs) + (:talign 4) + (call (@ x8664::symbol.fcell (% fname))) + (recover-fn-from-rip))))) + + +;;; tail call the function named by NAME with nargs NARGS. %FN is +;;; the caller, which will be in %FN on entry to the callee. For the +;;; couple of instructions where neither %RA0 or %FN point to the +;;; current function, ensure that %XFN does; this is necessary to +;;; prevent the current function from being GCed halfway through +;;; those couple of instructions. + +(defx86lapmacro jump-symbol (name nargs) + (target-arch-case + (:x8632 + `(progn + (load-constant ,name fname) + (set-nargs ,nargs) + (jmp (@ x8632::symbol.fcell (% fname))))) + (:x8664 + `(progn + (load-constant ,name fname) + (set-nargs ,nargs) + (jmp (@ x8664::symbol.fcell (% fname))))))) + +(defx86lapmacro push-argregs () + (let* ((done (gensym)) + (yz (gensym)) + (z (gensym))) + (target-arch-case + (:x8632 + `(progn + (testl (% nargs) (% nargs)) + (je ,done) + (cmpl ($ '1) (% nargs)) + (je ,z) + (push (% arg_y)) + ,z + (push (% arg_z)) + ,done)) + (:x8664 + `(progn + (testl (% nargs) (% nargs)) + (je ,done) + (cmpl ($ '2) (% nargs)) + (je ,yz) + (jb ,z) + (push (% arg_x)) + ,yz + (push (% arg_y)) + ,z + (push (% arg_z)) + ,done))))) + +;;; clears reg +(defx86lapmacro mark-as-node (reg) + (let* ((regnum (logand #x7 (x86::gpr-ordinal (string reg)))) + (bit (ash 1 regnum))) + `(progn + (xorl (% ,reg) (% ,reg)) + (orb ($ ,bit) (@ (% :rcontext) x8632::tcr.node-regs-mask))))) + +(defx86lapmacro mark-as-imm (reg) + (let* ((regnum (logand #x7 (x86::gpr-ordinal (string reg)))) + (bit (ash 1 regnum))) + `(progn + (andb ($ (lognot ,bit)) (@ (% :rcontext) x8632::tcr.node-regs-mask))))) + +(defx86lapmacro compose-digit (high low dest) + (target-arch-case + (:x8632 + `(progn + (unbox-fixnum ,low ,dest) + (andl ($ #xffff) (% ,dest)) + (shll ($ (- 16 x8632::fixnumshift)) (% ,high)) + (orl (% ,high) (% ,dest)))) + (:x8664 + (error "compose-digit on x8664?")))) + +(defx86lapmacro imm-word-count (fn imm dest) + `(progn + (movzwl (@ x8632::misc-data-offset (% ,fn)) (% ,imm)) + (btr ($ 15) (% ,imm)) + (vector-length ,fn ,dest) + (box-fixnum ,imm ,imm) + (subl (% ,imm) (% ,dest)))) + +(defx86lapmacro double-constant (name value) + (multiple-value-bind (high low) + (double-float-bits (float value 1.0d0)) + `(progn + (:uuo-section) + (:align 3) + ,name + (:long ,low) + (:long ,high) + (:main-section)))) Index: /branches/qres/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/qres/ccl/compiler/X86/x862.lisp (revision 13564) +++ /branches/qres/ccl/compiler/X86/x862.lisp (revision 13564) @@ -0,0 +1,10226 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NXENV") + (require "X8632ENV") + (require "X8664ENV")) + +(eval-when (:load-toplevel :execute :compile-toplevel) + (require "X86-BACKEND")) + +(defparameter *x862-debug-mask* 0) +(defconstant x862-debug-verbose-bit 0) +(defconstant x862-debug-vinsns-bit 1) +(defconstant x862-debug-lcells-bit 2) +(defparameter *x862-target-lcell-size* 0) +(defparameter *x862-target-node-size* 0) +(defparameter *x862-target-dnode-size* 0) +(defparameter *x862-target-fixnum-shift* 0) +(defparameter *x862-target-node-shift* 0) +(defparameter *x862-target-bits-in-word* 0) +(defparameter *x862-target-num-arg-regs* 0) +(defparameter *x862-target-num-save-regs* 0) +(defparameter *x862-target-half-fixnum-type* nil) + +(defparameter *x862-operator-supports-u8-target* ()) +(defparameter *x862-operator-supports-push* ()) +(defparameter *x862-tos-reg* ()) + +;; probably should be elsewhere + +(defmacro with-additional-imm-reg ((&rest reserved) &body body) + (let ((node (gensym)) + (bit (gensym))) + `(target-arch-case + (:x8632 + (with-node-target (,@reserved) ,node + (let* ((,bit (ash 1 (hard-regspec-value ,node))) + (*backend-node-temps* (logandc2 *backend-node-temps* ,bit)) + (*available-backend-node-temps* (logandc2 *available-backend-node-temps* ,bit)) + (*backend-imm-temps* (logior *backend-imm-temps* ,bit)) + (*available-backend-imm-temps* (logior *available-backend-imm-temps* ,bit))) + (! mark-as-imm ,node) + ,@body + (! mark-as-node ,node)))) + (:x8664 + (progn + ,@body))))) + + + +(defmacro with-x86-p2-declarations (declsform &body body) + `(let* ((*x862-tail-allow* *x862-tail-allow*) + (*x862-reckless* *x862-reckless*) + (*x862-open-code-inline* *x862-open-code-inline*) + (*x862-trust-declarations* *x862-trust-declarations*) + (*x862-full-safety* *x862-full-safety*)) + (x862-decls ,declsform) + ,@body)) + + +(defmacro with-x86-local-vinsn-macros ((segvar &optional vreg-var xfer-var) &body body) + (declare (ignorable xfer-var)) + (let* ((template-name-var (gensym)) + (template-temp (gensym)) + (args-var (gensym)) + (labelnum-var (gensym)) + (retvreg-var (gensym)) + (label-var (gensym))) + `(macrolet ((! (,template-name-var &rest ,args-var) + (let* ((,template-temp (get-vinsn-template-cell ,template-name-var (backend-p2-vinsn-templates *target-backend*)))) + (unless ,template-temp + (warn "VINSN \"~A\" not defined" ,template-name-var)) + `(prog1 + (%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var) + (setq *x862-tos-reg* nil))))) + (macrolet ((<- (,retvreg-var) + `(x862-copy-register ,',segvar ,',vreg-var ,,retvreg-var)) + (@ (,labelnum-var) + `(backend-gen-label ,',segvar ,,labelnum-var)) + (@= (,labelnum-var) + `(x862-emit-aligned-label ,',segvar ,,labelnum-var)) + (-> (,label-var) + `(! jump (aref *backend-labels* ,,label-var))) + (^ (&rest branch-args) + `(x862-branch ,',segvar ,',xfer-var ,@branch-args)) + (? (&key (class :gpr) + (mode :lisp)) + (let* ((class-val + (ecase class + (:gpr hard-reg-class-gpr) + (:fpr hard-reg-class-fpr) + (:crf hard-reg-class-crf))) + (mode-val-or-form + (if (eq class :gpr) + (if (member mode '(:natural :signed-natural)) + `(gpr-mode-name-value ,mode) + (gpr-mode-name-value mode)) + (if (eq class :fpr) + (if (eq mode :single-float) + hard-reg-class-fpr-mode-single + hard-reg-class-fpr-mode-double) + 0)))) + `(make-unwired-lreg nil + :class ,class-val + :mode ,mode-val-or-form))) + ($ (reg &key (class :gpr) (mode :lisp)) + (let* ((class-val + (ecase class + (:gpr hard-reg-class-gpr) + (:fpr hard-reg-class-fpr) + (:crf hard-reg-class-crf))) + (mode-val-or-form + (if (eq class :gpr) + (if (member mode '(:natural :signed-natural)) + `(gpr-mode-name-value ,mode) + (gpr-mode-name-value mode)) + (if (eq class :fpr) + (if (eq mode :single-float) + hard-reg-class-fpr-mode-single + hard-reg-class-fpr-mode-double) + 0)))) + `(make-wired-lreg ,reg + :class ,class-val + :mode ,mode-val-or-form)))) + ,@body)))) + + + +(defvar *x86-current-context-annotation* nil) +(defvar *x862-woi* nil) +(defvar *x862-open-code-inline* nil) +(defvar *x862-register-restore-count* 0) +(defvar *x862-register-restore-ea* nil) +(defvar *x862-compiler-register-save-label* nil) +(defvar *x862-valid-register-annotations* 0) +(defvar *x862-register-annotation-types* nil) +(defvar *x862-register-ea-annotations* nil) +(defvar *x862-constant-alist* nil) +(defvar *x862-double-float-constant-alist* nil) +(defvar *x862-single-float-constant-alist* nil) + +(defparameter *x862-tail-call-aliases* + () + #| '((%call-next-method . (%tail-call-next-method . 1))) |# + +) + +(defvar *x862-popreg-labels* nil) +(defvar *x862-popj-labels* nil) +(defvar *x862-valret-labels* nil) +(defvar *x862-nilret-labels* nil) + +(defvar *x862-icode* nil) +(defvar *x862-undo-stack* nil) +(defvar *x862-undo-because* nil) + + +(defvar *x862-cur-afunc* nil) +(defvar *x862-vstack* 0) +(defvar *x862-cstack* 0) +(defvar *x862-undo-count* 0) +(defvar *x862-returning-values* nil) +(defvar *x862-vcells* nil) +(defvar *x862-fcells* nil) +(defvar *x862-entry-vsp-saved-p* nil) + +(defvar *x862-entry-label* nil) +(defvar *x862-tail-label* nil) +(defvar *x862-tail-vsp* nil) +(defvar *x862-tail-nargs* nil) +(defvar *x862-tail-allow* t) +(defvar *x862-reckless* nil) +(defvar *x862-full-safety* nil) +(defvar *x862-trust-declarations* nil) +(defvar *x862-entry-vstack* nil) +(defvar *x862-fixed-nargs* nil) +(defvar *x862-need-nargs* t) + +(defparameter *x862-inhibit-register-allocation* nil) +(defvar *x862-record-symbols* nil) +(defvar *x862-recorded-symbols* nil) +(defvar *x862-emitted-source-notes* nil) + +(defvar *x862-result-reg* x8664::arg_z) + +(defvar *x8664-nvrs* + `(,x8664::save0 ,x8664::save1 ,x8664::save2 ,x8664::save3)) + +(defvar *reduced-x8664-nvrs* + `(,x8664::save0 ,x8664::save1 ,x8664::save2)) + +(defvar *x8632-nvrs* ()) + + +(defvar *x862-arg-z* nil) +(defvar *x862-arg-y* nil) +(defvar *x862-imm0* nil) +(defvar *x862-temp0* nil) +(defvar *x862-temp1* nil) +(defvar *x862-fn* nil) +(defvar *x862-fname* nil) +(defvar *x862-ra0* nil) +(defvar *x862-codecoverage-reg* nil) + +(defvar *x862-allocptr* nil) + +(defvar *x862-fp0* nil) +(defvar *x862-fp1* nil) + +(declaim (fixnum *x862-vstack* *x862-cstack*)) + + + + + +(defvar *x862-all-lcells* ()) + +(defun x86-immediate-label (imm) + (or (cdr (assoc imm *x862-constant-alist* :test #'eq)) + (let* ((lab (aref *backend-labels* (backend-get-next-label)))) + (push (cons imm lab) *x862-constant-alist*) + lab))) + +(defun x86-double-float-constant-label (imm) + (or (cdr (assoc imm *x862-double-float-constant-alist*)) + (let* ((lab (aref *backend-labels* (backend-get-next-label)))) + (push (cons imm lab) *x862-double-float-constant-alist*) + lab))) + +(defun x86-single-float-constant-label (imm) + (or (cdr (assoc imm *x862-single-float-constant-alist*)) + (let* ((lab (aref *backend-labels* (backend-get-next-label)))) + (push (cons imm lab) *x862-single-float-constant-alist*) + lab))) + + +(defun x862-free-lcells () + (without-interrupts + (let* ((prev (pool.data *lcell-freelist*))) + (dolist (r *x862-all-lcells*) + (setf (lcell-kind r) prev + prev r)) + (setf (pool.data *lcell-freelist*) prev) + (setq *x862-all-lcells* nil)))) + +(defun x862-note-lcell (c) + (push c *x862-all-lcells*) + c) + +(defvar *x862-top-vstack-lcell* ()) +(defvar *x862-bottom-vstack-lcell* ()) + +(defun x862-new-lcell (kind parent width attributes info) + (x862-note-lcell (make-lcell kind parent width attributes info))) + +(defun x862-new-vstack-lcell (kind width attributes info) + (setq *x862-top-vstack-lcell* (x862-new-lcell kind *x862-top-vstack-lcell* width attributes info))) + +(defun x862-reserve-vstack-lcells (n) + (dotimes (i n) (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil))) + +(defun x862-vstack-mark-top () + (x862-new-lcell :tos *x862-top-vstack-lcell* 0 0 nil)) + +;;; Alist mapping VARs to lcells/lregs +(defvar *x862-var-cells* ()) + +(defun x862-note-var-cell (var cell) + ;(format t "~& ~s -> ~s" (var-name var) cell) + (push (cons var cell) *x862-var-cells*)) + +(defun x862-note-top-cell (var) + (x862-note-var-cell var *x862-top-vstack-lcell*)) + +(defun x862-lookup-var-cell (var) + (or (cdr (assq var *x862-var-cells*)) + (and nil (warn "Cell not found for ~s" (var-name var))))) + +(defun x862-collect-lcells (kind &optional (bottom *x862-bottom-vstack-lcell*) (top *x862-top-vstack-lcell*)) + (do* ((res ()) + (cell top (lcell-parent cell))) + ((eq cell bottom) res) + (if (null cell) + (compiler-bug "Horrible compiler bug.") + (if (eq (lcell-kind cell) kind) + (push cell res))))) + + + +;;; ensure that lcell's offset matches what we expect it to. +;;; For bootstrapping. + +(defun x862-ensure-lcell-offset (c expected) + (if c (= (calc-lcell-offset c) expected) (zerop expected))) + +(defun x862-check-lcell-depth (&optional (context "wherever")) + (when (logbitp x862-debug-verbose-bit *x862-debug-mask*) + (let* ((depth (calc-lcell-depth *x862-top-vstack-lcell*))) + (or (= depth *x862-vstack*) + (warn "~a: lcell depth = ~d, vstack = ~d" context depth *x862-vstack*))))) + +(defun x862-do-lexical-reference (seg vreg ea) + (when vreg + (with-x86-local-vinsn-macros (seg vreg) + (if (eq vreg :push) + (if (memory-spec-p ea) + (if (addrspec-vcell-p ea) + (with-node-target () target + (x862-stack-to-register seg ea target) + (! vcell-ref target target) + (! vpush-register target)) + (! vframe-push (memspec-frame-address-offset ea) *x862-vstack*)) + (! vpush-register ea)) + (if (memory-spec-p ea) + (ensuring-node-target (target vreg) + (progn + (x862-stack-to-register seg ea target) + (if (addrspec-vcell-p ea) + (! vcell-ref target target)))) + (<- ea)))))) + +(defun x862-do-lexical-setq (seg vreg ea valreg) + (with-x86-local-vinsn-macros (seg vreg) + (cond ((typep ea 'lreg) + (x862-copy-register seg ea valreg)) + ((addrspec-vcell-p ea) ; closed-over vcell + (x862-copy-register seg *x862-arg-z* valreg) + (let* ((gvector (target-arch-case (:x8632 x8632::temp0) + (:x8664 x8664::arg_x)))) + (x862-stack-to-register seg ea gvector) + (x862-lri seg *x862-arg-y* 0) + (! call-subprim-3 *x862-arg-z* (subprim-name->offset '.SPgvset) gvector *x862-arg-y* *x862-arg-z*))) + ((memory-spec-p ea) ; vstack slot + (x862-register-to-stack seg valreg ea)) + (t + (x862-copy-register seg ea valreg))) + (when vreg + (<- valreg)))) + +;;; ensure that next-method-var is heap-consed (if it's closed over.) +;;; it isn't ever setqed, is it ? +(defun x862-heap-cons-next-method-var (seg var) + (with-x86-local-vinsn-macros (seg) + (when (eq (ash 1 $vbitclosed) + (logand (logior (ash 1 $vbitclosed) + (ash 1 $vbitcloseddownward)) + (the fixnum (nx-var-bits var)))) + (let* ((ea (var-ea var)) + (arg ($ *x862-arg-z*)) + (result ($ *x862-arg-z*))) + (x862-do-lexical-reference seg arg ea) + (x862-set-nargs seg 1) + (! ref-constant ($ *x862-fname*) (x86-immediate-label (x862-symbol-entry-locative '%cons-magic-next-method-arg))) + (! call-known-symbol arg) + (x862-do-lexical-setq seg nil ea result))))) + +;;; If we change the order of operands in a binary comparison operation, +;;; what should the operation change to ? (eg., (< X Y) means the same +;;; thing as (> Y X)). +(defparameter *x862-reversed-cr-bits* + (vector + nil ;o ? + nil ;no ? + x86::x86-a-bits ;b -> a + x86::x86-be-bits ;ae -> be + x86::x86-e-bits ;e->e + x86::x86-ne-bits ;ne->ne + x86::x86-ae-bits ;be->ae + x86::x86-b-bits ;a->b + nil ;s ? + nil ;ns ? + nil ;pe ? + nil ;po ? + x86::x86-g-bits ;l->g + x86::x86-le-bits ;ge->le + x86::x86-ge-bits ;le->ge + x86::x86-l-bits ;g->l + )) + +(defun x862-reverse-cr-bit (cr-bit) + (or (svref *x862-reversed-cr-bits* cr-bit) + (compiler-bug "Can't reverse CR bit ~d" cr-bit))) + + +(defun acode-condition-to-x86-cr-bit (cond) + (condition-to-x86-cr-bit (cadr cond))) + +(defun condition-to-x86-cr-bit (cond) + (case cond + (:EQ (values x86::x86-e-bits t)) + (:NE (values x86::x86-e-bits nil)) + (:GT (values x86::x86-le-bits nil)) + (:LE (values x86::x86-le-bits t)) + (:LT (values x86::x86-l-bits t)) + (:GE (values x86::x86-l-bits nil)))) + +;;; Generate the start and end bits for a RLWINM instruction that +;;; would be equivalent to to LOGANDing the constant with some value. +;;; Return (VALUES NIL NIL) if the constant contains more than one +;;; sequence of consecutive 1-bits, else bit indices. +;;; The caller generally wants to treat the constant as an (UNSIGNED-BYTE 32); +;;; since this uses LOGCOUNT and INTEGER-LENGTH to find the significant +;;; bits, it ensures that the constant is a (SIGNED-BYTE 32) that has +;;; the same least-significant 32 bits. +(defun x862-mask-bits (constant) + (if (< constant 0) (setq constant (logand #xffffffff constant))) + (if (= constant #xffffffff) + (values 0 31) + (if (zerop constant) + (values nil nil) + (let* ((signed (if (and (logbitp 31 constant) + (> constant 0)) + (- constant (ash 1 32)) + constant)) + (count (logcount signed)) + (len (integer-length signed)) + (highbit (logbitp (the fixnum (1- len)) constant))) + (declare (fixnum count len)) + (do* ((i 1 (1+ i)) + (pos (- len 2) (1- pos))) + ((= i count) + (let* ((start (- 32 len)) + (end (+ count start))) + (declare (fixnum start end)) + (if highbit + (values start (the fixnum (1- end))) + (values (logand 31 end) + (the fixnum (1- start)))))) + (declare (fixnum i pos)) + (unless (eq (logbitp pos constant) highbit) + (return (values nil nil)))))))) + + +(defun x862-ensure-binding-indices-for-vcells (vcells) + (dolist (cell vcells) + (ensure-binding-index (car cell))) + vcells) + +(defun x862-register-mask-byte (count) + (if (> count 0) + (logior + (ash 1 (- x8664::save0 8)) + (if (> count 1) + (logior + (ash 1 (- x8664::save1 8)) + (if (> count 2) + (logior + (ash 1 (- x8664::save2 8)) + (if (> count 3) + (ash 1 (- x8664::save3 8)) + 0)) + 0)) + 0)) + 0)) + +(defun x862-encode-register-save-ea (ea count) + (if (zerop count) + 0 + (min (- (ash ea (- *x862-target-node-shift*)) count) #xff))) + + +(defun x862-compile (afunc &optional lambda-form *x862-record-symbols*) + (progn + (dolist (a (afunc-inner-functions afunc)) + (unless (afunc-lfun a) + (x862-compile a + (if lambda-form (afunc-lambdaform a)) + *x862-record-symbols*))) ; always compile inner guys + (let* ((*x862-cur-afunc* afunc) + (*x862-returning-values* nil) + (*x86-current-context-annotation* nil) + (*x862-woi* nil) + (*next-lcell-id* -1) + (*x862-open-code-inline* nil) + (*x862-register-restore-count* nil) + (*x862-compiler-register-save-label* nil) + (*x862-valid-register-annotations* 0) + (*x862-register-ea-annotations* (x862-make-stack 16)) + (*x862-register-restore-ea* nil) + (*x862-constant-alist* nil) + (*x862-double-float-constant-alist* nil) + (*x862-single-float-constant-alist* nil) + (*x862-vstack* 0) + (*x862-cstack* 0) + (*x86-lap-entry-offset* (target-arch-case + (:x8632 x8632::fulltag-misc) + (:x8664 x8664::fulltag-function))) + (*x862-result-reg* (target-arch-case + (:x8632 x8632::arg_z) + (:x8664 x8664::arg_z))) + (*x862-imm0* (target-arch-case (:x8632 x8632::imm0) + (:x8664 x8664::imm0))) + (*x862-arg-z* (target-arch-case (:x8632 x8632::arg_z) + (:x8664 x8664::arg_z))) + (*x862-arg-y* (target-arch-case (:x8632 x8632::arg_y) + (:x8664 x8664::arg_y))) + (*x862-temp0* (target-arch-case (:x8632 x8632::temp0) + (:x8664 x8664::temp0))) + (*x862-codecoverage-reg* *x862-temp0*) + (*x862-temp1* (target-arch-case (:x8632 x8632::temp1) + (:x8664 x8664::temp1))) + (*x862-fn* (target-arch-case (:x8632 x8632::fn) + (:x8664 x8664::fn))) + (*x862-fname* (target-arch-case (:x8632 x8632::fname) + (:x8664 x8664::fname))) + (*x862-ra0* (target-arch-case (:x8632 x8632::ra0) + (:x8664 x8664::ra0))) + (*x862-allocptr* (target-arch-case (:x8632 x8632::allocptr) + (:x8664 x8664::allocptr))) + (*x862-fp0* (target-arch-case (:x8632 x8632::fp0) + (:x8664 x8664::fp0))) + (*x862-fp1* (target-arch-case (:x8632 x8632::fp1) + (:x8664 x8664::fp1))) + (*x862-target-num-arg-regs* (target-arch-case + (:x8632 $numx8632argregs) + (:x8664 $numx8664argregs))) + (*x862-target-num-save-regs* (target-arch-case + (:x8632 $numx8632saveregs) + (:x8664 $numx8664saveregs))) + (*x862-target-lcell-size* (arch::target-lisp-node-size (backend-target-arch *target-backend*))) + (*x862-target-fixnum-shift* (arch::target-fixnum-shift (backend-target-arch *target-backend*))) + (*x862-target-node-shift* (arch::target-word-shift (backend-target-arch *target-backend*))) + (*x862-target-bits-in-word* (arch::target-nbits-in-word (backend-target-arch *target-backend*))) + (*x862-target-node-size* *x862-target-lcell-size*) + (*x862-target-half-fixnum-type* `(signed-byte ,(- *x862-target-bits-in-word* + (1+ *x862-target-fixnum-shift*)))) + (*x862-target-dnode-size* (* 2 *x862-target-lcell-size*)) + (*x862-tos-reg* nil) + (*x862-all-lcells* ()) + (*x862-top-vstack-lcell* nil) + (*x862-bottom-vstack-lcell* (x862-new-vstack-lcell :bottom 0 0 nil)) + (*x862-var-cells* nil) + (*backend-vinsns* (backend-p2-vinsn-templates *target-backend*)) + (*backend-node-regs* (target-arch-case + (:x8632 x8632-node-regs) + (:x8664 x8664-node-regs))) + (*backend-node-temps* (target-arch-case + (:x8632 x8632-temp-node-regs) + (:x8664 x8664-temp-node-regs))) + (*available-backend-node-temps* (target-arch-case + (:x8632 x8632-temp-node-regs) + (:x8664 x8664-temp-node-regs))) + (*backend-imm-temps* (target-arch-case + (:x8632 x8632-imm-regs) + (:x8664 x8664-imm-regs))) + (*available-backend-imm-temps* (target-arch-case + (:x8632 x8632-imm-regs) + (:x8664 x8664-imm-regs))) + (*backend-crf-temps* (target-arch-case + (:x8632 x8632-cr-fields) + (:x8664 x8664-cr-fields))) + (*available-backend-crf-temps* (target-arch-case + (:x8632 x8632-cr-fields) + (:x8664 x8664-cr-fields))) + (*backend-fp-temps* (target-arch-case + (:x8632 x8632-temp-fp-regs) + (:x8664 x8664-temp-fp-regs))) + (*available-backend-fp-temps* (target-arch-case + (:x8632 x8632-temp-fp-regs) + (:x8664 x8664-temp-fp-regs))) + (bits 0) + (*logical-register-counter* -1) + (*backend-all-lregs* ()) + (*x862-popj-labels* nil) + (*x862-popreg-labels* nil) + (*x862-valret-labels* nil) + (*x862-nilret-labels* nil) + (*x862-undo-count* 0) + (*backend-labels* (x862-make-stack 64 target::subtag-simple-vector)) + (*x862-undo-stack* (x862-make-stack 64 target::subtag-simple-vector)) + (*x862-undo-because* (x862-make-stack 64)) + (*x862-entry-label* nil) + (*x862-tail-label* nil) + (*x862-tail-vsp* nil) + (*x862-tail-nargs* nil) + (*x862-inhibit-register-allocation* nil) + (*x862-tail-allow* t) + (*x862-reckless* nil) + (*x862-full-safety* nil) + (*x862-trust-declarations* t) + (*x862-entry-vstack* nil) + (*x862-fixed-nargs* nil) + (*x862-need-nargs* t) + (fname (afunc-name afunc)) + (*x862-entry-vsp-saved-p* nil) + (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc))) + (*x862-fcells* (afunc-fcells afunc)) + *x862-recorded-symbols* + (*x862-emitted-source-notes* '())) + (set-fill-pointer + *backend-labels* + (set-fill-pointer + *x862-undo-stack* + (set-fill-pointer + *x862-undo-because* + 0))) + (backend-get-next-label) ; start @ label 1, 0 is confused with NIL in compound cd + (with-dll-node-freelist (vinsns *vinsn-freelist*) + (unwind-protect + (progn + (setq bits (x862-toplevel-form vinsns (make-wired-lreg *x862-result-reg*) + $backend-return (afunc-acode afunc))) + (do* ((constants *x862-constant-alist* (cdr constants))) + ((null constants)) + (let* ((imm (caar constants))) + (when (x862-symbol-locative-p imm) + (setf (caar constants) (car imm))))) + (optimize-vinsns vinsns) + (when (logbitp x862-debug-vinsns-bit *x862-debug-mask*) + (format t "~% vinsns for ~s (after generation)" (afunc-name afunc)) + (do-dll-nodes (v vinsns) (format t "~&~s" v)) + (format t "~%~%")) + + (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*) + (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*) + (let* ((*x86-lap-labels* nil) + (instruction (x86::make-x86-instruction)) + (end-code-tag (gensym)) + (start-tag (gensym)) + (srt-tag (gensym)) + debug-info) + (make-x86-lap-label end-code-tag) + (target-arch-case + (:x8664 + (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8) + *x86-lap-entry-offset*) -3)) + (x86-lap-directive frag-list :byte 0) ;regsave PC + (x86-lap-directive frag-list :byte 0) ;regsave ea + (x86-lap-directive frag-list :byte 0)) ;regsave mask + (:x8632 + (make-x86-lap-label start-tag) + (make-x86-lap-label srt-tag) + (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4) + *x86-lap-entry-offset*) -2)) + (emit-x86-lap-label frag-list start-tag))) + (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list) + (when (or *x862-double-float-constant-alist* + *x862-single-float-constant-alist*) + (x86-lap-directive frag-list :align 3) + (dolist (double-pair *x862-double-float-constant-alist*) + (destructuring-bind (dfloat . lab) double-pair + (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) + (multiple-value-bind (high low) + (x862-double-float-bits dfloat) + (x86-lap-directive frag-list :long low) + (x86-lap-directive frag-list :long high)))) + (dolist (single-pair *x862-single-float-constant-alist*) + (destructuring-bind (sfloat . lab) single-pair + (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) + (let* ((val (single-float-bits sfloat))) + (x86-lap-directive frag-list :long val))))) + (target-arch-case + (:x8632 + (x86-lap-directive frag-list :align 2) + ;; start of self reference table + (x86-lap-directive frag-list :long 0) + (emit-x86-lap-label frag-list srt-tag) + ;; make space for self-reference offsets + (do-dll-nodes (frag frag-list) + (dolist (reloc (frag-relocs frag)) + (when (eq (reloc-type reloc) :self) + (x86-lap-directive frag-list :long 0)))) + (x86-lap-directive frag-list :long x8632::function-boundary-marker)) + (:x8664 + (x86-lap-directive frag-list :align 3) + (x86-lap-directive frag-list :quad x8664::function-boundary-marker))) + + (emit-x86-lap-label frag-list end-code-tag) + + (dolist (c (reverse *x862-constant-alist*)) + (let* ((vinsn-label (cdr c))) + (or (vinsn-label-info vinsn-label) + (setf (vinsn-label-info vinsn-label) + (find-or-create-x86-lap-label + vinsn-label))) + (emit-x86-lap-label frag-list vinsn-label) + (target-arch-case + (:x8632 + (x86-lap-directive frag-list :long 0)) + (:x8664 + (x86-lap-directive frag-list :quad 0))))) + + (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) + (setq debug-info (afunc-lfun-info afunc)) + (when (logbitp $fbitccoverage (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit)))) + (when lambda-form + (setq debug-info + (list* 'function-lambda-expression lambda-form debug-info))) + (when *x862-recorded-symbols* + (setq debug-info + (list* 'function-symbol-map *x862-recorded-symbols* debug-info))) + (when (and (getf debug-info '%function-source-note) *x862-emitted-source-notes*) + (setq debug-info ;; Compressed below + (list* 'pc-source-map *x862-emitted-source-notes* debug-info))) + (when debug-info + (setq bits (logior (ash 1 $lfbits-info-bit) bits))) + (unless (or fname lambda-form *x862-recorded-symbols*) + (setq bits (logior (ash 1 $lfbits-noname-bit) bits))) + (unless (afunc-parent afunc) + (x862-fixup-fwd-refs afunc)) + (setf (afunc-all-vars afunc) nil) + (setf (afunc-argsword afunc) bits) + (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note) + (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*)))) + (regsave-mask (if regsave-label (x862-register-mask-byte + *x862-register-restore-count*))) + (regsave-addr (if regsave-label (x862-encode-register-save-ea + *x862-register-restore-ea* + *x862-register-restore-count*)))) + (target-arch-case + (:x8632 + (when debug-info + (x86-lap-directive frag-list :long 0)) + (when fname + (x86-lap-directive frag-list :long 0)) + (x86-lap-directive frag-list :long 0)) + (:x8664 + (when debug-info + (x86-lap-directive frag-list :quad 0)) + (when fname + (x86-lap-directive frag-list :quad 0)) + (x86-lap-directive frag-list :quad 0))) + + (relax-frag-list frag-list) + (apply-relocs frag-list) + (fill-for-alignment frag-list) + (target-arch-case + (:x8632 + (let* ((label (find-x86-lap-label srt-tag)) + (srt-frag (x86-lap-label-frag label)) + (srt-index (x86-lap-label-offset label))) + ;; fill in self-reference offsets + (do-dll-nodes (frag frag-list) + (dolist (reloc (frag-relocs frag)) + (when (eq (reloc-type reloc) :self) + (setf (frag-ref-32 srt-frag srt-index) + (+ (frag-address frag) (reloc-pos reloc))) + (incf srt-index 4))))) + ;;(show-frag-bytes frag-list) + )) + + (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) + + (when (getf debug-info 'pc-source-map) + (setf (getf debug-info 'pc-source-map) (x862-generate-pc-source-map debug-info))) + (when (getf debug-info 'function-symbol-map) + (setf (getf debug-info 'function-symbol-map) (x862-digest-symbols))) + + (setf (afunc-lfun afunc) + #+x86-target + (if (eq *host-backend* *target-backend*) + (create-x86-function fname frag-list *x862-constant-alist* bits debug-info) + (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)) + #-x86-target + (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))))))) + (backend-remove-labels)))) + afunc)) + + + + +(defun x862-make-stack (size &optional (subtype target::subtag-s16-vector)) + (make-uarray-1 subtype size t 0 nil nil nil nil t nil)) + +(defun x862-fixup-fwd-refs (afunc) + (dolist (f (afunc-inner-functions afunc)) + (x862-fixup-fwd-refs f)) + (let ((fwd-refs (afunc-fwd-refs afunc))) + (when fwd-refs + (let* ((native-x86-functions #-x86-target nil + #+x86-target (eq *target-backend* + *host-backend*)) + (v (if native-x86-functions + (function-to-function-vector (afunc-lfun afunc)) + (afunc-lfun afunc))) + (vlen (uvsize v))) + (declare (fixnum vlen)) + (dolist (ref fwd-refs) + (let* ((ref-fun (afunc-lfun ref))) + (do* ((i (if native-x86-functions + (%function-code-words + (function-vector-to-function v)) + 1) + (1+ i))) + ((= i vlen)) + (declare (fixnum i)) + (if (eq (%svref v i) ref) + (setf (%svref v i) ref-fun))))))))) + +(defun x862-generate-pc-source-map (debug-info) + (let* ((definition-source-note (getf debug-info '%function-source-note)) + (emitted-source-notes (getf debug-info 'pc-source-map)) + (def-start (source-note-start-pos definition-source-note)) + (n (length emitted-source-notes)) + (nvalid 0) + (max 0) + (pc-starts (make-array n)) + (pc-ends (make-array n)) + (text-starts (make-array n)) + (text-ends (make-array n))) + (declare (fixnum n nvalid) + (dynamic-extent pc-starts pc-ends text-starts text-ends)) + (dolist (start emitted-source-notes) + (let* ((pc-start (x862-vinsn-note-label-address start t)) + (pc-end (x862-vinsn-note-label-address (vinsn-note-peer start) nil)) + (source-note (aref (vinsn-note-info start) 0)) + (text-start (- (source-note-start-pos source-note) def-start)) + (text-end (- (source-note-end-pos source-note) def-start))) + (declare (fixnum pc-start pc-end text-start text-end)) + (when (and (plusp pc-start) + (plusp pc-end) + (plusp text-start) + (plusp text-end)) + (if (> pc-start max) (setq max pc-start)) + (if (> pc-end max) (setq max pc-end)) + (if (> text-start max) (setq max text-start)) + (if (> text-end max) (setq max text-end)) + (setf (svref pc-starts nvalid) pc-start + (svref pc-ends nvalid) pc-end + (svref text-starts nvalid) text-start + (svref text-ends nvalid) text-end) + (incf nvalid)))) + (let* ((nentries (* nvalid 4)) + (vec (cond ((< max #x100) (make-array nentries :element-type '(unsigned-byte 8))) + ((< max #x10000) (make-array nentries :element-type '(unsigned-byte 16))) + (t (make-array nentries :element-type '(unsigned-byte 32)))))) + (declare (fixnum nentries)) + (do* ((i 0 (+ i 4)) + (j 1 (+ j 4)) + (k 2 (+ k 4)) + (l 3 (+ l 4)) + (idx 0 (1+ idx))) + ((= i nentries) vec) + (declare (fixnum i j k l idx)) + (setf (aref vec i) (svref pc-starts idx) + (aref vec j) (svref pc-ends idx) + (aref vec k) (svref text-starts idx) + (aref vec l) (svref text-ends idx)))))) + +(defun x862-vinsn-note-label-address (note &optional start-p sym) + (- + (let* ((label (vinsn-note-label note)) + (lap-label (if label (vinsn-label-info label)))) + (if lap-label + (x86-lap-label-address lap-label) + (compiler-bug "Missing or bad ~s label~@[: ~s~]" + (if start-p 'start 'end) + sym))) + (target-arch-case + (:x8632 x8632::fulltag-misc) ;xxx? + (:x8664 x8664::fulltag-function)))) + +(defun x862-digest-symbols () + (when *x862-recorded-symbols* + (setq *x862-recorded-symbols* (nx2-recorded-symbols-in-arglist-order *x862-recorded-symbols* *x862-cur-afunc*)) + (let* ((symlist *x862-recorded-symbols*) + (len (length symlist)) + (syms (make-array len)) + (ptrs (make-array (%i+ (%i+ len len) len))) + (i -1) + (j -1)) + (declare (fixnum i j)) + (dolist (info symlist (progn (%rplaca symlist syms) + (%rplacd symlist ptrs))) + (destructuring-bind (var sym startlab endlab) info + (let* ((ea (var-ea var)) + (ea-val (ldb (byte 16 0) ea))) + (setf (aref ptrs (incf i)) (if (memory-spec-p ea) + (logior (ash ea-val 6) #o77) + ea-val))) + (setf (aref syms (incf j)) sym) + (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address startlab t sym)) + (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address endlab nil sym)))) + *x862-recorded-symbols*))) + +(defun x862-decls (decls) + (if (fixnump decls) + (locally (declare (fixnum decls)) + (setq *x862-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls)) + *x862-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls)) + *x862-full-safety* (neq 0 (%ilogand2 $decl_full_safety decls)) + *x862-reckless* (neq 0 (%ilogand2 $decl_unsafe decls)) + *x862-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls)))))) + + + +;;; Vpush the last N non-volatile-registers. +(defun x862-save-nvrs (seg n) + (declare (fixnum n)) + (target-arch-case + ;; no nvrs on x8632 + (:x8664 + (when (> n 0) + (setq *x862-compiler-register-save-label* (x862-emit-note seg :regsave)) + (with-x86-local-vinsn-macros (seg) + (let* ((mask x8664-nonvolatile-node-regs)) + (dotimes (i n) + (let* ((reg (1- (integer-length mask)))) + (x862-vpush-register seg reg :regsave reg 0) + (setq mask (logandc2 mask (ash 1 reg))))))) + (setq *x862-register-restore-ea* *x862-vstack* + *x862-register-restore-count* n))))) + + +;;; If there are an indefinite number of args/values on the vstack, +;;; we have to restore from a register that matches the compiler's +;;; notion of the vstack depth. This can be computed by the caller +;;; (sum of vsp & nargs, or copy of vsp before indefinite number of +;;; args pushed, etc.) + + +(defun x862-restore-nvrs (seg ea nregs &optional (can-pop t)) + (target-arch-case + ;; no nvrs on x8632 + (:x8664 + (when (and ea nregs) + (with-x86-local-vinsn-macros (seg) + (let* ((mask x8664-nonvolatile-node-regs) + (regs ())) + (dotimes (i nregs) + (let* ((reg (1- (integer-length mask)))) + (push reg regs) + (setq mask (logandc2 mask (ash 1 reg))))) + (cond (can-pop + (let* ((diff-in-bytes (- *x862-vstack* ea))) + (unless (zerop diff-in-bytes) + (x862-adjust-vstack diff-in-bytes) + (! vstack-discard (floor diff-in-bytes *x862-target-node-size*))) + (dolist (reg regs) + (! vpop-register reg)))) + (t + (dolist (reg regs) + (! vframe-load reg (- ea *x862-target-node-size*) ea) + (decf ea *x862-target-node-size*)))))))))) + + +(defun x862-bind-lambda (seg lcells req opt rest keys auxen optsupvloc passed-in-regs lexpr &optional inherited + &aux (vloc 0) (numopt (list-length (%car opt))) + (nkeys (list-length (%cadr keys))) + reg) + (declare (fixnum vloc)) + (x862-check-lcell-depth) + (dolist (arg inherited) + (if (memq arg passed-in-regs) + (x862-set-var-ea seg arg (var-ea arg)) + (let* ((lcell (pop lcells))) + (if (setq reg (nx2-assign-register-var arg)) + (x862-init-regvar seg arg reg (x862-vloc-ea vloc)) + (x862-bind-var seg arg vloc lcell)) + (setq vloc (%i+ vloc *x862-target-node-size*))))) + (dolist (arg req) + (if (memq arg passed-in-regs) + (x862-set-var-ea seg arg (var-ea arg)) + (let* ((lcell (pop lcells))) + (if (setq reg (nx2-assign-register-var arg)) + (x862-init-regvar seg arg reg (x862-vloc-ea vloc)) + (x862-bind-var seg arg vloc lcell)) + (setq vloc (%i+ vloc *x862-target-node-size*))))) + (when opt + (if (x862-hard-opt-p opt) + (setq vloc (apply #'x862-initopt seg vloc optsupvloc lcells (nthcdr (- (length lcells) numopt) lcells) opt) + lcells (nthcdr numopt lcells)) + + (dolist (var (%car opt)) + (if (memq var passed-in-regs) + (x862-set-var-ea seg var (var-ea var)) + (let* ((lcell (pop lcells))) + (if (setq reg (nx2-assign-register-var var)) + (x862-init-regvar seg var reg (x862-vloc-ea vloc)) + (x862-bind-var seg var vloc lcell)) + (setq vloc (+ vloc *x862-target-node-size*))))))) + + (when rest + (if lexpr + (progn + (if (setq reg (nx2-assign-register-var rest)) + (progn + (x862-copy-register seg reg *x862-arg-z*) + (x862-set-var-ea seg rest reg)) + (let* ((loc *x862-vstack*)) + (x862-vpush-register seg *x862-arg-z* :reserved) + (x862-note-top-cell rest) + (x862-bind-var seg rest loc *x862-top-vstack-lcell*)))) + (let* ((rvloc (+ vloc (* 2 *x862-target-node-size* nkeys)))) + (if (setq reg (nx2-assign-register-var rest)) + (x862-init-regvar seg rest reg (x862-vloc-ea rvloc)) + (x862-bind-var seg rest rvloc (pop lcells)))))) + (when keys + (apply #'x862-init-keys seg vloc lcells keys)) + (x862-seq-bind seg (%car auxen) (%cadr auxen))) + + +(defun x862-initopt (seg vloc spvloc lcells splcells vars inits spvars) + (with-x86-local-vinsn-macros (seg) + (dolist (var vars vloc) + (let* ((initform (pop inits)) + (spvar (pop spvars)) + (lcell (pop lcells)) + (splcell (pop splcells)) + (reg (nx2-assign-register-var var)) + (regloadedlabel (if reg (backend-get-next-label)))) + (unless (nx-null initform) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea spvloc) x86::x86-e-bits t)) + (if reg + (x862-form seg reg regloadedlabel initform) + (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc))) + (@ skipinitlabel))) + (if reg + (progn + (x862-init-regvar seg var reg (x862-vloc-ea vloc)) + (@ regloadedlabel)) + (x862-bind-var seg var vloc lcell)) + (when spvar + (if (setq reg (nx2-assign-register-var spvar)) + (x862-init-regvar seg spvar reg (x862-vloc-ea spvloc)) + (x862-bind-var seg spvar spvloc splcell)))) + (setq vloc (%i+ vloc *x862-target-node-size*)) + (if spvloc (setq spvloc (%i+ spvloc *x862-target-node-size*)))))) + +(defun x862-init-keys (seg vloc lcells allow-others keyvars keysupp keyinits keykeys) + (declare (ignore keykeys allow-others)) + (with-x86-local-vinsn-macros (seg) + (dolist (var keyvars) + (let* ((spvar (pop keysupp)) + (initform (pop keyinits)) + (reg (nx2-assign-register-var var)) + (regloadedlabel (if reg (backend-get-next-label))) + (var-lcell (pop lcells)) + (sp-lcell (pop lcells)) + (sploc (%i+ vloc *x862-target-node-size*))) + (unless (nx-null initform) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea sploc) x86::x86-e-bits t)) + (if reg + (x862-form seg reg regloadedlabel initform) + (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc))) + (@ skipinitlabel))) + (if reg + (progn + (x862-init-regvar seg var reg (x862-vloc-ea vloc)) + (@ regloadedlabel)) + (x862-bind-var seg var vloc var-lcell)) + (when spvar + (if (setq reg (nx2-assign-register-var spvar)) + (x862-init-regvar seg spvar reg (x862-vloc-ea sploc)) + (x862-bind-var seg spvar sploc sp-lcell)))) + (setq vloc (%i+ vloc (* 2 *x862-target-node-size*)))))) + +;;; Vpush register r, unless var gets a globally-assigned register. +;;; Return NIL if register was vpushed, else var. +(defun x862-vpush-arg-register (seg reg var) + (when var + (if (var-nvr var) + var + (progn + (x862-vpush-register seg reg :reserved) + nil)))) + + +;;; nargs has been validated, arguments defaulted and canonicalized. +;;; Save caller's context, then vpush any argument registers that +;;; didn't get global registers assigned to their variables. +;;; Return a list of vars/nils for each argument register +;;; (nil if vpushed, var if still in arg_reg). +(defun x862-argregs-entry (seg revargs &optional variable-args-entry) + (with-x86-local-vinsn-macros (seg) + (let* ((nargs (length revargs)) + (reg-vars ())) + (declare (type (unsigned-byte 16) nargs)) + (unless variable-args-entry + (if (<= nargs *x862-target-num-arg-regs*) ; caller didn't vpush anything + (! save-lisp-context-no-stack-args) + (let* ((offset (* (the fixnum (- nargs *x862-target-num-arg-regs*)) *x862-target-node-size*))) + (declare (fixnum offset)) + (! save-lisp-context-offset offset)))) + (target-arch-case + (:x8632 + (destructuring-bind (&optional zvar yvar &rest stack-args) revargs + (let* ((nstackargs (length stack-args))) + (x862-set-vstack (* nstackargs *x862-target-node-size*)) + (dotimes (i nstackargs) + (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)) + (if (>= nargs 2) + (push (x862-vpush-arg-register seg ($ *x862-arg-y*) yvar) reg-vars)) + (if (>= nargs 1) + (push (x862-vpush-arg-register seg ($ *x862-arg-z*) zvar) reg-vars))))) + (:x8664 + (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs + (let* ((nstackargs (length stack-args))) + (x862-set-vstack (* nstackargs *x862-target-node-size*)) + (dotimes (i nstackargs) + (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)) + (if (>= nargs 3) + (push (x862-vpush-arg-register seg ($ x8664::arg_x) xvar) reg-vars)) + (if (>= nargs 2) + (push (x862-vpush-arg-register seg ($ *x862-arg-y*) yvar) reg-vars)) + (if (>= nargs 1) + (push (x862-vpush-arg-register seg ($ *x862-arg-z*) zvar) reg-vars)))))) + reg-vars))) + +;;; Just required args. +;;; Since this is just a stupid bootstrapping port, always save +;;; lisp context. +(defun x862-req-nargs-entry (seg rev-fixed-args) + (let* ((nargs (length rev-fixed-args))) + (declare (type (unsigned-byte 16) nargs)) + (with-x86-local-vinsn-macros (seg) + (unless *x862-reckless* + (! check-exact-nargs nargs)) + (x862-argregs-entry seg rev-fixed-args)))) + +;;; No more &optional args than register args; all &optionals default +;;; to NIL and none have supplied-p vars. No &key/&rest. +(defun x862-simple-opt-entry (seg rev-opt-args rev-req-args) + (let* ((min (length rev-req-args)) + (nopt (length rev-opt-args)) + (max (+ min nopt))) + (declare (type (unsigned-byte 16) min nopt max)) + (with-x86-local-vinsn-macros (seg) + (unless *x862-reckless* + (if rev-req-args + (! check-min-max-nargs min max) + (! check-max-nargs max))) + (if (> min *x862-target-num-arg-regs*) + (! save-lisp-context-in-frame) + (if (<= max *x862-target-num-arg-regs*) + (! save-lisp-context-no-stack-args) + (! save-lisp-context-variable-arg-count))) + (if (= nopt 1) + (! default-1-arg min) + (if (= nopt 2) + (! default-2-args min) + (! default-3-args min))) + (x862-argregs-entry seg (append rev-opt-args rev-req-args) t)))) + +;;; if "num-fixed" is > 0, we've already ensured that at least that many args +;;; were provided; that may enable us to generate better code for saving the +;;; argument registers. +;;; We're responsible for computing the caller's VSP and saving +;;; caller's state. +(defun x862-lexpr-entry (seg num-fixed) + (with-x86-local-vinsn-macros (seg) + (! save-lexpr-argregs num-fixed) + ;; The "lexpr" (address of saved nargs register, basically + ;; is now in arg_z + (! build-lexpr-frame) + (dotimes (i num-fixed) + (! copy-lexpr-argument (- num-fixed i))))) + + +(defun x862-structured-initopt (seg lcells vloc context vars inits spvars) + (with-x86-local-vinsn-macros (seg) + (dolist (var vars vloc) + (let* ((initform (pop inits)) + (spvar (pop spvars)) + (spvloc (%i+ vloc *x862-target-node-size*)) + (var-lcell (pop lcells)) + (sp-lcell (pop lcells))) + (unless (nx-null initform) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea spvloc) x86::x86-e-bits t)) + (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc)) + (@ skipinitlabel))) + (x862-bind-structured-var seg var vloc var-lcell context) + (when spvar + (x862-bind-var seg spvar spvloc sp-lcell))) + (setq vloc (%i+ vloc (* 2 *x862-target-node-size*)))))) + + + +(defun x862-structured-init-keys (seg lcells vloc context allow-others keyvars keysupp keyinits keykeys) + (declare (ignore keykeys allow-others)) + (with-x86-local-vinsn-macros (seg) + (dolist (var keyvars) + (let* ((spvar (pop keysupp)) + (initform (pop keyinits)) + (sploc (%i+ vloc *x862-target-node-size*)) + (var-lcell (pop lcells)) + (sp-reg ($ *x862-arg-z*)) + (sp-lcell (pop lcells))) + (unless (nx-null initform) + (x862-stack-to-register seg (x862-vloc-ea sploc) sp-reg) + (let ((skipinitlabel (backend-get-next-label))) + (with-crf-target () crf + (x862-compare-register-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) sp-reg x86::x86-e-bits t)) + (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc)) + (@ skipinitlabel))) + (x862-bind-structured-var seg var vloc var-lcell context) + (when spvar + (x862-bind-var seg spvar sploc sp-lcell))) + (setq vloc (%i+ vloc (* 2 *x862-target-node-size*)))))) + +(defun x862-vloc-ea (n &optional vcell-p) + (setq n (make-memory-spec (dpb memspec-frame-address memspec-type-byte n))) + (if vcell-p + (make-vcell-memory-spec n) + n)) + + +(defun x862-acode-operator-function (form) + (or (and (acode-p form) + (svref *x862-specials* (%ilogand #.operator-id-mask (acode-operator form)))) + (compiler-bug "x862-form ? ~s" form))) + +(defmacro with-note ((form-var seg-var) &body body) + (let* ((note (gensym "NOTE")) + (code-note (gensym "CODE-NOTE")) + (source-note (gensym "SOURCE-NOTE")) + (start (gensym "START")) + (end (gensym "END"))) + `(let* ((,note (acode-note ,form-var)) + (,code-note (and (code-note-p ,note) ,note)) + (,source-note (if ,code-note + (code-note-source-note ,note) + ,note)) + (,start (and ,source-note + (x862-emit-note ,seg-var :source-location-begin ,source-note)))) + #+debug-code-notes (require-type ,note '(or null code-note source-note)) + (when ,code-note + (with-x86-local-vinsn-macros (,seg-var) + (x862-store-immediate ,seg-var ,code-note *x862-codecoverage-reg*) + (! misc-set-immediate-c-node 0 *x862-codecoverage-reg* 1))) + (prog1 + (progn + ,@body) + (when ,source-note + (let ((,end (x862-emit-note ,seg-var :source-location-end))) + (setf (vinsn-note-peer ,start) ,end + (vinsn-note-peer ,end) ,start) + (push ,start *x862-emitted-source-notes*))))))) + +(defun x862-toplevel-form (seg vreg xfer form) + (let* ((code-note (acode-note form)) + (args (if code-note `(,@(%cdr form) ,code-note) (%cdr form)))) + (apply (x862-acode-operator-function form) seg vreg xfer args))) + +(defun x862-form (seg vreg xfer form) + (with-note (form seg) + (if (nx-null form) + (x862-nil seg vreg xfer) + (if (nx-t form) + (x862-t seg vreg xfer) + (let* ((fn (x862-acode-operator-function form)) ;; also typechecks + (op (acode-operator form))) + (if (and (null vreg) + (%ilogbitp operator-acode-subforms-bit op) + (%ilogbitp operator-assignment-free-bit op)) + (dolist (f (%cdr form) (x862-branch seg xfer)) + (x862-form seg nil nil f )) + (apply fn seg vreg xfer (%cdr form)))))))) + +;;; dest is a float reg - form is acode +(defun x862-form-float (seg freg xfer form) + (declare (ignore xfer)) + (with-note (form seg) + (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form)) + (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double) + (x862-form-typep form 'double-float)) + ;; kind of screwy - encoding the source type in the dest register spec + (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double)) + (let* ((fn (x862-acode-operator-function form))) + (apply fn seg freg nil (%cdr form))))) + + +(defun x862-form-typep (form type) + (acode-form-typep form type *x862-trust-declarations*) +) + +(defun x862-form-type (form) + (acode-form-type form *x862-trust-declarations*)) + +(defun x862-use-operator (op seg vreg xfer &rest forms) + (declare (dynamic-extent forms)) + (apply (svref *x862-specials* (%ilogand operator-id-mask op)) seg vreg xfer forms)) + + +(defun x862-check-fixnum-overflow (seg target &optional labelno) + (with-x86-local-vinsn-macros (seg) + (if *x862-open-code-inline* + (let* ((no-overflow (backend-get-next-label))) + (! handle-fixnum-overflow-inline target (aref *backend-labels* (or labelno no-overflow))) + (when labelno (-> labelno)) + (@ no-overflow)) + (if labelno + (! fix-fixnum-overflow-ool-and-branch target (aref *backend-labels* labelno)) + (! fix-fixnum-overflow-ool target))))) + +(defun x862-nil (seg vreg xfer) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if (eq vreg :push) + (progn + (! vpush-fixnum (target-nil-value)) + (^)) + (progn + (if (x862-for-value-p vreg) + (ensuring-node-target (target vreg) + (! load-nil target))) + (x862-branch seg (x862-cd-false xfer)))))) + +(defun x862-t (seg vreg xfer) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if (eq vreg :push) + (progn + (! vpush-fixnum (target-t-value)) + (^)) + (progn + (if (x862-for-value-p vreg) + (ensuring-node-target (target vreg) + (! load-t target))) + (x862-branch seg (x862-cd-true xfer)))))) + +(defun x862-for-value-p (vreg) + (and vreg (not (backend-crf-p vreg)))) + +(defun x862-mvpass (seg form &optional xfer) + (with-x86-local-vinsn-macros (seg) + (x862-form seg ($ *x862-arg-z*) (logior (or xfer 0) $backend-mvpass-mask) form))) + +(defun x862-adjust-vstack (delta) + (x862-set-vstack (%i+ *x862-vstack* delta))) + +(defun x862-set-vstack (new) + (setq *x862-vstack* (or new 0))) + + +;;; Emit a note at the end of the segment. +(defun x862-emit-note (seg class &rest info) + (declare (dynamic-extent info)) + (let* ((note (make-vinsn-note class info))) + (append-dll-node (vinsn-note-label note) seg) + note)) + +;;; Emit a note immediately before the target vinsn. +(defun x86-prepend-note (vinsn class &rest info) + (declare (dynamic-extent info)) + (let* ((note (make-vinsn-note class info))) + (insert-dll-node-before (vinsn-note-label note) vinsn) + note)) + +(defun x862-close-note (seg note) + (let* ((end (close-vinsn-note note))) + (append-dll-node (vinsn-note-label end) seg) + end)) + + + + + + +(defun x862-stack-to-register (seg memspec reg) + (with-x86-local-vinsn-macros (seg) + (let* ((offset (memspec-frame-address-offset memspec))) + (if (and *x862-tos-reg* + (= offset (- *x862-vstack* *x862-target-node-size*))) + (x862-copy-register seg reg *x862-tos-reg*) + (! vframe-load reg offset *x862-vstack*))))) + +(defun x862-lcell-to-register (seg lcell reg) + (with-x86-local-vinsn-macros (seg) + (! lcell-load reg lcell (x862-vstack-mark-top)))) + +(defun x862-register-to-lcell (seg reg lcell) + (with-x86-local-vinsn-macros (seg) + (! lcell-store reg lcell (x862-vstack-mark-top)))) + +(defun x862-register-to-stack (seg reg memspec) + (with-x86-local-vinsn-macros (seg) + (! vframe-store reg (memspec-frame-address-offset memspec) *x862-vstack*))) + + +(defun x862-ea-open (ea) + (if (and ea (not (typep ea 'lreg)) (addrspec-vcell-p ea)) + (make-memory-spec (memspec-frame-address-offset ea)) + ea)) + +(defun x862-set-NARGS (seg n) + (if (> n call-arguments-limit) + (error "~s exceeded." call-arguments-limit) + (with-x86-local-vinsn-macros (seg) + (! set-nargs n)))) + + + +(defun x862-single-float-bits (the-sf) + (single-float-bits the-sf)) + +(defun x862-double-float-bits (the-df) + (double-float-bits the-df)) + +(defun x862-push-immediate (seg xfer form) + (with-x86-local-vinsn-macros (seg) + (if (typep form 'character) + (! vpush-fixnum (logior (ash (char-code form) 8) + (arch::target-subtag-char (backend-target-arch *target-backend*)))) + (let* ((reg (x862-register-constant-p form))) + (if reg + (! vpush-register reg) + (let* ((lab (x86-immediate-label form))) + (! vpush-constant lab))))) + (x862-branch seg xfer))) + + +(pushnew (%nx1-operator immediate) *x862-operator-supports-push*) +(defun x862-immediate (seg vreg xfer form) + (if (eq vreg :push) + (x862-push-immediate seg xfer form) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if vreg + (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr) + (or (and (typep form 'double-float) (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double)) + (and (typep form 'short-float)(= (get-regspec-mode vreg) hard-reg-class-fpr-mode-single)))) + (if (zerop form) + (if (eql form 0.0d0) + (! zero-double-float-register vreg) + (! zero-single-float-register vreg)) + (if (typep form 'short-float) + (let* ((lab (x86-single-float-constant-label form))) + (! load-single-float-constant vreg lab)) + (let* ((lab (x86-double-float-constant-label form))) + (! load-double-float-constant vreg lab)))) + (target-arch-case + (:x8632 + (if (and (= (hard-regspec-class vreg) hard-reg-class-gpr) + (member (get-regspec-mode vreg) + '(hard-reg-class-gpr-mode-u32 + hard-reg-class-gpr-mode-s32 + hard-reg-class-gpr-mode-address)) + (or (typep form '(unsigned-byte 32)) + (typep form '(signed-byte 32)))) + ;; The bits fit. Get them in the register somehow. + (if (typep form '(signed-byte 32)) + (x862-lri seg vreg form) + (x862-lriu seg vreg form)) + (ensuring-node-target (target vreg) + (if (characterp form) + (! load-character-constant target (char-code form)) + (x862-store-immediate seg form target))))) + (:x8664 + (if (and (typep form '(unsigned-byte 32)) + (= (hard-regspec-class vreg) hard-reg-class-gpr) + (= (get-regspec-mode vreg) + hard-reg-class-gpr-mode-u32)) + (x862-lri seg vreg form) + (ensuring-node-target + (target vreg) + (if (characterp form) + (! load-character-constant target (char-code form)) + (x862-store-immediate seg form target))))))) + (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*)) + (x862-store-immediate seg form ($ *x862-temp0*)))) + (^)))) + +(defun x862-register-constant-p (form) + (and (consp form) + (or (memq form *x862-vcells*) + (memq form *x862-fcells*)) + (%cdr form))) + +(defun x862-store-immediate (seg imm dest) + (with-x86-local-vinsn-macros (seg) + (let* ((reg (x862-register-constant-p imm))) + (if reg + (x862-copy-register seg dest reg) + (let* ((lab (x86-immediate-label imm))) + (! ref-constant dest lab))) + dest))) + + +;;; Returns label iff form is (local-go ) and can go without adjusting stack. +(defun x862-go-label (form) + (let ((current-stack (x862-encode-stack))) + (while (and (acode-p form) (or (eq (acode-operator form) (%nx1-operator progn)) + (eq (acode-operator form) (%nx1-operator local-tagbody)))) + (setq form (caadr form))) + (when (acode-p form) + (let ((op (acode-operator form))) + (if (and (eq op (%nx1-operator local-go)) + (x862-equal-encodings-p (%caddr (%cadr form)) current-stack)) + (%cadr (%cadr form)) + (if (and (eq op (%nx1-operator local-return-from)) + (nx-null (caddr form))) + (let ((tagdata (car (cadr form)))) + (and (x862-equal-encodings-p (cdr tagdata) current-stack) + (null (caar tagdata)) + (< 0 (cdar tagdata) $backend-mvpass) + (cdar tagdata))))))))) + +(defun x862-single-valued-form-p (form) + (setq form (acode-unwrapped-form-value form)) + (or (nx-null form) + (nx-t form) + (if (acode-p form) + (let ((op (acode-operator form))) + (or (%ilogbitp operator-single-valued-bit op) + (and (eql op (%nx1-operator values)) + (let ((values (cadr form))) + (and values (null (cdr values))))) + nil ; Learn about functions someday + ))))) + +(defun x862-box-s32 (seg node-dest s32-src) + (with-x86-local-vinsn-macros (seg) + (target-arch-case + (:x8632 + (let* ((arg_z ($ *x862-arg-z*)) + (imm0 ($ *x862-imm0* :mode :s32))) + (x862-copy-register seg imm0 s32-src) + (! call-subprim (subprim-name->offset '.SPmakes32)) + (x862-copy-register seg node-dest arg_z))) + (:x8664 + (! box-fixnum node-dest s32-src))))) + +(defun x862-box-s64 (seg node-dest s64-src) + (with-x86-local-vinsn-macros (seg) + (if (target-arch-case + (:x8632 (error "bug")) + (:x8664 *x862-open-code-inline*)) + (let* ((no-overflow (backend-get-next-label))) + (! %set-z-flag-if-s64-fits-in-fixnum node-dest s64-src) + (! cbranch-true (aref *backend-labels* no-overflow) x86::x86-e-bits) + (! setup-bignum-alloc-for-s64-overflow s64-src) + (! %allocate-uvector node-dest) + (! set-bigits-after-fixnum-overflow node-dest) + (@ no-overflow)) + (let* ((arg_z ($ *x862-arg-z*)) + (imm0 (make-wired-lreg *x862-imm0* :mode (get-regspec-mode s64-src)))) + (x862-copy-register seg imm0 s64-src) + (! call-subprim (subprim-name->offset '.SPmakes64)) + (x862-copy-register seg node-dest arg_z))))) + +(defun x862-box-u32 (seg node-dest u32-src) + (with-x86-local-vinsn-macros (seg) + (target-arch-case + (:x8632 + (let* ((arg_z ($ *x862-arg-z*)) + (imm0 ($ *x862-imm0* :mode :u32))) + (x862-copy-register seg imm0 u32-src) + (! call-subprim (subprim-name->offset '.SPmakeu32)) + (x862-copy-register seg node-dest arg_z))) + (:x8664 + (! box-fixnum node-dest u32-src))))) + +(defun x862-box-u64 (seg node-dest u64-src) + (with-x86-local-vinsn-macros (seg) + (if (target-arch-case + (:x8632 (error "bug")) + (:x8664 *x862-open-code-inline*)) + (let* ((no-overflow (backend-get-next-label))) + (! %set-z-flag-if-u64-fits-in-fixnum node-dest u64-src) + (! cbranch-true (aref *backend-labels* no-overflow) x86::x86-e-bits) + (! setup-bignum-alloc-for-u64-overflow u64-src) + (! %allocate-uvector node-dest) + (! set-bigits-after-fixnum-overflow node-dest) + (@ no-overflow)) + (let* ((arg_z ($ *x862-arg-z*)) + (imm0 ($ *x862-imm0* :mode :u64))) + (x862-copy-register seg imm0 u64-src) + (! call-subprim (subprim-name->offset '.SPmakeu64)) + (x862-copy-register seg node-dest arg_z))))) + +(defun x862-single->heap (seg dest src) + (with-x86-local-vinsn-macros (seg) + (! setup-single-float-allocation) + (! %allocate-uvector dest) + (! set-single-float-value dest src))) + +(defun x862-double->heap (seg dest src) + (with-x86-local-vinsn-macros (seg) + (! setup-double-float-allocation) + (! %allocate-uvector dest) + (! set-double-float-value dest src))) + + +(defun x862-vref1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum) + (with-x86-local-vinsn-macros (seg vreg xfer) + (when vreg + (let* ((arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch))) + + (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) + (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) + (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) + (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) + (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))) + (vreg-class (and (not (eq vreg :push)) (hard-regspec-class vreg))) + (vreg-mode + (if (or (eql vreg-class hard-reg-class-gpr) + (eql vreg-class hard-reg-class-fpr)) + (get-regspec-mode vreg) + hard-reg-class-gpr-mode-invalid))) + (cond + (is-node + (if (eq vreg :push) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! push-misc-ref-c-node src index-known-fixnum) + (! push-misc-ref-node src unscaled-idx)) + (ensuring-node-target (target vreg) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! misc-ref-c-node target src index-known-fixnum) + (if unscaled-idx + (! misc-ref-node target src unscaled-idx) + (with-node-target (src) unscaled-idx + (x862-absolute-natural seg unscaled-idx nil (ash index-known-fixnum *x862-target-fixnum-shift*)) + (! misc-ref-node target src unscaled-idx))))))) + (is-32-bit + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch))) + (case type-keyword + (:single-float-vector + (with-fp-target () (fp-val :single-float) + (if (and (eql vreg-class hard-reg-class-fpr) + (eql vreg-mode hard-reg-class-fpr-mode-single)) + (setq fp-val vreg)) + (! misc-ref-c-single-float fp-val src index-known-fixnum) + (if (eql vreg-class hard-reg-class-fpr) + (<- fp-val) + (ensuring-node-target (target vreg) + (target-arch-case + (:x8632 (x862-single->heap seg target fp-val)) + (:x8664 (! single->node target fp-val))))))) + (:signed-32-bit-vector + (with-imm-target () (s32-reg :s32) + (if (eql vreg-mode hard-reg-class-gpr-mode-s32) + (setq s32-reg vreg)) + (! misc-ref-c-s32 s32-reg src index-known-fixnum) + (unless (eq vreg s32-reg) + (ensuring-node-target (target vreg) + (x862-box-s32 seg target s32-reg))))) + (:unsigned-32-bit-vector + (with-imm-target () (u32-reg :u32) + (if (eql vreg-mode hard-reg-class-gpr-mode-u32) + (setq u32-reg vreg)) + (! misc-ref-c-u32 u32-reg src index-known-fixnum) + (unless (eq vreg u32-reg) + (ensuring-node-target (target vreg) + (x862-box-u32 seg target u32-reg))))) + (t + (with-imm-target () temp + (if is-signed + (! misc-ref-c-s32 temp src index-known-fixnum) + (! misc-ref-c-u32 temp src index-known-fixnum)) + (ensuring-node-target (target vreg) + (if (eq type-keyword :simple-string) + (! u32->char target temp) + (if is-signed + (x862-box-s32 seg target temp) + (x862-box-u32 seg target temp))))))) + (with-imm-target () idx-reg + (if index-known-fixnum + (x862-absolute-natural seg idx-reg nil (ash index-known-fixnum 2)) + (! scale-32bit-misc-index idx-reg unscaled-idx)) + (case type-keyword + (:single-float-vector + (with-fp-target () (fp-val :single-float) + (if (and (eql vreg-class hard-reg-class-fpr) + (eql vreg-mode hard-reg-class-fpr-mode-single)) + (setq fp-val vreg)) + (! misc-ref-single-float fp-val src idx-reg) + (if (eq vreg-class hard-reg-class-fpr) + (<- fp-val) + (ensuring-node-target (target vreg) + (target-arch-case + (:x8632 (x862-single->heap seg target fp-val)) + (:x8664 (! single->node target fp-val))))))) + (:signed-32-bit-vector + (with-imm-target () (s32-reg :s32) + (if (eql vreg-mode hard-reg-class-gpr-mode-s32) + (setq s32-reg vreg)) + (! misc-ref-s32 s32-reg src idx-reg) + (unless (eq vreg s32-reg) + (ensuring-node-target (target vreg) + (x862-box-s32 seg target s32-reg))))) + (:unsigned-32-bit-vector + (with-imm-target () (u32-reg :u32) + (if (eql vreg-mode hard-reg-class-gpr-mode-u32) + (setq u32-reg vreg)) + (! misc-ref-u32 u32-reg src idx-reg) + (unless (eq vreg u32-reg) + (ensuring-node-target (target vreg) + (x862-box-u32 seg target u32-reg))))) + (t + (with-imm-target () temp + (if is-signed + (! misc-ref-s32 temp src idx-reg) + (! misc-ref-u32 temp src idx-reg)) + (ensuring-node-target (target vreg) + (if (eq type-keyword :simple-string) + (! u32->char target temp) + (if is-signed + (x862-box-s32 seg target temp) + (x862-box-u32 seg target temp)))))))))) + (is-8-bit + (with-imm-target () temp + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch))) + (if is-signed + (! misc-ref-c-s8 temp src index-known-fixnum) + (! misc-ref-c-u8 temp src index-known-fixnum)) + (with-additional-imm-reg () + (with-imm-target () idx-reg + (if index-known-fixnum + (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum)) + (! scale-8bit-misc-index idx-reg unscaled-idx)) + (if is-signed + (! misc-ref-s8 temp src idx-reg) + (! misc-ref-u8 temp src idx-reg))))) + (if (eq type-keyword :simple-string) + (ensuring-node-target (target vreg) + (! u32->char target temp)) + (if (and (= vreg-mode hard-reg-class-gpr-mode-u8) + (eq type-keyword :unsigned-8-bit-vector)) + (x862-copy-register seg vreg temp) + (ensuring-node-target (target vreg) + (! box-fixnum target temp)))))) + (is-16-bit + (with-imm-target () temp + (ensuring-node-target (target vreg) + (if (and index-known-fixnum + (<= index-known-fixnum (arch::target-max-16-bit-constant-index arch))) + (if is-signed + (! misc-ref-c-s16 temp src index-known-fixnum) + (! misc-ref-c-u16 temp src index-known-fixnum)) + (with-imm-target () idx-reg + (if index-known-fixnum + (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1))) + (! scale-16bit-misc-index idx-reg unscaled-idx)) + (if is-signed + (! misc-ref-s16 temp src idx-reg) + (! misc-ref-u16 temp src idx-reg)))) + (! box-fixnum target temp)))) + ;; Down to the dregs. + (is-64-bit + (with-node-target (src) extra + (unless unscaled-idx (setq unscaled-idx extra))) + (case type-keyword + (:double-float-vector + (with-fp-target () (fp-val :double-float) + (if (and (eql vreg-class hard-reg-class-fpr) + (eql vreg-mode hard-reg-class-fpr-mode-double)) + (setq fp-val vreg)) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! misc-ref-c-double-float fp-val src index-known-fixnum) + (progn + (if index-known-fixnum + (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))) + (! misc-ref-double-float fp-val src unscaled-idx))) + (if (eq vreg-class hard-reg-class-fpr) + (<- fp-val) + (ensuring-node-target (target vreg) + (x862-double->heap seg target fp-val))))) + ((:signed-64-bit-vector :fixnum-vector) + (ensuring-node-target (target vreg) + + (with-imm-target () (s64-reg :s64) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! misc-ref-c-s64 s64-reg src index-known-fixnum) + (progn + (if index-known-fixnum + (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))) + (! misc-ref-s64 s64-reg src unscaled-idx))) + (if (eq type-keyword :fixnum-vector) + (! box-fixnum target s64-reg) + (x862-box-s64 seg target s64-reg))))) + (t + (with-imm-target () (u64-reg :u64) + (if (eql vreg-mode hard-reg-class-gpr-mode-u64) + (setq u64-reg vreg)) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! misc-ref-c-u64 u64-reg src index-known-fixnum) + (progn + (if index-known-fixnum + (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))) + (! misc-ref-u64 u64-reg src unscaled-idx))) + (unless (eq u64-reg vreg) + (ensuring-node-target (target vreg) + (x862-box-u64 seg target u64-reg))))))) + (t + (unless is-1-bit + (nx-error "~& unsupported vector type: ~s" + type-keyword)) + (ensuring-node-target (target vreg) + (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch))) + (! misc-ref-c-bit-fixnum target src index-known-fixnum) + (with-imm-target () bitnum + (if index-known-fixnum + (x862-lri seg bitnum index-known-fixnum) + (! scale-1bit-misc-index bitnum unscaled-idx)) + (! nref-bit-vector-fixnum target bitnum src)))))))) + (^))) + + + +;;; safe = T means assume "vector" is miscobj, do bounds check. +;;; safe = fixnum means check that subtag of vector = "safe" and do +;;; bounds check. +;;; safe = nil means crash&burn. +;;; This mostly knows how to reference the elements of an immediate miscobj. +(defun x862-vref (seg vreg xfer type-keyword vector index safe) + (with-x86-local-vinsn-macros (seg vreg xfer) + (when *x862-full-safety* + (unless vreg (setq vreg *x862-arg-z*))) + (if (null vreg) + (progn + (x862-form seg nil nil vector) + (x862-form seg nil xfer index)) + (let* ((index-known-fixnum (acode-fixnum-form-p index)) + (unscaled-idx nil) + (src nil)) + (if (or safe (not index-known-fixnum)) + (multiple-value-setq (src unscaled-idx) + (x862-two-untargeted-reg-forms seg vector *x862-arg-y* index *x862-arg-z*)) + (setq src (x862-one-untargeted-reg-form seg vector *x862-arg-z*))) + (when safe + (if (typep safe 'fixnum) + (! trap-unless-typecode= src safe)) + (unless index-known-fixnum + (! trap-unless-fixnum unscaled-idx)) + (! check-misc-bound unscaled-idx src)) + (x862-vref1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum))))) + + + +(defun x862-aset2 (seg vreg xfer array i j new safe type-keyword dim0 dim1) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (with-x86-local-vinsn-macros (seg target) + (let* ((i-known-fixnum (acode-fixnum-form-p i)) + (j-known-fixnum (acode-fixnum-form-p j)) + (arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (constval (x862-constant-value-ok-for-type-keyword type-keyword new)) + (needs-memoization (and is-node (x862-acode-needs-memoization new))) + (src) + (unscaled-i) + (unscaled-j) + (val-reg (x862-target-reg-for-aset vreg type-keyword)) + (constidx + (and dim0 dim1 i-known-fixnum j-known-fixnum + (>= i-known-fixnum 0) + (>= j-known-fixnum 0) + (< i-known-fixnum dim0) + (< j-known-fixnum dim1) + (+ (* i-known-fixnum dim1) j-known-fixnum)))) + (progn + (if constidx + (multiple-value-setq (src val-reg) + (x862-two-targeted-reg-forms seg array ($ *x862-temp0*) new val-reg)) + (multiple-value-setq (src unscaled-i unscaled-j val-reg) + (if needs-memoization + (progn + (x862-four-targeted-reg-forms seg + array ($ *x862-temp0*) + i ($ x8664::arg_x) + j ($ *x862-arg-y*) + new val-reg) + (values ($ *x862-temp0*) ($ x8664::arg_x) ($ *x862-arg-y*) ($ *x862-arg-z*))) + (x862-four-untargeted-reg-forms seg + array ($ *x862-temp0*) + i ($ x8664::arg_x) + j ($ *x862-arg-y*) + new val-reg)))) + (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)) + (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr) + (logbitp (hard-regspec-value val-reg) + *backend-imm-temps*)) + (use-imm-temp (hard-regspec-value val-reg))) + (when safe + (when (typep safe 'fixnum) + (! trap-unless-simple-array-2 + src + (dpb safe target::arrayH.flags-cell-subtag-byte + (ash 1 $arh_simple_bit)) + (nx-error-for-simple-2d-array-type type-keyword))) + (unless i-known-fixnum + (! trap-unless-fixnum unscaled-i)) + (unless j-known-fixnum + (! trap-unless-fixnum unscaled-j))) + (with-imm-target () dim1 + (let* ((idx-reg ($ *x862-arg-y*))) + (if constidx + (if needs-memoization + (x862-lri seg *x862-arg-y* (ash constidx *x862-target-fixnum-shift*))) + (progn + (if safe + (! check-2d-bound dim1 unscaled-i unscaled-j src) + (! 2d-dim1 dim1 src)) + (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j))) + (let* ((v ($ x8664::arg_x))) + (! array-data-vector-ref v src) + (x862-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (x862-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization))))))))) + + +(defun x862-aset3 (seg vreg xfer array i j k new safe type-keyword dim0 dim1 dim2) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (with-x86-local-vinsn-macros (seg target) + (let* ((i-known-fixnum (acode-fixnum-form-p i)) + (j-known-fixnum (acode-fixnum-form-p j)) + (k-known-fixnum (acode-fixnum-form-p k)) + (arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (constval (x862-constant-value-ok-for-type-keyword type-keyword new)) + (needs-memoization (and is-node (x862-acode-needs-memoization new))) + (src) + (unscaled-i) + (unscaled-j) + (unscaled-k) + (val-reg (x862-target-reg-for-aset vreg type-keyword)) + (constidx + (and dim0 dim1 dim2 i-known-fixnum j-known-fixnum k-known-fixnum + (>= i-known-fixnum 0) + (>= j-known-fixnum 0) + (>= k-known-fixnum 0) + (< i-known-fixnum dim0) + (< j-known-fixnum dim1) + (< k-known-fixnum dim2) + (+ (* i-known-fixnum dim1 dim2) + (* j-known-fixnum dim2) + k-known-fixnum)))) + (progn + (if constidx + (multiple-value-setq (src val-reg) + (x862-two-targeted-reg-forms seg array ($ *x862-temp0*) new val-reg)) + (progn + (setq src ($ x8664::temp1) + unscaled-i ($ *x862-temp0*) + unscaled-j ($ x8664::arg_x) + unscaled-k ($ *x862-arg-y*)) + (x862-push-register + seg + (x862-one-untargeted-reg-form seg array ($ *x862-arg-z*))) + (x862-four-targeted-reg-forms seg + i ($ *x862-temp0*) + j ($ x8664::arg_x) + k ($ *x862-arg-y*) + new val-reg) + (x862-pop-register seg src))) + (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)) + (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr) + (logbitp (hard-regspec-value val-reg) + *backend-imm-temps*)) + (use-imm-temp (hard-regspec-value val-reg))) + + (when safe + (when (typep safe 'fixnum) + (! trap-unless-simple-array-3 + src + (dpb safe target::arrayH.flags-cell-subtag-byte + (ash 1 $arh_simple_bit)) + (nx-error-for-simple-3d-array-type type-keyword))) + (unless i-known-fixnum + (! trap-unless-fixnum unscaled-i)) + (unless j-known-fixnum + (! trap-unless-fixnum unscaled-j)) + (unless k-known-fixnum + (! trap-unless-fixnum unscaled-k))) + (with-imm-target () dim1 + (with-imm-target (dim1) dim2 + (let* ((idx-reg ($ *x862-arg-y*))) + (if constidx + (when needs-memoization + (x862-lri seg idx-reg (ash constidx *x862-target-fixnum-shift*))) + (progn + (if safe + (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src) + (! 3d-dims dim1 dim2 src)) + (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k))) + (let* ((v ($ x8664::arg_x))) + (! array-data-vector-ref v src) + (x862-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (x862-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization)))))))))) + + +(defun x862-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((i-known-fixnum (acode-fixnum-form-p i)) + (j-known-fixnum (acode-fixnum-form-p j)) + (src) + (unscaled-i) + (unscaled-j) + (constidx + (and dim0 dim1 i-known-fixnum j-known-fixnum + (>= i-known-fixnum 0) + (>= j-known-fixnum 0) + (< i-known-fixnum dim0) + (< j-known-fixnum dim1) + (+ (* i-known-fixnum dim1) j-known-fixnum)))) + (if constidx + (setq src (x862-one-targeted-reg-form seg array ($ *x862-arg-z*))) + (multiple-value-setq (src unscaled-i unscaled-j) + (x862-three-untargeted-reg-forms seg + array x8664::arg_x + i *x862-arg-y* + j *x862-arg-z*))) + (when safe + (when (typep safe 'fixnum) + (! trap-unless-simple-array-2 + src + (dpb safe target::arrayH.flags-cell-subtag-byte + (ash 1 $arh_simple_bit)) + (nx-error-for-simple-2d-array-type typekeyword))) + (unless i-known-fixnum + (! trap-unless-fixnum unscaled-i)) + (unless j-known-fixnum + (! trap-unless-fixnum unscaled-j))) + (with-node-target (src) idx-reg + (with-imm-target () dim1 + (unless constidx + (if safe + (! check-2d-bound dim1 unscaled-i unscaled-j src) + (! 2d-dim1 dim1 src)) + (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j)) + (with-node-target (idx-reg) v + (! array-data-vector-ref v src) + (x862-vref1 seg vreg xfer typekeyword v idx-reg constidx))))))) + +(defun x862-aref3 (seg vreg xfer array i j k safe typekeyword &optional dim0 dim1 dim2) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((i-known-fixnum (acode-fixnum-form-p i)) + (j-known-fixnum (acode-fixnum-form-p j)) + (k-known-fixnum (acode-fixnum-form-p k)) + (src) + (unscaled-i) + (unscaled-j) + (unscaled-k) + (constidx + (and dim0 dim1 i-known-fixnum j-known-fixnum k-known-fixnum + (>= i-known-fixnum 0) + (>= j-known-fixnum 0) + (>= k-known-fixnum 0) + (< i-known-fixnum dim0) + (< j-known-fixnum dim1) + (< k-known-fixnum dim2) + (+ (* i-known-fixnum dim1 dim2) + (* j-known-fixnum dim2) + k-known-fixnum)))) + (if constidx + (setq src (x862-one-targeted-reg-form seg array ($ *x862-arg-z*))) + (multiple-value-setq (src unscaled-i unscaled-j unscaled-k) + (x862-four-untargeted-reg-forms seg + array *x862-temp0* + i x8664::arg_x + j *x862-arg-y* + k *x862-arg-z*))) + (when safe + (when (typep safe 'fixnum) + (! trap-unless-simple-array-3 + src + (dpb safe target::arrayH.flags-cell-subtag-byte + (ash 1 $arh_simple_bit)) + (nx-error-for-simple-3d-array-type typekeyword))) + (unless i-known-fixnum + (! trap-unless-fixnum unscaled-i)) + (unless j-known-fixnum + (! trap-unless-fixnum unscaled-j)) + (unless k-known-fixnum + (! trap-unless-fixnum unscaled-k))) + (with-node-target (src) idx-reg + (with-imm-target () dim1 + (with-imm-target (dim1) dim2 + (unless constidx + (if safe + (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src) + (! 3d-dims dim1 dim2 src)) + (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k)))) + (with-node-target (idx-reg) v + (! array-data-vector-ref v src) + (x862-vref1 seg vreg xfer typekeyword v idx-reg constidx)))))) + + + +(defun x862-natural-vset (seg vreg xfer vector index value safe) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((index-known-fixnum (acode-fixnum-form-p index)) + (arch (backend-target-arch *target-backend*)) + (src nil) + (unscaled-idx nil)) + (with-imm-target () (target :natural) + (if (or safe (not index-known-fixnum)) + (multiple-value-setq (src unscaled-idx target) + (x862-three-untargeted-reg-forms seg vector *x862-arg-y* index *x862-arg-z* value (or vreg target))) + (multiple-value-setq (src target) + (x862-two-untargeted-reg-forms seg vector *x862-arg-y* value (or vreg target)))) + (when safe + (with-imm-temps (target) () ; Don't use target in type/bounds check + (if (typep safe 'fixnum) + (! trap-unless-typecode= src safe)) + (unless index-known-fixnum + (! trap-unless-fixnum unscaled-idx)) + (! check-misc-bound unscaled-idx src))) + (target-arch-case + + (:x8664 + (if (and index-known-fixnum + (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) + (! misc-set-c-u64 target src index-known-fixnum) + (progn + (if index-known-fixnum + (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))) + (! misc-set-u64 target src unscaled-idx))))) + (<- target) ; should be a no-op in this case + (^))))) + + +(defun x862-constant-value-ok-for-type-keyword (type-keyword form) + (let* ((arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch)))) + (if is-node + (cond ((nx-null form) + (target-nil-value)) + ((nx-t form) + (+ (target-nil-value) (arch::target-t-offset arch))) + (t + (let* ((fixval (acode-fixnum-form-p form))) + (if fixval + (ash fixval (arch::target-fixnum-shift arch)))))) + (if (and (acode-p form) + (or (eq (acode-operator form) (%nx1-operator immediate)) + (eq (acode-operator form) (%nx1-operator fixnum)))) + (let* ((val (%cadr form)) + + (typep (cond ((eq type-keyword :signed-32-bit-vector) + (typep val '(signed-byte 32))) + ((eq type-keyword :single-float-vector) + (typep val 'short-float)) + ((eq type-keyword :double-float-vector) + (typep val 'double-float)) + ((eq type-keyword :simple-string) + (typep val 'base-char)) + ((eq type-keyword :signed-8-bit-vector) + (typep val '(signed-byte 8))) + ((eq type-keyword :unsigned-8-bit-vector) + (typep val '(unsigned-byte 8))) + ((eq type-keyword :signed-16-bit-vector) + (typep val '(signed-byte 16))) + ((eq type-keyword :unsigned-16-bit-vector) + (typep val '(unsigned-byte 16))) + ((eq type-keyword :bit-vector) + (typep val 'bit))))) + (if typep val)))))) + +(defun x862-target-reg-for-aset (vreg type-keyword) + (let* ((arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch))) + (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) + (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) + (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) + (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) + (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))) + (vreg-class (if (and vreg (not (eq vreg :push))) (hard-regspec-class vreg))) + (vreg-mode (if (or (eql vreg-class hard-reg-class-gpr) + (eql vreg-class hard-reg-class-fpr)) + (get-regspec-mode vreg))) + (next-imm-target (available-imm-temp *available-backend-imm-temps*)) + (next-fp-target (available-fp-temp *available-backend-fp-temps*)) + (acc (make-wired-lreg *x862-arg-z*))) + (cond ((or is-node + (eq vreg :push) + is-1-bit + (eq type-keyword :simple-string) + (eq type-keyword :fixnum-vector) + (and (eql vreg-class hard-reg-class-gpr) + (eql vreg-mode hard-reg-class-gpr-mode-node))) + acc) + ;; If there's no vreg - if we're setting for effect only, and + ;; not for value - we can target an unboxed register directly. + ;; Usually. + ((null vreg) + (cond (is-64-bit + (if (eq type-keyword :double-float-vector) + (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double) + (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s64 hard-reg-class-gpr-mode-u64)))) + (is-32-bit + (if (eq type-keyword :single-float-vector) + (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-single) + (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s32 hard-reg-class-gpr-mode-u32)))) + (is-16-bit + (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s16 hard-reg-class-gpr-mode-u16))) + (is-8-bit + (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s8 hard-reg-class-gpr-mode-u8))) + (t "Bug: can't determine operand size for ~s" type-keyword))) + ;; Vreg is non-null. We might be able to use it directly. + (t + (let* ((lreg (if vreg-mode + (make-unwired-lreg (lreg-value vreg))))) + (if + (cond + (is-64-bit + (if (eq type-keyword :double-float-vector) + (and (eql vreg-class hard-reg-class-fpr) + (eql vreg-mode hard-reg-class-fpr-mode-double)) + (if is-signed + (and (eql vreg-class hard-reg-class-gpr) + (eql vreg-mode hard-reg-class-gpr-mode-s64)) + (and (eql vreg-class hard-reg-class-gpr) + (eql vreg-mode hard-reg-class-gpr-mode-u64))))) + (is-32-bit + (if (eq type-keyword :single-float-vector) + (and (eql vreg-class hard-reg-class-fpr) + (eql vreg-mode hard-reg-class-fpr-mode-single)) + (if is-signed + (and (eql vreg-class hard-reg-class-gpr) + (or (eql vreg-mode hard-reg-class-gpr-mode-s32) + (eql vreg-mode hard-reg-class-gpr-mode-s64))) + (and (eql vreg-class hard-reg-class-gpr) + (or (eql vreg-mode hard-reg-class-gpr-mode-u32) + (eql vreg-mode hard-reg-class-gpr-mode-u64) + (eql vreg-mode hard-reg-class-gpr-mode-s64)))))) + (is-16-bit + (if is-signed + (and (eql vreg-class hard-reg-class-gpr) + (or (eql vreg-mode hard-reg-class-gpr-mode-s16) + (eql vreg-mode hard-reg-class-gpr-mode-s32) + (eql vreg-mode hard-reg-class-gpr-mode-s64))) + (and (eql vreg-class hard-reg-class-gpr) + (or (eql vreg-mode hard-reg-class-gpr-mode-u16) + (eql vreg-mode hard-reg-class-gpr-mode-u32) + (eql vreg-mode hard-reg-class-gpr-mode-u64) + (eql vreg-mode hard-reg-class-gpr-mode-s32) + (eql vreg-mode hard-reg-class-gpr-mode-s64))))) + (t + (if is-signed + (and (eql vreg-class hard-reg-class-gpr) + (or (eql vreg-mode hard-reg-class-gpr-mode-s8) + (eql vreg-mode hard-reg-class-gpr-mode-s16) + (eql vreg-mode hard-reg-class-gpr-mode-s32) + (eql vreg-mode hard-reg-class-gpr-mode-s64))) + (and (eql vreg-class hard-reg-class-gpr) + (or (eql vreg-mode hard-reg-class-gpr-mode-u8) + (eql vreg-mode hard-reg-class-gpr-mode-u16) + (eql vreg-mode hard-reg-class-gpr-mode-u32) + (eql vreg-mode hard-reg-class-gpr-mode-u64) + (eql vreg-mode hard-reg-class-gpr-mode-s16) + (eql vreg-mode hard-reg-class-gpr-mode-s32) + (eql vreg-mode hard-reg-class-gpr-mode-s64)))))) + lreg + acc)))))) + +(defun x862-unboxed-reg-for-aset (seg type-keyword result-reg safe constval) + (with-x86-local-vinsn-macros (seg) + (let* ((arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) + (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) + (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) + (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) + (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))) + (result-is-node-gpr (and (eql (hard-regspec-class result-reg) + hard-reg-class-gpr) + (eql (get-regspec-mode result-reg) + hard-reg-class-gpr-mode-node))) + (next-imm-target (available-imm-temp *available-backend-imm-temps*)) + (next-fp-target (available-fp-temp *available-backend-fp-temps*))) + (if (or is-node (not result-is-node-gpr)) + result-reg + (cond (is-64-bit + (if (eq type-keyword :double-float-vector) + (let* ((reg (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double))) + (if safe + (! get-double? reg result-reg) + (! get-double reg result-reg)) + reg) + (if is-signed + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s64))) + (if (eq type-keyword :fixnum-vector) + (progn + (when safe + (! trap-unless-fixnum result-reg)) + (! fixnum->signed-natural reg result-reg)) + (! unbox-s64 reg result-reg)) + reg) + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u64))) + (! unbox-u64 reg result-reg) + reg)))) + (is-32-bit + ;; Generally better to use a GPR for the :SINGLE-FLOAT-VECTOR + ;; case here. + (if is-signed + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s32))) + (if (eq type-keyword :fixnum-vector) + (progn + (when safe + (! trap-unless-fixnum result-reg)) + (! fixnum->signed-natural reg result-reg)) + (! unbox-s32 reg result-reg)) + reg) + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u32))) + (cond ((eq type-keyword :simple-string) + (if (characterp constval) + (x862-lri seg reg (char-code constval)) + (! unbox-base-char reg result-reg))) + ((eq type-keyword :single-float-vector) + (if (typep constval 'single-float) + (x862-lri seg reg (single-float-bits constval)) + (progn + (when safe + (! trap-unless-single-float result-reg)) + (! single-float-bits reg result-reg)))) + (t + (if (typep constval '(unsigned-byte 32)) + (x862-lri seg reg constval) + (if *x862-reckless* + (target-arch-case + (:x8632 (! unbox-u32 reg result-reg)) + (:x8664 (! %unbox-u32 reg result-reg))) + (! unbox-u32 reg result-reg))))) + reg))) + (is-16-bit + (if is-signed + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s16))) + (if (typep constval '(signed-byte 16)) + (x862-lri seg reg constval) + (if *x862-reckless* + (! %unbox-s16 reg result-reg) + (! unbox-s16 reg result-reg))) + reg) + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16))) + (if (typep constval '(unsigned-byte 16)) + (x862-lri seg reg constval) + (if *x862-reckless* + (! %unbox-u16 reg result-reg) + (! unbox-u16 reg result-reg))) + reg))) + (is-8-bit + (if is-signed + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s8))) + (if (typep constval '(signed-byte 8)) + (x862-lri seg reg constval) + (if *x862-reckless* + (! %unbox-s8 reg result-reg) + (! unbox-s8 reg result-reg))) + reg) + (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8))) + (if (typep constval '(unsigned-byte 8)) + (x862-lri seg reg constval) + (if *x862-reckless* + (! %unbox-u8 reg result-reg) + (! unbox-u8 reg result-reg))) + reg))) + (t + (let* ((reg result-reg)) + (unless (typep constval 'bit) + (when safe + (! trap-unless-bit reg ))) + reg))))))) + + +;;; xxx +(defun x862-vset1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum val-reg unboxed-val-reg constval node-value-needs-memoization) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch))) + (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) + (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) + (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) + (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) + (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))) + (cond ((and is-node node-value-needs-memoization) + (unless (and (eql (hard-regspec-value src) (target-arch-case + (:x8632 x8632::temp0) + (:x8664 x8664::arg_x))) + (eql (hard-regspec-value unscaled-idx) *x862-arg-y*) + (eql (hard-regspec-value val-reg) *x862-arg-z*)) + (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg))) + (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg)) + (is-node + (if (and index-known-fixnum (<= index-known-fixnum + (target-word-size-case + (32 (arch::target-max-32-bit-constant-index arch)) + (64 (arch::target-max-64-bit-constant-index arch))))) + (if (typep constval '(signed-byte 32)) + (! misc-set-immediate-c-node constval src index-known-fixnum) + (! misc-set-c-node val-reg src index-known-fixnum)) + (progn + (if index-known-fixnum + (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *x862-target-node-shift*)))) + (if (typep constval '(signed-byte 32)) + (! misc-set-immediate-node constval src unscaled-idx) + (! misc-set-node val-reg src unscaled-idx))))) + (t + (cond + (is-64-bit + (if (and index-known-fixnum + (<= index-known-fixnum + (arch::target-max-64-bit-constant-index arch))) + (if (eq type-keyword :double-float-vector) + (! misc-set-c-double-float unboxed-val-reg src index-known-fixnum) + (if is-signed + (! misc-set-c-s64 unboxed-val-reg src index-known-fixnum) + (! misc-set-c-u64 unboxed-val-reg src index-known-fixnum))) + (progn + (if index-known-fixnum + (x862-absolute-natural seg unscaled-idx nil (ash index-known-fixnum 3))) + (if (eq type-keyword :double-float-vector) + (! misc-set-double-float unboxed-val-reg src unscaled-idx) + (if is-signed + (! misc-set-s64 unboxed-val-reg src unscaled-idx) + (! misc-set-u64 unboxed-val-reg src unscaled-idx)))))) + (is-32-bit + (if (and index-known-fixnum + (<= index-known-fixnum + (arch::target-max-32-bit-constant-index arch))) + (if (eq type-keyword :single-float-vector) + (if (eq (hard-regspec-class unboxed-val-reg) + hard-reg-class-fpr) + (! misc-set-c-single-float unboxed-val-reg src index-known-fixnum) + (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum)) + (if is-signed + (! misc-set-c-s32 unboxed-val-reg src index-known-fixnum) + (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum))) + (progn + (target-arch-case + (:x8632 + (with-node-target (src) scaled-idx + (if index-known-fixnum + (x862-lri seg scaled-idx (ash index-known-fixnum 2)) + (! scale-32bit-misc-index scaled-idx unscaled-idx)) + (if (and (eq type-keyword :single-float-vector) + (eql (hard-regspec-class unboxed-val-reg) + hard-reg-class-fpr)) + (! misc-set-single-float unboxed-val-reg src scaled-idx) + (if is-signed + (! misc-set-s32 unboxed-val-reg src scaled-idx) + (! misc-set-u32 unboxed-val-reg src scaled-idx))))) + (:x8664 + (with-imm-target (unboxed-val-reg) scaled-idx + (if index-known-fixnum + (x862-lri seg scaled-idx (ash index-known-fixnum 2)) + (! scale-32bit-misc-index scaled-idx unscaled-idx)) + (if (and (eq type-keyword :single-float-vector) + (eql (hard-regspec-class unboxed-val-reg) + hard-reg-class-fpr)) + (! misc-set-single-float unboxed-val-reg src scaled-idx) + (if is-signed + (! misc-set-s32 unboxed-val-reg src scaled-idx) + (! misc-set-u32 unboxed-val-reg src scaled-idx))))))))) + (is-16-bit + (with-additional-imm-reg (src unscaled-idx val-reg) + (with-imm-target (unboxed-val-reg) scaled-idx + (if (and index-known-fixnum + (<= index-known-fixnum + (arch::target-max-16-bit-constant-index arch))) + (if is-signed + (! misc-set-c-s16 unboxed-val-reg src index-known-fixnum) + (! misc-set-c-u16 unboxed-val-reg src index-known-fixnum)) + (progn + (if index-known-fixnum + (x862-lri seg scaled-idx (ash index-known-fixnum 1)) + (! scale-16bit-misc-index scaled-idx unscaled-idx)) + (if is-signed + (! misc-set-s16 unboxed-val-reg src scaled-idx) + (! misc-set-u16 unboxed-val-reg src scaled-idx))))))) + (is-8-bit + (with-additional-imm-reg (src unscaled-idx val-reg) + (with-imm-target (unboxed-val-reg) scaled-idx + (if (and index-known-fixnum + (<= index-known-fixnum + (arch::target-max-8-bit-constant-index arch))) + (if is-signed + (! misc-set-c-s8 unboxed-val-reg src index-known-fixnum) + (! misc-set-c-u8 unboxed-val-reg src index-known-fixnum)) + (progn + (if index-known-fixnum + (x862-lri seg scaled-idx index-known-fixnum) + (! scale-8bit-misc-index scaled-idx unscaled-idx)) + (if is-signed + (! misc-set-s8 unboxed-val-reg src scaled-idx) + (! misc-set-u8 unboxed-val-reg src scaled-idx))))))) + (is-1-bit + (with-additional-imm-reg (src unscaled-idx val-reg) + (with-imm-target (unboxed-val-reg) scaled-idx + (if (and index-known-fixnum + (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch))) + (if constval + (if (zerop constval) + (! set-constant-bit-to-zero src index-known-fixnum) + (! set-constant-bit-to-one src index-known-fixnum)) + (progn + (! set-constant-bit-to-variable-value src index-known-fixnum val-reg))) + (progn + (if index-known-fixnum + (x862-lri seg scaled-idx index-known-fixnum) + (! scale-1bit-misc-index scaled-idx unscaled-idx)) + (if constval + (if (zerop constval) + (! nset-variable-bit-to-zero src scaled-idx) + (! nset-variable-bit-to-one src scaled-idx)) + (progn + (! nset-variable-bit-to-variable-value src scaled-idx val-reg))))))))))) + (when (and vreg val-reg) (<- val-reg)) + (^)))) + + +(defun x862-code-coverage-entry (seg note) + (let* ((afunc *x862-cur-afunc*)) + (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage))) + (with-x86-local-vinsn-macros (seg) + (let* ((ccreg ($ x8664::arg_x))) + (! vpush-register ccreg) + (! ref-constant ccreg (x86-immediate-label note)) + (! misc-set-immediate-c-node 0 ccreg 1) + (! vpop-register ccreg))))) + +(defun x862-vset (seg vreg xfer type-keyword vector index value safe) + (with-x86-local-vinsn-macros (seg) + (let* ((arch (backend-target-arch *target-backend*)) + (is-node (member type-keyword (arch::target-gvector-types arch))) + (constval (x862-constant-value-ok-for-type-keyword type-keyword value)) + (needs-memoization (and is-node (x862-acode-needs-memoization value))) + (index-known-fixnum (acode-fixnum-form-p index))) + (let* ((src (target-arch-case + (:x8632 ($ x8632::temp0)) + (:x8664 ($ x8664::arg_x)))) + (unscaled-idx ($ *x862-arg-y*)) + (result-reg ($ *x862-arg-z*))) + (cond (needs-memoization + (x862-three-targeted-reg-forms seg + vector src + index unscaled-idx + value result-reg)) + (t + (setq result-reg (x862-target-reg-for-aset vreg type-keyword)) + (target-arch-case + (:x8632 + (with-node-temps (src) () + (x862-three-targeted-reg-forms seg + vector src + index unscaled-idx + value result-reg))) + (:x8664 + (if (and index-known-fixnum + (not safe) + (nx2-constant-index-ok-for-type-keyword index-known-fixnum type-keyword)) + (multiple-value-setq (src result-reg unscaled-idx) + (x862-two-untargeted-reg-forms seg + vector src + value result-reg)) + (multiple-value-setq (src unscaled-idx result-reg) + (x862-three-untargeted-reg-forms seg + vector src + index unscaled-idx + value result-reg))))))) + (when safe + (let* ((*available-backend-imm-temps* *available-backend-imm-temps*) + (value (if (eql (hard-regspec-class result-reg) + hard-reg-class-gpr) + (hard-regspec-value result-reg))) + (result-is-imm nil)) + (when (and value (logbitp value *available-backend-imm-temps*)) + (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*)) + (setq result-is-imm t)) + (if (typep safe 'fixnum) + (if result-is-imm + (with-additional-imm-reg (src safe) + (! trap-unless-typecode= src safe)) + (! trap-unless-typecode= src safe))) + (unless index-known-fixnum + (! trap-unless-fixnum unscaled-idx)) + (if result-is-imm + (with-additional-imm-reg (unscaled-idx src) + (! check-misc-bound unscaled-idx src)) + (! check-misc-bound unscaled-idx src)))) + (x862-vset1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum result-reg (x862-unboxed-reg-for-aset seg type-keyword result-reg safe constval) constval needs-memoization))))) + + + +(defun x862-tail-call-alias (immref sym &optional arglist) + (let ((alias (cdr (assq sym *x862-tail-call-aliases*)))) + (if (and alias (or (null arglist) (eq (+ (length (car arglist)) (length (cadr arglist))) (cdr alias)))) + (make-acode (%nx1-operator immediate) (car alias)) + immref))) + +;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid +;;; consing it. +(defun x862-eliminate-&rest (body rest key-p auxen rest-values) + (when (and rest (not key-p) (not (cadr auxen)) rest-values) + (when (eq (logand (the fixnum (nx-var-bits rest)) + (logior $vsetqmask (ash -1 $vbitspecial) + (ash 1 $vbitclosed) (ash 1 $vbitsetq) (ash 1 $vbitcloseddownward))) + 0) ; Nothing but simple references + (do* () + ((not (acode-p body))) + (let* ((op (acode-operator body))) + (if (or (eq op (%nx1-operator lexical-function-call)) + (eq op (%nx1-operator call))) + (destructuring-bind (fn-form (stack-args reg-args) &optional spread-p) (%cdr body) + (unless (and (eq spread-p t) + (eq (nx2-lexical-reference-p (%car reg-args)) rest)) + (return nil)) + (flet ((independent-of-all-values (form) + (setq form (acode-unwrapped-form-value form)) + (or (x86-constant-form-p form) + (let* ((lexref (nx2-lexical-reference-p form))) + (and lexref + (neq lexref rest) + (dolist (val rest-values t) + (unless (nx2-var-not-set-by-form-p lexref val) + (return)))))))) + (unless (or (eq op (%nx1-operator lexical-function-call)) + (independent-of-all-values fn-form)) + (return nil)) + (if (dolist (s stack-args t) + (unless (independent-of-all-values s) + (return nil))) + (let* ((arglist (append stack-args rest-values))) + (return + (make-acode op + fn-form + (if (<= (length arglist) *x862-target-num-arg-regs*) + (list nil (reverse arglist)) + (list (butlast arglist *x862-target-num-arg-regs*) + (reverse (last arglist *x862-target-num-arg-regs*)))) + nil))) + (return nil)))) + (if (eq op (%nx1-operator local-block)) + (setq body (%cadr body)) + (if (and (eq op (%nx1-operator if)) + (eq (nx2-lexical-reference-p (%cadr body)) rest)) + (setq body (%caddr body)) + (return nil))))))))) + +(defun x862-call-fn (seg vreg xfer fn arglist spread-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (when spread-p + (destructuring-bind (stack-args reg-args) arglist + (when (and (null (cdr reg-args)) + (nx-null (acode-unwrapped-form-value (car reg-args)))) + (setq spread-p nil) + (let* ((nargs (length stack-args))) + (declare (fixnum nargs)) + (if (<= nargs *x862-target-num-arg-regs*) + (setq arglist (list nil (reverse stack-args))) + (setq arglist (list (butlast stack-args *x862-target-num-arg-regs*) (reverse (last stack-args *x862-target-num-arg-regs*))))))))) + (let* ((lexref (nx2-lexical-reference-p fn)) + (simple-case (or (fixnump fn) + (typep fn 'lreg) + (x862-immediate-function-p fn) + (and + lexref + (not spread-p) + (flet ((all-simple (args) + (dolist (arg args t) + (when (and arg (not (nx2-var-not-set-by-form-p lexref arg))) + (return))))) + (and (all-simple (car arglist)) + (all-simple (cadr arglist)) + (setq fn (var-ea lexref))))))) + (cstack *x862-cstack*) + (top *x862-top-vstack-lcell*) + (vstack *x862-vstack*)) + (setq xfer (or xfer 0)) + (when (and (eq xfer $backend-return) + (eq 0 *x862-undo-count*) + (acode-p fn) + (eq (acode-operator fn) (%nx1-operator immediate)) + (symbolp (cadr fn))) + (setq fn (x862-tail-call-alias fn (%cadr fn) arglist))) + + (if (and (eq xfer $backend-return) (not (x862-tailcallok xfer))) + (progn + (x862-call-fn seg vreg $backend-mvpass fn arglist spread-p) + (x862-set-vstack (%i+ (if simple-case 0 *x862-target-node-size*) vstack)) + (setq *x862-cstack* cstack) + (let ((*x862-returning-values* t)) (x862-do-return seg))) + (let* ((mv-p (x862-mv-p xfer)) + (mv-return-label (if (and mv-p + (not (x862-tailcallok xfer))) + (backend-get-next-label)))) + (unless simple-case + (x862-vpush-register seg (x862-one-untargeted-reg-form seg fn *x862-arg-z*)) + (setq fn (x862-vloc-ea vstack))) + (x862-invoke-fn seg fn (x862-arglist seg arglist mv-return-label) spread-p xfer mv-return-label) + (if (and (logbitp $backend-mvpass-bit xfer) + (not simple-case)) + (progn + (! save-values) + (! vstack-discard 1) + (x862-set-nargs seg 0) + (! recover-values)) + (unless (or mv-p simple-case) + (! vstack-discard 1))) + (x862-set-vstack vstack) + (setq *x862-top-vstack-lcell* top) + (setq *x862-cstack* cstack) + (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p)) + (<- *x862-arg-z*) + (x862-branch seg (logand (lognot $backend-mvpass-mask) xfer))))) + nil))) + +(defun x862-restore-full-lisp-context (seg) + (with-x86-local-vinsn-macros (seg) + (! restore-full-lisp-context))) + +(defun x862-emit-aligned-label (seg labelnum) + (with-x86-local-vinsn-macros (seg) + (! emit-aligned-label (aref *backend-labels* labelnum)) + (@ labelnum) + (target-arch-case + (:x8632 + (! recover-fn)) + (:x8664 + (! recover-fn-from-rip))))) + + +(defun x862-call-symbol (seg jump-p) + (with-x86-local-vinsn-macros (seg) + (if jump-p + (! jump-known-symbol) + (! call-known-symbol *x862-arg-z*)))) + +;;; Nargs = nil -> multiple-value case. +(defun x862-invoke-fn (seg fn nargs spread-p xfer &optional mvpass-label) + (with-x86-local-vinsn-macros (seg) + (let* ((f-op (acode-unwrapped-form-value fn)) + (immp (and (consp f-op) + (eq (%car f-op) (%nx1-operator immediate)))) + (symp (and immp (symbolp (%cadr f-op)))) + (label-p (and (fixnump fn) + (locally (declare (fixnum fn)) + (and (= fn -2) (- fn))))) + (tail-p (eq xfer $backend-return)) + (func (if (consp f-op) (%cadr f-op))) + (a-reg nil) + (lfunp (and (acode-p f-op) + (eq (acode-operator f-op) (%nx1-operator simple-function)))) + (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p)))) + (callable (or symp lfunp label-p)) + (destreg (if symp ($ *x862-fname*) (unless label-p ($ *x862-temp0*)))) + (alternate-tail-call + (and tail-p label-p *x862-tail-label* (eql nargs *x862-tail-nargs*) (not spread-p)))) + (when expression-p + ;;Have to do this before spread args, since might be vsp-relative. + (if nargs + (x862-do-lexical-reference seg destreg fn) + (x862-copy-register seg destreg fn))) + (if (or symp lfunp) + (setq func (if symp + (x862-symbol-entry-locative func) + (x862-afunc-lfun-ref func)) + a-reg (x862-register-constant-p func))) + (when tail-p + #-no-compiler-bugs + (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well. How could this have happened ?")) + (when a-reg + (x862-copy-register seg destreg a-reg)) + (unless spread-p + (unless alternate-tail-call + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* (and nargs (<= nargs *x862-target-num-arg-regs*)))))) + (if spread-p + (progn + (x862-set-nargs seg (%i- nargs 1)) + ; .SPspread-lexpr-z & .SPspreadargz preserve temp1 + (target-arch-case + (:x8632 + (! save-node-register-to-spill-area *x862-temp0*))) + (if (eq spread-p 0) + (! spread-lexpr) + (! spread-list)) + (target-arch-case + (:x8632 + (! load-node-register-from-spill-area *x862-temp0*))) + + (when (and tail-p *x862-register-restore-count*) + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* nil))) + (if nargs + (unless alternate-tail-call (x862-set-nargs seg nargs)) + (! pop-argument-registers))) + (if callable + (if (not tail-p) + (if (x862-mvpass-p xfer) + (let* ((call-reg (if symp ($ *x862-fname*) ($ *x862-temp0*)))) + (unless mvpass-label (compiler-bug "no label for mvpass")) + (if label-p + (x862-copy-register seg call-reg ($ *x862-fn*)) + (if a-reg + (x862-copy-register seg call-reg a-reg) + (x862-store-immediate seg func call-reg))) + (if symp + (! pass-multiple-values-symbol) + (! pass-multiple-values)) + (when mvpass-label + (@= mvpass-label))) + (progn + (if label-p + (progn + (! call-label (aref *backend-labels* 2))) + (progn + (if a-reg + (x862-copy-register seg destreg a-reg) + (x862-store-immediate seg func destreg)) + (if symp + (x862-call-symbol seg nil) + (! call-known-function)))))) + (if alternate-tail-call + (progn + (x862-unwind-stack seg xfer 0 0 *x862-tail-vsp*) + (! jump (aref *backend-labels* *x862-tail-label*))) + (progn + (x862-unwind-stack seg xfer 0 0 #x7fffff) + (if (and (not spread-p) nargs (%i<= nargs *x862-target-num-arg-regs*)) + (progn + (unless (or label-p a-reg) (x862-store-immediate seg func destreg)) + (x862-restore-full-lisp-context seg) + (if label-p + (! jump (aref *backend-labels* 1)) + (progn + (if symp + (x862-call-symbol seg t) + (! jump-known-function))))) + (progn + (unless (or label-p a-reg) (x862-store-immediate seg func destreg)) + (when label-p + (x862-copy-register seg *x862-temp0* *x862-fn*)) + + (cond ((or spread-p (null nargs)) + (if symp + (! tail-call-sym-gen) + (! tail-call-fn-gen))) + ((%i> nargs *x862-target-num-arg-regs*) + (if symp + (! tail-call-sym-slide) + (! tail-call-fn-slide))) + (t + (if symp + (! tail-call-sym-vsp) + (! tail-call-fn-vsp))))))))) + ;; The general (funcall) case: we don't know (at compile-time) + ;; for sure whether we've got a symbol or a (local, constant) + ;; function. + (progn + (unless (or (fixnump fn) (typep fn 'lreg)) + (x862-one-targeted-reg-form seg fn destreg)) + (if (not tail-p) + (if (x862-mvpass-p xfer) + (progn (! pass-multiple-values) + (when mvpass-label + (@= mvpass-label))) + (! funcall)) + (cond ((or (null nargs) spread-p) + (! tail-funcall-gen)) + ((%i> nargs *x862-target-num-arg-regs*) + (! tail-funcall-slide)) + (t + (! restore-full-lisp-context) + (! tail-funcall))))))) + nil)) + +(defun x862-seq-fbind (seg vreg xfer vars afuncs body p2decls) + (let* ((old-stack (x862-encode-stack)) + (copy afuncs) + (func nil)) + (with-x86-p2-declarations p2decls + (dolist (var vars) + (when (neq 0 (afunc-fn-refcount (setq func (pop afuncs)))) + (x862-seq-bind-var seg var (nx1-afunc-ref func)))) + (x862-undo-body seg vreg xfer body old-stack) + (dolist (var vars) + (when (neq 0 (afunc-fn-refcount (setq func (pop copy)))) + (x862-close-var seg var)))))) + +(defun x862-make-closure (seg afunc downward-p) + (with-x86-local-vinsn-macros (seg) + (flet ((var-to-reg (var target) + (let* ((ea (var-ea (var-bits var)))) + (if ea + (x862-addrspec-to-reg seg (x862-ea-open ea) target) + (! load-nil target)) + target)) + (set-some-cells (dest cellno c0 c1 c2 c3) + (declare (fixnum cellno)) + (! misc-set-c-node c0 dest cellno) + (incf cellno) + (when c1 + (! misc-set-c-node c1 dest cellno) + (incf cellno) + (when c2 + (! misc-set-c-node c2 dest cellno) + (incf cellno) + (when c3 + (! misc-set-c-node c3 dest cellno) + (incf cellno)))) + cellno)) + (let* ((inherited-vars (afunc-inherited-vars afunc)) + (arch (backend-target-arch *target-backend*)) + (dest ($ *x862-arg-z*)) + (vsize (+ (length inherited-vars) + (target-arch-case + (:x8632 7) + (:x8664 5)) ; %closure-code%, afunc + 1))) ; lfun-bits + (declare (list inherited-vars)) + (let* ((cell (target-arch-case (:x8632 6) + (:x8664 4)))) + (declare (fixnum cell)) + (if downward-p + (progn + (! make-fixed-stack-gvector + dest + (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) + (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function))) + (x862-open-undo $undostkblk)) + (progn + (x862-lri seg + *x862-imm0* + (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function))) + (target-arch-case + (:x8632 + (! setup-uvector-allocation *x862-imm0*) + (x862-lri seg *x862-imm0* (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8632::fulltag-misc))) + (:x8664 + (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8664::fulltag-misc)))) + (! %allocate-uvector dest))) + (! init-nclosure *x862-arg-z*) + ;;; xxx --- x8632 likely to have register conflicts with *x862-ra0* + (x862-store-immediate seg (x862-afunc-lfun-ref afunc) *x862-ra0*) + (target-arch-case + (:x8632 + (with-node-temps (*x862-arg-z*) (t0) + (do* ((func *x862-ra0* nil)) + ((null inherited-vars)) + (let* ((t0r (or func (if inherited-vars + (var-to-reg (pop inherited-vars) t0))))) + (! misc-set-c-node t0r dest cell) + (incf cell))))) + (:x8664 + (with-node-temps (*x862-arg-z*) (t0 t1 t2 t3) + (do* ((func *x862-ra0* nil)) + ((null inherited-vars)) + (let* ((t0r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t0)))) + (t1r (if inherited-vars (var-to-reg (pop inherited-vars) t1))) + (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2))) + (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3)))) + (setq cell (set-some-cells dest cell t0r t1r t2r t3r))))))) + (x862-lri seg *x862-arg-y* (ash (logior (ash -1 $lfbits-noname-bit) (ash 1 $lfbits-trampoline-bit)) *x862-target-fixnum-shift*)) + (! misc-set-c-node *x862-arg-y* dest cell)) + (! finalize-closure dest) + dest)))) + +(defun x862-symbol-entry-locative (sym) + (setq sym (require-type sym 'symbol)) + (when (eq sym '%call-next-method-with-args) + (setf (afunc-bits *x862-cur-afunc*) + (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *x862-cur-afunc*)))) + (or (assq sym *x862-fcells*) + (let ((new (list sym))) + (push new *x862-fcells*) + new))) + +(defun x862-symbol-value-cell (sym) + (setq sym (require-type sym 'symbol)) + (or (assq sym *x862-vcells*) + (let ((new (list sym))) + (push new *x862-vcells*) + (ensure-binding-index sym) + new))) + + +(defun x862-symbol-locative-p (imm) + (and (consp imm) + (or (memq imm *x862-vcells*) + (memq imm *x862-fcells*)))) + + + + +(defun x862-immediate-function-p (f) + (setq f (acode-unwrapped-form-value f)) + (and (acode-p f) + (or (eq (%car f) (%nx1-operator immediate)) + (eq (%car f) (%nx1-operator simple-function))))) + +(defun x86-constant-form-p (form) + (setq form (nx-untyped-form form)) + (if form + (or (nx-null form) + (nx-t form) + (and (consp form) + (or (eq (acode-operator form) (%nx1-operator immediate)) + (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator simple-function))))))) + + + +(defun x862-integer-constant-p (form mode) + (let* ((val + (or (acode-fixnum-form-p (setq form (acode-unwrapped-form form))) + (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq form (%cadr form)) + (if (typep form 'integer) + form))))) + (when val + (let* ((type (mode-specifier-type mode)) + (high (numeric-ctype-high type)) + (low (numeric-ctype-low type))) + (if (and (>= val low) + (<= val high)) + val + (if (<= (integer-length val) (integer-length (- high low))) + (if (eql 0 low) ; type is unsigned, value is negative + (logand high val) + (- val (1+ (- high low)))))))))) + + + + +(defun x86-side-effect-free-form-p (form) + (when (consp (setq form (acode-unwrapped-form-value form))) + (or (x86-constant-form-p form) + ;(eq (acode-operator form) (%nx1-operator bound-special-ref)) + (and (eq (acode-operator form) (%nx1-operator %svref)) + (destructuring-bind (v i) (acode-operands form) + (let* ((idx (acode-fixnum-form-p i))) + (and idx + (nx2-constant-index-ok-for-type-keyword idx :simple-vector) + (consp (setq v (acode-unwrapped-form-value v))) + (eq (acode-operator v) (%nx1-operator lexical-reference)) + (let* ((var (cadr v))) + (unless (%ilogbitp $vbitsetq (nx-var-bits var)) + (var-nvr var))))))) + (if (eq (acode-operator form) (%nx1-operator lexical-reference)) + (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form)))))))) + +(defun x862-formlist (seg stkargs &optional revregargs) + (with-x86-local-vinsn-macros (seg) + (let* ((nregs (length revregargs)) + (n nregs)) + (declare (fixnum n)) + (dolist (arg stkargs) + (let* ((pushform (x862-acode-operator-supports-push arg))) + (if pushform + (progn + (x862-form seg :push nil pushform) + (x862-new-vstack-lcell :outgoing-argument *x862-target-lcell-size* 0 nil) + (x862-adjust-vstack *x862-target-node-size*)) + + (let* ((reg (x862-one-untargeted-reg-form seg arg *x862-arg-z*))) + (x862-vpush-register-arg seg reg))) + (incf n))) + (when revregargs + (let* ((zform (%car revregargs)) + (yform (%cadr revregargs)) + (xform (%caddr revregargs))) + (if (eq 3 nregs) + (progn + (target-arch-case (:x8632 (compiler-bug "3 reg args on x8632?"))) + (x862-three-targeted-reg-forms seg xform ($ x8664::arg_x) + yform ($ *x862-arg-y*) + zform ($ *x862-arg-z*))) + (if (eq 2 nregs) + (x862-two-targeted-reg-forms seg yform ($ *x862-arg-y*) zform ($ *x862-arg-z*)) + (x862-one-targeted-reg-form seg zform ($ *x862-arg-z*)))))) + n))) + +(defun x862-arglist (seg args &optional mv-label) + (with-x86-local-vinsn-macros (seg) + (when mv-label + (x862-vpush-label seg (aref *backend-labels* mv-label))) + (when (car args) + (! reserve-outgoing-frame) + (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil) + (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil) + (setq *x862-vstack* (+ *x862-vstack* (* 2 *x862-target-node-size*)))) + (x862-formlist seg (car args) (cadr args)))) + + +(defun x862-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type) + (let* ((mode (ecase ffi-arg-type + ((nil) :natural) + (:signed-byte :s8) + (:unsigned-byte :u8) + (:signed-halfword :s16) + (:unsigned-halfword :u16) + (:signed-fullword :s32) + (:unsigned-fullword :u32) + (:unsigned-doubleword :u64) + (:signed-doubleword :s64))) + (modeval (gpr-mode-name-value mode))) + (with-x86-local-vinsn-macros (seg) + (let* ((value (x862-integer-constant-p form mode))) + (if value + (progn + (unless (typep immreg 'lreg) + (setq immreg (make-unwired-lreg immreg :mode modeval))) + (if (< value 0) + (x862-lri seg immreg value) + (x862-lriu seg immreg value)) + immreg) + (progn + (x862-one-targeted-reg-form seg form (make-wired-lreg *x862-imm0* :mode modeval)))))))) + + +(defun x862-macptr-arg-to-reg (seg form address-reg) + (x862-one-targeted-reg-form seg + form + address-reg)) + + +(defun x862-one-lreg-form (seg form lreg) + (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr))) + (if is-float + (x862-form-float seg lreg nil form) + (x862-form seg lreg nil form)) + lreg)) + +(defun x862-one-targeted-reg-form (seg form reg) + (x862-one-lreg-form seg form reg)) + +(defun x862-one-untargeted-lreg-form (seg form reg) + (x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg)))) + +(defun x862-one-untargeted-reg-form (seg form suggested) + (with-x86-local-vinsn-macros (seg) + (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr)) + (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node)))) + (if node-p + (let* ((ref (x862-lexical-reference-ea form)) + (reg (backend-ea-physical-reg ref hard-reg-class-gpr))) + (if reg + ref + (if (nx-null form) + (progn + (! load-nil suggested) + suggested) + (if (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq reg (x862-register-constant-p (cadr form)))) + reg + (x862-one-untargeted-lreg-form seg form suggested))))) + (x862-one-untargeted-lreg-form seg form suggested))))) + + + + +(defun x862-push-register (seg areg) + (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr)) + (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single))) + (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node))) + vinsn) + (with-x86-local-vinsn-macros (seg) + (if a-node + (setq vinsn (x862-vpush-register seg areg :node-temp)) + (if a-single + (target-arch-case + (:x8632 + (setq vinsn (! temp-push-single-float areg)) + (x862-open-undo $undo-x86-c-frame)) + (:x8664 + (setq vinsn (! vpush-single-float areg)) + (x862-new-vstack-lcell :single-float *x862-target-lcell-size* 0 nil) + (x862-adjust-vstack *x862-target-node-size*))) + (target-arch-case + (:x8632 + (if a-float + (progn + (setq vinsn (! temp-push-double-float areg)) + (x862-open-undo $undo-x86-c-frame)) + (progn + (setq vinsn (! temp-push-unboxed-word areg)) + (x862-open-undo $undo-x86-c-frame)))) + (:x8664 + (setq vinsn + (if a-float + (! temp-push-double-float areg) + (! temp-push-unboxed-word areg))) + (x862-open-undo $undo-x86-c-frame))))) + vinsn))) + + + +(defun x862-pop-register (seg areg) + (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr)) + (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single))) + (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node))) + vinsn) + (with-x86-local-vinsn-macros (seg) + (if a-node + (setq vinsn (x862-vpop-register seg areg)) + (if a-single + (target-arch-case + (:x8632 + (setq vinsn (! temp-pop-single-float areg)) + (x862-close-undo)) + (:x8664 + (setq vinsn (! vpop-single-float areg)) + (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*)) + (x862-adjust-vstack (- *x862-target-node-size*)))) + (target-arch-case + (:x8632 + (if a-float + (progn + (setq vinsn (! temp-pop-double-float areg)) + (x862-close-undo)) + (progn + (setq vinsn (! temp-pop-unboxed-word areg)) + (x862-close-undo)))) + (:x8664 + (setq vinsn + (if a-float + (! temp-pop-double-float areg) + (! temp-pop-unboxed-word areg))) + (x862-close-undo))))) + vinsn))) + +;;; If reg is a GPR and of mode node, use arg_z, otherwise, just return +;;; reg. +(defun x862-acc-reg-for (reg) + (with-x86-local-vinsn-macros (seg) + (if (and (eql (hard-regspec-class reg) hard-reg-class-gpr) + (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node)) + ($ *x862-arg-z*) + reg))) + +;;; The compiler often generates superfluous pushes & pops. Try to +;;; eliminate them. +(defun x862-elide-pushes (seg push-vinsn pop-vinsn) + (with-x86-local-vinsn-macros (seg) + (let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0)) + (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0)) + (same-reg (eq (hard-regspec-value pushed-reg) + (hard-regspec-value popped-reg))) + (csp-p (vinsn-attribute-p push-vinsn :csp))) + (when csp-p ; vsp case is harder. + (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :csp :discard) + (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p + push-vinsn pop-vinsn pushed-reg)) + (popped-reg-is-set (if same-reg + pushed-reg-is-set + (vinsn-sequence-sets-reg-p + push-vinsn pop-vinsn popped-reg)))) + (unless (and pushed-reg-is-set popped-reg-is-set) + (unless same-reg + (let* ((copy (if (eq (hard-regspec-class pushed-reg) + hard-reg-class-fpr) + (if (= (get-regspec-mode pushed-reg) + hard-reg-class-fpr-mode-double) + (! copy-double-float popped-reg pushed-reg) + (! copy-single-float popped-reg pushed-reg)) + (! copy-gpr popped-reg pushed-reg)))) + (remove-dll-node copy) + (if pushed-reg-is-set + (insert-dll-node-after copy push-vinsn) + (insert-dll-node-before copy push-vinsn)))) + (elide-vinsn push-vinsn) + (elide-vinsn pop-vinsn)))))))) + + +;;; we never leave the first form pushed (the 68K compiler had some subprims that +;;; would vpop the first argument out of line.) +(defun x862-two-targeted-reg-forms (seg aform areg bform breg) + (let* ((avar (nx2-lexical-reference-p aform)) + (atriv (and (x862-trivial-p bform areg) (nx2-node-gpr-p breg))) + (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform) + (if avar (nx2-var-not-set-by-form-p avar bform))))) + apushed) + (progn + (unless aconst + (if atriv + (x862-one-targeted-reg-form seg aform areg) + (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (x862-one-targeted-reg-form seg bform breg) + (if aconst + (x862-one-targeted-reg-form seg aform areg) + (if apushed + (x862-elide-pushes seg apushed (x862-pop-register seg areg))))) + (values areg breg))) + + +(defun x862-two-untargeted-reg-forms (seg aform areg bform breg) + (with-x86-local-vinsn-macros (seg) + (let* ((avar (nx2-lexical-reference-p aform)) + (adest areg) + (bdest breg) + (atriv (and (x862-trivial-p bform) (nx2-node-gpr-p breg))) + (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform) + (if avar (nx2-var-not-set-by-form-p avar bform))))) + (apushed (not (or atriv aconst)))) + (progn + (unless aconst + (if atriv + (setq adest (x862-one-untargeted-reg-form seg aform areg)) + (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (setq bdest (x862-one-untargeted-reg-form seg bform breg)) + (if aconst + (setq adest (x862-one-untargeted-reg-form seg aform areg)) + (if apushed + (x862-elide-pushes seg apushed (x862-pop-register seg areg))))) + (values adest bdest)))) + + +(defun x862-three-targeted-reg-forms (seg aform areg bform breg cform creg) + (let* ((bnode (nx2-node-gpr-p breg)) + (cnode (nx2-node-gpr-p creg)) + (atriv (or (null aform) + (and (x862-trivial-p bform areg) + (x862-trivial-p cform areg) + bnode + cnode))) + (btriv (or (null bform) + (and (x862-trivial-p cform breg) + cnode))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (nx2-lexical-reference-p aform))) + (and avar + (nx2-var-not-set-by-form-p avar bform) + (nx2-var-not-set-by-form-p avar cform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (nx2-lexical-reference-p bform))) + (and bvar (nx2-var-not-set-by-form-p bvar cform)))))) + (apushed nil) + (bpushed nil)) + (if (and aform (not aconst)) + (if atriv + (x862-one-targeted-reg-form seg aform areg) + (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (x862-one-targeted-reg-form seg bform breg) + (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) + (x862-one-targeted-reg-form seg cform creg) + (unless btriv + (if bconst + (x862-one-targeted-reg-form seg bform breg) + (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) + (unless atriv + (if aconst + (x862-one-targeted-reg-form seg aform areg) + (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) + (values areg breg creg))) + +(defun x862-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg) + (let* ((bnode (nx2-node-gpr-p breg)) + (cnode (nx2-node-gpr-p creg)) + (dnode (nx2-node-gpr-p dreg)) + (atriv (or (null aform) + (and (x862-trivial-p bform areg) + (x862-trivial-p cform areg) + (x862-trivial-p dform areg) + bnode + cnode + dnode))) + (btriv (or (null bform) + (and (x862-trivial-p cform breg) + (x862-trivial-p dform breg) + cnode + dnode))) + (ctriv (or (null cform) + (and (x862-trivial-p dform creg) + dnode))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (nx2-lexical-reference-p aform))) + (and avar + (nx2-var-not-set-by-form-p avar bform) + (nx2-var-not-set-by-form-p avar cform) + (nx2-var-not-set-by-form-p avar dform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (nx2-lexical-reference-p bform))) + (and bvar + (nx2-var-not-set-by-form-p bvar cform) + (nx2-var-not-set-by-form-p bvar dform)))))) + (cconst (and (not ctriv) + (or + (x86-side-effect-free-form-p cform) + (let ((cvar (nx2-lexical-reference-p cform))) + (and cvar (nx2-var-not-set-by-form-p cvar dform)))))) + (apushed nil) + (bpushed nil) + (cpushed nil)) + (if (and aform (not aconst)) + (if atriv + (x862-one-targeted-reg-form seg aform areg) + (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (x862-one-targeted-reg-form seg bform breg) + (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) + (if (and cform (not cconst)) + (if ctriv + (x862-one-targeted-reg-form seg cform creg) + (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg)))))) + (x862-one-targeted-reg-form seg dform dreg) + (unless ctriv + (if cconst + (x862-one-targeted-reg-form seg cform creg) + (x862-elide-pushes seg cpushed (x862-pop-register seg creg)))) + (unless btriv + (if bconst + (x862-one-targeted-reg-form seg bform breg) + (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) + (unless atriv + (if aconst + (x862-one-targeted-reg-form seg aform areg) + (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) + (values areg breg creg dreg))) + +(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg) + (with-x86-local-vinsn-macros (seg) + (let* ((bnode (nx2-node-gpr-p breg)) + (cnode (nx2-node-gpr-p creg)) + (atriv (or (null aform) + (and (x862-trivial-p bform) + (x862-trivial-p cform) + bnode + cnode))) + (btriv (or (null bform) + (and (x862-trivial-p cform) + cnode))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (nx2-lexical-reference-p aform))) + (and avar + (nx2-var-not-set-by-form-p avar bform) + (nx2-var-not-set-by-form-p avar cform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (nx2-lexical-reference-p bform))) + (and bvar (nx2-var-not-set-by-form-p bvar cform)))))) + (adest areg) + (bdest breg) + (cdest creg) + (apushed nil) + (bpushed nil)) + (if (and aform (not aconst)) + (if atriv + (setq adest (x862-one-untargeted-reg-form seg aform ($ areg))) + (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (setq bdest (x862-one-untargeted-reg-form seg bform ($ breg))) + (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) + (setq cdest (x862-one-untargeted-reg-form seg cform creg)) + (unless btriv + (if bconst + (setq bdest (x862-one-untargeted-reg-form seg bform breg)) + (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) + (unless atriv + (if aconst + (setq adest (x862-one-untargeted-reg-form seg aform areg)) + (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) + (values adest bdest cdest)))) + +(defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg) + (let* ((bnode (nx2-node-gpr-p breg)) + (cnode (nx2-node-gpr-p creg)) + (dnode (nx2-node-gpr-p dreg)) + (atriv (or (null aform) + (and (x862-trivial-p bform) + (x862-trivial-p cform) + (x862-trivial-p dform) + bnode + cnode + dnode))) + (btriv (or (null bform) + (and (x862-trivial-p cform) + (x862-trivial-p dform) + cnode + dnode))) + (ctriv (or (null cform) + (x862-trivial-p dform))) + (aconst (and (not atriv) + (or (x86-side-effect-free-form-p aform) + (let ((avar (nx2-lexical-reference-p aform))) + (and avar + (nx2-var-not-set-by-form-p avar bform) + (nx2-var-not-set-by-form-p avar cform) + (nx2-var-not-set-by-form-p avar dform)))))) + (bconst (and (not btriv) + (or + (x86-side-effect-free-form-p bform) + (let ((bvar (nx2-lexical-reference-p bform))) + (and bvar + (nx2-var-not-set-by-form-p bvar cform) + (nx2-var-not-set-by-form-p bvar dform)))))) + (cconst (and (not ctriv) + (or + (x86-side-effect-free-form-p cform) + (let ((cvar (nx2-lexical-reference-p cform))) + (and cvar + (nx2-var-not-set-by-form-p cvar dform)))))) + (adest areg) + (bdest breg) + (cdest creg) + (ddest dreg) + (apushed nil) + (bpushed nil) + (cpushed nil)) + (if (and aform (not aconst)) + (if atriv + (setq adest (x862-one-targeted-reg-form seg aform areg)) + (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (if (and bform (not bconst)) + (if btriv + (setq bdest (x862-one-untargeted-reg-form seg bform breg)) + (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) + (if (and cform (not cconst)) + (if ctriv + (setq cdest (x862-one-untargeted-reg-form seg cform creg)) + (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg)))))) + (setq ddest (x862-one-untargeted-reg-form seg dform dreg)) + (unless ctriv + (if cconst + (setq cdest (x862-one-untargeted-reg-form seg cform creg)) + (x862-elide-pushes seg cpushed (x862-pop-register seg creg)))) + (unless btriv + (if bconst + (setq bdest (x862-one-untargeted-reg-form seg bform breg)) + (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) + (unless atriv + (if aconst + (setq adest (x862-one-untargeted-reg-form seg aform areg)) + (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) + (values adest bdest cdest ddest))) + +(defun x862-lri (seg reg value) + (with-x86-local-vinsn-macros (seg) + (! lri reg value))) + +;;; unsigned variant +(defun x862-lriu (seg reg value) + (with-x86-local-vinsn-macros (seg) + (! lriu reg value))) + +(defun x862-multiple-value-body (seg form) + (let* ((lab (backend-get-next-label)) + (*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (old-stack (x862-encode-stack))) + (with-x86-local-vinsn-macros (seg) + (x862-open-undo $undomvexpect) + (x862-undo-body seg nil (logior $backend-mvpass-mask lab) form old-stack) + (@ lab)))) + +(defun x862-afunc-lfun-ref (afunc) + (or + (afunc-lfun afunc) + (progn (pushnew afunc (afunc-fwd-refs *x862-cur-afunc*) :test #'eq) + afunc))) + +(defun x862-augment-arglist (afunc arglist &optional (maxregs *x862-target-num-arg-regs*)) + (let ((inherited-args (afunc-inherited-vars afunc))) + (when inherited-args + (let* ((current-afunc *x862-cur-afunc*) + (stkargs (car arglist)) + (regargs (cadr arglist)) + (inhforms nil) + (numregs (length regargs)) + (own-inhvars (afunc-inherited-vars current-afunc))) + (dolist (var inherited-args) + (let* ((root-var (nx-root-var var)) + (other-guy + (dolist (v own-inhvars #|(error "other guy not found")|# root-var) + (when (eq root-var (nx-root-var v)) (return v))))) + (push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms))) + (dolist (form inhforms) + (if (%i< numregs maxregs) + (progn + (setq regargs (nconc regargs (list form))) + (setq numregs (%i+ numregs 1))) + (push form stkargs))) + (%rplaca (%cdr arglist) regargs) ; might have started out NIL. + (%rplaca arglist stkargs)))) + arglist) + +(defun x862-acode-operator-supports-u8 (form) + (setq form (acode-unwrapped-form-value form)) + (when (acode-p form) + (let* ((operator (acode-operator form))) + (if (member operator *x862-operator-supports-u8-target*) + (values operator (acode-operand 1 form)))))) + +(defun x862-acode-operator-supports-push (form) + (let ((value (acode-unwrapped-form-value form))) + (when (acode-p value) + (if (or (nx-t value) + (nx-null value) + (let* ((operator (acode-operator value))) + (member operator *x862-operator-supports-push*))) + value)))) + +(defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator) + (with-x86-local-vinsn-macros (seg vreg xfer) + (with-imm-target () (u8 :u8) + (if (and (eql u8-operator (%nx1-operator lisptag)) + (eql 0 u8constant)) + (let* ((formreg (x862-one-untargeted-reg-form seg form *x862-arg-z*))) + + (! set-flags-from-lisptag formreg)) + (progn + (x862-use-operator u8-operator seg u8 nil form) + (if (zerop u8constant) + (! compare-u8-reg-to-zero u8) + (! compare-u8-constant u8 u8constant)))) + ;; Flags set. Branch or return a boolean value ? + (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit)) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))) + +;;; There are other cases involving constants that are worth exploiting. +(defun x862-compare (seg vreg xfer i j cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((iu8 (let* ((i-fixnum (acode-fixnum-form-p i))) + (if (typep i-fixnum '(unsigned-byte 8)) + i-fixnum))) + (ju8 (let* ((j-fixnum (acode-fixnum-form-p j))) + (if (typep j-fixnum '(unsigned-byte 8)) + j-fixnum))) + (u8 (or iu8 ju8)) + (other-u8 (if iu8 j (if ju8 i))) + (js32 (acode-s32-constant-p j)) + (is32 (acode-s32-constant-p i)) + (boolean (backend-crf-p vreg))) + (multiple-value-bind (u8-operator u8-operand) (if other-u8 (x862-acode-operator-supports-u8 other-u8)) + (if u8-operator + (x862-compare-u8 seg vreg xfer u8-operand u8 (if (and iu8 (not (eq cr-bit x86::x86-e-bits))) (logxor 1 cr-bit) cr-bit) true-p u8-operator) + (if (and boolean (or js32 is32)) + (let* ((reg (x862-one-untargeted-reg-form seg (if js32 i j) *x862-arg-z*)) + (constant (or js32 is32))) + (if (zerop constant) + (! compare-reg-to-zero reg) + (! compare-s32-constant reg (or js32 is32))) + (unless (or js32 (eq cr-bit x86::x86-e-bits)) + (setq cr-bit (x862-reverse-cr-bit cr-bit))) + (^ cr-bit true-p)) + (if (and ;(eq cr-bit x86::x86-e-bits) + (or js32 is32)) + (progn + (unless (or js32 (eq cr-bit x86::x86-e-bits)) + (setq cr-bit (x862-reverse-cr-bit cr-bit))) + (x862-test-reg-%izerop + seg + vreg + xfer + (x862-one-untargeted-reg-form + seg + (if js32 i j) + *x862-arg-z*) + cr-bit + true-p + (or js32 is32))) + (multiple-value-bind (ireg jreg) (x862-two-untargeted-reg-forms seg i *x862-arg-y* j *x862-arg-z*) + (x862-compare-registers seg vreg xfer ireg jreg cr-bit true-p))))))))) + +(defun x862-natural-compare (seg vreg xfer i j cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((jconstant (acode-fixnum-form-p j)) + (ju31 (typep jconstant '(unsigned-byte 31))) + (iconstant (acode-fixnum-form-p i)) + (iu31 (typep iconstant '(unsigned-byte 31))) + (boolean (backend-crf-p vreg))) + (if (and boolean (or ju31 iu31)) + (with-imm-target + () (reg :natural) + (x862-one-targeted-reg-form seg (if ju31 i j) reg) + (! compare-u31-constant reg (if ju31 jconstant iconstant)) + (unless (or ju31 (eq cr-bit x86::x86-e-bits)) + (setq cr-bit (x862-reverse-cr-bit cr-bit))) + (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit)) + (^ cr-bit true-p)) + (target-arch-case + (:x8664 + (with-imm-target () (ireg :natural) + (with-imm-target (ireg) (jreg :natural) + (x862-two-targeted-reg-forms seg i ireg j jreg) + (x862-compare-natural-registers seg vreg xfer ireg jreg cr-bit true-p)))) + (:x8632 + (with-imm-target () (jreg :natural) + (x862-one-targeted-reg-form seg i jreg) + (x862-push-register seg jreg) + (x862-one-targeted-reg-form seg j jreg) + (! temp-pop-temp1-as-unboxed-word) + (x862-close-undo) + (x862-compare-natural-registers seg vreg xfer ($ x8632::temp1) jreg cr-bit true-p)))))))) + + + + +(defun x862-compare-natural-registers (seg vreg xfer ireg jreg cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if vreg + (progn + (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit)) + (! compare ireg jreg) + (target-arch-case + (:x8664) + (:x8632 (! mark-temp1-as-node-preserving-flags))) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))) + (^)))) + + +(defun x862-compare-registers (seg vreg xfer ireg jreg cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if vreg + (progn + (! compare ireg jreg) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))) + (^)))) + +(defun x862-compare-register-to-constant (seg vreg xfer ireg cr-bit true-p constant) + (cond ((nx-null constant) + (x862-compare-register-to-nil seg vreg xfer ireg cr-bit true-p)) + (t + (with-x86-local-vinsn-macros (seg vreg xfer) + (when vreg + (if (nx-t constant) + (! compare-to-t ireg) + (let* ((imm (acode-immediate-operand constant)) + (reg (x862-register-constant-p imm))) + (if reg + (! compare-registers reg ireg) + (! compare-constant-to-register (x86-immediate-label imm) ireg)))) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))))) + +(defun x862-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (when vreg + (! compare-to-nil ireg) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))) + +(defun x862-compare-ea-to-nil (seg vreg xfer ea cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (when vreg + (if (addrspec-vcell-p ea) + (with-node-target () temp + (x862-stack-to-register seg ea temp) + (! compare-value-cell-to-nil temp)) + (! compare-vframe-offset-to-nil (memspec-frame-address-offset ea) *x862-vstack*)) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))) + +(defun x862-cr-bit-for-unsigned-comparison (cr-bit) + (ecase cr-bit + (#.x86::x86-e-bits #.x86::x86-e-bits) + (#.x86::x86-ne-bits #.x86::x86-ne-bits) + (#.x86::x86-l-bits #.x86::x86-b-bits) + (#.x86::x86-le-bits #.x86::x86-be-bits) + (#.x86::x86-ge-bits #.x86::x86-ae-bits) + (#.x86::x86-g-bits #.x86::x86-a-bits))) + + +(defun x862-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if vreg + (progn + (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit)) + (regspec-crf-gpr-case + (vreg dest) + (progn + (! double-float-compare ireg jreg) + (^ cr-bit true-p)) + (progn + (! double-float-compare ireg jreg) + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))) + (^)))) + +(defun x862-compare-single-float-registers (seg vreg xfer ireg jreg cr-bit true-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if vreg + (progn + (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit)) + (regspec-crf-gpr-case + (vreg dest) + (progn + (! single-float-compare ireg jreg) + (^ cr-bit true-p)) + (progn + (! single-float-compare ireg jreg) + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))) + (^)))) + + +(defun x862-immediate-form-p (form) + (if (and (consp form) + (or (eq (%car form) (%nx1-operator immediate)) + (eq (%car form) (%nx1-operator simple-function)))) + t)) + +(defun x862-test-%izerop (seg vreg xfer form cr-bit true-p) + (x862-test-reg-%izerop seg vreg xfer (x862-one-untargeted-reg-form seg form *x862-arg-z*) cr-bit true-p 0)) + +(defun x862-test-reg-%izerop (seg vreg xfer reg cr-bit true-p zero) + (declare (fixnum zero)) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if (zerop zero) + (! compare-reg-to-zero reg) + (! compare-s32-constant reg zero)) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^))))) + +(defun x862-lexical-reference-ea (form &optional (no-closed-p t)) + (when (acode-p (setq form (acode-unwrapped-form-value form))) + (if (eq (acode-operator form) (%nx1-operator lexical-reference)) + (let* ((addr (var-ea (%cadr form)))) + (if (typep addr 'lreg) + addr + (unless (and no-closed-p (addrspec-vcell-p addr )) + addr)))))) + + +(defun x862-vpush-register (seg src &optional why info attr) + (with-x86-local-vinsn-macros (seg) + (prog1 + (! vpush-register src) + (setq *x862-tos-reg* src) + (x862-new-vstack-lcell (or why :node) *x862-target-lcell-size* (or attr 0) info) + (x862-adjust-vstack *x862-target-node-size*)))) + + +;;; Need to track stack usage when pushing label for mv-call. +(defun x862-vpush-label (seg label) + (with-x86-local-vinsn-macros (seg) + (prog1 + (! vpush-label label) + (x862-new-vstack-lcell :label *x862-target-lcell-size* 0 nil) + (x862-adjust-vstack *x862-target-node-size*)))) + +(defun x862-temp-push-node (seg reg) + (with-x86-local-vinsn-macros (seg) + (! temp-push-node reg) + (x862-open-undo $undostkblk))) + +(defun x862-temp-pop-node (seg reg) + (with-x86-local-vinsn-macros (seg) + (! temp-pop-node reg) + (x862-close-undo))) + +(defun x862-vpush-register-arg (seg src) + (x862-vpush-register seg src :outgoing-argument)) + + +(defun x862-vpop-register (seg dest) + (with-x86-local-vinsn-macros (seg) + (prog1 + (! vpop-register dest) + (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*)) + (x862-adjust-vstack (- *x862-target-node-size*))))) + +(defun x862-macptr->heap (seg dest src) + (with-x86-local-vinsn-macros (seg) + (! setup-macptr-allocation src) + (! %allocate-uvector dest) + (! %set-new-macptr-value dest))) + +(defun x862-copy-register (seg dest src) + (with-x86-local-vinsn-macros (seg) + (when dest + (let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr)) + (src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr))) + (dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr)) + (src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr))) + (src-mode (if src (get-regspec-mode src))) + (dest-mode (get-regspec-mode dest)) + (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf))) + (if (null src) + (if dest-gpr + (! load-nil dest-gpr) + (if dest-crf + (! set-eq-bit))) + (if (and dest-crf src-gpr) + ;; "Copying" a GPR to a CR field means comparing it to rnil + (! compare-to-nil src) + (if (and dest-gpr src-gpr) + (if (eq src-mode dest-mode) + (unless (eq src-gpr dest-gpr) + (! copy-gpr dest src)) + ;; This is the "GPR <- GPR" case. There are + ;; word-size dependencies, but there's also + ;; lots of redundancy here. + (target-arch-case + (:x8632 + (ecase dest-mode + (#.hard-reg-class-gpr-mode-node ; boxed result. + (case src-mode + (#.hard-reg-class-gpr-mode-node + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + (#.hard-reg-class-gpr-mode-u32 + (x862-box-u32 seg dest src)) + (#.hard-reg-class-gpr-mode-s32 + (x862-box-s32 seg dest src)) + (#.hard-reg-class-gpr-mode-u16 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-address + (x862-macptr->heap seg dest src)))) + ((#.hard-reg-class-gpr-mode-u32 + #.hard-reg-class-gpr-mode-address) + (case src-mode + (#.hard-reg-class-gpr-mode-node + (let* ((src-type (get-node-regspec-type-modes src))) + (declare (fixnum src-type)) + (case dest-mode + (#.hard-reg-class-gpr-mode-u32 + (! unbox-u32 dest src)) + (#.hard-reg-class-gpr-mode-address + (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type) + *x862-reckless*) + (! trap-unless-macptr src)) + (! deref-macptr dest src))))) + ((#.hard-reg-class-gpr-mode-u32 + #.hard-reg-class-gpr-mode-s32 + #.hard-reg-class-gpr-mode-address) + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + (#.hard-reg-class-gpr-mode-u16 + (! u16->u32 dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! s16->s32 dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->u32 dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->s32 dest src)))) + (#.hard-reg-class-gpr-mode-s32 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-s32 dest src)) + ((#.hard-reg-class-gpr-mode-u32 + #.hard-reg-class-gpr-mode-s32 + #.hard-reg-class-gpr-mode-address) + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + (#.hard-reg-class-gpr-mode-u16 + (! u16->u32 dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! s16->s32 dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->u32 dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->s32 dest src)))) + (#.hard-reg-class-gpr-mode-u16 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-u16 dest src)) + ((#.hard-reg-class-gpr-mode-u8 + #.hard-reg-class-gpr-mode-s8) + (! u8->u32 dest src)) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))) + (#.hard-reg-class-gpr-mode-s16 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-s16 dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->s32 dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->u32 dest src)) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))) + (#.hard-reg-class-gpr-mode-u8 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (if *x862-reckless* + (! %unbox-u8 dest src) + (! unbox-u8 dest src))) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))) + (#.hard-reg-class-gpr-mode-s8 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-s8 dest src)) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))))) + (:x8664 + (ecase dest-mode + (#.hard-reg-class-gpr-mode-node ; boxed result. + (case src-mode + (#.hard-reg-class-gpr-mode-node + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + (#.hard-reg-class-gpr-mode-u64 + (x862-box-u64 seg dest src)) + (#.hard-reg-class-gpr-mode-s64 + (x862-box-s64 seg dest src)) + (#.hard-reg-class-gpr-mode-u32 + (x862-box-u32 seg dest src)) + (#.hard-reg-class-gpr-mode-s32 + (x862-box-s32 seg dest src)) + (#.hard-reg-class-gpr-mode-u16 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! box-fixnum dest src)) + (#.hard-reg-class-gpr-mode-address + (x862-macptr->heap seg dest src)))) + ((#.hard-reg-class-gpr-mode-u64 + #.hard-reg-class-gpr-mode-address) + (case src-mode + (#.hard-reg-class-gpr-mode-node + (let* ((src-type (get-node-regspec-type-modes src))) + (declare (fixnum src-type)) + (case dest-mode + (#.hard-reg-class-gpr-mode-u64 + (! unbox-u64 dest src)) + (#.hard-reg-class-gpr-mode-address + (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type) + *x862-reckless*) + (! trap-unless-macptr src)) + (! deref-macptr dest src))))) + ((#.hard-reg-class-gpr-mode-u64 + #.hard-reg-class-gpr-mode-s64 + #.hard-reg-class-gpr-mode-address) + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + ((#.hard-reg-class-gpr-mode-u16 + #.hard-reg-class-gpr-mode-s16) + (! u16->u32 dest src)) + ((#.hard-reg-class-gpr-mode-u8 + #.hard-reg-class-gpr-mode-s8) + (! u8->u32 dest src)))) + (#.hard-reg-class-gpr-mode-s64 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-s64 dest src)) + ((#.hard-reg-class-gpr-mode-u64 + #.hard-reg-class-gpr-mode-s64 + #.hard-reg-class-gpr-mode-address) + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + ((#.hard-reg-class-gpr-mode-u16 + #.hard-reg-class-gpr-mode-s16) + (! s16->s32 dest src)) + ((#.hard-reg-class-gpr-mode-u8 + #.hard-reg-class-gpr-mode-s8) + (! s8->s32 dest src)))) + (#.hard-reg-class-gpr-mode-s32 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-s32 dest src)) + ((#.hard-reg-class-gpr-mode-u32 + #.hard-reg-class-gpr-mode-s32 + #.hard-reg-class-gpr-mode-address) + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + (#.hard-reg-class-gpr-mode-u16 + (! u16->u32 dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! s16->s32 dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->u32 dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->s32 dest src)))) + (#.hard-reg-class-gpr-mode-u32 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (if *x862-reckless* + (! %unbox-u32 dest src) + (! unbox-u32 dest src))) + ((#.hard-reg-class-gpr-mode-u32 + #.hard-reg-class-gpr-mode-s32) + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))) + (#.hard-reg-class-gpr-mode-u16 + (! u16->u32 dest src)) + (#.hard-reg-class-gpr-mode-s16 + (! s16->s32 dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->u32 dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->s32 dest src)))) + (#.hard-reg-class-gpr-mode-u16 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (if *x862-reckless* + (! %unbox-u16 dest src) + (! unbox-u16 dest src))) + ((#.hard-reg-class-gpr-mode-u8 + #.hard-reg-class-gpr-mode-s8) + (! u8->u32 dest src)) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))) + (#.hard-reg-class-gpr-mode-s16 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-s16 dest src)) + (#.hard-reg-class-gpr-mode-s8 + (! s8->s32 dest src)) + (#.hard-reg-class-gpr-mode-u8 + (! u8->u32 dest src)) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))) + (#.hard-reg-class-gpr-mode-u8 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (if *x862-reckless* + (! %unbox-u8 dest src) + (! unbox-u8 dest src))) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))) + (#.hard-reg-class-gpr-mode-s8 + (case src-mode + (#.hard-reg-class-gpr-mode-node + (! unbox-s8 dest src)) + (t + (unless (eql dest-gpr src-gpr) + (! copy-gpr dest src))))))))) + (if src-gpr + (if dest-fpr + (progn + (case src-mode + (#.hard-reg-class-gpr-mode-node + (case dest-mode + (#.hard-reg-class-fpr-mode-double + (unless (or (logbitp hard-reg-class-fpr-type-double + (get-node-regspec-type-modes src)) + *x862-reckless*) + (! trap-unless-double-float src)) + (! get-double dest src)) + (#.hard-reg-class-fpr-mode-single + (unless *x862-reckless* (! trap-unless-single-float src)) + (! get-single dest src))))))) + (if dest-gpr + (case dest-mode + (#.hard-reg-class-gpr-mode-node + (case src-mode + (#.hard-reg-class-fpr-mode-double + (x862-double->heap seg dest src)) + (#.hard-reg-class-fpr-mode-single + (target-arch-case + (:x8632 + (x862-single->heap seg dest src)) + (:x8664 + (! single->node dest src))))))) + (if (and src-fpr dest-fpr) + (unless (eql dest-fpr src-fpr) + (if (= src-mode hard-reg-class-fpr-mode-double) + (if (= dest-mode hard-reg-class-fpr-mode-double) + (! copy-double-float dest src) + (! copy-double-to-single dest src)) + (if (= dest-mode hard-reg-class-fpr-mode-double) + (! copy-single-to-double dest src) + (! copy-single-float dest src)))))))))))))) + +(defun x862-unreachable-store (&optional vreg) + ;; I don't think that anything needs to be done here, + ;; but leave this guy around until we're sure. + ;; (X862-VPUSH-REGISTER will always vpush something, even + ;; if code to -load- that "something" never gets generated. + ;; If I'm right about this, that means that the compile-time + ;; stack-discipline problem that this is supposed to deal + ;; with can't happen.) + (declare (ignore vreg)) + nil) + +;;; bind vars to initforms, as per let*, &aux. +(defun x862-seq-bind (seg vars initforms) + (dolist (var vars) + (x862-seq-bind-var seg var (pop initforms)))) + +(defun x862-target-is-imm-subtag (subtag) + (when subtag + (target-arch-case + (:x8632 + (let* ((masked (logand subtag x8632::fulltagmask))) + (declare (fixnum masked)) + (= masked x8632::fulltag-immheader))) + (:x8664 + (let* ((masked (logand subtag x8664::fulltagmask))) + (declare (fixnum masked)) + (or (= masked x8664::fulltag-immheader-0) + (= masked x8664::fulltag-immheader-1) + (= masked x8664::fulltag-immheader-2))))))) + +(defun x862-target-is-node-subtag (subtag) + (when subtag + (target-arch-case + (:x8632 + (let* ((masked (logand subtag x8632::fulltagmask))) + (declare (fixnum masked)) + (= masked x8632::fulltag-nodeheader))) + (:x8664 + (let* ((masked (logand subtag x8664::fulltagmask))) + (declare (fixnum masked)) + (or (= masked x8664::fulltag-nodeheader-0) + (= masked x8664::fulltag-nodeheader-1))))))) + +(defun x862-dynamic-extent-form (seg curstack val &aux (form val)) + (when (acode-p val) + ;; this will do source note processing even if don't emit anything here, + ;; which is a bit wasteful but not incorrect. + (with-note (form seg) + (with-x86-local-vinsn-macros (seg) + (let* ((op (acode-operator form))) + (cond ((eq op (%nx1-operator list)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-set-nargs seg (x862-formlist seg (%cadr form) nil)) + (x862-open-undo $undostkblk curstack) + (! stack-cons-list)) + (setq val *x862-arg-z*)) + ((eq op (%nx1-operator list*)) + (let* ((arglist (%cadr form))) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-formlist seg (car arglist) (cadr arglist))) + (when (car arglist) + (x862-set-nargs seg (length (%car arglist))) + (! stack-cons-list*) + (x862-open-undo $undostkblk curstack)) + (setq val *x862-arg-z*))) + ((eq op (%nx1-operator multiple-value-list)) + (x862-multiple-value-body seg (%cadr form)) + (x862-open-undo $undostkblk curstack) + (! stack-cons-list) + (setq val *x862-arg-z*)) + ((eq op (%nx1-operator cons)) + (let* ((y ($ *x862-arg-y*)) + (z ($ *x862-arg-z*)) + (result ($ *x862-arg-z*))) + (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z) + (x862-open-undo $undostkblk ) + (! make-tsp-cons result y z) + (setq val result))) + ((eq op (%nx1-operator %consmacptr%)) + (with-imm-target () (address :address) + (x862-one-targeted-reg-form seg form address) + (with-node-target () node + (! macptr->stack node address) + (x862-open-undo $undo-x86-c-frame) + (setq val node)))) + ((eq op (%nx1-operator %new-ptr)) + (let* ((clear-form (caddr form)) + (cval (nx2-constant-form-value clear-form))) + (if cval + (progn + (x862-one-targeted-reg-form seg (%cadr form) ($ *x862-arg-z*)) + (if (nx-null cval) + (! make-stack-block) + (! make-stack-block0))) + (with-crf-target () crf + (let ((stack-block-0-label (backend-get-next-label)) + (done-label (backend-get-next-label)) + (rval ($ *x862-arg-z*)) + (rclear ($ *x862-arg-y*))) + (x862-two-targeted-reg-forms seg (%cadr form) rval clear-form rclear) + (! compare-to-nil crf rclear) + (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits) + (! make-stack-block) + (-> done-label) + (@ stack-block-0-label) + (! make-stack-block0) + (@ done-label))))) + (x862-open-undo $undo-x86-c-frame) + (setq val ($ *x862-arg-z*))) + ((eq op (%nx1-operator make-list)) + (x862-two-targeted-reg-forms seg (%cadr form) ($ *x862-arg-y*) (%caddr form) ($ *x862-arg-z*)) + (x862-open-undo $undostkblk curstack) + (! make-stack-list) + (setq val *x862-arg-z*)) + ((eq op (%nx1-operator vector)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-set-nargs seg (x862-formlist seg (%cadr form) nil)) + (! make-stack-vector)) + (x862-open-undo $undostkblk) + (setq val *x862-arg-z*)) + ((eq op (%nx1-operator %gvector)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (arglist (%cadr form))) + (x862-set-nargs seg (x862-formlist seg (append (car arglist) (reverse (cadr arglist))) nil)) + (! make-stack-gvector)) + (x862-open-undo $undostkblk) + (setq val *x862-arg-z*)) + ((eq op (%nx1-operator closed-function)) + (setq val (x862-make-closure seg (cadr form) t))) ; can't error + ((eq op (%nx1-operator %make-uvector)) + (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr form) + (let* ((fix-subtag (acode-fixnum-form-p subtag)) + (is-node (x862-target-is-node-subtag fix-subtag)) + (is-imm (x862-target-is-imm-subtag fix-subtag))) + (when (or is-node is-imm) + (if init-p + (progn + (x862-three-targeted-reg-forms seg element-count + (target-arch-case + (:x8632 + ($ x8632::temp1)) + (:x8664 + ($ x8664::arg_x))) + subtag ($ *x862-arg-y*) + init ($ *x862-arg-z*)) + (! stack-misc-alloc-init)) + (progn + (x862-two-targeted-reg-forms seg element-count ($ *x862-arg-y*) subtag ($ *x862-arg-z*)) + (! stack-misc-alloc))) + (if is-node + (x862-open-undo $undostkblk) + (x862-open-undo $undo-x86-c-frame)) + (setq val ($ *x862-arg-z*)))))))))) + val)) + +(defun x862-addrspec-to-reg (seg addrspec reg) + (if (memory-spec-p addrspec) + (x862-stack-to-register seg addrspec reg) + (x862-copy-register seg reg addrspec))) + +(defun x862-seq-bind-var (seg var val) + (with-x86-local-vinsn-macros (seg) + (let* ((sym (var-name var)) + (bits (nx-var-bits var)) + (closed-p (and (%ilogbitp $vbitclosed bits) + (%ilogbitp $vbitsetq bits))) + (curstack (x862-encode-stack)) + (make-vcell (and closed-p (eq bits (var-bits var)))) + (closed-downward (and closed-p (%ilogbitp $vbitcloseddownward bits)))) + (unless (fixnump val) + (setq val (nx-untyped-form val)) + (when (and (%ilogbitp $vbitdynamicextent bits) (acode-p val)) + (setq val (x862-dynamic-extent-form seg curstack val)))) + (if (%ilogbitp $vbitspecial bits) + (progn + (x862-dbind seg val sym) + (x862-set-var-ea seg var (x862-vloc-ea (- *x862-vstack* *x862-target-node-size*)))) + (let ((puntval nil)) + (flet ((x862-puntable-binding-p (var initform) + ;; The value returned is acode. + (let* ((bits (nx-var-bits var))) + (if (%ilogbitp $vbitpuntable bits) + initform)))) + (declare (inline x862-puntable-binding-p)) + (if (and (not (x862-load-ea-p val)) + (setq puntval (x862-puntable-binding-p var val))) + (progn + (nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits)) + (let* ((vtype (var-inittype var))) + (when (and vtype (not (eq t vtype))) + (setq puntval (make-acode (%nx1-operator typed-form) + vtype + puntval + nil)))) + (nx2-replace-var-refs var puntval) + (x862-set-var-ea seg var puntval)) + (progn + (let* ((vloc *x862-vstack*) + (reg (let* ((r (nx2-assign-register-var var))) + (if r ($ r))))) + (if (x862-load-ea-p val) + (if reg + (x862-addrspec-to-reg seg val reg) + (if (memory-spec-p val) + (with-node-temps () (temp) + (x862-addrspec-to-reg seg val temp) + (x862-vpush-register seg temp :node var bits)) + (x862-vpush-register seg val :node var bits))) + (if reg + (x862-one-targeted-reg-form seg val reg) + (let* ((pushform (x862-acode-operator-supports-push val))) + (if pushform + (progn + (x862-form seg :push nil pushform) + (x862-new-vstack-lcell :node *x862-target-lcell-size* bits var) + (x862-adjust-vstack *x862-target-node-size*)) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg val *x862-arg-z*) :node var bits))))) + (x862-set-var-ea seg var (or reg (x862-vloc-ea vloc closed-p))) + (if reg + (x862-note-var-cell var reg) + (x862-note-top-cell var)) + (when make-vcell + (with-node-target (*x862-allocptr*) closed + (with-node-target (*x862-allocptr* closed) vcell + (x862-stack-to-register seg vloc closed) + (if closed-downward + (progn + (! make-tsp-vcell vcell closed) + (x862-open-undo $undostkblk)) + (progn + (! setup-vcell-allocation) + (! %allocate-uvector vcell) + (! %init-vcell vcell closed))) + (x862-register-to-stack seg vcell vloc))))))))))))) + + + +;;; Never make a vcell if this is an inherited var. +;;; If the var's inherited, its bits won't be a fixnum (and will +;;; therefore be different from what NX-VAR-BITS returns.) +(defun x862-bind-var (seg var vloc &optional lcell &aux + (bits (nx-var-bits var)) + (closed-p (and (%ilogbitp $vbitclosed bits) (%ilogbitp $vbitsetq bits))) + (closed-downward (if closed-p (%ilogbitp $vbitcloseddownward bits))) + (make-vcell (and closed-p (eq bits (var-bits var)))) + (addr (x862-vloc-ea vloc))) + (with-x86-local-vinsn-macros (seg) + (if (%ilogbitp $vbitspecial bits) + (progn + (x862-dbind seg addr (var-name var)) + (x862-set-var-ea seg var (x862-vloc-ea (- *x862-vstack* *x862-target-node-size*))) + t) + (progn + (when (%ilogbitp $vbitpunted bits) + (compiler-bug "bind-var: var ~s was punted" var)) + (when make-vcell + (with-node-target (*x862-allocptr*) closed + (with-node-target (*x862-allocptr* closed) vcell + (x862-stack-to-register seg vloc closed) + (if closed-downward + (progn + (! make-tsp-vcell vcell closed) + (x862-open-undo $undostkblk)) + (progn + (! setup-vcell-allocation) + (! %allocate-uvector vcell) + (! %init-vcell vcell closed))) + (x862-register-to-stack seg vcell vloc)))) + (when lcell + (setf (lcell-kind lcell) :node + (lcell-attributes lcell) bits + (lcell-info lcell) var) + (x862-note-var-cell var lcell)) + (x862-set-var-ea seg var (x862-vloc-ea vloc closed-p)) + closed-downward)))) + +(defun x862-set-var-ea (seg var ea) + (setf (var-ea var) ea) + (when (and *x862-record-symbols* (or (typep ea 'lreg) (typep ea 'fixnum))) + (let* ((start (x862-emit-note seg :begin-variable-scope))) + (push (list var (var-name var) start (close-vinsn-note start)) + *x862-recorded-symbols*))) + ea) + +(defun x862-close-var (seg var) + (let ((bits (nx-var-bits var))) + (when (and *x862-record-symbols* + (or (logbitp $vbitspecial bits) + (not (logbitp $vbitpunted bits)))) + (let ((endnote (%car (%cdddr (assq var *x862-recorded-symbols*))))) + (unless endnote (compiler-bug "x862-close-var for ~s" (var-name var))) + (setf (vinsn-note-class endnote) :end-variable-scope) + (append-dll-node (vinsn-note-label endnote) seg))))) + +(defun x862-load-ea-p (ea) + (or (typep ea 'fixnum) + (typep ea 'lreg) + (typep ea 'lcell))) + +(defun x862-dbind (seg value sym) + (with-x86-local-vinsn-macros (seg) + (let* ((ea-p (x862-load-ea-p value)) + (nil-p (unless ea-p (nx-null (setq value (nx-untyped-form value))))) + (self-p (unless ea-p (and (or + (eq (acode-operator value) (%nx1-operator bound-special-ref)) + (eq (acode-operator value) (%nx1-operator special-ref))) + (eq (cadr value) sym))))) + (cond ((eq sym '*interrupt-level*) + (let* ((fixval (acode-fixnum-form-p value))) + (cond ((eql fixval 0) + (if *x862-open-code-inline* + (! bind-interrupt-level-0-inline) + (! bind-interrupt-level-0))) + ((eql fixval -1) + (if *x862-open-code-inline* + (! bind-interrupt-level-m1-inline) + (! bind-interrupt-level-m1))) + (t + (if ea-p + (x862-store-ea seg value *x862-arg-z*) + (x862-one-targeted-reg-form seg value ($ *x862-arg-z*))) + (! bind-interrupt-level)))) + (x862-open-undo $undointerruptlevel)) + (t + (if (or nil-p self-p) + (progn + (x862-store-immediate seg (x862-symbol-value-cell sym) *x862-arg-z*) + (if nil-p + (! bind-nil) + (if (or *x862-reckless* (eq (acode-operator value) (%nx1-operator special-ref))) + (! bind-self) + (! bind-self-boundp-check)))) + (progn + (if ea-p + (x862-store-ea seg value *x862-arg-z*) + (x862-one-targeted-reg-form seg value ($ *x862-arg-z*))) + (x862-store-immediate seg (x862-symbol-value-cell sym) ($ *x862-arg-y*)) + (! bind))) + (x862-open-undo $undospecial))) + (x862-new-vstack-lcell :special-value *x862-target-lcell-size* 0 sym) + (x862-new-vstack-lcell :special *x862-target-lcell-size* (ash 1 $vbitspecial) sym) + (x862-new-vstack-lcell :special-link *x862-target-lcell-size* 0 sym) + (x862-adjust-vstack (* 3 *x862-target-node-size*))))) + +;;; Store the contents of EA - which denotes either a vframe location +;;; or a hard register - in reg. + +(defun x862-store-ea (seg ea reg) + (if (typep ea 'fixnum) + (if (memory-spec-p ea) + (x862-stack-to-register seg ea reg) + (x862-copy-register seg reg ea)) + (if (typep ea 'lreg) + (x862-copy-register seg reg ea) + (if (typep ea 'lcell) + (x862-lcell-to-register seg ea reg))))) + + + + +;;; Callers should really be sure that this is what they want to use. +(defun x862-absolute-natural (seg vreg xfer value) + (with-x86-local-vinsn-macros (seg vreg xfer) + (when vreg + (x862-lri seg vreg value)) + (^))) + + + +(defun x862-store-macptr (seg vreg address-reg) + (with-x86-local-vinsn-macros (seg vreg) + (when (x862-for-value-p vreg) + (if (logbitp vreg *backend-imm-temps*) + (<- address-reg) + (x862-macptr->heap seg vreg address-reg))))) + +(defun x862-store-signed-longword (seg vreg imm-reg) + (with-x86-local-vinsn-macros (seg vreg) + (when (x862-for-value-p vreg) + (if (logbitp vreg *backend-imm-temps*) + (<- imm-reg) + (x862-box-s32 seg vreg imm-reg))))) + + + +;; xxx imm regs +(defun x862-%immediate-set-ptr (seg vreg xfer ptr offset val) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((intval (acode-absolute-ptr-p val t)) + (offval (acode-fixnum-form-p offset)) + (for-value (x862-for-value-p vreg))) + (flet ((address-and-node-regs () + (if for-value + (progn + (x862-one-targeted-reg-form seg val ($ *x862-arg-z*)) + (progn + (if intval + (x862-lri seg *x862-imm0* intval) + (! deref-macptr *x862-imm0* *x862-arg-z*)) + (values *x862-imm0* *x862-arg-z*))) + (values (x862-macptr-arg-to-reg seg val ($ *x862-imm0* :mode :address)) nil)))) + (unless (typep offval '(signed-byte 32)) + (setq offval nil)) + (unless (typep intval '(signed-byte 32)) + (setq intval nil)) + (cond (intval + (cond (offval + (with-imm-target () (ptr-reg :address) + (let* ((ptr-reg (x862-one-untargeted-reg-form seg + ptr + ptr-reg))) + (target-word-size-case + (32 + (! mem-set-c-constant-fullword intval ptr-reg offval)) + (64 + (! mem-set-c-constant-doubleword intval ptr-reg offval)))))) + (t + (with-additional-imm-reg () + (with-imm-target () (ptr-reg :address) + (with-imm-target (ptr-reg) (offsetreg :signed-natural) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ *x862-arg-z*)) + (! fixnum->signed-natural offsetreg *x862-arg-z*) + (target-word-size-case + (32 (! mem-set-constant-fullword intval ptr-reg offsetreg)) + (64 (! mem-set-constant-doubleword intval ptr-reg offsetreg)))))))) + (if for-value + (with-imm-target () (val-reg (target-word-size-case (32 :s32) (64 :s64))) + (x862-lri seg val-reg intval) + (<- (set-regspec-mode val-reg (gpr-mode-name-value :address)))))) + (offval + ;; Still simpler than the general case + (with-imm-target () (ptr-reg :address) + (x862-push-register seg + (x862-one-untargeted-reg-form seg ptr ptr-reg))) + (multiple-value-bind (address node) + (address-and-node-regs) + (with-additional-imm-reg () + (with-imm-target (address) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (target-word-size-case + (32 (! mem-set-c-fullword address ptr-reg offval)) + (64 (! mem-set-c-doubleword address ptr-reg offval))))) + (if for-value + (<- node)))) + (t + (with-imm-target () (ptr-reg :address) + (with-additional-imm-reg () + (with-imm-target (ptr-reg) (offset-reg :address) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ *x862-arg-z*)) + (! fixnum->signed-natural offset-reg *x862-arg-z*) + (! fixnum-add2 ptr-reg offset-reg) + (x862-push-register seg ptr-reg)))) + (multiple-value-bind (address node) + (address-and-node-regs) + (with-additional-imm-reg () + (with-imm-target (address) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (target-word-size-case + (32 (! mem-set-c-fullword address ptr-reg 0)) + (64 (! mem-set-c-doubleword address ptr-reg 0))))) + (if for-value + (<- node)))))) + (^)))) + + + + +(defun x862-%immediate-store (seg vreg xfer bits ptr offset val) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if (eql 0 (%ilogand #xf bits)) + (x862-%immediate-set-ptr seg vreg xfer ptr offset val) + (let* ((size (logand #xf bits)) + (signed (not (logbitp 5 bits))) + (nbits (ash size 3)) + (intval (acode-integer-constant-p val nbits)) + (ncbits (if (eql nbits 64) 32 nbits)) + (signed-intval (or (and intval + (> intval 0) + (logbitp (1- ncbits) intval) + (- intval (ash 1 ncbits))) + intval)) + (offval (acode-fixnum-form-p offset)) + (for-value (x862-for-value-p vreg))) + (declare (fixnum size)) + (flet ((val-to-argz-and-imm0 () + (x862-one-targeted-reg-form seg val ($ *x862-arg-z*)) + (if (eq size 8) + (if signed + (! gets64) + (! getu64)) + (if (and (eq size 4) + (target-arch-case + (:x8632 t) + (:x8664 nil))) + (if signed + (! gets32) + (! getu32)) + (! fixnum->signed-natural *x862-imm0* *x862-arg-z*))))) + + (and offval (%i> (integer-length offval) 31) (setq offval nil)) + (and intval (%i> (integer-length intval) 31) (setq intval nil)) + (and intval + (case size + (2 + (if (>= intval 32768) (setq intval (- intval 65536)))) + (1 + (if (>= intval 128) (setq intval (- intval 256)))))) + (cond (intval + (cond (offval + (with-imm-target () (ptr-reg :address) + (let* ((ptr-reg (x862-one-untargeted-reg-form seg + ptr + ptr-reg))) + (case size + (8 (! mem-set-c-constant-doubleword signed-intval ptr-reg offval)) + (4 (! mem-set-c-constant-fullword signed-intval ptr-reg offval)) + (2 (! mem-set-c-constant-halfword signed-intval ptr-reg offval)) + (1 (! mem-set-c-constant-byte signed-intval ptr-reg offval)))))) + (t + (with-imm-target () (ptr-reg :address) + (with-additional-imm-reg (*x862-arg-z*) + (with-imm-target (ptr-reg) (offsetreg :signed-natural) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ *x862-arg-z*)) + (! fixnum->signed-natural offsetreg *x862-arg-z*) + (case size + (8 (! mem-set-constant-doubleword intval ptr-reg offsetreg)) + (4 (! mem-set-constant-fullword intval ptr-reg offsetreg)) + (2 (! mem-set-constant-halfword intval ptr-reg offsetreg)) + (1 (! mem-set-constant-byte intval ptr-reg offsetreg)))))))) + (if for-value + (ensuring-node-target (target vreg) + (x862-lri seg vreg (ash intval *x862-target-fixnum-shift*))))) + (offval + ;; simpler than the general case + (with-imm-target () (ptr-reg :address) + (x862-push-register seg + (x862-one-untargeted-reg-form seg ptr ptr-reg))) + (val-to-argz-and-imm0) + (target-arch-case + (:x8632 + (with-additional-imm-reg (*x862-arg-z*) + (with-imm-temps (x8632::imm0) (ptr-reg) + (x862-pop-register seg ptr-reg) + (case size + (8 (! mem-set-c-doubleword *x862-imm0* ptr-reg offval)) + (4 (! mem-set-c-fullword *x862-imm0* ptr-reg offval)) + (2 (! mem-set-c-halfword *x862-imm0* ptr-reg offval)) + (1 (! mem-set-c-byte *x862-imm0* ptr-reg offval)))))) + (:x8664 + (with-imm-target (x8664::imm0) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (case size + (8 (! mem-set-c-doubleword *x862-imm0* ptr-reg offval)) + (4 (! mem-set-c-fullword *x862-imm0* ptr-reg offval)) + (2 (! mem-set-c-halfword *x862-imm0* ptr-reg offval)) + (1 (! mem-set-c-byte *x862-imm0* ptr-reg offval)))))) + (if for-value + (<- *x862-arg-z*))) + (t + (with-imm-target () (ptr-reg :address) + (with-additional-imm-reg (*x862-arg-z* ptr-reg) + (with-imm-target (ptr-reg) (offset-reg :address) + (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ *x862-arg-z*)) + (! fixnum->signed-natural offset-reg *x862-arg-z*) + (! fixnum-add2 ptr-reg offset-reg) + (x862-push-register seg ptr-reg)))) + (val-to-argz-and-imm0) + (target-arch-case + (:x8632 + ;; Ensure imm0 is marked as in use so that some + ;; vinsn doesn't decide to use it a temp. + (with-additional-imm-reg () + (with-imm-temps (x8632::imm0) (ptr-reg) + (x862-pop-register seg ptr-reg) + (case size + (8 (! mem-set-c-doubleword *x862-imm0* ptr-reg 0)) + (4 (! mem-set-c-fullword *x862-imm0* ptr-reg 0)) + (2 (! mem-set-c-halfword *x862-imm0* ptr-reg 0)) + (1 (! mem-set-c-byte *x862-imm0* ptr-reg 0)))))) + (:x8664 + (with-imm-target (x8664::imm0) (ptr-reg :address) + (x862-pop-register seg ptr-reg) + (case size + (8 (! mem-set-c-doubleword *x862-imm0* ptr-reg 0)) + (4 (! mem-set-c-fullword *x862-imm0* ptr-reg 0)) + (2 (! mem-set-c-halfword *x862-imm0* ptr-reg 0)) + (1 (! mem-set-c-byte *x862-imm0* ptr-reg 0)))))) + (if for-value + (< *x862-arg-z*)))) + + (^)))))) + + + + + +(defun x862-encoding-undo-count (encoding) + (svref encoding 0)) + +(defun x862-encoding-cstack-depth (encoding) ; hardly ever interesting + (svref encoding 1)) + +(defun x862-encoding-vstack-depth (encoding) + (svref encoding 2)) + +(defun x862-encoding-vstack-top (encoding) + (svref encoding 3)) + +(defun x862-encode-stack () + (vector *x862-undo-count* *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*)) + +(defun x862-decode-stack (encoding) + (values (x862-encoding-undo-count encoding) + (x862-encoding-cstack-depth encoding) + (x862-encoding-vstack-depth encoding) + (x862-encoding-vstack-top encoding))) + +(defun x862-equal-encodings-p (a b) + (dotimes (i 3 t) + (unless (eq (svref a i) (svref b i)) (return)))) + +(defun x862-open-undo (&optional (reason $undocatch) (curstack (x862-encode-stack))) + (set-fill-pointer + *x862-undo-stack* + (set-fill-pointer *x862-undo-because* *x862-undo-count*)) + (vector-push-extend curstack *x862-undo-stack*) + (vector-push-extend reason *x862-undo-because*) + (setq *x862-undo-count* (%i+ *x862-undo-count* 1))) + +(defun x862-close-undo (&aux + (new-count (%i- *x862-undo-count* 1)) + (i (aref *x862-undo-stack* new-count))) + (multiple-value-setq (*x862-undo-count* *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*) + (x862-decode-stack i)) + (set-fill-pointer + *x862-undo-stack* + (set-fill-pointer *x862-undo-because* new-count))) + + + + + +;;; "Trivial" means can be evaluated without allocating or modifying registers. +;;; Interim definition, which will probably stay here forever. +(defun x862-trivial-p (form &optional reg &aux untyped-form op bits) + (setq untyped-form (nx-untyped-form form)) + (and + (consp untyped-form) + (not (eq (setq op (%car untyped-form)) (%nx1-operator call))) + (or + (nx-null untyped-form) + (nx-t untyped-form) + (eq op (%nx1-operator simple-function)) + (eq op (%nx1-operator fixnum)) + (eq op (%nx1-operator immediate)) + #+nil + (eq op (%nx1-operator bound-special-ref)) + (and (or (eq op (%nx1-operator inherited-arg)) + (eq op (%nx1-operator lexical-reference))) + (or (%ilogbitp $vbitpunted (setq bits (nx-var-bits (cadr untyped-form)))) + (neq (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) + (%ilogand (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) bits))))) + (or (and reg (neq (hard-regspec-value reg) *x862-codecoverage-reg*)) + (not (code-note-p (acode-note form)))))) + + + +(defun x862-ref-symbol-value (seg vreg xfer sym check-boundp) + (declare (ignorable check-boundp)) + (setq check-boundp (not *x862-reckless*)) + (with-x86-local-vinsn-macros (seg vreg xfer) + (when (or check-boundp vreg) + (unless vreg (setq vreg ($ *x862-arg-z*))) + (if (eq sym '*interrupt-level*) + (ensuring-node-target (target vreg) + (! ref-interrupt-level target)) + (if *x862-open-code-inline* + (ensuring-node-target (target vreg) + (with-node-target (target) src + (let* ((vcell (x862-symbol-value-cell sym)) + (reg (x862-register-constant-p vcell))) + (if reg + (setq src reg) + (x862-store-immediate seg vcell src))) + (if check-boundp + (! ref-symbol-value-inline target src) + (! %ref-symbol-value-inline target src)))) + (let* ((src ($ *x862-arg-z*)) + (dest ($ *x862-arg-z*))) + (x862-store-immediate seg (x862-symbol-value-cell sym) src) + (if check-boundp + (! ref-symbol-value dest src) + (! %ref-symbol-value dest src)) + (<- dest))))) + (^))) + +;;; Should be less eager to box result +(defun x862-extract-charcode (seg vreg xfer char safe) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((src (x862-one-untargeted-reg-form seg char *x862-arg-z*))) + (when safe + (! trap-unless-character src)) + (if vreg + (ensuring-node-target (target vreg) + (! character->fixnum target src))) + (^)))) + + +(defun x862-reference-list (seg vreg xfer listform safe refcdr) + (if (x862-form-typep listform 'list) + (setq safe nil)) ; May also have been passed as NIL. + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((src (x862-one-untargeted-reg-form seg listform *x862-arg-z*))) + (when safe + (! trap-unless-list src)) + (if vreg + (if (eq vreg :push) + (if refcdr + (! %vpush-cdr src) + (! %vpush-car src)) + (ensuring-node-target (target vreg) + (if refcdr + (! %cdr target src) + (! %car target src))))) + (^)))) + + + +(defun x862-misc-byte-count (subtag element-count) + (funcall (arch::target-array-data-size-function + (backend-target-arch *target-backend*)) + subtag element-count)) + + +;;; The naive approach is to vpush all of the initforms, allocate the +;;; miscobj, then sit in a loop vpopping the values into the vector. +;;; That's "naive" when most of the initforms in question are +;;; "side-effect-free" (constant references or references to un-SETQed +;;; lexicals), in which case it makes more sense to just store the +;;; things into the vector cells, vpushing/ vpopping only those things +;;; that aren't side-effect-free. (It's necessary to evaluate any +;;; non-trivial forms before allocating the miscobj, since that +;;; ensures that the initforms are older (in the EGC sense) than it +;;; is.) The break-even point space-wise is when there are around 3 +;;; non-trivial initforms to worry about. + + +(defun x862-allocate-initialized-gvector (seg vreg xfer subtag initforms) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if (null vreg) + (dolist (f initforms) (x862-form seg nil nil f)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (arch (backend-target-arch *target-backend*)) + (n (length initforms)) + (nntriv (let* ((count 0)) + (declare (fixnum count)) + (dolist (f initforms count) + (unless (x86-side-effect-free-form-p f) + (incf count))))) + (header (arch::make-vheader n subtag))) + (declare (fixnum n nntriv)) + (cond ((or *x862-open-code-inline* (> nntriv 3)) + (x862-formlist seg initforms nil) + (target-arch-case + (:x8632 + (x862-lri seg *x862-imm0* header) + (! setup-uvector-allocation *x862-imm0*) + (x862-lri seg *x862-imm0* (- (ash (logandc2 (+ n 2) 1) (arch::target-word-shift arch)) x8632::fulltag-misc))) + (:x8664 + (x862-lri seg *x862-imm0* header) + (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ n 2) 1) (arch::target-word-shift arch)) x8664::fulltag-misc)))) + (! %allocate-uvector vreg) + (unless (eql n 0) + (! %init-gvector vreg (ash n (arch::target-word-shift arch))))) + (t + (let* ((pending ()) + (vstack *x862-vstack*)) + (declare (fixnum vstack)) + (dolist (form initforms) + (if (x86-side-effect-free-form-p form) + (push form pending) + (progn + (push nil pending) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg form *x862-arg-z*))))) + (target-arch-case + (:x8632 + (x862-lri seg *x862-imm0* header) + (! setup-uvector-allocation *x862-imm0*) + (x862-lri seg *x862-imm0* (- (ash (logandc2 (+ n 2) 1) (arch::target-word-shift arch)) x8632::fulltag-misc))) + (:x8664 + (x862-lri seg *x862-imm0* header) + (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ n 2) 1) (arch::target-word-shift arch)) x8664::fulltag-misc)))) + (ensuring-node-target (target vreg) + (! %allocate-uvector target) + (with-node-temps (target) (nodetemp) + (do* ((forms pending (cdr forms)) + (index (1- n) (1- index)) + (pushed-cell (+ vstack (the fixnum (ash nntriv (arch::target-word-shift arch)))))) + ((null forms)) + (declare (list forms) (fixnum pushed-cell)) + (let* ((form (car forms)) + (reg nodetemp)) + (if form + (setq reg (x862-one-untargeted-reg-form seg form nodetemp)) + (progn + (decf pushed-cell *x862-target-node-size*) + (x862-stack-to-register seg (x862-vloc-ea pushed-cell) nodetemp))) + (! misc-set-c-node reg target index))))) + (! vstack-discard nntriv)) + )))) + (^))) + +;;; Heap-allocated constants -might- need memoization: they might be newly-created, +;;; as in the case of synthesized toplevel functions in .pfsl files. +(defun x862-acode-needs-memoization (valform) + (if (x862-form-typep valform 'fixnum) + nil + (let* ((val (acode-unwrapped-form-value valform))) + (if (or (nx-t val) + (nx-null val) + (and (acode-p val) + (let* ((op (acode-operator val))) + (or (eq op (%nx1-operator fixnum)) #|(eq op (%nx1-operator immediate))|#)))) + nil + t)))) + +(defun x862-modify-cons (seg vreg xfer ptrform valform safe setcdr returnptr) + (if (x862-form-typep ptrform 'cons) + (setq safe nil)) ; May also have been passed as NIL. + (with-x86-local-vinsn-macros (seg vreg xfer) + (multiple-value-bind (ptr-vreg val-vreg) (x862-two-targeted-reg-forms seg ptrform ($ *x862-arg-y*) valform ($ *x862-arg-z*)) + (when safe + (! trap-unless-cons ptr-vreg)) + (if setcdr + (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPrplacd) ptr-vreg val-vreg) + (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPrplaca) ptr-vreg val-vreg)) + (if returnptr + (<- ptr-vreg) + (<- val-vreg)) + (^)))) + + + +(defun x862-find-nilret-label () + (dolist (l *x862-nilret-labels*) + (destructuring-bind (label vsp csp register-restore-count register-restore-ea &rest agenda) l + (and (or (and (eql 0 register-restore-count) + (or (not (eql 0 vsp)) + (eq vsp *x862-vstack*))) + (and + (eq register-restore-count *x862-register-restore-count*) + (eq vsp *x862-vstack*))) + (or agenda (eq csp *x862-cstack*)) + (eq register-restore-ea *x862-register-restore-ea*) + (eq (%ilsr 1 (length agenda)) *x862-undo-count*) + (dotimes (i (the fixnum *x862-undo-count*) t) + (unless (and (eq (pop agenda) (aref *x862-undo-because* i)) + (eq (pop agenda) (aref *x862-undo-stack* i))) + (return))) + (return label))))) + +(defun x862-record-nilret-label () + (let* ((lab (backend-get-next-label)) + (info nil)) + (dotimes (i (the fixnum *x862-undo-count*)) + (push (aref *x862-undo-because* i) info) + (push (aref *x862-undo-stack* i) info)) + (push (cons + lab + (cons + *x862-vstack* + (cons + *x862-cstack* + (cons + *x862-register-restore-count* + (cons + *x862-register-restore-ea* + (nreverse info)))))) + *x862-nilret-labels*) + lab)) + +;;; If we know that the form is something that sets a CR bit, +;;; allocate a CR field and evaluate the form in such a way +;;; as to set that bit. +;;; If it's a compile-time constant, branch accordingly and +;;; let the dead code die. +;;; Otherwise, evaluate it to some handy register and compare +;;; that register to RNIL. +;;; "XFER" is a compound destination. +(defun x862-conditional-form (seg xfer form) + (let* ((uwf (acode-unwrapped-form-value form))) + (if (x86-constant-form-p uwf) + (with-note (form seg) + (if (nx-null uwf) + (x862-branch seg (x862-cd-false xfer)) + (x862-branch seg (x862-cd-true xfer)))) + (with-crf-target () crf + (let* ((ea (x862-lexical-reference-ea form nil))) + (if (and ea (memory-spec-p ea)) + (with-note (form seg) + (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits nil)) + (x862-form seg crf xfer form))))))) + + +(defun x862-branch (seg xfer &optional cr-bit true-p) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (with-x86-local-vinsn-macros (seg) + (setq xfer (or xfer 0)) + (when (logbitp $backend-mvpass-bit xfer) ;(x862-mvpass-p cd) + (setq xfer (logand (lognot $backend-mvpass-mask) xfer)) + (unless *x862-returning-values* + (x862-vpush-register seg *x862-arg-z*) + (x862-set-nargs seg 1))) + (if (neq 0 xfer) + (if (eq xfer $backend-return) ;; xfer : RETURN ==> popj + (x862-do-return seg) + (if (not (x862-cd-compound-p xfer)) + (-> xfer) ;; xfer : label# ==> jmp label# + ;; cd is compound : ( / ) + (let* ((truebranch (x862-cd-true xfer)) + (falsebranch (x862-cd-false xfer)) + (tbranch (if true-p truebranch falsebranch)) + (nbranch (if true-p falsebranch truebranch)) + (tn0 (neq 0 tbranch)) + (tnret (neq $backend-return tbranch)) + (nn0 (neq 0 nbranch)) + (nnret (neq $backend-return nbranch)) + (tlabel (if (and tnret tn0) (aref *backend-labels* tbranch))) + (nlabel (if (and nnret nn0) (aref *backend-labels* nbranch)))) + (unless cr-bit (setq cr-bit x86::x86-e-bits)) + (if (and tn0 tnret nn0 nnret) + (progn + (! cbranch-true tlabel cr-bit ) ;; (label# / label#) + (-> nbranch))) + (if (and nnret tnret) + (if nn0 + (! cbranch-false nlabel cr-bit) + (! cbranch-true tlabel cr-bit)) + (let* ((aux-label (backend-get-next-label)) + (auxl (aref *backend-labels* aux-label))) + (if tn0 + (! cbranch-true auxl cr-bit) + (! cbranch-false auxl cr-bit) ) + (x862-do-return seg) + (@ aux-label)))))))))) + +(defun x862-cd-merge (cd label) + (setq cd (or cd 0)) + (let ((mvpass (logbitp $backend-mvpass-bit cd))) + (if (neq 0 (logand (lognot $backend-mvpass-mask) cd)) + (if (x862-cd-compound-p cd) + (x862-make-compound-cd + (x862-cd-merge (x862-cd-true cd) label) + (x862-cd-merge (x862-cd-false cd) label) + mvpass) + cd) + (if mvpass + (logior $backend-mvpass-mask label) + label)))) + +(defun x862-mvpass-p (xfer) + (if xfer (or (logbitp $backend-mvpass-bit xfer) (eq xfer $backend-mvpass)))) + +(defun x862-cd-compound-p (xfer) + (if xfer (logbitp $backend-compound-branch-target-bit xfer))) + +(defun x862-cd-true (xfer) + (if (x862-cd-compound-p xfer) + (ldb $backend-compound-branch-true-byte xfer) + xfer)) + +(defun x862-cd-false (xfer) + (if (x862-cd-compound-p xfer) + (ldb $backend-compound-branch-false-byte xfer) + xfer)) + +(defun x862-make-compound-cd (tpart npart &optional mvpass-p) + (dpb (or npart 0) $backend-compound-branch-false-byte + (dpb (or tpart 0) $backend-compound-branch-true-byte + (logior (if mvpass-p $backend-mvpass-mask 0) $backend-compound-branch-target-mask)))) + +(defun x862-invert-cd (cd) + (if (x862-cd-compound-p cd) + (x862-make-compound-cd (x862-cd-false cd) (x862-cd-true cd) (logbitp $backend-mvpass-bit cd)) + cd)) + + + +;;; execute body, cleanup afterwards (if need to) +(defun x862-undo-body (seg vreg xfer body old-stack) + (let* ((current-stack (x862-encode-stack)) + (numundo (%i- *x862-undo-count* (x862-encoding-undo-count old-stack)))) + (declare (fixnum numundo)) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if (eq current-stack old-stack) + (x862-form seg vreg xfer body) + (if (eq xfer $backend-return) + (progn + (x862-form seg vreg xfer body) + (dotimes (i numundo) (x862-close-undo))) + (if (x862-mvpass-p xfer) + (progn + (x862-mvpass seg body) ; presumed to be ok + (let* ((*x862-returning-values* :pass)) + (x862-nlexit seg xfer numundo) + (^)) + (dotimes (i numundo) (x862-close-undo))) + (progn + ;; There are some cases where storing thru *x862-arg-z* + ;; can be avoided (stores to vlocs, specials, etc.) and + ;; some other case where it can't ($test, $vpush.) The + ;; case of a null vd can certainly avoid it; the check + ;; of numundo is to keep $acc boxed in case of nthrow. + (x862-form seg (if (or vreg (not (%izerop numundo))) *x862-arg-z*) nil body) + (x862-unwind-set seg xfer old-stack) + (when vreg (<- *x862-arg-z*)) + (^)))))))) + + +(defun x862-unwind-set (seg xfer encoding) + (multiple-value-bind (target-catch target-cstack target-vstack target-vstack-lcell) + (x862-decode-stack encoding) + (x862-unwind-stack seg xfer target-catch target-cstack target-vstack) + (setq *x862-undo-count* target-catch + *x862-cstack* target-cstack + *x862-vstack* target-vstack + *x862-top-vstack-lcell* target-vstack-lcell))) + +(defun x862-unwind-stack (seg xfer target-catch target-cstack target-vstack) + (let* ((current-catch *x862-undo-count*) + (current-cstack *x862-cstack*) + (current-vstack *x862-vstack*) + (diff (%i- current-catch target-catch)) + target + (exit-vstack current-vstack)) + (declare (ignorable target)) + (when (neq 0 diff) + (setq exit-vstack (x862-nlexit seg xfer diff)) + (multiple-value-setq (target current-cstack current-vstack) + (x862-decode-stack (aref *x862-undo-stack* target-catch)))) + (if (%i< 0 (setq diff (%i- current-cstack target-cstack))) + (compiler-bug "Bug: adjust foreign stack ?")) + (if (%i< 0 (setq diff (%i- current-vstack target-vstack))) + (with-x86-local-vinsn-macros (seg) + (! vstack-discard (ash diff (- *x862-target-fixnum-shift*))))) + exit-vstack)) + +;;; We can sometimes combine unwinding the catch stack with returning +;;; from the function by jumping to a subprim that knows how to do +;;; this. If catch frames were distinguished from unwind-protect +;;; frames, we might be able to do this even when saved registers are +;;; involved (but the subprims restore them from the last catch +;;; frame.) *** there are currently only subprims to handle the "1 +;;; frame" case; add more *** +(defun x862-do-return (seg) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (mask *x862-register-restore-count*) + (ea *x862-register-restore-ea*) + (label nil) + (vstack nil) + (foldp (not *x862-open-code-inline*))) + (if (%izerop mask) (setq mask nil)) + (with-x86-local-vinsn-macros (seg) + (progn + (setq vstack (x862-set-vstack (x862-unwind-stack seg $backend-return 0 0 #x7fffff))) + (if *x862-returning-values* + (cond ((and mask foldp (setq label (%cdr (assq vstack *x862-valret-labels*)))) + (-> label)) + (t + (@ (setq label (backend-get-next-label))) + (push (cons vstack label) *x862-valret-labels*) + (x862-restore-nvrs seg ea mask nil) + (! nvalret))) + (if (null mask) + (! popj) + (if (and foldp (setq label (assq *x862-vstack* *x862-popreg-labels*))) + (-> (cdr label)) + (let* ((new-label (backend-get-next-label))) + (@ new-label) + (push (cons *x862-vstack* new-label) *x862-popreg-labels*) + (x862-set-vstack (x862-restore-nvrs seg ea mask)) + (! popj))))))) + nil)) + + +(defun x862-mvcall (seg vreg xfer fn arglist &optional recursive-p) + (with-x86-local-vinsn-macros (seg vreg xfer) + (if (and (eq xfer $backend-return) (not (x862-tailcallok xfer))) + (progn + (x862-mvcall seg vreg $backend-mvpass fn arglist t) + (let* ((*x862-returning-values* t)) (^))) + (let* ((mv-p (x862-mv-p xfer))) + (if (null arglist) + (x862-call-fn seg vreg xfer fn arglist nil) + (let* ((label (when (or recursive-p (x862-mvpass-p xfer)) (backend-get-next-label)))) + (when label + (x862-vpush-label seg (aref *backend-labels* label))) + (x862-temp-push-node seg (x862-one-untargeted-reg-form seg fn *x862-arg-z*)) + (x862-multiple-value-body seg (pop arglist)) + (x862-open-undo $undostkblk) + (! save-values) + (dolist (form arglist) + (x862-multiple-value-body seg form) + (! add-values)) + (! recover-values-for-mvcall) + (x862-close-undo) + (x862-temp-pop-node seg *x862-temp0*) + (x862-invoke-fn seg *x862-temp0* nil nil xfer label) + (when label + ;; Pushed a label earlier, then returned to it. + (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*)) + (x862-adjust-vstack (- *x862-target-node-size*))))) + (unless recursive-p + (if mv-p + (unless (eq xfer $backend-return) + (let* ((*x862-returning-values* t)) + (^))) + (progn + (<- *x862-arg-z*) + (^)))))))) + + + + +(defun x862-hard-opt-p (opts) + (or + (dolist (x (%cadr opts)) + (unless (nx-null x) (return t))) + (dolist (x (%caddr opts)) + (when x (return t))))) + +(defun x862-close-lambda (seg req opt rest keys auxen) + (dolist (var req) + (x862-close-var seg var)) + (dolist (var (%car opt)) + (x862-close-var seg var)) + (dolist (var (%caddr opt)) + (when var + (x862-close-var seg var))) + (if rest + (x862-close-var seg rest)) + (dolist (var (%cadr keys)) + (x862-close-var seg var)) + (dolist (var (%caddr keys)) + (if var (x862-close-var seg var))) + (dolist (var (%car auxen)) + (x862-close-var seg var))) + +(defun x862-close-structured-var (seg var) + (if (x862-structured-var-p var) + (apply #'x862-close-structured-lambda seg (cdr var)) + (x862-close-var seg var))) + +(defun x862-close-structured-lambda (seg whole req opt rest keys auxen) + (if whole + (x862-close-var seg whole)) + (dolist (var req) + (x862-close-structured-var seg var)) + (dolist (var (%car opt)) + (x862-close-structured-var seg var)) + (dolist (var (%caddr opt)) + (when var + (x862-close-var seg var))) + (if rest + (x862-close-structured-var seg rest)) + (dolist (var (%cadr keys)) + (x862-close-structured-var seg var)) + (dolist (var (%caddr keys)) + (if var (x862-close-var seg var))) + (dolist (var (%car auxen)) + (x862-close-var seg var))) + + +(defun x862-init-regvar (seg var reg addr) + (with-x86-local-vinsn-macros (seg) + (x862-stack-to-register seg addr reg) + (x862-set-var-ea seg var ($ reg)))) + +(defun x862-bind-structured-var (seg var vloc lcell &optional context) + (if (not (x862-structured-var-p var)) + (let* ((reg (nx2-assign-register-var var))) + (if reg + (x862-init-regvar seg var reg (x862-vloc-ea vloc)) + (x862-bind-var seg var vloc lcell))) + (let* ((v2 (%cdr var)) + (v v2) + (vstack *x862-vstack*) + (whole (pop v)) + (req (pop v)) + (opt (pop v)) + (rest (pop v)) + (keys (pop v))) + + (apply #'x862-bind-structured-lambda seg + (x862-spread-lambda-list seg (x862-vloc-ea vloc) whole req opt rest keys context) + vstack context v2)))) + +(defun x862-bind-structured-lambda (seg lcells vloc context whole req opt rest keys auxen + &aux (nkeys (list-length (%cadr keys)))) + (declare (fixnum vloc)) + (when whole + (x862-bind-structured-var seg whole vloc (pop lcells)) + (incf vloc *x862-target-node-size*)) + (dolist (arg req) + (x862-bind-structured-var seg arg vloc (pop lcells) context) + (incf vloc *x862-target-node-size*)) + (when opt + (if (x862-hard-opt-p opt) + (setq vloc (apply #'x862-structured-initopt seg lcells vloc context opt) + lcells (nthcdr (ash (length (car opt)) 1) lcells)) + (dolist (var (%car opt)) + (x862-bind-structured-var seg var vloc (pop lcells) context) + (incf vloc *x862-target-node-size*)))) + (when rest + (x862-bind-structured-var seg rest vloc (pop lcells) context) + (incf vloc *x862-target-node-size*)) + (when keys + (apply #'x862-structured-init-keys seg lcells vloc context keys) + (setq vloc (%i+ vloc (* *x862-target-node-size* (+ nkeys nkeys))))) + (x862-seq-bind seg (%car auxen) (%cadr auxen))) + +(defun x862-structured-var-p (var) + (and (consp var) (or (eq (%car var) *nx-lambdalist*) + (eq (%car var) (%nx1-operator lambda-list))))) + +(defun x862-simple-var (var &aux (bits (cadr var))) + (if (or (%ilogbitp $vbitclosed bits) + (%ilogbitp $vbitspecial bits)) + (nx-error "Non-simple-variable ~S" (%car var)) + var)) + +(defun x862-nlexit (seg xfer &optional (nlevels 0)) + (let* ((numnthrow 0) + (n *x862-undo-count*) + (cstack *x862-cstack*) + (vstack *x862-vstack*) + (target-vstack) + (lastcatch n) + (returning (eq xfer $backend-return)) + (junk1 nil) + (unbind ()) + (dest (%i- n nlevels)) + (retval *x862-returning-values*) + reason) + (declare (ignorable junk1)) + (with-x86-local-vinsn-macros (seg) + (when (neq 0 nlevels) + (let* ((num-temp-frames 0) + (num-c-frames 0)) + (declare (fixnum num-temp-frames num-c-frames)) + (flet ((pop-temp-frames () + (dotimes (i num-temp-frames) + (! discard-temp-frame))) + (pop-c-frames () + (dotimes (i num-c-frames) + (! discard-c-frame))) + (throw-through-numnthrow-catch-frames () + (when (neq 0 numnthrow) + (let* ((tag-label (backend-get-next-label)) + (tag-label-value (aref *backend-labels* tag-label))) + (x862-lri seg *x862-imm0* (ash numnthrow *x862-target-fixnum-shift*)) + (if retval + (! nthrowvalues tag-label-value) + (! nthrow1value tag-label-value)) + (@= tag-label)) + (setq numnthrow 0) + (multiple-value-setq (junk1 cstack vstack) + (x862-decode-stack (aref *x862-undo-stack* lastcatch))))) + (find-last-catch () + (do* ((n n) + (reasons *x862-undo-because*)) + ((= n dest)) + (declare (fixnum n)) + (when (eql $undocatch (aref reasons (decf n))) + (incf numnthrow) + (setq lastcatch n))))) + + (find-last-catch) + (throw-through-numnthrow-catch-frames) + (setq n lastcatch) + (while (%i> n dest) + (setq reason (aref *x862-undo-because* (setq n (%i- n 1)))) + (cond ((eql $undostkblk reason) + (incf num-temp-frames)) + ((eql $undo-x86-c-frame reason) + (incf num-c-frames)) + ((or (eql reason $undospecial) + (eql reason $undointerruptlevel)) + (push reason unbind)))) + (if unbind + (target-arch-case + (:x8632 + (let* ((*available-backend-node-temps* *available-backend-node-temps*)) + (when retval (use-node-temp x8632::nargs)) + (x862-dpayback-list seg (nreverse unbind)))) + (:x8664 + (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)) + (when retval (use-imm-temp x8664::nargs.q)) + (x862-dpayback-list seg (nreverse unbind)))))) + (when (and (neq lastcatch dest) + (%i> + vstack + (setq target-vstack + (nth-value 2 (x862-decode-stack (aref *x862-undo-stack* dest))))) + (neq retval t)) + (unless returning + (let ((vdiff (%i- vstack target-vstack))) + (if retval + (progn + (x862-lri seg *x862-imm0* vdiff) + (! slide-values)) + (! adjust-vsp vdiff))))) + (pop-temp-frames) + (pop-c-frames))) + vstack)))) + + +;;; Restore the most recent dynamic bindings. Bindings +;;; of *INTERRUPT-LEVEL* get special treatment. +(defun x862-dpayback-list (seg reasons) + (with-x86-local-vinsn-macros (seg) + (let* ((n 0)) + (declare (fixnum n)) + (dolist (r reasons (if (> n 0) (! dpayback n))) + (if (eql r $undospecial) + (incf n) + (if (eql r $undointerruptlevel) + (progn + (when (> n 0) + (! dpayback n) + (setq n 0)) + (if (and *x862-open-code-inline* + (target-arch-case + (:x8632 nil) + (:x8664 t))) + (let* ((*available-backend-node-temps* (bitclr *x862-arg-z* (bitclr x8664::rcx *available-backend-node-temps*)))) + (! unbind-interrupt-level-inline)) + (! unbind-interrupt-level))) + (compiler-bug "unknown payback token ~s" r))))))) + +(defun x862-spread-lambda-list (seg listform whole req opt rest keys + &optional enclosing-ea cdr-p) + (with-x86-local-vinsn-macros (seg) + (let* ((numopt (length (%car opt))) + (nkeys (length (%cadr keys))) + (numreq (length req)) + (vtotal numreq) + (old-top *x862-top-vstack-lcell*) + (argreg ($ (target-arch-case + (:x8632 ($ x8632::temp1)) + (:x8664 ($ x8664::temp0))))) + (keyvectreg (target-arch-case + (:x8632 ($ x8632::arg_y)) + (:x8664 ($ x8664::arg_x)))) + (doadlword (dpb nkeys (byte 8 16) (dpb numopt (byte 8 8) (dpb numreq (byte 8 0) 0 ))))) + (declare (fixnum numopt nkeys numreq vtotal doadlword)) + (when (or (> numreq 255) (> numopt 255) (> nkeys 255)) + (compiler-bug "A lambda list can contain a maximum of 255 required, 255 optional, and 255 keywords args")) + (if (fixnump listform) + (x862-store-ea seg listform argreg) + (x862-one-targeted-reg-form seg listform argreg)) + (when whole + (x862-vpush-register seg argreg :reserved)) + (when keys + (setq doadlword (%ilogior2 (ash #x80000000 -6) doadlword)) + (incf vtotal (%ilsl 1 nkeys)) + (if (%car keys) ; &allow-other-keys + (setq doadlword (%ilogior doadlword (ash #x80000000 -5)))) + (x862-store-immediate seg (%car (%cdr (%cdr (%cdr (%cdr keys))))) keyvectreg)) + (when opt + (setq vtotal (%i+ vtotal numopt)) + (when (x862-hard-opt-p opt) + (setq doadlword (%ilogior2 doadlword (ash #x80000000 -7))) + (setq vtotal (%i+ vtotal numopt)))) + (when rest + (setq doadlword (%ilogior2 (ash #x80000000 -4) doadlword) vtotal (%i+ vtotal 1))) + (x862-reserve-vstack-lcells vtotal) + (! load-adl doadlword) + (if cdr-p + (! macro-bind) + (if enclosing-ea + (progn + (x862-store-ea seg enclosing-ea *x862-arg-z*) + (! destructuring-bind-inner)) + (! destructuring-bind))) + (x862-set-vstack (%i+ *x862-vstack* (* *x862-target-node-size* vtotal))) + (x862-collect-lcells :reserved old-top)))) + + +(defun x862-tailcallok (xfer) + (and (eq xfer $backend-return) + *x862-tail-allow* + (eq 0 *x862-undo-count*))) + +(defun x862-mv-p (cd) + (or (eq cd $backend-return) (x862-mvpass-p cd))) + +(defun x862-expand-note (frag-list note) + (let* ((lab (vinsn-note-label note))) + (case (vinsn-note-class note) + ((:regsave :begin-variable-scope :end-variable-scope + :source-location-begin :source-location-end) + (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)))))) + +(defun x86-emit-instruction-from-vinsn (opcode-template + form + frag-list + instruction + immediate-operand) + #+debug + (format t "~&~a" (cons (x86::x86-opcode-template-mnemonic opcode-template) + form)) + (set-x86-instruction-template instruction opcode-template) + (let* ((operand-classes (x86::x86-opcode-template-operand-classes + opcode-template)) + (operand-types (x86::x86-opcode-template-operand-types + opcode-template)) + (register-table (target-arch-case + (:x8632 x86::*x8632-register-entries*) + (:x8664 x86::*x8664-register-entries*)))) + (dotimes (i (length operand-classes)) + (let* ((operand (pop form)) + (insert-function (svref operand-classes i)) + (type (svref operand-types i)) + (insert-keyword (svref x86::*x86-operand-insert-function-keywords* + insert-function))) + #+debug + (format t "~& insert-function = ~s, operand = ~s" + insert-keyword + operand) + (ecase insert-keyword + (:insert-nothing ) + ((:insert-modrm-reg :insert-xmm-reg) + (x86::insert-modrm-reg-entry instruction + (if (logtest (x86::encode-operand-type + :reg8) + type) + (x86::x86-reg8 operand) + (svref register-table operand)))) + ((:insert-modrm-rm :insert-xmm-rm) + (x86::insert-modrm-rm-entry instruction + (if (logtest (x86::encode-operand-type + :reg8) + type) + (x86::x86-reg8 operand) + (svref register-table operand)))) + (:insert-memory + (destructuring-bind (seg disp base index scale) operand + (when seg (setq seg + (svref x86::*x86-seg-entries* (x86::reg-entry-reg-num (svref register-table seg))))) + ;; Optimize things like this later; almost all + ;; displacements will be constants at this point. + (when disp (setq disp (parse-x86-lap-expression disp))) + (when base (setq base (svref register-table base))) + (when index (setq index (svref register-table index))) + (when scale (setq scale (1- (integer-length scale)))) + (x86::insert-memory-operand-values + instruction + seg + disp + base + index + scale + (if (or base index) + (if disp + (logior (optimize-displacement-type disp) + (x86::encode-operand-type :baseindex)) + (x86::encode-operand-type :baseindex)) + (optimize-displacement-type disp))))) + (:insert-opcode-reg + (x86::insert-opcode-reg-entry instruction + (if (logtest (x86::encode-operand-type + :reg8) + type) + (x86::x86-reg8 operand) + (svref register-table operand)))) + (:insert-opcode-reg4 + (x86::insert-opcode-reg4-entry instruction + (if (logtest (x86::encode-operand-type + :reg8) + type) + (x86::x86-reg8 operand) + (svref register-table operand)))) + (:insert-reg4-pseudo-rm-high + (x86::insert-reg4-pseudo-rm-high-entry instruction + (svref register-table operand))) + (:insert-reg4-pseudo-rm-low + (x86::insert-reg4-pseudo-rm-low-entry instruction + (svref register-table operand))) + (:insert-cc + (unless (typep operand 'x86-lap-expression) + (setq operand (parse-x86-lap-expression operand))) + (setf (ldb (byte 4 0) + (x86::x86-instruction-base-opcode instruction)) + (x86-lap-expression-value operand))) + (:insert-label + (setf (x86::x86-instruction-extra instruction) + (find-or-create-x86-lap-label operand))) + (:insert-imm8-for-int + ) + (:insert-extra + ) + (:insert-imm8 + (setf (x86::x86-immediate-operand-type immediate-operand) + (x86::encode-operand-type :imm8) + (x86::x86-immediate-operand-value immediate-operand) + (parse-x86-lap-expression operand) + (x86::x86-instruction-imm instruction) + immediate-operand)) + (:insert-imm8s + (setf (x86::x86-immediate-operand-type immediate-operand) + (x86::encode-operand-type :imm8s) + (x86::x86-immediate-operand-value immediate-operand) + (parse-x86-lap-expression operand) + (x86::x86-instruction-imm instruction) + immediate-operand)) + (:insert-imm16 + (setf (x86::x86-immediate-operand-type immediate-operand) + (x86::encode-operand-type :imm16) + (x86::x86-immediate-operand-value immediate-operand) + (parse-x86-lap-expression operand) + (x86::x86-instruction-imm instruction) + immediate-operand)) + (:insert-imm32s + (setf (x86::x86-immediate-operand-type immediate-operand) + (x86::encode-operand-type :imm32s) + (x86::x86-immediate-operand-value immediate-operand) + (parse-x86-lap-expression operand) + (x86::x86-instruction-imm instruction) + immediate-operand)) + (:insert-imm32 + (setf (x86::x86-immediate-operand-type immediate-operand) + (x86::encode-operand-type :imm32) + (x86::x86-immediate-operand-value immediate-operand) + (parse-x86-lap-expression operand) + (x86::x86-instruction-imm instruction) + immediate-operand)) + (:insert-imm64 + (setf (x86::x86-immediate-operand-type immediate-operand) + (x86::encode-operand-type :imm64) + (x86::x86-immediate-operand-value immediate-operand) + (parse-x86-lap-expression operand) + (x86::x86-instruction-imm instruction) + immediate-operand)) + (:insert-mmx-reg + (x86::insert-mmx-reg-entry instruction + (svref register-table operand))) + (:insert-mmx-rm + (x86::insert-mmx-rm-entry instruction + (svref register-table operand))) + (:insert-self + (setf (x86::x86-immediate-operand-type immediate-operand) + (x86::encode-operand-type :self) + (x86::x86-immediate-operand-value immediate-operand) + (parse-x86-lap-expression operand) + (x86::x86-instruction-imm instruction) + immediate-operand))))) + (x86-generate-instruction-code frag-list instruction))) + + +(defun x862-expand-vinsns (header frag-list instruction &optional uuo-frag-list) + (let* ((immediate-operand (x86::make-x86-immediate-operand))) + (do-dll-nodes (v header) + (if (%vinsn-label-p v) + (let* ((id (vinsn-label-id v))) + (if (or (typep id 'fixnum) (null id)) + (when (or t (vinsn-label-refs v) (null id)) + (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v))) + (x862-expand-note frag-list id))) + (x862-expand-vinsn v frag-list instruction immediate-operand uuo-frag-list))) + (when uuo-frag-list + (merge-dll-nodes frag-list uuo-frag-list))) + ;;; This doesn't have too much to do with anything else that's + ;;; going on here, but it needs to happen before the lregs + ;;; are freed. There really shouldn't be such a thing as a + ;;; var-ea, of course ... + (dolist (s *x862-recorded-symbols*) + (let* ((var (car s)) + (ea (var-ea var))) + (when (typep ea 'lreg) + (setf (var-ea var) (lreg-value ea))))) + (free-logical-registers) + (x862-free-lcells)) + +;;; It's not clear whether or not predicates, etc. want to look +;;; at an lreg or just at its value slot. +;;; It's clear that the assembler just wants the value, and that +;;; the value had better be assigned by the time we start generating +;;; machine code. +;;; For now, we replace lregs in the operand vector with their values +;;; on entry, but it might be reasonable to make PARSE-OPERAND-FORM +;;; deal with lregs ... +(defun x862-expand-vinsn (vinsn frag-list instruction immediate-operand &optional uuo-frag-list) + (let* ((template (vinsn-template vinsn)) + (main-frag-list frag-list) + (vp (vinsn-variable-parts vinsn)) + (nvp (vinsn-template-nvp template)) + (unique-labels ())) + (declare (fixnum nvp)) + (dotimes (i nvp) + (let* ((val (svref vp i))) + (when (typep val 'lreg) + (setf (svref vp i) (lreg-value val))))) + (dolist (name (vinsn-template-local-labels template)) + (let* ((unique (cons name nil))) + (push unique unique-labels) + (make-x86-lap-label unique))) + (labels ((parse-operand-form (valform &optional for-pred) + (cond ((typep valform 'keyword) + (if (eq valform :rcontext) + (backend-lisp-context-register *target-backend*) + (or (assq valform unique-labels) + (compiler-bug + "unknown vinsn label ~s" valform)))) + ((atom valform) valform) + ((eq (car valform) :rcontext) + (if (>= (backend-lisp-context-register *target-backend*) + (target-arch-case + (:x8632 x86::+x8632-segment-register-offset+) + (:x8664 x86::+x8664-segment-register-offset+))) + (mapcar #'parse-operand-form `(:rcontext ,(cadr valform) nil nil nil)) + (mapcar #'parse-operand-form `(nil ,(cadr valform) :rcontext nil nil)))) + ((and (atom (cdr valform)) + (typep (car valform) 'fixnum)) + (svref vp (car valform))) + ((eq (car valform) :@) + (mapcar #'parse-operand-form (cdr valform))) + ((eq (car valform) :^) + (list :^ (parse-operand-form (cadr valform)))) + (t (let* ((op-vals (cdr valform)) + (parsed-ops (make-list (length op-vals))) + (tail parsed-ops)) + (declare (dynamic-extent parsed-ops) + (list parsed-ops tail)) + (dolist (op op-vals + (if for-pred + (apply (car valform) parsed-ops) + (parse-x86-lap-expression (cons (car valform) parsed-ops)))) + (setq tail (cdr (rplaca tail (parse-operand-form op))))))))) + (expand-insn-form (f) + (let* ((operands (cdr f)) + (head (make-list (length operands))) + (tail head)) + (declare (dynamic-extent head) + (cons head tail)) + (dolist (op operands) + (rplaca tail (parse-operand-form op)) + (setq tail (cdr tail))) + (x86-emit-instruction-from-vinsn + (svref x86::*x86-opcode-templates* (car f)) + head + frag-list + instruction + immediate-operand))) + (eval-predicate (f) + (case (car f) + (:pred (let* ((op-vals (cddr f)) + (parsed-ops (make-list (length op-vals))) + (tail parsed-ops)) + (declare (dynamic-extent parsed-ops) + (list parsed-ops tail)) + (dolist (op op-vals (apply (cadr f) parsed-ops)) + (setq tail (cdr (rplaca tail (parse-operand-form op t))))))) + (:not (not (eval-predicate (cadr f)))) + (:or (dolist (pred (cadr f)) + (when (eval-predicate pred) + (return t)))) + (:and (dolist (pred (cadr f) t) + (unless (eval-predicate pred) + (return nil)))) + (t (compiler-bug "Unknown predicate: ~s" f)))) + (expand-pseudo-op (f) + (case (car f) + (:anchored-uuo-section + (expand-form '(:uuo-section)) + (expand-form `(:long (:^ ,(cadr f))))) + (:anchored-uuo + (expand-form (cadr f)) + ;; add a trailing 0 byte after the uu0 + (frag-list-push-byte frag-list 0)) + ((:uuo :uuo-section) + (if uuo-frag-list + (progn + (setq frag-list uuo-frag-list) + (finish-frag-for-align frag-list 2)) + (compiler-bug "No frag-list for :uuo"))) + ((:main :main-section) + (setq frag-list main-frag-list)) + (t + (destructuring-bind (directive arg) f + (setq arg (parse-operand-form arg)) + (let* ((exp (parse-x86-lap-expression arg)) + (constantp (or (not (x86-lap-expression-p exp)) + (constant-x86-lap-expression-p exp)))) + (if constantp + (let* ((val (x86-lap-expression-value exp))) + (ecase directive + (:byte (frag-list-push-byte frag-list val)) + (:short (frag-list-push-16 frag-list val)) + (:long (frag-list-push-32 frag-list val)) + (:quad (frag-list-push-64 frag-list val)) + (:align (finish-frag-for-align frag-list val)) + (:talign (finish-frag-for-talign frag-list val)))) + (let* ((pos (frag-list-position frag-list)) + (frag (frag-list-current frag-list)) + (reloctype nil)) + (ecase directive + (:byte (frag-list-push-byte frag-list 0) + (setq reloctype :expr8)) + (:short (frag-list-push-16 frag-list 0) + (setq reloctype :expr16)) + (:long (frag-list-push-32 frag-list 0) + (setq reloctype :expr32)) + (:quad (frag-list-push-64 frag-list 0) + (setq reloctype :expr64)) + ((:align :talign) (compiler-bug "~s expression ~s not constant" directive arg))) + (when reloctype + (push + (make-reloc :type reloctype + :arg exp + :pos pos + :frag frag) + (frag-relocs frag)))))))))) + + (expand-form (f) + (if (keywordp f) + (emit-x86-lap-label frag-list (assq f unique-labels)) + (if (atom f) + (compiler-bug "Invalid form in vinsn body: ~s" f) + (if (atom (car f)) + (if (keywordp (car f)) + (expand-pseudo-op f) + (expand-insn-form f)) + (if (eval-predicate (car f)) + (dolist (subform (cdr f)) + (expand-form subform)))))))) + (declare (dynamic-extent #'expand-form #'parse-operand-form #'expand-insn-form #'eval-predicate)) + ;;(format t "~& vinsn = ~s" vinsn) + (dolist (form (vinsn-template-body template)) + ;;(format t "~&form = ~s" form) + (expand-form form )) + (setf (vinsn-variable-parts vinsn) nil) + (when vp + (free-varparts-vector vp))))) + + + + + +(defun x862-builtin-index-subprim (idx) + (let* ((arch (backend-target-arch *target-backend*)) + (table (arch::target-primitive->subprims arch)) + (shift (arch::target-subprims-shift arch))) + (dolist (cell table) + (destructuring-bind ((low . high) . base) cell + (if (and (>= idx low) + (< idx high)) + (return (+ base (ash (- idx low) shift)))))))) + +(defun x862-fixed-call-builtin (seg vreg xfer name subprim) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((index (arch::builtin-function-name-offset name)) + (idx-subprim (if index (x862-builtin-index-subprim index))) + (tail-p (x862-tailcallok xfer))) + (when tail-p + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count*) + (x862-restore-full-lisp-context seg)) + (if idx-subprim + (setq subprim idx-subprim) + (if index (! lri ($ *x862-imm0*) (ash index *x862-target-fixnum-shift*)))) + (if tail-p + (! jump-subprim subprim) + (progn + (! call-subprim subprim) + (<- ($ *x862-arg-z*)) + (^)))))) + +(defun x862-unary-builtin (seg vreg xfer name form) + (with-x86-local-vinsn-macros (seg) + (x862-one-targeted-reg-form seg form ($ *x862-arg-z*)) + (x862-fixed-call-builtin seg vreg xfer name (subprim-name->offset '.SPcallbuiltin1)))) + +(defun x862-binary-builtin (seg vreg xfer name form1 form2) + (with-x86-local-vinsn-macros (seg) + (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) + (x862-fixed-call-builtin seg vreg xfer name (subprim-name->offset '.SPcallbuiltin2)))) + +(defun x862-ternary-builtin (seg vreg xfer name form1 form2 form3) + (with-x86-local-vinsn-macros (seg) + (x862-three-targeted-reg-forms seg form1 (target-arch-case + (:x8632 ($ x8632::temp0)) + (:x8664 ($ x8664::arg_x))) + form2 ($ *x862-arg-y*) + form3 ($ *x862-arg-z*)) + (x862-fixed-call-builtin seg vreg xfer name (subprim-name->offset '.SPcallbuiltin3)))) + + +(eval-when (:compile-toplevel :execute :load-toplevel) + + +(defmacro defx862 (name locative arglist &body forms) + (multiple-value-bind (body decls) + (parse-body forms nil t) + (destructuring-bind (vcode-block dest control &rest other-args) arglist + (let* ((fun `(nfunction ,name + (lambda (,vcode-block ,dest ,control ,@other-args) ,@decls + (block ,name (with-x86-local-vinsn-macros (,vcode-block ,dest ,control) ,@body)))))) + `(progn + (record-source-file ',name 'function) + (svset *x862-specials* (%ilogand #.operator-id-mask (%nx1-operator ,locative)) ,fun)))))) +) + +(defx862 x862-lambda lambda-list (seg vreg xfer req opt rest keys auxen body p2decls &optional code-note) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((stack-consed-rest nil) + (next-method-var-scope-info nil) + (lexprp (if (consp rest) (progn (setq rest (car rest)) t))) + (rest-var-bits (and rest (nx-var-bits rest))) + (rest-ignored-p (and rest (not lexprp) (%ilogbitp $vbitignore rest-var-bits))) + (want-stack-consed-rest (or rest-ignored-p + (and rest (not lexprp) (%ilogbitp $vbitdynamicextent rest-var-bits)))) + (afunc *x862-cur-afunc*) + (inherited-vars (afunc-inherited-vars afunc)) + (fbits (afunc-bits afunc)) + (methodp (%ilogbitp $fbitmethodp fbits)) + (method-var (if methodp (pop req))) + (next-method-p (%ilogbitp $fbitnextmethp fbits)) + (allow-other-keys-p (%car keys)) + (hardopt (x862-hard-opt-p opt)) + (lap-p (when (and (consp (%car req)) (eq (%caar req) '&lap)) + (prog1 (%cdar req) (setq req nil)))) + (num-inh (length inherited-vars)) + (num-req (length req)) + (num-opt (length (%car opt))) + (no-regs nil) + (arg-regs nil) + optsupvloc + reglocatives + pregs + (reserved-lcells nil) + (*x862-vstack* 0)) + (declare (type (unsigned-byte 16) num-req num-opt num-inh)) + (with-x86-p2-declarations p2decls + (setq *x862-inhibit-register-allocation* + (setq no-regs (%ilogbitp $fbitnoregs fbits))) + (multiple-value-setq (pregs reglocatives) + (nx2-allocate-global-registers + *x862-fcells* + *x862-vcells* + (afunc-all-vars afunc) + inherited-vars + (unless no-regs + (target-arch-case + (:x8664 + (if (= (backend-lisp-context-register *target-backend*) x8664::save3) + *reduced-x8664-nvrs* + *x8664-nvrs*)) + (:x8632 + *x8632-nvrs*))))) + (@ (backend-get-next-label)) ; generic self-reference label, should be label #1 + (! establish-fn) + (@ (backend-get-next-label)) ; self-call label + (when keys ;; Ensure keyvect is the first immediate + (x86-immediate-label (%cadr (%cdddr keys)))) + (when code-note + (x862-code-coverage-entry seg code-note)) + (unless next-method-p + (setq method-var nil)) + + (let* ((rev-req (reverse req)) + (rev-fixed (if inherited-vars (reverse (append inherited-vars req)) rev-req)) + (num-fixed (length rev-fixed)) + (rev-opt (reverse (car opt))) + (max-args (unless (or rest keys) (+ num-fixed num-opt)))) + (if (not (or opt rest keys)) + (setq arg-regs (x862-req-nargs-entry seg rev-fixed)) + (if (and (not (or hardopt rest keys)) + (<= num-opt *x862-target-num-arg-regs*)) + (setq arg-regs (x862-simple-opt-entry seg rev-opt rev-fixed)) + (progn + ;; If the minumum acceptable number of args is + ;; non-zero, ensure that at least that many were + ;; received. If there's an upper bound, enforce it. + + (cond (rev-fixed + (x862-reserve-vstack-lcells num-fixed) + (if max-args + (! check-min-max-nargs num-fixed max-args) + (! check-min-nargs num-fixed))) + (max-args + (! check-max-nargs max-args))) + (if (not (or rest keys)) + (if (<= (+ num-fixed num-opt) *x862-target-num-arg-regs*) + (! save-lisp-context-no-stack-args) + (! save-lisp-context-variable-arg-count)) + (! save-lisp-context-variable-arg-count)) + ;; If there were &optional args, initialize their values + ;; to NIL. All of the argregs get vpushed as a result of this. + (when opt + (x862-reserve-vstack-lcells num-opt) + (if max-args + (! push-max-argregs max-args) + (! push-argregs)) + (! default-optionals (+ num-fixed num-opt))) + (when keys + (let* ((keyvect (%car (%cdr (%cdr (%cdr (%cdr keys)))))) + (flags (the fixnum (logior (the fixnum (if rest 4 0)) + (the fixnum (if (or methodp allow-other-keys-p) 1 0))))) + (nkeys (length keyvect)) + (nprev (+ num-fixed num-opt))) + (declare (fixnum flags nkeys nprev)) + (dotimes (i (the fixnum (+ nkeys nkeys))) + (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)) + (target-arch-case + ;; xxx hack alert (see SPkeyword_bind in x86-spentry32.s) + (:x8632 + (! set-high-halfword *x862-temp1* flags)) + (:x8664 + (x862-lri seg *x862-temp1* (ash flags *x862-target-fixnum-shift*)))) + (unless (= nprev 0) + (x862-lri seg *x862-imm0* (ash nprev *x862-target-fixnum-shift*))) + (x86-immediate-label keyvect) + (if (= 0 nprev) + (! simple-keywords) + (if (= 0 num-opt) + (! keyword-args) + (! keyword-bind))))) + (when rest + ;; If any keyword-binding's happened, the key/value + ;; pairs have been slid to the top-of-stack for us. + ;; There'll be an even number of them (nargs - the + ;; "previous" (required/&optional) count.) + (if lexprp + (x862-lexpr-entry seg num-fixed) + (progn + (if want-stack-consed-rest + (setq stack-consed-rest t)) + (let* ((nprev (+ num-fixed num-opt)) + (simple (and (not keys) (= 0 nprev)))) + (declare (fixnum nprev)) + (unless simple + (x862-lri seg *x862-imm0* (ash nprev *x862-target-fixnum-shift*))) + (if stack-consed-rest + (if simple + (! stack-rest-arg) + (if (and (not keys) (= 0 num-opt)) + (! req-stack-rest-arg) + (! stack-cons-rest-arg))) + (if simple + (! heap-rest-arg) + (if (and (not keys) (= 0 num-opt)) + (! req-heap-rest-arg) + (! heap-cons-rest-arg))))) + ;; Make an lcell for the &rest arg + (x862-reserve-vstack-lcells 1)))) + (when hardopt + (x862-reserve-vstack-lcells num-opt) + + + ;; ! opt-supplied-p wants nargs to contain the + ;; actual arg-count minus the number of "fixed" + ;; (required, inherited) args. + + (unless (= 0 num-fixed) + (! scale-nargs num-fixed)) + (cond ((= 1 num-opt) + (! one-opt-supplied-p)) + ((= 2 num-opt) + (! two-opt-supplied-p)) + (t + (! opt-supplied-p num-opt)))) + (let* ((nwords-vpushed (+ num-fixed + num-opt + (if hardopt num-opt 0) + (if lexprp 0 (if rest 1 0)) + (ash (length (%cadr keys)) 1))) + (nbytes-vpushed (* nwords-vpushed *x862-target-node-size*))) + (declare (fixnum nwords-vpushed nbytes-vpushed)) + (x862-set-vstack nbytes-vpushed) + (setq optsupvloc (- *x862-vstack* (* num-opt *x862-target-node-size*))))))) + ;; Caller's context is saved; *x862-vstack* is valid. Might + ;; still have method-var to worry about. + (unless (= 0 pregs) + ;; Save NVRs; load constants into any that get constants. + (x862-save-nvrs seg pregs) + (dolist (pair reglocatives) + (let* ((pair pair) + (constant (car pair)) + (reg (cdr pair))) + (declare (cons pair constant)) + (rplacd constant reg) + (! ref-constant reg (x86-immediate-label (car constant)))))) + (when (and (not (or opt rest keys)) + (<= max-args *x862-target-num-arg-regs*) + (not (some #'null arg-regs))) + (setq *x862-tail-vsp* *x862-vstack* + *x862-tail-nargs* max-args) + (@ (setq *x862-tail-label* (backend-get-next-label)))) + (when method-var + (target-arch-case + (:x8632 + (with-node-target () next-method-context + (! load-next-method-context next-method-context) + (x862-seq-bind-var seg method-var next-method-context))) + (:x8664 + (x862-seq-bind-var seg method-var x8664::next-method-context))) + (when *x862-recorded-symbols* + (setq next-method-var-scope-info (pop *x862-recorded-symbols*)))) + + ;; If any arguments are still in arg_x, arg_y, arg_z, that's + ;; because they weren't vpushed in a "simple" entry case and + ;; belong in some NVR. Put them in their NVRs, so that we + ;; can handle arbitrary expression evaluation (special + ;; binding, value-cell consing, etc.) without clobbering the + ;; argument registers. + (when arg-regs + (do* ((vars arg-regs (cdr vars)) + (arg-reg-numbers (target-arch-case + (:x8632 (list *x862-arg-z* *x862-arg-y*)) + (:x8664 (list *x862-arg-z* *x862-arg-y* x8664::arg_x)))) + (arg-reg-num (pop arg-reg-numbers) (pop arg-reg-numbers))) + ((null vars)) + (declare (list vars)) + (let* ((var (car vars))) + (when var + (let* ((reg (nx2-assign-register-var var))) + (x862-copy-register seg reg arg-reg-num) + (setf (var-ea var) reg)))))) + (setq *x862-entry-vsp-saved-p* t) + (when stack-consed-rest + (x862-open-undo $undostkblk)) + (setq *x862-entry-vstack* *x862-vstack*) + (setq reserved-lcells (x862-collect-lcells :reserved)) + (x862-bind-lambda seg reserved-lcells req opt rest keys auxen optsupvloc arg-regs lexprp inherited-vars) + (when next-method-var-scope-info + (push next-method-var-scope-info *x862-recorded-symbols*))) + (when method-var (x862-heap-cons-next-method-var seg method-var)) + (x862-form seg vreg xfer body) + (x862-close-lambda seg req opt rest keys auxen) + (dolist (v inherited-vars) + (x862-close-var seg v)) + (when method-var + (x862-close-var seg method-var)) + (let* ((bits 0)) + (when (%i> num-inh (ldb $lfbits-numinh -1)) + (setq num-inh (ldb $lfbits-numinh -1))) + (setq bits (dpb num-inh $lfbits-numinh bits)) + (unless lap-p + (when (%i> num-req (ldb $lfbits-numreq -1)) + (setq num-req (ldb $lfbits-numreq -1))) + (setq bits (dpb num-req $lfbits-numreq bits)) + (when (%i> num-opt (ldb $lfbits-numopt -1)) + (setq num-opt (ldb $lfbits-numopt -1))) + (setq bits (dpb num-opt $lfbits-numopt bits)) + (when hardopt (setq bits (%ilogior (%ilsl $lfbits-optinit-bit 1) bits))) + (when rest (setq bits (%ilogior (if lexprp (%ilsl $lfbits-restv-bit 1) (%ilsl $lfbits-rest-bit 1)) bits))) + (when keys (setq bits (%ilogior (%ilsl $lfbits-keys-bit 1) bits))) + (when allow-other-keys-p (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits))) + (when (%ilogbitp $fbitnextmethargsp (afunc-bits afunc)) + (if methodp + (setq bits (%ilogior (%ilsl $lfbits-nextmeth-with-args-bit 1) bits)) + (let ((parent (afunc-parent afunc))) + (when parent + (setf (afunc-bits parent) (bitset $fbitnextmethargsp (afunc-bits parent))))))) + (when methodp + (setq bits (logior (ash 1 $lfbits-method-bit) bits)) + (when next-method-p + (setq bits (logior (%ilsl $lfbits-nextmeth-bit 1) bits))))) + bits))))) + + +(defx862 x862-progn progn (seg vreg xfer forms) + (declare (list forms)) + (if (null forms) + (x862-nil seg vreg xfer) + (loop + (let* ((form (pop forms))) + (if forms + (x862-form seg nil nil form) + (return (x862-form seg vreg xfer form))))))) + + + +(defx862 x862-prog1 prog1 (seg vreg xfer forms) + (if (eq (list-length forms) 1) + (x862-use-operator (%nx1-operator values) seg vreg xfer forms) + (if (null vreg) + (x862-use-operator (%nx1-operator progn) seg vreg xfer forms) + (let* ((float-p (= (hard-regspec-class vreg) hard-reg-class-fpr)) + (crf-p (= (hard-regspec-class vreg) hard-reg-class-crf)) + (node-p (unless (or float-p crf-p) + (= (get-regspec-mode vreg) hard-reg-class-gpr-mode-node))) + (first (pop forms))) + (if (and node-p + (nx-null (car forms)) + (null (cdr forms))) + (x862-form seg vreg xfer first) + (progn + (x862-push-register seg + (if (or node-p crf-p) + (x862-one-untargeted-reg-form seg first *x862-arg-z*) + (x862-one-targeted-reg-form seg first vreg))) + (dolist (form forms) + (x862-form seg nil nil form)) + (if crf-p + (progn + (x862-vpop-register seg *x862-arg-z*) + (<- *x862-arg-z*)) + (x862-pop-register seg vreg)) + (^))))))) + +(defx862 x862-free-reference free-reference (seg vreg xfer sym) + (x862-ref-symbol-value seg vreg xfer sym t)) + +(defx862 x862-special-ref special-ref (seg vreg xfer sym) + (x862-ref-symbol-value seg vreg xfer sym t)) + +(defx862 x862-bound-special-ref bound-special-ref (seg vreg xfer sym) + (x862-ref-symbol-value seg vreg xfer sym t)) + +(defx862 x862-%slot-ref %slot-ref (seg vreg xfer instance idx) + (ensuring-node-target (target (or vreg ($ *x862-arg-z*))) + (multiple-value-bind (v i) + (x862-two-untargeted-reg-forms seg instance *x862-arg-y* idx *x862-arg-z*) + (unless *x862-reckless* + (! check-misc-bound i v)) + (with-node-temps (v) (temp) + (! %slot-ref temp v i) + (x862-copy-register seg target temp)))) + (^)) + +(pushnew (%nx1-operator %svref) *x862-operator-supports-push*) +(defx862 x862-%svref %svref (seg vreg xfer vector index) + (x862-vref seg vreg xfer :simple-vector vector index nil)) + +(pushnew (%nx1-operator svref) *x862-operator-supports-push*) +(defx862 x862-svref svref (seg vreg xfer vector index) + (x862-vref seg vreg xfer :simple-vector vector index (unless *x862-reckless* (nx-lookup-target-uvector-subtag :simple-vector)))) + +;;; It'd be nice if this didn't box the result. Worse things happen ... +;;; Once there's a robust mechanism, adding a CHARCODE storage class shouldn't be hard. +(defx862 x862-%sbchar %sbchar (seg vreg xfer string index) + (x862-vref seg vreg xfer :simple-string string index (unless *x862-reckless* (nx-lookup-target-uvector-subtag :simple-string)))) + + +(defx862 x862-%svset %svset (seg vreg xfer vector index value) + (x862-vset seg vreg xfer :simple-vector vector index value nil)) + +(defx862 x862-svset svset (seg vreg xfer vector index value) + (x862-vset seg vreg xfer :simple-vector vector index value (nx-lookup-target-uvector-subtag :simple-vector))) + +(defx862 x862-typed-form typed-form (seg vreg xfer typespec form &optional check) + (if check + (x862-typechecked-form seg vreg xfer typespec form) + (x862-form seg vreg xfer form))) + +(defx862 x862-type-asserted-form type-asserted-form (seg vreg xfer typespec form &optional check) + (declare (ignore typespec check)) + (x862-form seg vreg xfer form)) + +(defx862 x862-%primitive %primitive (seg vreg xfer &rest ignore) + (declare (ignore seg vreg xfer ignore)) + (compiler-bug "You're probably losing big: using %primitive ...")) + +(defx862 x862-consp consp (seg vreg xfer cc form) + (if (null vreg) + (x862-form seg vreg xfer form) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (! set-z-flag-if-consp (x862-one-untargeted-reg-form seg form *x862-arg-z*)) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))) + +(defx862 x862-cons cons (seg vreg xfer y z) + (if (null vreg) + (progn + (x862-form seg nil nil y) + (x862-form seg nil xfer z)) + (multiple-value-bind (yreg zreg) (x862-two-untargeted-reg-forms seg y *x862-arg-y* z *x862-arg-z*) + (ensuring-node-target (target vreg) + (! cons target yreg zreg)) + (^)))) + + + +(defx862 x862-%rplaca %rplaca (seg vreg xfer ptr val) + (x862-modify-cons seg vreg xfer ptr val nil nil t)) + +(defx862 x862-%rplacd %rplacd (seg vreg xfer ptr val) + (x862-modify-cons seg vreg xfer ptr val nil t t)) + +(defx862 x862-rplaca rplaca (seg vreg xfer ptr val) + (x862-modify-cons seg vreg xfer ptr val t nil t)) + +(defx862 x862-set-car set-car (seg vreg xfer ptr val) + (x862-modify-cons seg vreg xfer ptr val t nil nil)) + +(defx862 x862-rplacd rplacd (seg vreg xfer ptr val) + (x862-modify-cons seg vreg xfer ptr val t t t)) + +(defx862 x862-set-cdr set-cdr (seg vreg xfer ptr val) + (x862-modify-cons seg vreg xfer ptr val t t nil)) + +(pushnew (%nx1-operator %car) *x862-operator-supports-push*) +(defx862 x862-%car %car (seg vreg xfer form) + (x862-reference-list seg vreg xfer form nil nil)) + +(pushnew (%nx1-operator %cdr) *x862-operator-supports-push*) +(defx862 x862-%cdr %cdr (seg vreg xfer form) + (x862-reference-list seg vreg xfer form nil t)) + +(pushnew (%nx1-operator car) *x862-operator-supports-push*) +(defx862 x862-car car (seg vreg xfer form) + (x862-reference-list seg vreg xfer form t nil)) + +(pushnew (%nx1-operator cdr) *x862-operator-supports-push*) +(defx862 x862-cdr cdr (seg vreg xfer form) + (x862-reference-list seg vreg xfer form t t)) + +(defx862 x862-vector vector (seg vreg xfer arglist) + (x862-allocate-initialized-gvector seg vreg xfer + (nx-lookup-target-uvector-subtag + :simple-vector) arglist)) + +(defx862 x862-%gvector %gvector (seg vreg xfer arglist) + (let* ((all-on-stack (append (car arglist) (reverse (cadr arglist)))) + (subtag-form (car all-on-stack)) + (subtag (acode-fixnum-form-p subtag-form))) + (if (null vreg) + (dolist (form all-on-stack (^)) (x862-form seg nil nil form)) + (if (null subtag) + (progn ; Vpush everything and call subprim + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-set-nargs seg (x862-formlist seg all-on-stack nil)) + (! gvector)) + (<- *x862-arg-z*) + (^)) + (x862-allocate-initialized-gvector seg vreg xfer subtag (cdr all-on-stack)))))) + +;;; Should be less eager to box result +(defx862 x862-%char-code %char-code (seg vreg xfer c) + (x862-extract-charcode seg vreg xfer c nil)) + +(defx862 x862-char-code char-code (seg vreg xfer c) + (x862-extract-charcode seg vreg xfer c (not (x862-form-typep c 'character)))) + +(defx862 x862-%ilogior2 %ilogior2 (seg vreg xfer form1 form2) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (x862-use-operator (%nx1-operator fixnum) seg vreg xfer (logior fix1 fix2))) + (let* ((fixval (or fix1 fix2)) + (fiximm (if fixval (<= (integer-length fixval) + (- 31 *x862-target-fixnum-shift*)))) + (otherform (when fiximm (if fix1 form2 form1)))) + (if otherform + (if (null vreg) + (x862-form seg nil xfer otherform) + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg otherform target) + (! %logior-c target target (ash fixval *x862-target-fixnum-shift*)))) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) + (if vreg (ensuring-node-target (target vreg) (! %logior2 target r1 r2))))) + (^)))) + +;;; in a lot of (typical ?) cases, it might be possible to use a +;;; rotate-and-mask instead of andi./andis. + +(defx862 x862-%ilogand2 %ilogand2 (seg vreg xfer form1 form2) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (x862-use-operator (%nx1-operator fixnum) seg vreg xfer (logand fix1 fix2))) + (let* ((fixval (or fix1 fix2)) + (fiximm (if fixval (<= (integer-length fixval) + (- 31 *x862-target-fixnum-shift*)))) + (otherform (when fiximm (if fix1 form2 form1)))) + (if otherform + (if (null vreg) + (x862-form seg nil xfer otherform) + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg otherform target) + (! %logand-c target target (ash fixval *x862-target-fixnum-shift*)))) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) + (if vreg (ensuring-node-target (target vreg) (! %logand2 target r1 r2))))) + (^)))) + +(defx862 x862-%ilogxor2 %ilogxor2 (seg vreg xfer form1 form2) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (x862-use-operator (%nx1-operator fixnum) seg vreg xfer (logxor fix1 fix2))) + (let* ((fixval (or fix1 fix2)) + (fiximm (if fixval (<= (integer-length fixval) + (- 31 *x862-target-fixnum-shift*)))) + (otherform (when fiximm (if fix1 form2 form1)))) + (if otherform + (if (null vreg) + (x862-form seg nil xfer otherform) + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg otherform target) + (! %logxor-c target target (ash fixval *x862-target-fixnum-shift*)))) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) + (if vreg (ensuring-node-target (target vreg) (! %logxor2 target r1 r2))))) + (^)))) + +(defx862 x862-%ineg %ineg (seg vreg xfer n) + (if (null vreg) + (x862-form seg vreg xfer n) + (progn + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg n target) + (! negate-fixnum target) + (x862-check-fixnum-overflow seg target)) + (^ )))) + +(defx862 x862-%%ineg %%ineg (seg vreg xfer n) + (if (null vreg) + (x862-form seg vreg xfer n) + (progn + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg n target) + (when vreg + (! negate-fixnum target))) + (^)))) + +(defx862 x862-characterp characterp (seg vreg xfer cc form) + (x862-char-p seg vreg xfer cc form)) + +(pushnew (%nx1-operator struct-ref) *x862-operator-supports-push*) +(defx862 x862-struct-ref struct-ref (seg vreg xfer struct offset) + (x862-vref seg vreg xfer :struct struct offset (unless *x862-reckless* (nx-lookup-target-uvector-subtag :struct)))) + +(defx862 x862-struct-set struct-set (seg vreg xfer struct offset value) + (x862-vset seg vreg xfer :struct struct offset value (unless *x862-reckless* (nx-lookup-target-uvector-subtag :struct)))) + +(defx862 x862-istruct-typep istruct-typep (seg vreg xfer cc form type) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form *x862-arg-y* type *x862-arg-z*) + (! set-z-flag-if-istruct-typep r1 r2) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))) + + +(pushnew (%nx1-operator lisptag) *x862-operator-supports-u8-target*) +(defx862 x862-lisptag lisptag (seg vreg xfer node) + (if (null vreg) + (x862-form seg vreg xfer node) + (progn + (unboxed-other-case (vreg :u8) + (! extract-tag vreg (x862-one-untargeted-reg-form seg node *x862-arg-z*)) + (ensuring-node-target (target vreg) + (! extract-tag-fixnum target (x862-one-untargeted-reg-form seg node *x862-arg-z*)))) + (^)))) + +(pushnew (%nx1-operator fulltag) *x862-operator-supports-u8-target*) +(defx862 x862-fulltag fulltag (seg vreg xfer node) + (if (null vreg) + (x862-form seg vreg xfer node) + (progn + (unboxed-other-case (vreg :u8) + (! extract-fulltag vreg (x862-one-untargeted-reg-form seg node *x862-arg-z*)) + (ensuring-node-target (target vreg) + (! extract-fulltag-fixnum target (x862-one-untargeted-reg-form seg node *x862-arg-z*)))) + (^)))) + +(pushnew (%nx1-operator typecode) *x862-operator-supports-u8-target*) +(defx862 x862-typecode typecode (seg vreg xfer node) + (if (null vreg) + (x862-form seg vreg xfer node) + (progn + (unboxed-other-case (vreg :u8) + (! extract-typecode vreg (x862-one-untargeted-reg-form seg node *x862-arg-z*)) + (let* ((reg (x862-one-untargeted-reg-form seg node (if (eq (hard-regspec-value vreg) *x862-arg-z*) + *x862-arg-y* *x862-arg-z*)))) + (ensuring-node-target (target vreg) + (! extract-typecode-fixnum target reg )))) + (^)))) + +(defx862 x862-setq-special setq-special (seg vreg xfer sym val) + (let* ((symreg ($ *x862-arg-y*)) + (valreg ($ *x862-arg-z*))) + (x862-one-targeted-reg-form seg val valreg) + (x862-store-immediate seg (x862-symbol-value-cell sym) symreg) + (! setq-special symreg valreg) + (<- valreg)) + (^)) + + +(defx862 x862-local-go local-go (seg vreg xfer tag) + (declare (ignorable xfer)) + (let* ((curstack (x862-encode-stack)) + (label (cadr tag)) + (deststack (caddr tag))) + (if (not (x862-equal-encodings-p curstack deststack)) + (multiple-value-bind (catch cstack vstack) + (x862-decode-stack deststack) + (x862-unwind-stack seg nil catch cstack vstack))) + (-> label) + (x862-unreachable-store vreg))) + +(defx862 x862-local-block local-block (seg vreg xfer blocktag body) + (let* ((curstack (x862-encode-stack)) + (compound (x862-cd-compound-p xfer)) + (mvpass-p (x862-mvpass-p xfer)) + (need-label (if xfer (or compound mvpass-p) t)) + end-of-block + last-cd + (dest (if (backend-crf-p vreg) *x862-arg-z* vreg))) + (if need-label + (setq end-of-block (backend-get-next-label))) + (setq last-cd (if need-label (%ilogior2 (if mvpass-p $backend-mvpass-mask 0) end-of-block) xfer)) + (%rplaca blocktag (cons (cons dest last-cd) curstack)) + (if mvpass-p + (x862-multiple-value-body seg body) + (x862-form seg dest (if xfer last-cd) body)) + (when need-label + (@ end-of-block) + (if compound + (<- dest)) + (x862-branch seg (logand (lognot $backend-mvpass-mask) (or xfer 0)))))) + +(defx862 x862-%izerop %izerop (seg vreg xfer cc form) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (x862-test-%izerop seg vreg xfer form cr-bit true-p))) + + +(defx862 x862-uvsize uvsize (seg vreg xfer v) + (let* ((misc-reg (x862-one-untargeted-reg-form seg v *x862-arg-z*))) + (unless *x862-reckless* (! trap-unless-uvector misc-reg)) + (if vreg + (ensuring-node-target (target vreg) + (! misc-element-count-fixnum target misc-reg))) + (^))) + +(defx862 x862-%ilsl %ilsl (seg vreg xfer form1 form2) + (if (null vreg) + (progn + (x862-form seg nil nil form1) + (x862-form seg nil xfer form2)) + (let* ((const (acode-fixnum-form-p form1)) + (max (target-arch-case (:x8632 31) (:x8664 63)))) + (ensuring-node-target (target vreg) + (if const + (let* ((src (x862-one-untargeted-reg-form seg form2 *x862-arg-z*))) + (if (<= const max) + (! %ilsl-c target const src) + (! lri target 0))) + (multiple-value-bind (count src) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) + (! %ilsl target count src)))) + (^)))) + +(defx862 x862-endp endp (seg vreg xfer cc form) + (let* ((formreg (x862-one-untargeted-reg-form seg form *x862-arg-z*))) + (! trap-unless-list formreg) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (x862-compare-register-to-nil seg vreg xfer formreg cr-bit true-p)))) + + + +(defx862 x862-%code-char %code-char (seg vreg xfer c) + (if (null vreg) + (x862-form seg nil xfer c) + (progn + (ensuring-node-target (target vreg) + (with-imm-target () (dest :u8) + (! u32->char target (x862-one-untargeted-reg-form seg c dest)))) + (^)))) + +(defx862 x862-%schar %schar (seg vreg xfer str idx) + (multiple-value-bind (src unscaled-idx) + (x862-two-untargeted-reg-forms seg str *x862-arg-y* idx *x862-arg-z*) + (if vreg + (ensuring-node-target (target vreg) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! %schar8 target src unscaled-idx)) + (t (! %schar32 target src unscaled-idx))))) + (^))) + +(defx862 x862-%set-schar %set-schar (seg vreg xfer str idx char) + (multiple-value-bind (src unscaled-idx char) + (x862-three-untargeted-reg-forms seg + str (target-arch-case + (:x8632 x8632::temp0) + (:x8664 x8664::arg_x)) + idx *x862-arg-y* + char *x862-arg-z*) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! %set-schar8 src unscaled-idx char)) + (t (! %set-schar32 src unscaled-idx char))) + (when vreg (<- char)) + (^))) + +(defx862 x862-%set-scharcode %set-scharcode (seg vreg xfer str idx char) + (multiple-value-bind (src unscaled-idx char) + (x862-three-untargeted-reg-forms seg str (target-arch-case + (:x8632 x8632::temp0) + (:x8664 x8664::arg_x)) + idx *x862-arg-y* + char *x862-arg-z*) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 + (! %set-scharcode8 src unscaled-idx char)) + (t + (! %set-scharcode32 src unscaled-idx char))) + (when vreg (<- char)) + (^))) + +(defx862 x862-%scharcode %scharcode (seg vreg xfer str idx) + (multiple-value-bind (src unscaled-idx) + (x862-two-untargeted-reg-forms seg str *x862-arg-y* idx *x862-arg-z*) + (if vreg + (ensuring-node-target (target vreg) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! %scharcode8 target src unscaled-idx)) + (t (! %scharcode32 target src unscaled-idx))))) + (^))) + + + +(defx862 x862-code-char code-char (seg vreg xfer c) + (let* ((reg (x862-one-untargeted-reg-form seg c *x862-arg-z*))) + ;; Typecheck even if result unused. + (! require-char-code reg) + (if vreg + (ensuring-node-target (target vreg) + (! fixnum->char target reg))) + (^))) + +(defx862 x862-%valid-code-char %valid-code-char (seg vreg xfer c) + (let* ((reg (x862-one-untargeted-reg-form seg c *x862-arg-z*))) + (when *x862-full-safety* (! require-char-code reg)) + (if vreg + (ensuring-node-target (target vreg) + (! code-char->char target reg))) + (^))) + +(defun x862-eq-test (seg vreg xfer cc form1 form2) + (with-x86-local-vinsn-macros (seg) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (let* ((f1 (acode-unwrapped-form form1)) + (f2 (acode-unwrapped-form form2))) + (cond ((or (nx-null f1 ) + (nx-t f1) + (and (acode-p f1) + (eq (acode-operator f1) (%nx1-operator immediate)))) + (x862-compare-register-to-constant seg vreg xfer (x862-one-untargeted-reg-form seg form2 ($ *x862-arg-z*)) cr-bit true-p f1)) + ((or (nx-null f2) + (nx-t f2) + (and (acode-p f2) + (eq (acode-operator f2) (%nx1-operator immediate)))) + (x862-compare-register-to-constant seg vreg xfer + (x862-one-untargeted-reg-form seg form1 ($ *x862-arg-z*)) + cr-bit true-p f2)) + (t (x862-compare seg vreg xfer form1 form2 cr-bit true-p))))))) + +(defx862 x862-eq eq (seg vreg xfer cc form1 form2) + (x862-eq-test seg vreg xfer cc form1 form2)) + +(defx862 x862-neq neq (seg vreg xfer cc form1 form2) + (x862-eq-test seg vreg xfer cc form1 form2)) + +(defx862 x862-numcmp numcmp (seg vreg xfer cc form1 form2) + (let* ((name (ecase (cadr cc) + (:eq '=-2) + (:ne '/=-2) + (:lt '<-2) + (:le '<=-2) + (:gt '>-2) + (:ge '>=-2)))) + (if (or (x862-explicit-non-fixnum-type-p form1) + (x862-explicit-non-fixnum-type-p form2)) + (x862-binary-builtin seg vreg xfer name form1 form2) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (if (funcall name fix1 fix2) + (x862-t seg vreg xfer) + (x862-nil seg vreg xfer)) + (x862-inline-numcmp seg vreg xfer cc name form1 form2)))))) + +(defun x862-inline-numcmp (seg vreg xfer cc name form1 form2) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2)) + (fixval (or fix1 fix2)) + (fiximm (if fixval (<= (integer-length fixval) + (- 31 *x862-target-fixnum-shift*)))) + (otherform (when fiximm (if fix1 form2 form1))) + (out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + (if otherform + (x862-one-targeted-reg-form seg otherform ($ *x862-arg-y*)) + (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*))) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ *x862-arg-y*) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ *x862-arg-y*) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ *x862-arg-y*) ($ *x862-arg-z*) (aref *backend-labels* out-of-line))))) + (if otherform + (if (zerop fixval) + (! compare-reg-to-zero ($ *x862-arg-y*)) + (! compare-s32-constant ($ *x862-arg-y*) (ash fixval *x862-target-fixnum-shift*))) + (! compare ($ *x862-arg-y*) ($ *x862-arg-z*))) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (when otherform + (unless (or (and fix2 (not fix1)) (eq cr-bit x86::x86-e-bits)) + (setq cr-bit (x862-reverse-cr-bit cr-bit)))) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean ($ *x862-arg-z*) cr-bit) + (-> done) + (@ out-of-line) + (when otherform + (x862-lri seg ($ *x862-arg-z*) (ash fixval *x862-target-fixnum-shift*)) + (unless (or fix2 (eq cr-bit x86::x86-e-bits)) + (! xchg-registers ($ *x862-arg-z*) ($ *x862-arg-y*)))) + (let* ((index (arch::builtin-function-name-offset name)) + (idx-subprim (x862-builtin-index-subprim index))) + (! call-subprim-2 ($ *x862-arg-z*) idx-subprim ($ *x862-arg-y*) ($ *x862-arg-z*))) + (@ done) + (<- ($ *x862-arg-z*)) + (^))))) + + + + +(defx862 x862-%word-to-int %word-to-int (seg vreg xfer form) + (if (null vreg) + (x862-form seg nil xfer form) + (progn + (ensuring-node-target (target vreg) + (! sign-extend-halfword target (x862-one-untargeted-reg-form seg form *x862-arg-z*))) + (^)))) + +(defx862 x862-multiple-value-list multiple-value-list (seg vreg xfer form) + (x862-multiple-value-body seg form) + (! list) + (when vreg + (<- *x862-arg-z*)) + (^)) + +(defx862 x862-immform immediate (seg vreg xfer form) + (x862-immediate seg vreg xfer form)) + +(pushnew (%nx1-operator lexical-reference) *x862-operator-supports-push*) +(defx862 x862-lexical-reference lexical-reference (seg vreg xfer varnode) + (let* ((ea-or-form (var-ea varnode))) + (if (and (acode-punted-var-p varnode) (not (fixnump ea-or-form))) + (if (or (not (eq vreg :push)) + (x862-acode-operator-supports-push ea-or-form)) + (x862-form seg vreg xfer ea-or-form) + (ensuring-node-target (target vreg) + (x862-form seg target xfer ea-or-form) + (! vpush-register target))) + (let* ((cell (x862-lookup-var-cell varnode))) + (if (and cell (typep cell 'lcell)) + (if (x862-ensure-lcell-offset cell (logand ea-or-form #xffff)) + (and nil (format t "~& could use cell ~s for var ~s" cell (var-name varnode))) + (if (logbitp x862-debug-verbose-bit *x862-debug-mask*) + (compiler-bug "wrong ea for lcell for var ~s: got ~d, expected ~d" + (var-name varnode) (calc-lcell-offset cell) (logand ea-or-form #xffff)))) + (if (not cell) + (when (memory-spec-p ea-or-form) + (if (logbitp x862-debug-verbose-bit *x862-debug-mask*) + (compiler-bug "no lcell for ~s." (var-name varnode)))))) + (unless (or (typep ea-or-form 'lreg) (fixnump ea-or-form)) + (compiler-bug "bogus ref to var ~s (~s) : ~s " varnode (var-name varnode) ea-or-form)) + (x862-do-lexical-reference seg vreg ea-or-form) + (^))))) + +(defx862 x862-setq-lexical setq-lexical (seg vreg xfer varspec form) + (let* ((ea (var-ea varspec))) + ;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) + (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) + (or (null vreg) (eq ea vreg))) + ea + *x862-arg-z*)))) + (x862-do-lexical-setq seg vreg ea valreg)) + (^))) + + + +(pushnew (%nx1-operator fixnum) *x862-operator-supports-push*) +(defx862 x862-fixnum fixnum (seg vreg xfer value) + (if (null vreg) + (^) + (if (eq vreg :push) + (let* ((boxed (ash value *x862-target-fixnum-shift*))) + (if (typep boxed '(signed-byte 32)) + (! vpush-fixnum boxed) + (with-node-target () target + (x862-absolute-natural seg target nil boxed) + (! vpush-register target))) + (^)) + (let* ((class (hard-regspec-class vreg)) + (mode (get-regspec-mode vreg)) + (unboxed (if (= class hard-reg-class-gpr) + (not (or (= hard-reg-class-gpr-mode-node mode) + (= hard-reg-class-gpr-mode-address mode)))))) + (if unboxed + (x862-absolute-natural seg vreg xfer value) + (if (= class hard-reg-class-crf) + (progn + ;compiler-bug "Would have clobbered a GPR!") + (x862-branch seg (x862-cd-true xfer))) + (progn + (ensuring-node-target (target vreg) + (x862-absolute-natural seg target nil (ash value *x862-target-fixnum-shift*))) + (^)))))))) + +(defx862 x862-%ilogbitp %ilogbitp (seg vreg xfer cc bitnum form) + (if (null vreg) + (progn + (x862-form seg nil nil bitnum) + (x862-form seg vreg xfer form)) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (unless (eq cr-bit x86::x86-e-bits) + (bug "bad cr-bit")) + (setq cr-bit x86::x86-b-bits true-p (not true-p)) + (let* ((fixbit (acode-fixnum-form-p bitnum))) + (if fixbit + (let* ((reg (x862-one-untargeted-reg-form seg form *x862-arg-z*)) + (x86-bit (min (+ fixbit *x862-target-fixnum-shift*) (1- *x862-target-bits-in-word*)))) + (! set-c-flag-if-constant-logbitp x86-bit reg)) + (multiple-value-bind (rbit rform) (x862-two-untargeted-reg-forms seg bitnum *x862-arg-y* form *x862-arg-z*) + (! set-c-flag-if-variable-logbitp rbit rform))) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^))))))) + + +(defx862 x862-uvref uvref (seg vreg xfer vector index) + (x862-two-targeted-reg-forms seg vector ($ *x862-arg-y*) index ($ *x862-arg-z*)) + (! misc-ref) + (<- ($ *x862-arg-z*)) + (^)) + +(defx862 x862-uvset uvset (seg vreg xfer vector index value) + (x862-three-targeted-reg-forms seg + vector (target-arch-case + (:x8632 ($ x8632::temp0)) + (:x8664 ($ x8664::arg_x))) + index ($ *x862-arg-y*) + value ($ *x862-arg-z*)) + (! misc-set) + (<- ($ *x862-arg-z*)) + (^)) + +(defx862 x862-%decls-body %decls-body (seg vreg xfer form p2decls) + (with-x86-p2-declarations p2decls + (x862-form seg vreg xfer form))) + + + +(defx862 x862-%err-disp %err-disp (seg vreg xfer arglist) + (let* ((*x862-vstack* *x862-vstack*)) + (x862-set-nargs seg (x862-arglist seg arglist)) + (! ksignalerr)) + (x862-nil seg vreg xfer)) + + +(defx862 x862-local-tagbody local-tagbody (seg vreg xfer taglist body) + (let* ((encstack (x862-encode-stack)) + (tagop (%nx1-operator tag-label))) + (dolist (tag taglist) + (rplacd tag (cons (backend-get-next-label) (cons encstack (cadr (cddr (cddr tag))))))) + (dolist (form body) + (if (eq (acode-operator form) tagop) + (let ((tag (cddr form))) + (when (cddr tag) (! align-loop-head)) + (@ (car tag))) + (x862-form seg nil nil form))) + (x862-nil seg vreg xfer))) + +(defx862 x862-call call (seg vreg xfer fn arglist &optional spread-p) + (when (and (null vreg) + (acode-p fn) + (eq (acode-operator fn) (%nx1-operator immediate))) + (let* ((name (cadr fn))) + (when (memq name *warn-if-function-result-ignored*) + (p2-whine *x862-cur-afunc* :result-ignored name)))) + (x862-call-fn seg vreg xfer fn arglist spread-p)) + +(defx862 x862-self-call self-call (seg vreg xfer arglist &optional spread-p) + (setq arglist (x862-augment-arglist *x862-cur-afunc* arglist (if spread-p 1 *x862-target-num-arg-regs*))) + (x862-call-fn seg vreg xfer -2 arglist spread-p)) + + +(defx862 x862-lexical-function-call lexical-function-call (seg vreg xfer afunc arglist &optional spread-p) + (x862-call-fn seg vreg xfer (list (%nx1-operator simple-function) afunc) + (x862-augment-arglist afunc arglist (if spread-p 1 *x862-target-num-arg-regs*)) + spread-p)) + +(defx862 x862-builtin-call builtin-call (seg vreg xfer index arglist) + (let* ((nargs (x862-arglist seg arglist)) + (tail-p (and (x862-tailcallok xfer) (<= nargs *x862-target-num-arg-regs*))) + (idx (acode-fixnum-form-p index)) + (idx-subprim (x862-builtin-index-subprim idx)) + (subprim + (or idx-subprim + (case nargs + (0 (subprim-name->offset '.SPcallbuiltin0)) + (1 (subprim-name->offset '.SPcallbuiltin1)) + (2 (subprim-name->offset '.SPcallbuiltin2)) + (3 (subprim-name->offset '.SPcallbuiltin3)) + (t (subprim-name->offset '.SPcallbuiltin)))))) + (when tail-p + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count*) + (x862-restore-full-lisp-context seg)) + (unless idx-subprim + (! lri *x862-imm0* (ash idx *x862-target-fixnum-shift*)) + (when (eql subprim (subprim-name->offset '.SPcallbuiltin)) + (x862-set-nargs seg nargs))) + (if tail-p + (! jump-subprim subprim) + (progn + (! call-subprim subprim) + (<- *x862-arg-z*) + (^))))) + + +(defx862 x862-if if (seg vreg xfer testform true false &aux test-val) + (if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value testform))) + (x862-form seg vreg xfer (if (nx-null test-val) false true)) + (let* ((cstack *x862-cstack*) + (vstack *x862-vstack*) + (top-lcell *x862-top-vstack-lcell*) + (entry-stack (x862-encode-stack)) + (true-stack nil) + (false-stack nil) + (true-cleanup-label nil) + (same-stack-effects nil) + (true-is-goto (x862-go-label true)) + (false-is-goto (and (not true-is-goto) (x862-go-label false))) + (endlabel (backend-get-next-label)) + (falselabel (backend-get-next-label)) + (need-else (unless false-is-goto (or (not (nx-null false)) (x862-for-value-p vreg)))) + (both-single-valued (and (not *x862-open-code-inline*) + (eq xfer $backend-return) + (x862-for-value-p vreg) + need-else + (x862-single-valued-form-p true) + (x862-single-valued-form-p false)))) + (if (eq 0 xfer) + (setq xfer nil)) + (if both-single-valued ; it's implied that we're returning + (let* ((result *x862-arg-z*)) + (let ((merge-else-branch-label (if (nx-null false) (x862-find-nilret-label)))) + (x862-conditional-form seg (x862-make-compound-cd 0 falselabel) testform) + (x862-form seg result endlabel true) + (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label))) + (backend-copy-label merge-else-branch-label falselabel) + (progn + (@ falselabel) + (if (nx-null false) (@ (x862-record-nilret-label))) + (x862-form seg result nil false))) + (@ endlabel) + (<- result) + (^))) + (progn + (if (and need-else (x862-mvpass-p xfer)) + (setq true-cleanup-label (backend-get-next-label))) + (x862-conditional-form + seg + (x862-make-compound-cd + (or true-is-goto 0) + (or false-is-goto + (if need-else + (if true-is-goto 0 falselabel) + (if true-is-goto xfer (x862-cd-merge xfer falselabel))))) + testform) + (if true-is-goto + (x862-unreachable-store) + (if true-cleanup-label + (progn + (x862-open-undo $undomvexpect) + (x862-form seg vreg (logior $backend-mvpass-mask true-cleanup-label) true)) + (x862-form seg vreg (if need-else (x862-cd-merge xfer endlabel) xfer) true))) + (setq true-stack (x862-encode-stack)) + (setq *x862-cstack* cstack) + (x862-set-vstack vstack) + (setq *x862-top-vstack-lcell* top-lcell) + (if false-is-goto (x862-unreachable-store)) + (let ((merge-else-branch-label (if (and (nx-null false) (eq xfer $backend-return)) (x862-find-nilret-label)))) + (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label))) + (backend-copy-label merge-else-branch-label falselabel) + (progn + (@ falselabel) + (when need-else + (if true-cleanup-label + (x862-mvpass seg false) + (x862-form seg vreg xfer false)) + (setq false-stack (x862-encode-stack)))))) + (when true-cleanup-label + (if (setq same-stack-effects (x862-equal-encodings-p true-stack false-stack)) ; can share cleanup code + (@ true-cleanup-label)) + (let* ((*x862-returning-values* :pass)) + (x862-nlexit seg xfer 1) + (x862-branch seg (if (and xfer (neq xfer $backend-mvpass-mask)) xfer (if (not same-stack-effects) endlabel)))) + (unless same-stack-effects + (@ true-cleanup-label) + (multiple-value-setq (true *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*) + (x862-decode-stack true-stack)) + (let* ((*x862-returning-values* :pass)) + (x862-nlexit seg xfer 1) + (^))) + (x862-close-undo) + (multiple-value-setq (*x862-undo-count* *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*) + (x862-decode-stack entry-stack))) + (@ endlabel)))))) + +(defx862 x862-or or (seg vreg xfer forms) + (let* ((mvpass (x862-mvpass-p xfer)) + (tag1 (backend-get-next-label)) + (tag2 (backend-get-next-label)) + (vstack *x862-vstack*) + (cstack *x862-cstack*) + (dest (if (backend-crf-p vreg) vreg (if vreg *x862-arg-z* (available-crf-temp *available-backend-crf-temps*)))) + (cd1 (x862-make-compound-cd + (if (eq dest *x862-arg-z*) tag1 (x862-cd-merge (x862-cd-true xfer) tag1)) 0))) + (while (cdr forms) + (x862-form seg dest (if (eq dest *x862-arg-z*) nil cd1) (car forms)) + (when (eq dest *x862-arg-z*) + (with-crf-target () val-crf + (x862-copy-register seg val-crf dest) + (x862-branch seg cd1))) + (setq forms (%cdr forms))) + (if mvpass + (progn (x862-multiple-value-body seg (car forms)) + (let* ((*x862-returning-values* t)) (x862-branch seg (x862-cd-merge xfer tag2)))) + (x862-form seg vreg (if (eq dest *x862-arg-z*) (x862-cd-merge xfer tag2) xfer) (car forms))) + (setq *x862-vstack* vstack *x862-cstack* cstack) + (@ tag1) + (when (eq dest *x862-arg-z*) + (<- *x862-arg-z*) + (^)) + (@ tag2))) + +(defx862 x862-simple-function simple-function (seg vreg xfer afunc) + (x862-immediate seg vreg xfer (x862-afunc-lfun-ref afunc))) + +(defx862 x862-list list (seg vreg xfer arglist) + (if (null vreg) + (dolist (form arglist) + (x862-form seg vreg nil form)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (nargs (x862-formlist seg arglist nil))) + (x862-set-nargs seg nargs) + (! list) + (<- *x862-arg-z*))) + (^)) + +(defx862 x862-list* list* (seg vreg xfer arglist) + (if (null vreg) + (dolist (arg (apply #'append arglist)) + (x862-form seg nil nil arg)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (nargs (x862-formlist seg (car arglist) (cadr arglist)))) + (declare (fixnum nargs)) + (when (> nargs 1) + (x862-set-nargs seg (1- nargs)) + (! list*)) + (<- *x862-arg-z*))) + (^)) + +(defx862 x862-minus1 minus1 (seg vreg xfer form) + (x862-unary-builtin seg vreg xfer '%negate form)) + +;;; Return T if form is declare to be something that couldn't be a fixnum. +(defun x862-explicit-non-fixnum-type-p (form) + (let* ((type (x862-form-type form)) + (target-fixnum-type (nx-target-type 'fixnum))) + (and (not (subtypep type target-fixnum-type)) + (not (subtypep target-fixnum-type type))))) + +(defun x862-inline-sub2 (seg vreg xfer form1 form2) + (let* ((v2 (acode-fixnum-form-p form2))) + (if (and v2 (not (eql v2 most-negative-fixnum))) + (x862-inline-add2 seg vreg xfer form1 (make-acode (%nx1-operator fixnum) (- v2))) + (with-x86-local-vinsn-macros (seg vreg xfer) + (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) + (let* ((out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + (ensuring-node-target (target vreg) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ *x862-arg-y*) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ *x862-arg-y*) ($ *x862-arg-z*) (aref *backend-labels* out-of-line)))) + (! fixnum-sub2 ($ *x862-arg-z*) ($ *x862-arg-y*) ($ *x862-arg-z*)) + (x862-check-fixnum-overflow seg ($ *x862-arg-z*) done) + (@ out-of-line) + (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-minus) ($ *x862-arg-y*) ($ *x862-arg-z*)) + (@ done) + (x862-copy-register seg target ($ *x862-arg-z*))) + (^)))))) + +(defun x862-inline-add2 (seg vreg xfer form1 form2) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((c1 (acode-fixnum-form-p form1)) + (c2 (acode-fixnum-form-p form2)) + (fix1 (s32-fixnum-constant-p c1)) + (fix2 (s32-fixnum-constant-p c2)) + (otherform (if fix1 + form2 + (if fix2 + form1)))) + (if otherform + (x862-one-targeted-reg-form seg otherform ($ *x862-arg-z*)) + (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*))) + (let* ((out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + (ensuring-node-target (target vreg) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ *x862-arg-y*) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ *x862-arg-y*) ($ *x862-arg-z*) (aref *backend-labels* out-of-line))))) + (if otherform + (! add-constant ($ *x862-arg-z*) (ash (or fix1 fix2) *x862-target-fixnum-shift*)) + (! fixnum-add2 ($ *x862-arg-z*) ($ *x862-arg-y*))) + (x862-check-fixnum-overflow seg ($ *x862-arg-z*) done) + (@ out-of-line) + (if otherform + (x862-lri seg ($ *x862-arg-y*) (ash (or fix1 fix2) *x862-target-fixnum-shift*))) + (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-plus) ($ *x862-arg-y*) ($ *x862-arg-z*)) + (@ done) + (x862-copy-register seg target ($ *x862-arg-z*))) + (^))))) + +(defx862 x862-add2 add2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *x862-trust-declarations*) + (if (and (x862-form-typep form1 'double-float) + (x862-form-typep form2 'double-float)) + (x862-use-operator (%nx1-operator %double-float+-2) + seg + vreg + xfer + form1 + form2) + (if (and (x862-form-typep form1 'single-float) + (x862-form-typep form2 'single-float)) + (x862-use-operator (%nx1-operator %short-float+-2) + seg + vreg + xfer + form1 + form2) + (if (and (x862-form-typep form1 'fixnum) + (x862-form-typep form2 'fixnum)) + (x862-use-operator (%nx1-operator %i+) + seg + vreg + xfer + form1 + form2 + t) + (if (or (x862-explicit-non-fixnum-type-p form1) + (x862-explicit-non-fixnum-type-p form2)) + (x862-binary-builtin seg vreg xfer '+-2 form1 form2) + (x862-inline-add2 seg vreg xfer form1 form2))))))) + +(defx862 x862-sub2 sub2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *x862-trust-declarations*) + (if (and (x862-form-typep form1 'double-float) + (x862-form-typep form2 'double-float)) + (x862-use-operator (%nx1-operator %double-float--2) + seg + vreg + xfer + form1 + form2) + (if (and (x862-form-typep form1 'single-float) + (x862-form-typep form2 'single-float)) + (x862-use-operator (%nx1-operator %short-float--2) + seg + vreg + xfer + form1 + form2) + (if (and (x862-form-typep form1 'fixnum) + (x862-form-typep form2 'fixnum)) + (x862-use-operator (%nx1-operator %i-) + seg + vreg + xfer + form1 + form2 + t) + (if (or (x862-explicit-non-fixnum-type-p form1) + (x862-explicit-non-fixnum-type-p form2)) + (x862-binary-builtin seg vreg xfer '--2 form1 form2) + (x862-inline-sub2 seg vreg xfer form1 form2))))))) + +(defx862 x862-mul2 mul2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *x862-trust-declarations*) + (if (and (x862-form-typep form1 'double-float) + (x862-form-typep form2 'double-float)) + (x862-use-operator (%nx1-operator %double-float*-2) + seg + vreg + xfer + form1 + form2) + (if (and (x862-form-typep form1 'single-float) + (x862-form-typep form2 'single-float)) + (x862-use-operator (%nx1-operator %short-float*-2) + seg + vreg + xfer + form1 + form2) + (x862-binary-builtin seg vreg xfer '*-2 form1 form2))))) + +(defx862 x862-div2 div2 (seg vreg xfer form1 form2) + (multiple-value-bind (form1 form2) + (nx-binop-numeric-contagion form1 form2 *x862-trust-declarations*) + (if (and (x862-form-typep form1 'double-float) + (x862-form-typep form2 'double-float)) + (x862-use-operator (%nx1-operator %double-float/-2) + seg + vreg + xfer + form1 + form2) + (if (and (x862-form-typep form1 'single-float) + (x862-form-typep form2 'single-float)) + (x862-use-operator (%nx1-operator %short-float/-2) + seg + vreg + xfer + form1 + form2) + (let* ((f2 (acode-fixnum-form-p form2)) + (unwrapped (acode-unwrapped-form form1)) + (f1 nil) + (f1/f2 nil)) + (if (and f2 + (not (zerop f2)) + (acode-p unwrapped) + (or (eq (acode-operator unwrapped) (%nx1-operator mul2)) + (eq (acode-operator unwrapped) (%nx1-operator %i*))) + (setq f1 (acode-fixnum-form-p (cadr unwrapped))) + (typep (setq f1/f2 (/ f1 f2)) 'fixnum)) + (x862-use-operator (%nx1-operator mul2) + seg + vreg + xfer + (make-acode (%nx1-operator fixnum) f1/f2) + (caddr unwrapped)) + (x862-binary-builtin seg vreg xfer '/-2 form1 form2))))))) + +(defx862 x862-logbitp logbitp (seg vreg xfer bitnum int) + (x862-binary-builtin seg vreg xfer 'logbitp bitnum int)) + +(defun x862-inline-logior2 (seg vreg xfer form1 form2) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (x862-use-operator (%nx1-operator fixnum) seg vreg xfer (logior fix1 fix2)) + (let* ((fixval (or fix1 fix2)) + (fiximm (if fixval (<= (integer-length fixval) + (- 31 *x862-target-fixnum-shift*)))) + (otherform (when fiximm (if fix1 form2 form1)))) + (let* ((out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + (ensuring-node-target (target vreg) + (if otherform + (x862-one-targeted-reg-form seg otherform ($ *x862-arg-z*)) + (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*))) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ *x862-arg-y*) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ *x862-arg-y*) ($ *x862-arg-z*) (aref *backend-labels* out-of-line))))) + (if otherform + (! %logior-c ($ *x862-arg-z*) ($ *x862-arg-z*) (ash fixval *x862-target-fixnum-shift*)) + (! %logior2 ($ *x862-arg-z*) ($ *x862-arg-z*) ($ *x862-arg-y*))) + (-> done) + (@ out-of-line) + (if otherform + (x862-lri seg ($ *x862-arg-y*) (ash fixval *x862-target-fixnum-shift*))) + (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-logior) ($ *x862-arg-y*) ($ *x862-arg-z*)) + (@ done) + (x862-copy-register seg target ($ *x862-arg-z*))) + (^))))))) + +(defx862 x862-logior2 logior2 (seg vreg xfer form1 form2) + (if (or (x862-explicit-non-fixnum-type-p form1) + (x862-explicit-non-fixnum-type-p form2)) + (x862-binary-builtin seg vreg xfer 'logior-2 form1 form2) + (x862-inline-logior2 seg vreg xfer form1 form2))) + +(defx862 x862-logxor2 logxor2 (seg vreg xfer form1 form2) + (x862-binary-builtin seg vreg xfer 'logxor-2 form1 form2)) + +(defun x862-inline-logand2 (seg vreg xfer form1 form2) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((fix1 (acode-fixnum-form-p form1)) + (fix2 (acode-fixnum-form-p form2))) + (if (and fix1 fix2) + (x862-use-operator (%nx1-operator fixnum) seg vreg xfer (logand fix1 fix2)) + (let* ((fixval (or fix1 fix2)) + (fiximm (if fixval (<= (integer-length fixval) + (- 31 *x862-target-fixnum-shift*)))) + (otherform (when fiximm (if fix1 form2 form1)))) + (let* ((out-of-line (backend-get-next-label)) + (done (backend-get-next-label))) + (ensuring-node-target (target vreg) + (if otherform + (x862-one-targeted-reg-form seg otherform ($ *x862-arg-z*)) + (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*))) + (if otherform + (unless (acode-fixnum-form-p otherform) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line))) + (if (acode-fixnum-form-p form1) + (! branch-unless-arg-fixnum ($ *x862-arg-z*) (aref *backend-labels* out-of-line)) + (if (acode-fixnum-form-p form2) + (! branch-unless-arg-fixnum ($ *x862-arg-y*) (aref *backend-labels* out-of-line)) + (! branch-unless-both-args-fixnums ($ *x862-arg-y*) ($ *x862-arg-z*) (aref *backend-labels* out-of-line))))) + (if otherform + (! %logand-c ($ *x862-arg-z*) ($ *x862-arg-z*) (ash fixval *x862-target-fixnum-shift*)) + (! %logand2 ($ *x862-arg-z*) ($ *x862-arg-z*) ($ *x862-arg-y*))) + (-> done) + (@ out-of-line) + (if otherform + (x862-lri seg ($ *x862-arg-y*) (ash fixval *x862-target-fixnum-shift*))) + (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-logand) ($ *x862-arg-y*) ($ *x862-arg-z*)) + (@ done) + (x862-copy-register seg target ($ *x862-arg-z*))) + (^))))))) + +(defx862 x862-logand2 logand2 (seg vreg xfer form1 form2) + (if (or (x862-explicit-non-fixnum-type-p form1) + (x862-explicit-non-fixnum-type-p form2)) + (x862-binary-builtin seg vreg xfer 'logand-2 form1 form2) + (x862-inline-logand2 seg vreg xfer form1 form2))) + +(defx862 x862-%quo2 %quo2 (seg vreg xfer form1 form2) + (x862-binary-builtin seg vreg xfer '/-2 form1 form2)) + +(defx862 x862-%aref1 %aref1 (seg vreg xfer v i) + (let* ((vtype (acode-form-type v t)) + (ctype (if vtype (specifier-type vtype))) + (atype (if (array-ctype-p ctype) ctype)) + (keyword (if (and atype + (let* ((dims (array-ctype-dimensions atype))) + (or (eq dims '*) + (and (not (atom dims)) + (= (length dims) 1)))) + (not (array-ctype-complexp atype))) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (if keyword + (x862-vref seg vreg xfer keyword v i (unless *x862-reckless* + (nx-lookup-target-uvector-subtag keyword))) + (x862-binary-builtin seg vreg xfer '%aref1 v i)))) + +(defx862 x862-%aset1 aset1 (seg vreg xfer v i n) + (let* ((vtype (acode-form-type v t)) + (atype (if vtype (specifier-type vtype))) + (keyword (if (and atype + (let* ((dims (array-ctype-dimensions atype))) + (or (eq dims '*) + (and (not (atom dims)) + (= (length dims) 1)))) + (not (array-ctype-complexp atype))) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (if keyword + (x862-vset seg vreg xfer keyword v i n (not *x862-reckless*)) + (target-arch-case + (:x8632 + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((subprim (subprim-name->offset '.SPaset1)) + (tail-p (x862-tailcallok xfer))) + (x862-three-targeted-reg-forms seg + v ($ x8632::temp0) + i ($ x8632::arg_y) + n ($ x8632::arg_z)) + (if tail-p + (progn + (x862-restore-full-lisp-context seg) + (! jump-subprim subprim)) + (progn + (! call-subprim subprim) + (when vreg + (<- ($ x8632::arg_z))) + (^)))))) + (:x8664 + (x862-ternary-builtin seg vreg xfer '%aset1 v i n)))))) + +;;; Return VAL if its a fixnum whose boxed representation fits in 32 +;;; bits. (On a 32-bit platform, that's true of all native fixnums.) +(defun s32-fixnum-constant-p (val) + (when val + (target-arch-case + (:x8632 + ;; On x8632, all fixnums fit in 32 bits. + val) + (:x8664 + (if (typep val '(signed-byte #.(- 32 x8664::fixnumshift))) + val))))) + +(defx862 x862-%i+ %i+ (seg vreg xfer form1 form2 &optional overflow) + (when overflow + (let* ((type *x862-target-half-fixnum-type*)) + (when (and (x862-form-typep form1 type) + (x862-form-typep form2 type)) + (setq overflow nil)))) + (cond ((null vreg) + (x862-form seg nil nil form1) + (x862-form seg nil xfer form2)) + (t + (let* ((c1 (acode-fixnum-form-p form1)) + (c2 (acode-fixnum-form-p form2)) + (fix1 (s32-fixnum-constant-p c1)) + (fix2 (s32-fixnum-constant-p c2)) + (other (if fix1 + form2 + (if fix2 + form1))) + (sum (and c1 c2 (if overflow (+ c1 c2) (%i+ c1 c2))))) + + (if sum + (if (nx1-target-fixnump sum) + (x862-use-operator (%nx1-operator fixnum) seg vreg nil sum) + (x862-use-operator (%nx1-operator immediate) seg vreg nil sum)) + (if other + (let* ((constant (ash (or fix1 fix2) *x862-target-fixnum-shift*))) + (if (zerop constant) + (x862-form seg vreg nil other) + (if overflow + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg other target) + (! add-constant target constant) + (x862-check-fixnum-overflow seg target)) + (ensuring-node-target (target vreg) + (let* ((reg (x862-one-untargeted-reg-form seg other target))) + (! add-constant3 target reg constant)))))) + (if (not overflow) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) + ;; This isn't guaranteed to set the overflow flag, + ;; but may do so. + (ensuring-node-target (target vreg) + (! fixnum-add3 target r1 r2))) + (ensuring-node-target (target vreg) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) + (cond ((= (hard-regspec-value target) + (hard-regspec-value r1)) + (! fixnum-add2 target r2)) + ((= (hard-regspec-value target) + (hard-regspec-value r2)) + (! fixnum-add2 target r1)) + (t + (x862-copy-register seg target r1) + (! fixnum-add2 target r2))) + (x862-check-fixnum-overflow seg target)))))) + (^))))) + +(defx862 x862-%i- %i- (seg vreg xfer num1 num2 &optional overflow) + (when overflow + (let* ((type *x862-target-half-fixnum-type*)) + (when (and (x862-form-typep num1 type) + (x862-form-typep num2 type)) + (setq overflow nil)))) + (let* ((v1 (acode-fixnum-form-p num1)) + (v2 (acode-fixnum-form-p num2))) + (if (and v1 v2) + (x862-use-operator (%nx1-operator immediate) seg vreg xfer (if overflow (- v1 v2)(%i- v1 v2))) + (if (and v2 (/= v2 (arch::target-most-negative-fixnum (backend-target-arch *target-backend*)))) + (x862-use-operator (%nx1-operator %i+) seg vreg xfer num1 (make-acode (%nx1-operator fixnum) (- v2)) overflow) + (cond + ((null vreg) + (x862-form seg nil nil num1) + (x862-form seg nil xfer num2)) + (t + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg num1 *x862-arg-y* num2 *x862-arg-z*) + ;; This isn't guaranteed to set the overflow flag, + ;; but may do so. + (ensuring-node-target (target vreg) + (! fixnum-sub2 target r1 r2) + (if overflow + (x862-check-fixnum-overflow seg target))) + (^)))))))) + +(defx862 x862-%i* %i* (seg vreg xfer num1 num2) + (if (null vreg) + (progn + (x862-form seg nil nil num1) + (x862-form seg nil xfer num2)) + (let* ((fix1 (acode-fixnum-form-p num1)) + (fix2 (acode-fixnum-form-p num2)) + (other (if (typep fix1 '(signed-byte 32)) num2 (if (typep fix2 '(signed-byte 32)) num1)))) + (if (and fix1 fix2) + (x862-lri seg vreg (ash (* fix1 fix2) *x862-target-fixnum-shift*)) + (if other + (! multiply-immediate vreg (x862-one-untargeted-reg-form seg other *x862-arg-z*) (or fix1 fix2)) + (multiple-value-bind (rx ry) (x862-two-untargeted-reg-forms seg num1 *x862-arg-y* num2 *x862-arg-z*) + (ensuring-node-target (target vreg) + (! multiply-fixnums target rx ry))))) + (^)))) + +(defx862 x862-nth-value nth-value (seg vreg xfer n form) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (let* ((nreg (x862-one-untargeted-reg-form seg n *x862-arg-z*))) + (unless (acode-fixnum-form-p n) + (! trap-unless-fixnum nreg)) + (x862-vpush-register seg nreg)) + (x862-multiple-value-body seg form) ; sets nargs + (! nth-value *x862-arg-z*)) + (<- *x862-arg-z*) + (^)) + +(defx862 x862-values values (seg vreg xfer forms) + (if (eq (list-length forms) 1) + (if (x862-cd-compound-p xfer) + (x862-form seg vreg xfer (%car forms)) + (progn + (x862-form seg vreg nil (%car forms)) + (^))) + (if (not (x862-mv-p xfer)) + (if forms + (x862-use-operator (%nx1-operator prog1) seg vreg xfer forms) + (x862-nil seg vreg xfer)) + (progn + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-set-nargs seg (x862-formlist seg forms nil))) + (let* ((*x862-returning-values* t)) + (^)))))) + +(defx862 x862-base-char-p base-char-p (seg vreg xfer cc form) + (x862-char-p seg vreg xfer cc form)) + +(defun x862-char-p (seg vreg xfer cc form) + (with-x86-local-vinsn-macros (seg vreg xfer) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (! mask-base-char *x862-imm0* (x862-one-untargeted-reg-form seg form *x862-arg-z*)) + (x862-test-reg-%izerop seg vreg xfer *x862-imm0* cr-bit true-p + (target-arch-case + (:x8632 x8632::subtag-character) + (:x8664 x8664::subtag-character)))))) + + + +(defx862 x862-let* let* (seg vreg xfer vars vals body p2decls &aux + (old-stack (x862-encode-stack))) + (x862-check-lcell-depth) + (with-x86-p2-declarations p2decls + (x862-seq-bind seg vars vals) + (x862-undo-body seg vreg xfer body old-stack)) + (dolist (v vars) (x862-close-var seg v))) + +(defx862 x862-multiple-value-bind multiple-value-bind (seg vreg xfer vars valform body p2decls) + (let* ((n (list-length vars)) + (vloc *x862-vstack*) + (nbytes (* n *x862-target-node-size*)) + (old-stack (x862-encode-stack))) + (with-x86-p2-declarations p2decls + (x862-multiple-value-body seg valform) + (! fitvals n) + (x862-set-vstack (%i+ vloc nbytes)) + (let* ((old-top *x862-top-vstack-lcell*) + (lcells (progn (x862-reserve-vstack-lcells n) (x862-collect-lcells :reserved old-top)))) + (dolist (var vars) + (let* ((lcell (pop lcells)) + (reg (nx2-assign-register-var var))) + (if reg + (x862-init-regvar seg var reg (x862-vloc-ea vloc)) + (x862-bind-var seg var vloc lcell)) + (setq vloc (%i+ vloc *x862-target-node-size*))))) + (x862-undo-body seg vreg xfer body old-stack) + (dolist (var vars) + (x862-close-var seg var))))) + +(defx862 x862-debind debind (seg vreg xfer lambda-list bindform req opt rest keys auxen whole body p2decls cdr-p) + (declare (ignore lambda-list)) + (let* ((old-stack (x862-encode-stack)) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (vloc *x862-vstack*)) + (with-x86-p2-declarations p2decls + (x862-bind-structured-lambda + seg + (x862-spread-lambda-list seg bindform whole req opt rest keys nil cdr-p) + vloc (x862-vloc-ea vloc) whole req opt rest keys auxen) + (x862-undo-body seg vreg xfer body old-stack) + (x862-close-structured-lambda seg whole req opt rest keys auxen)))) + +(defx862 x862-multiple-value-prog1 multiple-value-prog1 (seg vreg xfer forms) + (if (or (not (x862-mv-p xfer)) (x862-single-valued-form-p (%car forms))) + (x862-use-operator (%nx1-operator prog1) seg vreg xfer forms) + (progn + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-multiple-value-body seg (%car forms)) + (x862-open-undo $undostkblk) + (! save-values)) + (dolist (form (cdr forms)) + (x862-form seg nil nil form)) + (x862-set-nargs seg 0) + (! recover-values) + (x862-close-undo) + (let* ((*x862-returning-values* t)) + (^))))) + +(defx862 x862-not not (seg vreg xfer cc form) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (let* ((ea (x862-lexical-reference-ea form nil))) + (if (and ea (memory-spec-p ea)) + (x862-compare-ea-to-nil + seg + vreg + xfer + ea + cr-bit + true-p) + (x862-compare-register-to-nil + seg + vreg + xfer + (x862-one-untargeted-reg-form seg form *x862-arg-z*) + cr-bit + true-p))))) + + +(defx862 x862-%alloc-misc %make-uvector (seg vreg xfer element-count st &optional initval) + (if (null vreg) + (progn + (x862-form seg nil nil element-count) + (x862-form seg nil xfer st)) + (let* ((subtag (acode-fixnum-form-p st)) + (nelements (acode-fixnum-form-p element-count)) + (nbytes (if (and subtag nelements) (x862-misc-byte-count subtag nelements)))) + (if (and nbytes (null initval) + (< (logand + (lognot (1- *x862-target-dnode-size*)) + (+ nbytes *x862-target-node-size* + (1- *x862-target-dnode-size*))) #x8000)) + (let* ((header *x862-imm0*) + (n (- (* (ceiling (+ nbytes *x862-target-node-size*) *x862-target-dnode-size*) *x862-target-dnode-size*) + (target-arch-case + (:x8632 x8632::fulltag-misc) + (:x8664 x8664::fulltag-misc))))) + (x862-lri seg header (arch::make-vheader nelements subtag)) + (target-arch-case + (:x8632 + (! setup-uvector-allocation header) + (x862-lri seg x8632::imm0 n)) + (:x8664 + (x862-lri seg x8664::imm1 n))) + (ensuring-node-target (target vreg) + (! %allocate-uvector target))) + (progn + (if initval + (progn + (x862-three-targeted-reg-forms seg element-count + (target-arch-case + (:x8632 ($ x8632::temp0)) + (:x8664 ($ x8664::arg_x))) + st ($ *x862-arg-y*) + initval ($ *x862-arg-z*)) + (! misc-alloc-init) + (<- ($ *x862-arg-z*))) + (progn + (x862-two-targeted-reg-forms seg element-count ($ *x862-arg-y*) st ($ *x862-arg-z*)) + (! misc-alloc) + (<- ($ *x862-arg-z*)))))) + (^)))) + +(defx862 x862-%iasr %iasr (seg vreg xfer form1 form2) + (if (null vreg) + (progn + (x862-form seg nil nil form1) + (x862-form seg vreg xfer form2)) + (let* ((count (acode-fixnum-form-p form1)) + (max (target-arch-case (:x8632 31) (:x8664 63)))) + (declare (fixnum max)) + (ensuring-node-target (target vreg) + (if count + (! %iasr-c target (if (> count max) max count) + (x862-one-untargeted-reg-form seg form2 *x862-arg-z*)) + (multiple-value-bind (cnt src) (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) + (! %iasr target cnt src)))) + (^)))) + +(defx862 x862-%ilsr %ilsr (seg vreg xfer form1 form2) + (if (null vreg) + (progn + (x862-form seg nil nil form1) + (x862-form seg vreg xfer form2)) + (let* ((count (acode-fixnum-form-p form1))) + (ensuring-node-target (target vreg) + (if count + (let ((src (x862-one-untargeted-reg-form seg form2 ($ *x862-arg-z*)))) + (if (<= count 31) + (! %ilsr-c target count src) + (! lri target 0))) + (multiple-value-bind (cnt src) (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) + (! %ilsr target cnt src)))) + (^)))) + + +(defx862 x862-%i<> %i<> (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (x862-compare seg vreg xfer form1 form2 cr-bit true-p))) + +(defx862 x862-%natural<> %natural<> (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (x862-natural-compare seg vreg xfer form1 form2 cr-bit true-p))) + +(defx862 x862-double-float-compare double-float-compare (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (with-fp-target () (r1 :double-float) + (with-fp-target (r1) (r2 :double-float) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 r1 form2 r2) + (x862-compare-double-float-registers seg vreg xfer r1 r2 cr-bit true-p)))))) + +(defx862 x862-short-float-compare short-float-compare (seg vreg xfer cc form1 form2) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (with-fp-target () (r1 :single-float) + (with-fp-target (r1) (r2 :single-float) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 r1 form2 r2) + (x862-compare-single-float-registers seg vreg xfer r1 r2 cr-bit true-p)))))) + +(eval-when (:compile-toplevel :execute) + (defmacro defx862-df-op (fname opname vinsn) + `(defx862 ,fname ,opname (seg vreg xfer f0 f1) + (if (null vreg) + (progn + (x862-form seg nil nil f0) + (x862-form seg vreg xfer f1)) + (with-fp-target () (r1 :double-float) + (with-fp-target (r1) (r2 :double-float) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg f0 r1 f1 r2) + (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr) + (or (not (= (hard-regspec-value vreg) + (hard-regspec-value r2))) + ,(and + (not (eq opname '%double-float--2)) + (not (eq opname '%double-float/-2))))) + (! ,vinsn vreg r1 r2) + (with-fp-target (r2) (result :double-float) + (! ,vinsn result r1 r2) + (if (= (hard-regspec-class vreg) hard-reg-class-fpr) + (<- result) + (ensuring-node-target (target vreg) + (x862-copy-register seg target result))))) + (^))))))) + + (defmacro defx862-sf-op (fname opname vinsn) + `(defx862 ,fname ,opname (seg vreg xfer f0 f1) + (if (null vreg) + (progn + (x862-form seg nil nil f0) + (x862-form seg vreg xfer f1)) + (with-fp-target () (r1 :single-float) + (with-fp-target (r1) (r2 :single-float) + (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg f0 r1 f1 r2) + (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr) + (or (not (= (hard-regspec-value vreg) + (hard-regspec-value r2))) + ,(and + (not (eq opname '%short-float--2)) + (not (eq opname '%short-float/-2))))) + (! ,vinsn vreg r1 r2) + (with-fp-target (r2) (result :single-float) + (! ,vinsn result r1 r2) + (if (= (hard-regspec-class vreg) hard-reg-class-fpr) + (<- result) + (ensuring-node-target (target vreg) + (x862-copy-register seg target result))))) + (^))))))) + ) + +(defx862-df-op x862-%double-float+-2 %double-float+-2 double-float+-2) +(defx862-df-op x862-%double-float--2 %double-float--2 double-float--2) +(defx862-df-op x862-%double-float*-2 %double-float*-2 double-float*-2) +(defx862-df-op x862-%double-float/-2 %double-float/-2 double-float/-2) + +(defx862-sf-op x862-%short-float+-2 %short-float+-2 single-float+-2) +(defx862-sf-op x862-%short-float--2 %short-float--2 single-float--2) +(defx862-sf-op x862-%short-float*-2 %short-float*-2 single-float*-2) +(defx862-sf-op x862-%short-float/-2 %short-float/-2 single-float/-2) + +(defun x862-get-float (seg vreg xfer ptr offset double-p fp-reg) + (with-x86-local-vinsn-macros (seg vreg xfer) + (cond ((null vreg) + (x862-form seg nil nil ptr) + (x862-form seg nil xfer offset)) + (t + (let* ((fixoffset (acode-fixnum-form-p offset))) + (if (typep fixoffset '(signed-byte 32)) + (with-imm-target () (ptrreg :address) + (x862-form seg ptrreg nil ptr) + (if double-p + (! mem-ref-c-double-float fp-reg ptrreg fixoffset) + (! mem-ref-c-single-float fp-reg ptrreg fixoffset))) + (with-imm-target () (ptrreg :address) + (with-additional-imm-reg () + (with-imm-target (ptrreg) (offsetreg :signed-natural) + (x862-two-targeted-reg-forms seg + ptr ptrreg + offset ($ *x862-arg-z*)) + (! fixnum->signed-natural offsetreg *x862-arg-z*) + (if double-p + (! mem-ref-double-float fp-reg ptrreg offsetreg) + (! mem-ref-single-float fp-reg ptrreg offsetreg)))))) + (<- fp-reg)) + (^))))) + + +(defx862 x862-%get-double-float %get-double-float (seg vreg xfer ptr offset) + (with-fp-target () (fp-reg :double-float) + (x862-get-float seg vreg xfer ptr offset t fp-reg))) + +(defx862 x862-%get-single-float %get-single-float (seg vreg xfer ptr offset) + (with-fp-target () (fp-reg :single-float) + (x862-get-float seg vreg xfer ptr offset nil fp-reg))) + +(defun x862-set-float (seg vreg xfer ptr offset newval double-p fp-reg) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((fixoffset (acode-fixnum-form-p offset)) + (immoffset (typep fixoffset '(unsigned-byte 15)))) + (with-imm-target () (ptr-reg :address) + (cond ((or (null vreg) + (= (hard-regspec-class vreg) hard-reg-class-fpr)) + (cond (immoffset + (x862-push-register + seg + (x862-one-untargeted-reg-form seg + ptr + ptr-reg)) + (x862-one-targeted-reg-form seg newval fp-reg) + (x862-pop-register seg ptr-reg) + (if double-p + (! mem-set-c-double-float fp-reg ptr-reg fixoffset) + (! mem-set-c-single-float fp-reg ptr-reg fixoffset))) + (t + (with-additional-imm-reg () + (with-imm-target (ptr-reg) (offset-reg :s32) + (x862-push-register + seg + (x862-one-untargeted-reg-form seg + ptr + ptr-reg)) + (x862-push-register + seg + (x862-one-untargeted-reg-form seg + offset + *x862-arg-z*)) + (x862-one-targeted-reg-form seg newval fp-reg) + (x862-pop-register seg *x862-arg-z*) + (x862-pop-register seg ptr-reg) + (! fixnum->signed-natural offset-reg *x862-arg-z*) + (if double-p + (! mem-set-double-float fp-reg ptr-reg offset-reg) + (! mem-set-single-float fp-reg ptr-reg offset-reg)))))) + (<- fp-reg)) + (t + (cond (immoffset + (let* ((rnew ($ *x862-arg-z*))) + (x862-push-register + seg + (x862-one-untargeted-reg-form seg + ptr + ptr-reg)) + (x862-one-targeted-reg-form seg newval rnew) + (x862-pop-register seg ptr-reg) + (with-additional-imm-reg () + (with-imm-temps (ptr-reg) () + (x862-copy-register seg fp-reg rnew) + (if double-p + (! mem-set-c-double-float fp-reg ptr-reg fixoffset) + (! mem-set-c-single-float fp-reg ptr-reg fixoffset)))))) + (t + (let* ((roffset ($ *x862-arg-y*)) + (rnew ($ *x862-arg-z*))) + (x862-push-register + seg + (x862-one-untargeted-reg-form + seg + ptr ptr-reg)) + (x862-two-targeted-reg-forms seg + offset roffset + newval rnew) + (x862-pop-register seg ptr-reg) + (with-additional-imm-reg () + (with-imm-target (ptr-reg) (offset-reg :s32) + (with-imm-temps (ptr-reg) () + (x862-copy-register seg fp-reg rnew) + (! fixnum->signed-natural offset-reg roffset)) + (if double-p + (! mem-set-double-float fp-reg ptr-reg offset-reg) + (! mem-set-single-float fp-reg ptr-reg offset-reg))))))) + (<- *x862-arg-z*))) + (^))))) + +(defx862 x862-%set-double-float %set-double-float (seg vreg xfer ptr offset newval) + (with-fp-target () (fp-reg :double-float) + (x862-set-float seg vreg xfer ptr offset newval t fp-reg))) + +(defx862 x862-%set-single-float %set-single-float (seg vreg xfer ptr offset newval) + (with-fp-target () (fp-reg :single-float) + (x862-set-float seg vreg xfer ptr offset newval nil fp-reg))) + +(defx862 x862-immediate-get-ptr immediate-get-ptr (seg vreg xfer ptr offset) + (let* ((absptr (acode-absolute-ptr-p ptr)) + (triv-p (x862-trivial-p offset)) + (dest vreg) + (offval (acode-fixnum-form-p offset))) + (cond ((not vreg) + (x862-form seg nil nil ptr) + (x862-form seg nil xfer offset)) + (t + (if (and absptr offval) + (setq absptr (+ absptr offval) offval 0) + (setq absptr nil)) + (and offval (%i> (integer-length offval) 31) (setq offval nil)) + (and absptr (%i> (integer-length absptr) 31) (setq absptr nil)) + (if absptr + (! mem-ref-c-absolute-natural dest absptr) + (if offval + (let* ((src (x862-macptr-arg-to-reg seg ptr ($ *x862-imm0* :mode :address)))) + (! mem-ref-c-natural dest src offval)) + (let* ((src (x862-macptr-arg-to-reg seg ptr ($ *x862-imm0* :mode :address)))) + (if triv-p + (with-additional-imm-reg () + (with-imm-temps (src) (x) + (if (acode-fixnum-form-p offset) + (x862-lri seg x (acode-fixnum-form-p offset)) + (! fixnum->signed-natural x (x862-one-untargeted-reg-form seg offset *x862-arg-z*))) + (! mem-ref-natural dest src x))) + (progn + (! temp-push-unboxed-word src) + (x862-open-undo $undostkblk) + (let* ((oreg (x862-one-untargeted-reg-form seg offset *x862-arg-z*))) + (with-additional-imm-reg (*x862-arg-z*) + (with-imm-temps () (src x) + (! temp-pop-unboxed-word src) + (x862-close-undo) + (! fixnum->signed-natural x oreg) + (! mem-ref-natural dest src x))))))))) + (^))))) + +(defx862 x862-get-bit %get-bit (seg vreg xfer ptr offset) + (if (null vreg) + (progn + (x862-form seg nil nil ptr) + (x862-form seg nil xfer offset)) + (let* ((offval (acode-fixnum-form-p offset))) + (if (typep offval '(signed-byte 32)) ; or thereabouts + (with-imm-target () (src-reg :address) + (x862-one-targeted-reg-form seg ptr src-reg) + (if (node-reg-p vreg) + (! mem-ref-c-bit-fixnum vreg src-reg offval) + (with-imm-target () ;OK if src-reg & dest overlap + (dest :u8) + (! mem-ref-c-bit dest src-reg offval) + (<- dest)))) + (with-imm-target () (src-reg :address) + (x862-two-targeted-reg-forms seg ptr src-reg offset ($ *x862-arg-z*)) + (if (node-reg-p vreg) + (! mem-ref-bit-fixnum vreg src-reg ($ *x862-arg-z*)) + (with-imm-target () ;OK if src-reg & dest overlap + (dest :u8) + (! mem-ref-bit dest src-reg offset) + (<- dest))))) + (^)))) + + + +;;; gonna run out of imm regs here +;;; This returns an unboxed object, unless the caller wants to box it. +(defx862 x862-immediate-get-xxx immediate-get-xxx (seg vreg xfer bits ptr offset) + (declare (fixnum bits)) + (let* ((fixnump (logbitp 6 bits)) + (signed (logbitp 5 bits)) + (size (logand 15 bits)) + (absptr (acode-absolute-ptr-p ptr)) + (triv-p (x862-trivial-p offset)) + (offval (acode-fixnum-form-p offset))) + (declare (fixnum size)) + (cond ((null vreg) + (x862-form seg nil nil ptr) + (x862-form seg nil xfer offset)) + (t + (if (and absptr offval) + (setq absptr (+ absptr offval) offval 0) + (setq absptr nil)) + (and offval (%i> (integer-length offval) 31) (setq offval nil)) + (and absptr (%i> (integer-length absptr) 31) (setq absptr nil)) + ;;; huh? + (target-arch-case + (:x8632 (when (or fixnump (eql size 4) (and (eql size 4) signed)) + (and offval (logtest 2 offval) (setq offval nil)) + (and absptr (logtest 2 absptr) (setq absptr nil)))) + (:x8664 (when (or fixnump (eql size 8) (and (eql size 8) signed)) + (and offval (logtest 3 offval) (setq offval nil)) + (and absptr (logtest 3 absptr) (setq absptr nil))))) + (cond + (fixnump + (with-imm-target () (dest :signed-natural) + (cond + (absptr + (target-arch-case + (:x8632 (! mem-ref-c-absolute-fullword dest absptr)) + (:x8664 (! mem-ref-c-absolute-doubleword dest absptr)))) + (offval + (with-imm-target () (src-reg :address) + (x862-one-targeted-reg-form seg ptr src-reg) + (target-arch-case + (:x8632 (! mem-ref-c-fullword dest src-reg offval)) + (:x8664 (! mem-ref-c-doubleword dest src-reg offval))))) + (t + (with-imm-target () (src-reg :address) + (with-additional-imm-reg () + (with-imm-target (src-reg) (offset-reg :signed-natural) + (x862-one-targeted-reg-form seg ptr src-reg) + (if triv-p + (if (acode-fixnum-form-p offset) + (x862-lri seg offset-reg (acode-fixnum-form-p offset)) + (! fixnum->signed-natural offset-reg (x862-one-untargeted-reg-form seg offset *x862-arg-z*))) + (progn + (! temp-push-unboxed-word src-reg) + (x862-open-undo $undostkblk) + (! fixnum->signed-natural offset-reg (x862-one-untargeted-reg-form seg offset *x862-arg-z*)) + (! temp-pop-unboxed-word src-reg) + (x862-close-undo))) + (target-arch-case + (:x8632 (! mem-ref-fullword dest src-reg offset-reg)) + (:x8664 (! mem-ref-doubleword dest src-reg offset-reg)))))))) + (if (node-reg-p vreg) + (! box-fixnum vreg dest) + (<- dest)))) + (signed + (with-imm-target () (dest :signed-natural) + (cond + (absptr + (case size + (8 (! mem-ref-c-absolute-signed-doubleword dest absptr)) + (4 (! mem-ref-c-absolute-signed-fullword dest absptr)) + (2 (! mem-ref-c-absolute-s16 dest absptr)) + (1 (! mem-ref-c-absolute-s8 dest absptr)))) + (offval + (with-additional-imm-reg () + (with-imm-target (dest) (src-reg :address) + (x862-one-targeted-reg-form seg ptr src-reg) + (case size + (8 (! mem-ref-c-signed-doubleword dest src-reg offval)) + (4 (! mem-ref-c-signed-fullword dest src-reg offval)) + (2 (! mem-ref-c-s16 dest src-reg offval)) + (1 (! mem-ref-c-s8 dest src-reg offval)))))) + (t + (with-imm-target () (src-reg :address) + (with-additional-imm-reg () + (with-imm-target (src-reg) (offset-reg :signed-natural) + (x862-one-targeted-reg-form seg ptr src-reg) + (if triv-p + (if (acode-fixnum-form-p offset) + (x862-lri seg offset-reg (acode-fixnum-form-p offset)) + (! fixnum->signed-natural offset-reg (x862-one-untargeted-reg-form seg offset *x862-arg-z*))) + (progn + (! temp-push-unboxed-word src-reg) + (x862-open-undo $undostkblk) + (! fixnum->signed-natural offset-reg (x862-one-untargeted-reg-form seg offset *x862-arg-z*)) + (! temp-pop-unboxed-word src-reg) + (x862-close-undo))) + (case size + (8 (! mem-ref-signed-doubleword dest src-reg offset-reg)) + (4 (! mem-ref-signed-fullword dest src-reg offset-reg)) + (2 (! mem-ref-s16 dest src-reg offset-reg)) + (1 (! mem-ref-s8 dest src-reg offset-reg)))))))) + (if (node-reg-p vreg) + (case size + ((1 2) (! box-fixnum vreg dest)) + (4 (target-arch-case + (:x8632 (<- dest)) + (:x8664 (! box-fixnum vreg dest)))) + (8 (<- dest))) + (<- dest)))) + (t + (with-imm-target () (dest :natural) + (cond + (absptr + (case size + (8 (! mem-ref-c-absolute-doubleword dest absptr)) + (4 (! mem-ref-c-absolute-fullword dest absptr)) + (2 (! mem-ref-c-absolute-u16 dest absptr)) + (1 (! mem-ref-c-absolute-u8 dest absptr)))) + (offval + (with-additional-imm-reg () + (with-imm-target (dest) (src-reg :address) + (x862-one-targeted-reg-form seg ptr src-reg) + (case size + (8 (! mem-ref-c-doubleword dest src-reg offval)) + (4 (! mem-ref-c-fullword dest src-reg offval)) + (2 (! mem-ref-c-u16 dest src-reg offval)) + (1 (! mem-ref-c-u8 dest src-reg offval)))))) + (t + (with-additional-imm-reg () + (with-imm-target () (src-reg :address) + (with-imm-target (src-reg) (offset-reg :signed-natural) + (x862-one-targeted-reg-form seg ptr src-reg) + (if triv-p + (if (acode-fixnum-form-p offset) + (x862-lri seg offset-reg (acode-fixnum-form-p offset)) + (! fixnum->signed-natural offset-reg (x862-one-untargeted-reg-form seg offset *x862-arg-z*))) + (progn + (! temp-push-unboxed-word src-reg) + (x862-open-undo $undostkblk) + (! fixnum->signed-natural offset-reg (x862-one-untargeted-reg-form seg offset *x862-arg-z*)) + (! temp-pop-unboxed-word src-reg) + (x862-close-undo))) + (case size + (8 (! mem-ref-doubleword dest src-reg offset-reg)) + (4 (! mem-ref-fullword dest src-reg offset-reg)) + (2 (! mem-ref-u16 dest src-reg offset-reg)) + (1 (! mem-ref-u8 dest src-reg offset-reg)))))))) + (<- (set-regspec-mode + dest + (gpr-mode-name-value + (case size + (8 :u64) + (4 :u32) + (2 :u16) + (1 :u8)))))))) + (^))))) + +(defx862 x862-let let (seg vreg xfer vars vals body p2decls) + (let* ((old-stack (x862-encode-stack)) + (val nil) + (bits nil) + (valcopy vals)) + (with-x86-p2-declarations p2decls + (dolist (var vars) + (setq val (%car valcopy)) + (cond ((or (%ilogbitp $vbitspecial (setq bits (nx-var-bits var))) + (and (var-nvr var) + (dolist (val (%cdr valcopy)) + (unless (x862-trivial-p val) (return t))))) + (let* ((pair (cons (x862-vloc-ea *x862-vstack*) nil))) + (%rplaca valcopy pair) + (if (and (%ilogbitp $vbitdynamicextent bits) + (progn + (setq val + (x862-dynamic-extent-form seg (x862-encode-stack) val)) + (x862-load-ea-p val))) + (progn + (%rplaca pair (x862-vloc-ea *x862-vstack*)) + (x862-vpush-register seg val :reserved)) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg val *x862-arg-z*) :reserved)) + (%rplacd pair *x862-top-vstack-lcell*))) + (t (x862-seq-bind-var seg var val) + (%rplaca valcopy nil))) + (setq valcopy (%cdr valcopy))) + (dolist (var vars) + (declare (list val)) + (when (setq val (pop vals)) + (if (%ilogbitp $vbitspecial (nx-var-bits var)) + (progn + (x862-dbind seg (car val) (var-name var)) + (x862-set-var-ea seg var (x862-vloc-ea (- *x862-vstack* *x862-target-node-size*))) + ) + (x862-seq-bind-var seg var (car val))))) + (x862-undo-body seg vreg xfer body old-stack) + (dolist (var vars) + (x862-close-var seg var))))) + +(defx862 x862-closed-function closed-function (seg vreg xfer afunc) + (x862-make-closure seg afunc nil) + (when vreg (<- *x862-arg-z*)) + (^)) + +(defx862 x862-flet flet (seg vreg xfer vars afuncs body p2decls) + (if (dolist (afunc afuncs) + (unless (eql 0 (afunc-fn-refcount afunc)) + (return t))) + (x862-seq-fbind seg vreg xfer vars afuncs body p2decls) + (with-x86-p2-declarations p2decls + (x862-form seg vreg xfer body)))) + +(defx862 x862-labels labels (seg vreg xfer vars afuncs body p2decls) + (let* ((fwd-refs nil) + (func nil) + (togo vars) + (real-vars ()) + (real-funcs ()) + (funs afuncs)) + (dolist (v vars) + (when (neq 0 (afunc-fn-refcount (setq func (pop funs)))) + (push v real-vars) + (push func real-funcs) + (let* ((i (target-arch-case + (:x8632 7) + (:x8664 5))) ; skip 4 words of code, inner function + (our-var nil) + (item nil)) + (declare (fixnum i)) + (dolist (ref (afunc-inherited-vars func)) + (when (memq (setq our-var (var-bits ref)) togo) + (setq item (cons i our-var)) + (let* ((refs (assq v fwd-refs))) + (if refs + (push item (cdr refs)) + (push (list v item) fwd-refs)))) + (incf i))) + (setq togo (%cdr togo)))) + (if (null fwd-refs) + (x862-seq-fbind seg vreg xfer (nreverse real-vars) (nreverse real-funcs) body p2decls) + (let* ((old-stack (x862-encode-stack))) + (setq real-vars (nreverse real-vars) real-funcs (nreverse real-funcs)) + (with-x86-p2-declarations p2decls + (dolist (var real-vars) + (x862-seq-bind-var seg var (nx1-afunc-ref (pop real-funcs)))) + (dolist (ref fwd-refs) + (let ((ea (var-ea (pop ref)))) + (x862-addrspec-to-reg seg ea *x862-temp0*) + (dolist (r ref) + (let* ((v-ea (var-ea (cdr r)))) + (let* ((val-reg (if (eq v-ea ea) + *x862-temp0* + (progn + (x862-addrspec-to-reg seg v-ea *x862-temp1*) + *x862-temp1*)))) + (! set-closure-forward-reference val-reg *x862-temp0* (car r))))))) + (x862-undo-body seg vreg xfer body old-stack) + (dolist (var real-vars) + (x862-close-var seg var))))))) + +;;; Make a function call (e.g., to mapcar) with some of the toplevel arguments +;;; stack-consed (downward) closures. Bind temporaries to these closures so +;;; that tail-recursion/non-local exits work right. +;;; (all of the closures are distinct: FLET and LABELS establish dynamic extent themselves.) +(defx862 x862-with-downward-closures with-downward-closures (seg vreg xfer tempvars closures callform) + (let* ((old-stack (x862-encode-stack))) + (x862-seq-bind seg tempvars closures) + (x862-undo-body seg vreg xfer callform old-stack) + (dolist (v tempvars) (x862-close-var seg v)))) + + +(defx862 x862-local-return-from local-return-from (seg vreg xfer blocktag value) + (declare (ignorable vreg xfer)) + (let* ((*x862-undo-count* *x862-undo-count*) + (tagdata (car blocktag)) + (cur-stack (x862-encode-stack)) + (dest-vd (caar tagdata)) + (dest-cd (cdar tagdata)) + (mv-p (x862-mvpass-p dest-cd)) + (dest-stack (cdr tagdata)) + (need-break (neq cur-stack dest-stack))) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (*x862-cstack* *x862-cstack*)) + (if + (or + (eq dest-cd $backend-return) + (and mv-p + (eq (x862-encoding-undo-count cur-stack) + (x862-encoding-undo-count dest-stack)) + (eq (x862-encoding-cstack-depth cur-stack) + (x862-encoding-cstack-depth dest-stack)))) + (x862-form seg dest-vd dest-cd value) + (if mv-p + (progn + (x862-multiple-value-body seg value) + (let* ((*x862-returning-values* :pass)) + (x862-nlexit seg dest-cd (%i- *x862-undo-count* (x862-encoding-undo-count dest-stack))) + (x862-branch seg dest-cd))) + (progn + (x862-form + seg + (if need-break (if dest-vd *x862-arg-z*) dest-vd) + (if need-break nil dest-cd) + value) + (when need-break + (x862-unwind-set seg dest-cd dest-stack) + (when dest-vd (x862-copy-register seg dest-vd *x862-arg-z*)) + (x862-branch seg dest-cd)))))) + (x862-unreachable-store))) + +(defx862 x862-inherited-arg inherited-arg (seg vreg xfer arg) + (when vreg + (x862-addrspec-to-reg seg (x862-ea-open (var-ea arg)) vreg)) + (^)) + +(defx862 x862-%lisp-word-ref %lisp-word-ref (seg vreg xfer base offset) + (let* ((fixoffset (acode-fixnum-form-p offset))) + (cond ((null vreg) + (x862-form seg nil nil base) + (x862-form seg nil xfer offset)) + ((target-arch-case + (:x8632 (typep fixoffset '(signed-byte 30))) + (:x8664 (typep fixoffset '(signed-byte 13)))) ;xxx needlessly small + (ensuring-node-target (target vreg) + (! lisp-word-ref-c target + (x862-one-untargeted-reg-form seg base *x862-arg-z*) + (ash fixoffset *x862-target-fixnum-shift*))) + (^)) + (t (multiple-value-bind (breg oreg) + (x862-two-untargeted-reg-forms seg base *x862-arg-y* offset *x862-arg-z*) + (ensuring-node-target (target vreg) + (! lisp-word-ref target breg oreg)) + (^)))))) + +(defx862 x862-%fixnum-ref %fixnum-ref (seg vreg xfer base offset) + (let* ((fixoffset (acode-fixnum-form-p offset))) + (cond ((null vreg) + (x862-form seg nil nil base) + (x862-form seg nil xfer offset)) + ((typep fixoffset '(signed-byte 16)) + (ensuring-node-target (target vreg) + (! lisp-word-ref-c target + (x862-one-untargeted-reg-form seg base *x862-arg-z*) + fixoffset)) + (^)) + (t (multiple-value-bind (breg oreg) + (x862-two-untargeted-reg-forms seg base *x862-arg-y* offset *x862-arg-z*) + (with-imm-target () (otemp :s32) + (! fixnum->signed-natural otemp oreg) + (ensuring-node-target (target vreg) + (! lisp-word-ref target breg otemp))) + (^)))))) + +(defx862 x862-%fixnum-ref-natural %fixnum-ref-natural (seg vreg xfer base offset) + (let* ((fixoffset (acode-fixnum-form-p offset))) + (cond ((null vreg) + (x862-form seg nil nil base) + (x862-form seg nil xfer offset)) + ((typep fixoffset '(signed-byte 16)) + (with-imm-target () (val :natural) + (! lisp-word-ref-c val + (x862-one-untargeted-reg-form seg base *x862-arg-z*) + fixoffset) + (<- val)) + (^)) + (t (multiple-value-bind (breg oreg) + (x862-two-untargeted-reg-forms seg base *x862-arg-y* offset *x862-arg-z*) + (with-imm-target () (otemp :s32) + (! fixnum->signed-natural otemp oreg) + (with-imm-target () (val :natural) + (! lisp-word-ref val breg otemp) + (<- val))) + (^)))))) + +(defx862 x862-int>0-p int>0-p (seg vreg xfer cc form) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (x862-one-targeted-reg-form seg form ($ *x862-arg-z*)) + (! integer-sign) + (x862-test-reg-%izerop seg vreg xfer *x862-imm0* cr-bit true-p 0))) + + +(defx862 x862-throw throw (seg vreg xfer tag valform ) + (declare (ignorable vreg xfer)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg tag *x862-arg-z*)) + (if (x862-trivial-p valform) + (progn + (x862-vpush-register seg (x862-one-untargeted-reg-form seg valform *x862-arg-z*)) + (x862-set-nargs seg 1)) + (x862-multiple-value-body seg valform)) + (! throw))) + +;;; This (and unwind-protect and things like that) are a little funky in that +;;; they have no good way of specifying the exit-point. The bad way is to +;;; follow the call to the catch-frame-creating subprim with a branch to that +;;; exit-point; the subprim returns to the following instruction. +;;; If the compiler ever gets smart about eliminating dead code, it has to +;;; be careful not to consider the block following the jump to be dead. +;;; Use a vinsn other than JUMP to reference the label. +(defx862 x862-catch catch (seg vreg xfer tag valform) + (let* ((tag-label (backend-get-next-label)) + (tag-label-value (aref *backend-labels* tag-label)) + (mv-pass (x862-mv-p xfer))) + (x862-one-targeted-reg-form seg tag ($ *x862-arg-z*)) + (if mv-pass + (! nmkcatchmv tag-label-value) + (! nmkcatch1v tag-label-value)) + (x862-open-undo) + (if mv-pass + (x862-multiple-value-body seg valform) + (x862-one-targeted-reg-form seg valform ($ *x862-arg-z*))) + (x862-lri seg *x862-imm0* (ash 1 *x862-target-fixnum-shift*)) + (if mv-pass + (! nthrowvalues tag-label-value) + (! nthrow1value tag-label-value)) + (x862-close-undo) + (@= tag-label) + (unless mv-pass (if vreg (<- *x862-arg-z*))) + (let* ((*x862-returning-values* mv-pass)) ; nlexit keeps values on stack + (^)))) + + +(defx862 x862-fixnum-overflow fixnum-overflow (seg vreg xfer form) + (destructuring-bind (op n0 n1) (acode-unwrapped-form form) + (x862-use-operator op seg vreg xfer n0 n1 *nx-t*))) + +(defx862 x862-%aref2 simple-typed-aref2 (seg vreg xfer typename arr i j &optional dim0 dim1) + (if (null vreg) + (progn + (x862-form seg nil nil arr) + (x862-form seg nil nil i) + (x862-form seg nil xfer j))) + (let* ((type-keyword (acode-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword )) + (safe (unless *x862-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1))) + (x862-aref2 seg vreg xfer arr i j safe type-keyword dim0 dim1))) + +(defx862 x862-generic-aref2 general-aref2 (seg vreg xfer arr i j) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (dims (and atype (array-ctype-dimensions atype))) + (keyword (and atype + (or (eq dims '*) + (and (typep dims 'list) + (= 2 (length dims)))) + (not (array-ctype-complexp atype)) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (cond (keyword + (when (eq dims '*) + (setq dims nil)) + (let* ((dim0 (car dims)) + (dim1 (cadr dims))) + (x862-aref2 seg + vreg + xfer + arr + i + j + (if *x862-reckless* + nil + (nx-lookup-target-uvector-subtag keyword )) + keyword ;(make-acode (%nx1-operator immediate) ) + (if (typep dim0 'fixnum) dim0) (if (typep dim1 'fixnum) dim1)))) + (t + (x862-three-targeted-reg-forms seg + arr (target-arch-case + (:x8632 ($ x8632::temp0)) + (:x8664 ($ x8664::arg_x))) + i ($ *x862-arg-y*) + j ($ *x862-arg-z*)) + (x862-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SParef2)))))) + +(defx862 x862-%aref3 simple-typed-aref3 (seg vreg xfer typename arr i j k &optional dim0 dim1 dim2) + (if (null vreg) + (progn + (x862-form seg nil nil arr) + (x862-form seg nil nil i) + (x862-form seg nil nil j) + (x862-form seg nil xfer k))) + (let* ((type-keyword (acode-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword )) + (safe (unless *x862-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1)) + (dim2 (acode-fixnum-form-p dim2))) + (x862-aref3 seg vreg xfer arr i j k safe type-keyword dim0 dim1 dim2))) + + +(defx862 x862-general-aref3 general-aref3 (seg vreg xfer arr i j k) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (dims (and atype (array-ctype-dimensions atype))) + (keyword (and atype + (or (eq dims '*) + (and (typep dims 'list) + (= 3 (length dims)))) + (not (array-ctype-complexp atype)) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (cond (keyword + (when (eq dims '*) + (setq dims nil)) + (let* ((dim0 (car dims)) + (dim1 (cadr dims)) + (dim2 (caddr dims))) + (x862-aref3 seg + vreg + xfer + arr + i + j + k + (if *x862-reckless* + nil + (nx-lookup-target-uvector-subtag keyword )) + keyword ;(make-acode (%nx1-operator immediate) ) + (if (typep dim0 'fixnum) dim0) + (if (typep dim1 'fixnum) dim1) + (if (typep dim2 'fixnum) dim2)))) + (t + (x862-four-targeted-reg-forms seg + arr ($ *x862-temp0*) + i ($ x8664::arg_x) + j ($ *x862-arg-y*) + k ($ *x862-arg-z*)) + (x862-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SParef3)))))) + +(defx862 x862-general-aset2 general-aset2 (seg vreg xfer arr i j new) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (dims (and atype (array-ctype-dimensions atype))) + (keyword (and atype + (or (eq dims '*) + (and (typep dims 'list) + (= 2 (length dims)))) + (not (array-ctype-complexp atype)) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (cond (keyword + (when (eq dims '*) + (setq dims nil)) + (let* ((dim0 (car dims)) + (dim1 (cadr dims))) + (x862-aset2 seg + vreg + xfer + arr + i + j + new + (unless *x862-reckless* + (nx-lookup-target-uvector-subtag keyword )) + keyword + (if (typep dim0 'fixnum) dim0) + (if (typep dim1 'fixnum) dim1)))) + (t + (x862-four-targeted-reg-forms seg + arr ($ *x862-temp0*) + i ($ x8664::arg_x) + j ($ *x862-arg-y*) + new ($ *x862-arg-z*)) + (x862-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SPaset2)))))) + +(defx862 x862-general-aset3 general-aset3 (seg vreg xfer arr i j k new) + (target-arch-case + (:x8632 (error "not for x8632 yet"))) + (let* ((atype0 (acode-form-type arr t)) + (ctype (if atype0 (specifier-type atype0))) + (atype (if (array-ctype-p ctype) ctype)) + (dims (and atype (array-ctype-dimensions atype))) + (keyword (and atype + (or (eq dims '*) + (unless (atom dims) + (= 3 (length dims)))) + (not (array-ctype-complexp atype)) + (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + atype)))) + (cond (keyword + (when (eq dims '*) + (setq dims nil)) + (let* ((dim0 (car dims)) + (dim1 (cadr dims)) + (dim2 (caddr dims))) + (x862-aset3 seg + vreg + xfer + arr + i + j + k + new + (unless *x862-reckless* + (nx-lookup-target-uvector-subtag keyword )) + keyword + (if (typep dim0 'fixnum) dim0) + (if (typep dim1 'fixnum) dim1) + (if (typep dim2 'fixnum) dim2)))) + (t + (x862-push-register seg (x862-one-untargeted-reg-form seg arr ($ *x862-arg-z*))) + (x862-four-targeted-reg-forms seg + i ($ *x862-temp0*) + j ($ x8664::arg_x) + k ($ *x862-arg-y*) + new ($ *x862-arg-z*)) + (x862-pop-register seg ($ x8664::temp1)) + (x862-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SPaset3)))))) + + +(defx862 x862-%aset2 simple-typed-aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1) + (let* ((type-keyword (acode-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword)) + (safe (unless *x862-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1))) + (x862-aset2 seg vreg xfer arr i j new safe type-keyword dim0 dim1))) + + +(defx862 x862-%aset3 simple-typed-aset3 (seg vreg xfer typename arr i j k new &optional dim0 dim1 dim2) + (let* ((type-keyword (acode-immediate-operand typename)) + (fixtype (nx-lookup-target-uvector-subtag type-keyword)) + (safe (unless *x862-reckless* fixtype)) + (dim0 (acode-fixnum-form-p dim0)) + (dim1 (acode-fixnum-form-p dim1)) + (dim2 (acode-fixnum-form-p dim2))) + (x862-aset3 seg vreg xfer arr i j k new safe type-keyword dim0 dim1 dim2))) + +(defx862 x862-%typed-uvref %typed-uvref (seg vreg xfer subtag uvector index) + (let* ((type-keyword + (let* ((fixtype (acode-fixnum-form-p subtag))) + (if fixtype + (nx-target-uvector-subtag-name fixtype) + (acode-immediate-operand subtag))))) + (if type-keyword + (x862-vref seg vreg xfer type-keyword uvector index (unless *x862-reckless* (nx-lookup-target-uvector-subtag type-keyword))) + (progn + (x862-three-targeted-reg-forms seg + subtag (target-arch-case + (:x8632 ($ x8632::temp0)) + (:x8664 ($ x8664::arg_x))) + uvector ($ *x862-arg-y*) + index ($ *x862-arg-z*)) + (! subtag-misc-ref) + (when vreg (<- ($ *x862-arg-z*))) + (^)) ))) + +(defx862 x862-%typed-uvset %typed-uvset (seg vreg xfer subtag uvector index newval) + (let* ((type-keyword + (let* ((fixtype (acode-fixnum-form-p subtag))) + (if fixtype + (nx-target-uvector-subtag-name fixtype) + (acode-immediate-operand subtag))))) + (if type-keyword + (x862-vset seg vreg xfer type-keyword uvector index newval (unless *x862-reckless* (nx-lookup-target-uvector-subtag type-keyword))) + (progn + (target-arch-case + (:x8632 + (x862-four-targeted-reg-forms seg subtag ($ x8632::temp1) uvector ($ x8632::temp0) index ($ x8632::arg_y) newval ($ x8632::arg_z))) + (:x8664 + (x862-four-targeted-reg-forms seg subtag ($ x8664::temp0) uvector ($ x8664::arg_x) index ($ x8664::arg_y) newval ($ x8664::arg_z)))) + (! subtag-misc-set) + (when vreg (<- ($ *x862-arg-z*))) + (^))))) + +(defx862 x862-%macptrptr% %macptrptr% (seg vreg xfer form) + (with-imm-target () (target :address) + (x862-one-targeted-reg-form seg form (or vreg target))) + (^)) + + +;;; cons a macptr, unless "vreg" is an immediate register of mode :address. +(defx862 x862-%consmacptr% %consmacptr% (seg vreg xfer form) + (cond ((null vreg) (x862-form seg nil xfer form)) + ((eql (get-regspec-mode vreg) hard-reg-class-gpr-mode-address) + (x862-form seg vreg xfer form)) + (t + (with-imm-target () (temp :address) + (<- (x862-one-targeted-reg-form seg form temp)) + (^))))) + +(defx862 x862-%immediate-ptr-to-int %immediate-ptr-to-int (seg vreg xfer form) + (if (null vreg) + (x862-form seg nil xfer form) + (with-imm-target () (address-reg :address) + (x862-form seg address-reg nil form) + (<- (set-regspec-mode address-reg (gpr-mode-name-value :natural))) + (^)))) + +(defx862 x862-%immediate-int-to-ptr %immediate-int-to-ptr (seg vreg xfer form) + (if (null vreg) + (x862-form seg nil xfer form) + (progn + (unless (logbitp (hard-regspec-value vreg) *backend-imm-temps*) + (compiler-bug "I give up. When will I get this right ?")) + (let* ((natural-reg (x862-one-targeted-reg-form seg + form + ($ vreg :mode :natural)))) + (<- natural-reg) + (^))))) + + +(defx862 x862-%function %function (seg vreg xfer sym) + (when vreg + (let* ((symreg (x862-one-untargeted-reg-form seg (make-acode (%nx1-operator immediate) + (x862-symbol-entry-locative sym)) *x862-arg-z*))) + (with-node-temps (vreg symreg) (val) + (! symbol-function val symreg) + (<- val)))) + (^)) + +(defx862 x862-%unbound-marker %unbound-marker (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (x862-lri seg target (target-arch-case + (:x8632 x8632::unbound-marker) + (:x8664 x8664::unbound-marker))))) + (^)) + +(defx862 x862-slot-unbound-marker %slot-unbound-marker (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (x862-lri seg target (target-arch-case + (:x8632 x8632::slot-unbound-marker) + (:x8664 x8664::slot-unbound-marker))))) + (^)) + +(defx862 x862-illegal-marker %illegal-marker (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (x862-lri seg target (target-arch-case + (:x8632 x8632::illegal-marker) + (:x8664 x8664::illegal-marker))))) + (^)) + +(defx862 x862-lambda-bind lambda-bind (seg vreg xfer vals req rest keys-p auxen body p2decls) + (let* ((old-stack (x862-encode-stack)) + (nreq (list-length req)) + (rest-arg (nthcdr nreq vals)) + (apply-body (x862-eliminate-&rest body rest keys-p auxen rest-arg))) + (x862-seq-bind seg req vals) + (when apply-body (setq rest nil body apply-body)) + (let* + ((vloc *x862-vstack*) + (restloc vloc) + (nvloc (progn (if (or rest keys-p) (x862-formlist seg rest-arg)) *x862-vstack*))) + (with-x86-p2-declarations p2decls + (when rest + (when keys-p + (until (eq restloc nvloc) + (with-node-temps () (temp) + (x862-stack-to-register seg (x862-vloc-ea restloc) temp) + (x862-vpush-register seg temp)) + (setq restloc (%i+ restloc *x862-target-node-size*)))) + (x862-set-nargs seg (length rest-arg)) + (x862-set-vstack restloc) + (if (%ilogbitp $vbitdynamicextent (nx-var-bits rest)) + (progn + (! stack-cons-list) + (x862-open-undo $undostkblk)) + (! list)) + (x862-vpush-register seg *x862-arg-z*)) + (when rest (x862-bind-var seg rest restloc)) + (destructuring-bind (vars inits) auxen + (while vars + (let ((val (%car inits))) + (if (fixnump val) + (progn + (when rest (setq val (%i+ (%i+ val val) 1))) + (x862-bind-var seg (%car vars) (%i+ vloc (* val *x862-target-node-size*)))) + (x862-seq-bind-var seg (%car vars) val))) + (setq vars (%cdr vars) inits (%cdr inits)))) + (x862-undo-body seg vreg xfer body old-stack) + (dolist (var req) (x862-close-var seg var)) + (when rest (x862-close-var seg rest)) + (dolist (var (%car auxen)) (x862-close-var seg var)))))) + +(macrolet + ((def-x862-require (function op &optional (vinsn op)) + `(defx862 ,function ,op (seg vreg xfer val) + (let* ((val-reg (x862-one-untargeted-reg-form + seg + val + (if (eq vreg *x862-arg-z*) *x862-arg-y* *x862-arg-z*)))) + (! ,vinsn val-reg) + (when vreg (<- val-reg)) + (^))))) + (def-x862-require x862-require-simple-vector require-simple-vector) + (def-x862-require x862-require-simple-string require-simple-string) + (def-x862-require x862-require-integer require-integer) + (def-x862-require x862-require-fixnum require-fixnum) + (def-x862-require x862-require-real require-real) + (def-x862-require x862-require-list require-list) + (def-x862-require x862-require-character require-character) + (def-x862-require x862-require-number require-number) + (def-x862-require x862-require-symbol require-symbol) + (def-x862-require x862-require-s8 require-s8) + (def-x862-require x862-require-s8 require-u8) + (def-x862-require x862-require-s8 require-s16) + (def-x862-require x862-require-s8 require-u16) + (def-x862-require x862-require-s8 require-s32) + (def-x862-require x862-require-s8 require-u32) + (def-x862-require x862-require-s8 require-s64) + (def-x862-require x862-require-s8 require-u64)) + +(defun x862-typechecked-form (seg vreg xfer typespec form) + (with-x86-local-vinsn-macros (seg vreg xfer) + (let* ((op + (cond ((eq typespec 'fixnum) (%nx1-operator require-fixnum)) + ((eq typespec 'integer) (%nx1-operator require-integer)) + ((memq typespec '(base-char character)) + (%nx1-operator require-character)) + ((eq typespec 'symbol) (%nx1-operator require-symbol)) + ((eq typespec 'list) (%nx1-operator require-list)) + ((eq typespec 'real) (%nx1-operator require-real)) + ((memq typespec '(simple-base-string simple-string)) + (%nx1-operator require-simple-string)) + ((eq typespec 'number) (%nx1-operator require-number)) + ((eq typespec 'simple-vector) (%nx1-operator require-simple-vector)) + (t + (let* ((ctype (specifier-type typespec))) + (cond ((type= ctype (load-time-value (specifier-type '(signed-byte 8)))) + (%nx1-operator require-s8)) + ((type= ctype (load-time-value (specifier-type '(unsigned-byte 8)))) + (%nx1-operator require-u8)) + ((type= ctype (load-time-value (specifier-type '(signed-byte 16)))) + (%nx1-operator require-s16)) + ((type= ctype (load-time-value (specifier-type '(unsigned-byte 16)))) + (%nx1-operator require-u16)) + ((type= ctype (load-time-value (specifier-type '(signed-byte 32)))) + (%nx1-operator require-s32)) + ((type= ctype (load-time-value (specifier-type '(unsigned-byte 32)))) + (%nx1-operator require-u32)) + ((type= ctype (load-time-value (specifier-type '(signed-byte 64)))) + (%nx1-operator require-s64)) + ((type= ctype (load-time-value (specifier-type '(unsigned-byte 64)))) + (%nx1-operator require-u64)))))))) + (if op + (x862-use-operator op seg vreg xfer form) + (if (or (eq typespec t) + (eq typespec '*)) + (x862-form seg vreg xfer form) + (with-note (form seg) + (let* ((ok (backend-get-next-label))) + (if (and (symbolp typespec) (non-nil-symbolp (type-predicate typespec))) + ;; Do this so can compile the lisp with typechecking even though typep + ;; doesn't get defined til fairly late. + (progn + (x862-one-targeted-reg-form seg form ($ *x862-arg-z*)) + (x862-store-immediate seg (type-predicate typespec) ($ *x862-fname*)) + (x862-set-nargs seg 1) + (x862-vpush-register seg ($ *x862-arg-z*))) + (progn + (x862-one-targeted-reg-form seg form ($ *x862-arg-y*)) + (x862-store-immediate seg typespec ($ *x862-arg-z*)) + (x862-store-immediate seg 'typep ($ *x862-fname*)) + (x862-set-nargs seg 2) + (x862-vpush-register seg ($ *x862-arg-y*)))) + (! call-known-symbol ($ *x862-arg-z*)) + (! compare-to-nil ($ *x862-arg-z*)) + (x862-vpop-register seg ($ *x862-arg-y*)) + (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits) + (target-arch-case + (:x8632 + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (! reserve-outgoing-frame) + (incf *x862-vstack* (* 2 *x862-target-node-size*)) + (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*)) + (x862-store-immediate seg typespec ($ *x862-arg-z*)) + (x862-set-nargs seg 3) + (! ksignalerr))) + (:x8664 + (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*)) + (x862-store-immediate seg typespec ($ *x862-arg-z*)) + (x862-set-nargs seg 3) + (! ksignalerr))) + (@ ok) + (<- ($ *x862-arg-y*)) + (^)))))))) + + + + + + +(defx862 x862-%badarg2 %badarg2 (seg vreg xfer badthing goodthing) + (x862-two-targeted-reg-forms seg badthing ($ *x862-arg-y*) goodthing ($ *x862-arg-z*)) + (target-arch-case + (:x8632 + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (! reserve-outgoing-frame) + (incf *x862-vstack* (* 2 *x862-target-node-size*)) + (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*)) + (x862-set-nargs seg 3) + (! ksignalerr)) + (<- nil) + (^)) + (:x8664 + (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*)) + (x862-set-nargs seg 3) + (! ksignalerr) + (<- nil) + (^)))) + +(defx862 x862-%set-sbchar %set-sbchar (seg vreg xfer string index value) + (x862-vset + seg + vreg + xfer + :simple-string + string + index + value + (unless *x862-reckless* (nx-lookup-target-uvector-subtag :simple-string)))) + + +;;; If we didn't use this for stack consing, turn it into a call. Ugh. + +(defx862 x862-make-list make-list (seg vreg xfer size initial-element) + (let* ((args (list size + (make-acode (%nx1-operator immediate) :initial-element) + initial-element))) + (x862-form seg vreg xfer + (make-acode (%nx1-operator call) + (make-acode (%nx1-operator immediate) 'make-list) + (if (<= (length args) *x862-target-num-arg-regs*) + (list nil (reverse args)) + (list (butlast args *x862-target-num-arg-regs*) + (reverse (last args *x862-target-num-arg-regs*)))))))) + +(defx862 x862-setq-free setq-free (seg vreg xfer sym val) + (let* ((rsym ($ *x862-arg-y*)) + (rval ($ *x862-arg-z*))) + (x862-one-targeted-reg-form seg val rval) + (x862-immediate seg rsym nil (x862-symbol-value-cell sym)) + (! setqsym) + (<- rval) + (^))) + +(defx862 x862-%setf-macptr %setf-macptr (seg vreg xfer x y) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg x *x862-arg-z*)) + (with-imm-target () (src-reg :address) + (x862-one-targeted-reg-form seg y src-reg) + (x862-vpop-register seg *x862-arg-z*) + (unless (or *x862-reckless* (x862-form-typep x 'macptr)) + (with-additional-imm-reg (*x862-arg-z*) + (with-imm-temps (src-reg) () + (! trap-unless-macptr *x862-arg-z*)))) + (! set-macptr-address src-reg *x862-arg-z*) + (<- *x862-arg-z*) + (^))) + +;; used for x8632 only +(defx862 x862-%setf-short-float %setf-short-float (seg vref xfer fnode fval) + (target-arch-case + (:x8664 (error "%setf-short-float makes no sense on x8664"))) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg fnode *x862-arg-z*)) + (let* ((target ($ *x862-fp1* :class :fpr :mode :single-float)) + (node ($ *x862-arg-z*))) + (x862-one-targeted-reg-form seg fval target) + (x862-vpop-register seg node) + (unless (or *x862-reckless* (x862-form-typep fnode 'single-float)) + (! trap-unless-single-float node)) + (! store-single node target) + (<- node) + (^))) + +(defx862 x862-%setf-double-float %setf-double-float (seg vref xfer fnode fval) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg fnode *x862-arg-z*)) + (let* ((target ($ *x862-fp1* :class :fpr :mode :double-float)) + (node ($ *x862-arg-z*))) + (x862-one-targeted-reg-form seg fval target) + (x862-vpop-register seg node) + (unless (or *x862-reckless* (x862-form-typep fnode 'double-float)) + (! trap-unless-double-float node)) + (! store-double node target) + (<- node) + (^))) + + + +(defx862 x862-unwind-protect unwind-protect (seg vreg xfer protected-form cleanup-form) + (let* ((cleanup-label (backend-get-next-label)) + (protform-label (backend-get-next-label)) + (old-stack (x862-encode-stack)) + (ilevel '*interrupt-level*)) + (! nmkunwind + (aref *backend-labels* protform-label) + (aref *backend-labels* cleanup-label)) + (x862-open-undo $undointerruptlevel) + (x862-new-vstack-lcell :special-value *x862-target-lcell-size* 0 ilevel) + (x862-new-vstack-lcell :special *x862-target-lcell-size* (ash 1 $vbitspecial) ilevel) + (x862-new-vstack-lcell :special-link *x862-target-lcell-size* 0 ilevel) + (x862-adjust-vstack (* 3 *x862-target-node-size*)) + (@= cleanup-label) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) + (x862-open-undo $undostkblk) ; tsp frame created by nthrow. + (x862-new-vstack-lcell :cleanup-return *x862-target-lcell-size* 0 nil) + (x862-adjust-vstack *x862-target-node-size*) + (x862-form seg nil nil cleanup-form) + (x862-close-undo) + (! jump-return-pc)) + (x862-open-undo) + (@= protform-label) + (x862-open-undo $undointerruptlevel) + (x862-new-vstack-lcell :special-value *x862-target-lcell-size* 0 ilevel) + (x862-new-vstack-lcell :special *x862-target-lcell-size* (ash 1 $vbitspecial) ilevel) + (x862-new-vstack-lcell :special-link *x862-target-lcell-size* 0 ilevel) + (x862-adjust-vstack (* 3 *x862-target-node-size*)) + (x862-undo-body seg vreg xfer protected-form old-stack))) + +(defx862 x862-progv progv (seg vreg xfer symbols values body) + (let* ((cleanup-label (backend-get-next-label)) + (protform-label (backend-get-next-label)) + (old-stack (x862-encode-stack))) + (x862-two-targeted-reg-forms seg symbols ($ *x862-arg-y*) values ($ *x862-arg-z*)) + (! progvsave) + (x862-open-undo $undostkblk) + (! mkunwind + (aref *backend-labels* protform-label) + (aref *backend-labels* cleanup-label)) + (@= cleanup-label) + (! progvrestore) + (x862-open-undo) + (@= protform-label) + (x862-undo-body seg vreg xfer body old-stack))) + +(defx862 x862-%ptr-eql %ptr-eql (seg vreg xfer cc x y ) + (if (null vreg) + (progn + (x862-form seg nil nil x) + (x862-form seg nil xfer y)) + (let* ((x-abs (acode-absolute-ptr-p x t)) + (y-abs (acode-absolute-ptr-p y t)) + (abs (or x-abs y-abs)) + (other (if abs (if x-abs y x)))) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (if other + (with-imm-target () (other-target :address) + (x862-one-targeted-reg-form seg other other-target) + (if (typep abs '(signed-byte 16)) + (x862-test-reg-%izerop seg vreg xfer other-target cr-bit true-p abs) + (with-additional-imm-reg () + (with-imm-temps (other-target) ((abs-target :address)) + (use-imm-temp other-target) + (x862-lri seg abs-target abs) + (x862-compare-registers seg vreg xfer other-target abs-target cr-bit true-p))))) + ;; Neither expression is obviously a constant-valued macptr. + (with-imm-target () (target-a :address) + (x862-one-targeted-reg-form seg x target-a) + (! temp-push-unboxed-word target-a) + (x862-open-undo $undostkblk) + (x862-one-targeted-reg-form seg y target-a) + (with-additional-imm-reg () + (with-imm-target (target-a) (target-b :address) + (! temp-pop-unboxed-word target-b) + (x862-close-undo) + (x862-compare-registers seg vreg xfer target-b target-a cr-bit true-p))))))))) + +(defx862 x862-set-bit %set-bit (seg vreg xfer ptr offset newval) + (let* ((offval (acode-fixnum-form-p offset)) + (constval (acode-fixnum-form-p newval))) + (if (typep offval '(signed-byte 32)) + (with-imm-target () (src :address) + (x862-one-targeted-reg-form seg ptr src) + (if constval + (progn + (if (eql constval 0) + (! mem-set-c-bit-0 src offval) + (! mem-set-c-bit-1 src offval)) + (when vreg + (x862-form seg vreg nil newval))) + (with-imm-target () (src :address) + (x862-two-targeted-reg-forms seg ptr src newval ($ *x862-arg-z*)) + (! mem-set-c-bit-variable-value src offval ($ *x862-arg-z*)) + (<- ($ *x862-arg-z*))))) + (if constval + (with-imm-target () (src :address) + (x862-two-targeted-reg-forms seg ptr src offset ($ *x862-arg-z*)) + (if (eql constval 0) + (! mem-set-bit-0 src ($ *x862-arg-z*)) + (! mem-set-bit-1 src ($ *x862-arg-z*))) + (when vreg + (x862-form seg vreg nil newval))) + (with-imm-target () (src :address) + (x862-three-targeted-reg-forms seg ptr src offset ($ *x862-arg-y*) newval ($ *x862-arg-z*)) + (! mem-set-bit-variable-value src ($ *x862-arg-y*) ($ *x862-arg-z*)) + (<- ($ *x862-arg-z*))))) + (^))) + +(defx862 x862-%immediate-set-xxx %immediate-set-xxx (seg vreg xfer bits ptr offset val) + (x862-%immediate-store seg vreg xfer bits ptr offset val)) + + + +(defx862 x862-%immediate-inc-ptr %immediate-inc-ptr (seg vreg xfer ptr by) + (let* ((triv-by (x862-trivial-p by)) + (fixnum-by (acode-fixnum-form-p by))) + (if (and fixnum-by (eql 0 fixnum-by)) + (x862-form seg vreg xfer ptr) + (let* ((ptr-reg (with-imm-target () (ptr-reg :address) + (x862-one-targeted-reg-form seg ptr ptr-reg))) + (s32-by (s32-fixnum-constant-p fixnum-by))) + (if s32-by + (let* ((result ptr-reg)) + (! add-constant result s32-by) + (<- result)) + (progn + (unless triv-by + (x862-push-register seg ptr-reg)) + (let* ((boxed-by (x862-one-targeted-reg-form seg by *x862-arg-z*))) + (unless triv-by + (x862-pop-register seg ptr-reg)) + (with-additional-imm-reg () + (with-imm-target (ptr-reg) (by-reg :signed-natural) + (! fixnum->signed-natural by-reg boxed-by) + (let* ((result ptr-reg)) + (! fixnum-add2 result by-reg) + (<- result))))))) + (^))))) + + + +(defx862 x862-multiple-value-call multiple-value-call (seg vreg xfer fn arglist) + (x862-mvcall seg vreg xfer fn arglist)) + +(defx862 x862-i386-syscall i386-syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports) + (declare (ignore monitor-exception-ports)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (*x862-cstack* *x862-cstack*) + (offset 0) + (nwords 0)) + (dolist (argspec argspecs) + (case argspec + ((:unsigned-doubleword :signed-doubleword) + (incf nwords 2)) + (t (incf nwords)))) + (! alloc-c-frame nwords) + (x862-open-undo $undo-x86-c-frame) + (x862-vpush-register seg (x862-one-untargeted-reg-form seg idx x8632::arg_z)) + ;; Evaluate each form into the C frame, according to the + ;; matching argspec. + (do* ((specs argspecs (cdr specs)) + (vals argvals (cdr vals))) + ((null specs)) + (declare (list specs vals)) + (let* ((valform (car vals)) + (spec (car specs)) + (absptr (acode-absolute-ptr-p valform))) + (case spec + ((:unsigned-doubleword :signed-doubleword) + (x862-one-targeted-reg-form seg valform ($ x8632::arg_z)) + (if (eq spec :signed-doubleword) + (! gets64) + (! getu64)) + (! set-c-arg-from-mm0 offset) + (incf offset 2)) + (:address + (with-imm-target () (ptr :address) + (if absptr + (x862-lri seg ptr absptr) + (x862-form seg ptr nil valform)) + (! set-c-arg ptr offset)) + (incf offset)) + (t + (with-imm-target () (valreg :natural) + (let* ((reg (x862-unboxed-integer-arg-to-reg seg valform valreg spec))) + (! set-c-arg reg offset) + (incf offset))))))) + (x862-vpop-register seg ($ x8632::arg_z)) + (case resultspec + ((:unsigned-doubleword :signed-doubleword) + (! syscall2)) ;copies doubleword result into %mm0 + (t + (! syscall))) + (x862-close-undo) + (when vreg + (cond ((eq resultspec :void) (<- nil)) + ((eq resultspec :unsigned-doubleword) + (ensuring-node-target (target vreg) + (! makeu64) + (x862-copy-register seg target ($ *x862-arg-z*)))) + ((eq resultspec :signed-doubleword) + (ensuring-node-target (target vreg) + (! makes64) + (x862-copy-register seg target ($ *x862-arg-z*)))) + (t + (case resultspec + (:signed-byte (! sign-extend-s8 *x862-imm0* *x862-imm0*)) + (:signed-halfword (! sign-extend-s16 *x862-imm0* *x862-imm0*)) + (:unsigned-byte (! zero-extend-u8 *x862-imm0* *x862-imm0*)) + (:unsigned-halfword (! zero-extend-u16 *x862-imm0* *x862-imm0*))) + (<- (make-wired-lreg x8632::imm0 + :mode + (gpr-mode-name-value + (case resultspec + (:address :address) + (:signed-byte :s8) + (:unsigned-byte :u8) + (:signed-halfword :s16) + (:unsigned-halfword :u16) + (:signed-fullword :s32) + (t :u32)))))))) + (^))) + + +(defx862 x862-syscall syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports) + (declare (ignore monitor-exception-ports)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (*x862-cstack* *x862-cstack*) + (gpr-offset 0) + (other-offset 6) + (nother-words 0) + (ngpr-args 0) + (simple-foreign-args nil)) + (declare (fixnum ngpr-args nother-words + gpr-offset other-offset)) + (dolist (argspec argspecs) + (declare (ignorable argspec)) + (incf ngpr-args) + (if (> ngpr-args 6) + (incf nother-words))) + (let* ((total-words nother-words)) + (when (zerop total-words) + (setq simple-foreign-args nil)) + (! alloc-c-frame total-words)) + (x862-open-undo $undo-x86-c-frame) + (setq ngpr-args 0) + (unless simple-foreign-args + (x862-vpush-register seg (x862-one-untargeted-reg-form seg idx *x862-arg-z*))) + ;; Evaluate each form into the C frame, according to the + ;; matching argspec. + (do* ((specs argspecs (cdr specs)) + (vals argvals (cdr vals))) + ((null specs)) + (declare (list specs vals)) + (let* ((valform (car vals)) + (spec (car specs)) + (absptr (acode-absolute-ptr-p valform))) + (case spec + (:address + (with-imm-target () (ptr :address) + (if absptr + (x862-lri seg ptr absptr) + (x862-form seg ptr nil valform)) + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (! set-c-arg ptr gpr-offset) + (incf gpr-offset)) + (t + (! set-c-arg ptr other-offset) + (incf other-offset))))) + (t + (with-imm-target () (valreg :natural) + (let* ((reg (x862-unboxed-integer-arg-to-reg seg valform valreg spec))) + (incf ngpr-args) + (cond ((<= ngpr-args 8) + (! set-c-arg reg gpr-offset) + (incf gpr-offset)) + (t + (! set-c-arg reg other-offset) + (incf other-offset))))))))) + (unless simple-foreign-args + (x862-vpop-register seg ($ *x862-arg-z*))) + (! syscall) + (x862-close-undo) + (when vreg + (cond ((eq resultspec :void) (<- nil)) + ((eq resultspec :unsigned-doubleword) + (ensuring-node-target (target vreg) + (! makeu64) + (x862-copy-register seg target ($ *x862-arg-z*)))) + ((eq resultspec :signed-doubleword) + (ensuring-node-target (target vreg) + (! makes64) + (x862-copy-register seg target ($ *x862-arg-z*)))) + (t + (case resultspec + (:signed-byte (! sign-extend-s8 *x862-imm0* *x862-imm0*)) + (:signed-halfword (! sign-extend-s16 *x862-imm0* *x862-imm0*)) + (:signed-fullword (! sign-extend-s32 *x862-imm0* *x862-imm0*)) + (:unsigned-byte (! zero-extend-u8 *x862-imm0* *x862-imm0*)) + (:unsigned-halfword (! zero-extend-u16 *x862-imm0* *x862-imm0*)) + (:unsigned-fullword (! zero-extend-u32 *x862-imm0* *x862-imm0*))) + (<- (make-wired-lreg *x862-imm0* + :mode + (gpr-mode-name-value + (case resultspec + (:address :address) + (:signed-byte :s8) + (:unsigned-byte :u8) + (:signed-halfword :s16) + (:unsigned-halfword :u16) + (:signed-fullword :s32) + (t :u32)))))))) + (^))) + +(defx862 x862-i386-ff-call i386-ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor) + (declare (ignore monitor)) + #+debug + (format t "~&~%i386-ff-call: argspecs = ~s, argvals = ~s, resultspec = ~s" + argspecs argvals resultspec) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (*x862-cstack* *x862-cstack*) + (offset 0) + (simple-foreign-args nil) + (nwords 0)) + (dolist (argspec argspecs) + (case argspec + ((:double-float :unsigned-doubleword :signed-doubleword) + (incf nwords 2)) + (t + (if (typep argspec 'unsigned-byte) + (incf nwords argspec) + (incf nwords))))) + (when (null argspecs) + (setq simple-foreign-args t)) + (! alloc-c-frame nwords) + (x862-open-undo $undo-x86-c-frame) + (unless simple-foreign-args + (x862-vpush-register seg (x862-one-untargeted-reg-form seg address x8632::arg_z))) + ;; Evaluate each form into the C frame, according to the + ;; matching argspec. + (do* ((specs argspecs (cdr specs)) + (vals argvals (cdr vals))) + ((null specs)) + (declare (list specs vals)) + (let* ((valform (car vals)) + (spec (car specs)) + (absptr (acode-absolute-ptr-p valform))) + (case spec + (:registers + (error "don't know what to do with argspec ~s" spec)) + (:double-float + (let* ((df ($ x8632::fp0 :class :fpr :mode :double-float))) + (x862-one-targeted-reg-form seg valform df) + (! set-double-c-arg df offset)) + (incf offset 2)) + (:single-float + (let* ((sf ($ x8632::fp0 :class :fpr :mode :single-float))) + (x862-one-targeted-reg-form seg valform sf) + (! set-single-c-arg sf offset)) + (incf offset)) + (:address + (with-imm-target () (ptr :address) + (if absptr + (x862-lri seg ptr absptr) + (x862-form seg ptr nil valform)) + (! set-c-arg ptr offset)) + (incf offset)) + ((:signed-doubleword :unsigned-doubleword) + (x862-one-targeted-reg-form seg valform x8632::arg_z) + ;; Subprims return 64-bit result in mm0 + (if (eq spec :unsigned-doubleword) + (! getu64) + (! gets64)) + (! set-c-arg-from-mm0 offset) + (incf offset 2)) + (t + (if (typep spec 'unsigned-byte) + (progn + (with-imm-target () (ptr :address) + (x862-one-targeted-reg-form seg valform ptr) + (with-additional-imm-reg (ptr) + (with-imm-temps (ptr) (r) + (dotimes (i spec) + (! mem-ref-c-fullword r ptr (ash i x8632::word-shift)) + (! set-c-arg r (+ offset i)))))) + (incf offset spec)) + (with-imm-target () (valreg :natural) + (let* ((reg (x862-unboxed-integer-arg-to-reg seg valform valreg spec))) + (! set-c-arg reg offset) + (incf offset)))))))) + (if simple-foreign-args + (x862-one-targeted-reg-form seg address x8632::arg_z) + (x862-vpop-register seg ($ x8632::arg_z))) + (! ff-call) + (x862-close-undo) + (when vreg + (cond ((eq resultspec :void) (<- nil)) + ;; Floating-point results are returned on the x87 stack. + ((eq resultspec :double-float) + (let ((fpreg ($ x8632::fp0 :class :fpr :mode :double-float))) + (! fp-stack-to-double fpreg) + (<- fpreg))) + ((eq resultspec :single-float) + (let ((fpreg ($ x8632::fp0 :class :fpr :mode :single-float))) + (! fp-stack-to-single fpreg) + (<- fpreg))) + ((eq resultspec :unsigned-doubleword) + (ensuring-node-target (target vreg) + (! get-64-bit-ffcall-result) + (! makeu64) + (x862-copy-register seg target ($ *x862-arg-z*)))) + ((eq resultspec :signed-doubleword) + (ensuring-node-target (target vreg) + (! get-64-bit-ffcall-result) + (! makes64) + (x862-copy-register seg target ($ *x862-arg-z*)))) + (t + (case resultspec + (:signed-byte (! sign-extend-s8 *x862-imm0* *x862-imm0*)) + (:signed-halfword (! sign-extend-s16 *x862-imm0* *x862-imm0*)) + (:unsigned-byte (! zero-extend-u8 *x862-imm0* *x862-imm0*)) + (:unsigned-halfword (! zero-extend-u16 *x862-imm0* *x862-imm0*))) + (<- (make-wired-lreg x8632::imm0 + :mode + (gpr-mode-name-value + (case resultspec + (:address :address) + (:signed-byte :s8) + (:unsigned-byte :u8) + (:signed-halfword :s16) + (:unsigned-halfword :u16) + (:signed-fullword :s32) + (t :u32)))))))) + (^))) + +(defx862 x862-ff-call ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor) + (declare (ignore monitor)) + (let* ((*x862-vstack* *x862-vstack*) + (*x862-top-vstack-lcell* *x862-top-vstack-lcell*) + (*x862-cstack* *x862-cstack*) + (gpr-offset 0) + (other-offset 6) + (single-float-offset 6) + (double-float-offset 6) + (nsingle-floats 0) ; F + (ndouble-floats 0) ; D + (nother-words 0) + (nfpr-args 0) + (ngpr-args 0) + (simple-foreign-args nil) + (fp-loads ()) + (return-registers ())) + (declare (fixnum nsingle-floats ndouble-floats nfpr-args ngpr-args nother-words + gpr-offset other-offset single-float-offset double-float-offset)) + (dolist (argspec argspecs) + (case argspec + (:double-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf ndouble-floats) + (incf nother-words))) + (:single-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf nsingle-floats) + (incf nother-words))) + (:registers (setq return-registers t)) + (t + (if (typep argspec 'unsigned-byte) + (incf nother-words argspec) + (progn + (incf ngpr-args) + (if (> ngpr-args 6) + (incf nother-words))))))) + (let* ((total-words (+ nother-words nsingle-floats ndouble-floats))) + (when (null argspecs) + (setq simple-foreign-args t)) + (! alloc-c-frame total-words)) + (x862-open-undo $undo-x86-c-frame) + (setq single-float-offset (+ other-offset nother-words)) + (setq double-float-offset + (+ single-float-offset nsingle-floats)) + (setq ngpr-args 0 nfpr-args 0) + (unless simple-foreign-args + (x862-vpush-register seg (x862-one-untargeted-reg-form seg address x8664::arg_z))) + ;; Evaluate each form into the C frame, according to the + ;; matching argspec. Remember type and arg offset of any FP + ;; args, since FP regs will have to be loaded later. + (do* ((specs argspecs (cdr specs)) + (vals argvals (cdr vals))) + ((null specs)) + (declare (list specs vals)) + (let* ((valform (car vals)) + (spec (car specs)) + (absptr (acode-absolute-ptr-p valform))) + (case spec + (:registers + (let* ((reg (x862-one-untargeted-reg-form seg valform x8664::arg_z))) + (unless *x862-reckless* + (! trap-unless-macptr reg)) + (x862-vpush-register seg reg))) + (:double-float + (let* ((df ($ x8664::fp1 :class :fpr :mode :double-float))) + (incf nfpr-args) + (x862-one-targeted-reg-form seg valform df ) + (cond ((<= nfpr-args 8) + (! set-double-c-arg df double-float-offset) + (push (cons :double-float double-float-offset) fp-loads) + (incf double-float-offset)) + (t + (! set-double-c-arg df other-offset) + (incf other-offset))))) + (:single-float + (let* ((sf ($ x8664::fp1 :class :fpr :mode :single-float))) + (incf nfpr-args) + (x862-one-targeted-reg-form + seg valform sf) + (cond ((<= nfpr-args 8) + (! set-single-c-arg sf single-float-offset) + (push (cons :single-float single-float-offset) fp-loads) + (incf single-float-offset)) + (t + (! set-single-c-arg sf other-offset) + (incf other-offset))))) + (:address + (with-imm-target () (ptr :address) + (if absptr + (x862-lri seg ptr absptr) + (x862-form seg ptr nil valform)) + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (! set-c-arg ptr gpr-offset) + (incf gpr-offset)) + (t + (! set-c-arg ptr other-offset) + (incf other-offset))))) + (t + (if (typep spec 'unsigned-byte) + (progn + (with-imm-target () (ptr :address) + (x862-one-targeted-reg-form seg valform ptr) + (with-imm-target (ptr) (r :natural) + (dotimes (i spec) + (! mem-ref-c-doubleword r ptr (ash i x8664::word-shift)) + (! set-c-arg r other-offset) + (incf other-offset))))) + (with-imm-target () (valreg :natural) + (let* ((reg (x862-unboxed-integer-arg-to-reg seg valform valreg spec))) + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (! set-c-arg reg gpr-offset) + (incf gpr-offset)) + (t + (! set-c-arg reg other-offset) + (incf other-offset)))))))))) + (do* ((fpreg x8664::fp0 (1+ fpreg)) + (reloads (nreverse fp-loads) (cdr reloads))) + ((or (null reloads) (= fpreg x8664::fp8))) + (declare (list reloads) (fixnum fpreg)) + (let* ((reload (car reloads)) + (size (car reload)) + (from (cdr reload))) + (if (eq size :double-float) + (! reload-double-c-arg ($ fpreg :class :fpr :mode :double-float) from) + (! reload-single-c-arg ($ fpreg :class :fpr :mode :single-float) from)))) + (if return-registers + (x862-vpop-register seg ($ x8664::arg_y))) + (if simple-foreign-args + (x862-one-targeted-reg-form seg address x8664::arg_z) + (x862-vpop-register seg ($ x8664::arg_z))) + (x862-lri seg x8664::rax (min 8 nfpr-args)) + (if return-registers + (! ff-call-return-registers) + (! ff-call) ) + (x862-close-undo) + (when vreg + (cond ((eq resultspec :void) (<- nil)) + ((eq resultspec :double-float) + (<- ($ x8664::fp0 :class :fpr :mode :double-float))) + ((eq resultspec :single-float) + (<- ($ x8664::fp0 :class :fpr :mode :single-float))) + ((eq resultspec :unsigned-doubleword) + (if (node-reg-p vreg) + (progn + (! makeu64) + (<- ($ x8664::arg_z))) + (<- ($ x8664::rax :class :gpr :mode :u64)))) + ((eq resultspec :signed-doubleword) + (if (node-reg-p vreg) + (progn + (! makes64) + (<- ($ x8664::arg_z))) + (<- ($ x8664::rax :class :gpr :mode :s64)))) + (t + (case resultspec + (:signed-byte (! sign-extend-s8 x8664::imm0 x8664::imm0)) + (:signed-halfword (! sign-extend-s16 x8664::imm0 x8664::imm0)) + (:signed-fullword (! sign-extend-s32 x8664::imm0 x8664::imm0)) + (:unsigned-byte (! zero-extend-u8 x8664::imm0 x8664::imm0)) + (:unsigned-halfword (! zero-extend-u16 x8664::imm0 x8664::imm0)) + (:unsigned-fullword (! zero-extend-u32 x8664::imm0 x8664::imm0))) + (<- (make-wired-lreg x8664::imm0 + :mode + (gpr-mode-name-value + (case resultspec + (:address :address) + (:signed-byte :s8) + (:unsigned-byte :u8) + (:signed-halfword :s16) + (:unsigned-halfword :u16) + (:signed-fullword :s32) + (t :u32)))))))) + (^))) + + + +(defx862 x862-%temp-list %temp-list (seg vreg xfer arglist) + (x862-use-operator (%nx1-operator list) seg vreg xfer arglist)) + +(defx862 x862-%temp-cons %temp-cons (seg vreg xfer car cdr) + (x862-use-operator (%nx1-operator cons) seg vreg xfer car cdr)) + + + +(defx862 x862-%debug-trap %debug-trap (seg vreg xfer arg) + (x862-one-targeted-reg-form seg arg ($ *x862-arg-z*)) + (! %debug-trap) + (<- ($ *x862-arg-z*)) + (^)) + +(defx862 x862-%reference-external-entry-point %reference-external-entry-point + (seg vreg xfer arg) + (ensuring-node-target (target vreg) + (let* ((reg (if (eq (hard-regspec-value target) *x862-arg-z*) ($ *x862-arg-y*) ($ *x862-arg-z*)))) + (x862-one-targeted-reg-form seg arg reg) + (! eep.address target reg))) + (^)) + +(defx862 x862-%natural+ %natural+ (seg vreg xfer x y) + (if (null vreg) + (progn + (x862-form seg nil nil x) + (x862-form seg nil xfer y)) + (let* ((fix-x (acode-fixnum-form-p x)) + (fix-y (acode-fixnum-form-p y))) + (if (and fix-x fix-y) + (x862-absolute-natural seg vreg xfer (+ fix-x fix-y)) + (let* ((u31x (and (typep fix-x '(unsigned-byte 31)) fix-x)) + (u31y (and (typep fix-y '(unsigned-byte 31)) fix-y))) + (if (not (or u31x u31y)) + (with-imm-target () (xreg :natural) + (with-additional-imm-reg () + (with-imm-target (xreg) (yreg :natural) + (x862-two-targeted-reg-forms seg x xreg y yreg) + (! %natural+ xreg yreg))) + (<- xreg)) + (let* ((other (if u31x y x))) + (with-imm-target () (other-reg :natural) + (x862-one-targeted-reg-form seg other other-reg) + (! %natural+-c other-reg (or u31x u31y)) + (<- other-reg)))) + (^)))))) + +(defx862 x862-%natural- %natural- (seg vreg xfer x y) + (if (null vreg) + (progn + (x862-form seg nil nil x) + (x862-form seg nil xfer y)) + (let* ((fix-x (acode-fixnum-form-p x)) + (fix-y (acode-fixnum-form-p y))) + (if (and fix-x fix-y) + (x862-absolute-natural seg vreg xfer (- fix-x fix-y)) + (let* ((u31y (and (typep fix-y '(unsigned-byte 31)) fix-y))) + (if (not u31y) + (with-imm-target () (xreg :natural) + (with-additional-imm-reg () + (with-imm-target (xreg) (yreg :natural) + (x862-two-targeted-reg-forms seg x xreg y yreg) + (! %natural- xreg yreg)) + (<- xreg))) + (progn + (with-imm-target () (xreg :natural) + (x862-one-targeted-reg-form seg x xreg) + (! %natural--c xreg u31y) + (<- xreg)))) + (^)))))) + +(defx862 x862-%natural-logior %natural-logior (seg vreg xfer x y) + (if (null vreg) + (progn + (x862-form seg nil nil x) + (x862-form seg nil xfer y)) + (let* ((naturalx (nx-natural-constant-p x)) + (naturaly (nx-natural-constant-p y))) + (if (and naturalx naturaly) + (x862-absolute-natural seg vreg xfer (logior naturalx naturaly)) + (let* ((u31x (nx-u31-constant-p x)) + (u31y (nx-u31-constant-p y)) + (constant (or u31x u31y))) + (if (not constant) + (with-imm-target () (xreg :natural) + (with-additional-imm-reg () + (with-imm-target (xreg) (yreg :natural) + (x862-two-targeted-reg-forms seg x xreg y yreg) + (! %natural-logior xreg yreg))) + (<- xreg)) + (let* ((other (if u31x y x))) + (with-imm-target () (other-reg :natural) + (x862-one-targeted-reg-form seg other other-reg) + (! %natural-logior-c other-reg constant) + (<- other-reg)))) + (^)))))) + +(defx862 x862-%natural-logxor %natural-logxor (seg vreg xfer x y) + (if (null vreg) + (progn + (x862-form seg nil nil x) + (x862-form seg nil xfer y)) + (let* ((naturalx (nx-natural-constant-p x)) + (naturaly (nx-natural-constant-p y))) + (if (and naturalx naturaly) + (x862-absolute-natural seg vreg xfer (logxor naturalx naturaly)) + (let* ((u32x (nx-u32-constant-p x)) + (u32y (nx-u32-constant-p y)) + (constant (or u32x u32y))) + (if (not constant) + (with-imm-target () (xreg :natural) + (with-additional-imm-reg () + (with-imm-target (xreg) (yreg :natural) + (x862-two-targeted-reg-forms seg x xreg y yreg) + (! %natural-logxor xreg yreg))) + (<- xreg)) + (let* ((other (if u32x y x))) + (with-imm-target () (other-reg :natural) + (x862-one-targeted-reg-form seg other other-reg) + (! %natural-logxor-c other-reg constant) + (<- other-reg)))) + (^)))))) + +(defx862 x862-%natural-logand %natural-logand (seg vreg xfer x y) + (if (null vreg) + (progn + (x862-form seg nil nil x) + (x862-form seg nil xfer y)) + (let* ((naturalx (nx-natural-constant-p x)) + (naturaly (nx-natural-constant-p y))) + (if (and naturalx naturaly) + (x862-absolute-natural seg vreg xfer (logand naturalx naturaly)) + (let* ((u31x (nx-u31-constant-p x)) + (u31y (nx-u31-constant-p y)) + (constant (or u31x u31y))) + (if (not constant) + (with-imm-target () (xreg :natural) + (with-additional-imm-reg () + (with-imm-target (xreg) (yreg :natural) + (x862-two-targeted-reg-forms seg x xreg y yreg) + (! %natural-logand xreg yreg))) + (<- xreg)) + (let* ((other (if u31x y x))) + (with-imm-target () (other-reg :natural) + (x862-one-targeted-reg-form seg other other-reg) + (! %natural-logand-c other-reg constant) + (<- other-reg)))) + (^)))))) + +(defx862 x862-natural-shift-right natural-shift-right (seg vreg xfer num amt) + (with-imm-target () (dest :natural) + (x862-one-targeted-reg-form seg num dest) + (! natural-shift-right dest (acode-fixnum-form-p amt)) + (<- dest) + (^))) + +(defx862 x862-natural-shift-left natural-shift-left (seg vreg xfer num amt) + (with-imm-target () (dest :natural) + (x862-one-targeted-reg-form seg num dest) + (! natural-shift-left dest (acode-fixnum-form-p amt)) + (<- dest) + (^))) + +;;; This assumes that "global" variables are always boundp. +(defx862 x862-global-ref global-ref (seg vreg xfer sym) + (when vreg + (ensuring-node-target (target vreg) + (with-node-temps () (symreg) + (setq symreg (or (x862-register-constant-p sym) + (x862-store-immediate seg sym symreg))) + (! symbol-ref target symreg (target-arch-case + (:x8632 x8632::symbol.vcell-cell) + (:x8664 x8664::symbol.vcell-cell)))))) + (^)) + +(defx862 x862-global-setq global-setq (seg vreg xfer sym val) + (x862-vset seg + vreg + xfer + :symbol + (make-acode (%nx1-operator %symptr->symvector) + (make-acode (%nx1-operator immediate) sym)) + (make-acode (%nx1-operator fixnum) + (target-arch-case + (:x8632 x8632::symbol.vcell-cell) + (:x8664 x8664::symbol.vcell-cell))) + val + nil)) + +(defx862 x862-%current-frame-ptr %current-frame-ptr (seg vreg xfer) + (cond ((x862-tailcallok xfer) + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count*) + (x862-restore-full-lisp-context seg) + (! %current-frame-ptr ($ *x862-arg-z*)) + (! jump-return-pc)) + (t + (when vreg + (ensuring-node-target (target vreg) + (! %current-frame-ptr target))) + (^)))) + +(defx862 x862-%foreign-stack-pointer %foreign-stack-pointer (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (! %foreign-stack-pointer target))) + (^)) + + +(defx862 x862-%current-tcr %current-tcr (seg vreg xfer) + (when vreg + (ensuring-node-target (target vreg) + (! %current-tcr target))) + (^)) + + + +(defx862 x862-%interrupt-poll %interrupt-poll (seg vreg xfer) + (! event-poll) + (x862-nil seg vreg xfer)) + + +(defx862 x862-with-c-frame with-c-frame (seg vreg xfer body &aux + (old-stack (x862-encode-stack))) + (! alloc-c-frame 0) + (x862-open-undo $undo-x86-c-frame) + (x862-undo-body seg vreg xfer body old-stack)) + +(defx862 x862-with-variable-c-frame with-variable-c-frame (seg vreg xfer size body &aux + (old-stack (x862-encode-stack))) + (let* ((reg (x862-one-untargeted-reg-form seg size *x862-arg-z*))) + (! alloc-variable-c-frame reg) + (x862-open-undo $undo-x86-c-frame) + (x862-undo-body seg vreg xfer body old-stack))) + +(defx862 x862-%symbol->symptr %symbol->symptr (seg vreg xfer sym) + (let* ((src (x862-one-untargeted-reg-form seg sym *x862-arg-z*))) + (ensuring-node-target (target vreg) + (! %symbol->symptr target src)) + (^))) + +(defx862 x862-%double-to-single %double-to-single (seg vreg xfer arg) + (if (null vreg) + (x862-form seg vreg xfer arg) + (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr) + (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-single)) + (let* ((dreg (x862-one-untargeted-reg-form + seg arg + (make-wired-lreg (hard-regspec-value vreg) + :class hard-reg-class-fpr + :mode hard-reg-class-fpr-mode-double)))) + (! double-to-single vreg dreg) + (^)) + (with-fp-target () (argreg :double-float) + (x862-one-targeted-reg-form seg arg argreg) + (with-fp-target () (sreg :single-float) + (! double-to-single sreg argreg) + (<- sreg) + (^)))))) + +(defx862 x862-%single-to-double %single-to-double (seg vreg xfer arg) + (if (null vreg) + (x862-form seg vreg xfer arg) + (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr) + (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double)) + (let* ((sreg (x862-one-untargeted-reg-form + seg arg + (make-wired-lreg (hard-regspec-value vreg) + :class hard-reg-class-fpr + :mode hard-reg-class-fpr-mode-double)))) + (! single-to-double vreg sreg) + (^)) + (with-fp-target () (sreg :single-float) + (x862-one-targeted-reg-form seg arg sreg) + (with-fp-target () (dreg :double-float) + (! single-to-double dreg sreg) + (<- dreg) + (^)))))) + +(defx862 x862-%symptr->symvector %symptr->symvector (seg vreg xfer arg) + (if (null vreg) + (x862-form seg vreg xfer arg) + (progn + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg arg target) + (! %symptr->symvector target)) + (^)))) + +(defx862 x862-%symvector->symptr %symvector->symptr (seg vreg xfer arg) + (if (null vreg) + (x862-form seg vreg xfer arg) + (progn + (ensuring-node-target (target vreg) + (x862-one-targeted-reg-form seg arg target) + (! %symvector->symptr target)) + (^)))) + +(defx862 x862-%fixnum-to-single %fixnum-to-single (seg vreg xfer arg) + (with-fp-target () (sreg :single-float) + (let* ((r (x862-one-untargeted-reg-form seg arg *x862-arg-z*))) + (unless (or (acode-fixnum-form-p arg) + *x862-reckless*) + (! trap-unless-fixnum r)) + (! fixnum->single-float sreg r) + (<- sreg) + (^)))) + +(defx862 x862-%fixnum-to-double %fixnum-to-double (seg vreg xfer arg) + (with-fp-target () (dreg :double-float) + (let* ((r (x862-one-untargeted-reg-form seg arg *x862-arg-z*))) + (unless (or (acode-fixnum-form-p arg) + *x862-reckless*) + (! trap-unless-fixnum r)) + (! fixnum->double-float dreg r) + (<- dreg) + (^)))) + +(defx862 x862-%double-float %double-float (seg vreg xfer arg) + (let* ((real (or (acode-fixnum-form-p arg) + (let* ((form (acode-unwrapped-form-value arg))) + (if (and (acode-p form) + (eq (acode-operator form) + (%nx1-operator immediate)) + (typep (cadr form) 'real)) + (cadr form))))) + (dconst (and real (ignore-errors (float real 0.0d0))))) + (if dconst + (x862-immediate seg vreg xfer dconst) + (if (x862-form-typep arg 'single-float) + (x862-use-operator (%nx1-operator %single-to-double) + seg + vreg + xfer + arg) + (if (x862-form-typep arg 'fixnum) + (x862-use-operator (%nx1-operator %fixnum-to-double) + seg + vreg + xfer + arg) + (x862-use-operator (%nx1-operator call) + seg + vreg + xfer + (make-acode (%nx1-operator immediate) + '%double-float) + (list nil (list arg)))))))) + +(defx862 x862-%single-float %single-float (seg vreg xfer arg) + (let* ((real (or (acode-fixnum-form-p arg) + (let* ((form (acode-unwrapped-form-value arg))) + (if (and (acode-p form) + (eq (acode-operator form) + (%nx1-operator immediate)) + (typep (cadr form) 'real)) + (cadr form))))) + (sconst (and real (ignore-errors (float real 0.0f0))))) + (if sconst + (x862-immediate seg vreg xfer sconst) + (if (x862-form-typep arg 'double-float) + (x862-use-operator (%nx1-operator %double-to-single) + seg + vreg + xfer + arg) + (if (x862-form-typep arg 'fixnum) + (x862-use-operator (%nx1-operator %fixnum-to-single) + seg + vreg + xfer + arg) + (x862-use-operator (%nx1-operator call) + seg + vreg + xfer + (make-acode (%nx1-operator immediate) + '%short-float) + (list nil (list arg)))))))) + + +(defx862 x862-%new-ptr %new-ptr (seg vreg xfer size clear-p ) + (x862-call-fn seg + vreg + xfer + (make-acode (%nx1-operator immediate) + '%new-gcable-ptr) + (list nil (list clear-p size)) + nil)) + +;------ + +#+not-yet +(progn + + +;;;Make a gcable macptr. + + + + +) + +#-x86-target +(defun x8664-xcompile-lambda (def &key show-vinsns (symbolic-names t) + (target :darwinx8664) + (disassemble t)) + (let* ((*x862-debug-mask* (if show-vinsns + (ash 1 x862-debug-vinsns-bit) + 0)) + (backend (find-backend target)) + (*target-ftd* (if backend + (backend-target-foreign-type-data backend) + *target-ftd*))) + (multiple-value-bind (xlfun warnings) + (compile-named-function def :target target) + (signal-or-defer-warnings warnings nil) + (when disassemble + (format t "~%~%") + (apply #'x86-disassemble-xfunction + xlfun + (unless symbolic-names (list nil)))) + xlfun))) + +#-x8632-target +(defun x8632-xcompile-lambda (def &key show-vinsns (symbolic-names t) + (target :darwinx8632) + (disassemble t)) + (let* ((*x862-debug-mask* (if show-vinsns + (ash 1 x862-debug-vinsns-bit) + 0)) + (backend (find-backend target)) + (*target-ftd* (if backend + (backend-target-foreign-type-data backend) + *target-ftd*))) + (multiple-value-bind (xlfun warnings) + (compile-named-function def :target target) + (signal-or-defer-warnings warnings nil) + (when disassemble + (let ((*target-backend* backend)) + (format t "~%~%") + (apply #'x86-disassemble-xfunction + xlfun + (unless symbolic-names (list nil))))) + xlfun))) + + Index: /branches/qres/ccl/compiler/acode-rewrite.lisp =================================================================== --- /branches/qres/ccl/compiler/acode-rewrite.lisp (revision 13564) +++ /branches/qres/ccl/compiler/acode-rewrite.lisp (revision 13564) @@ -0,0 +1,379 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +(defvar *acode-post-trust-decls* nil) + +;;; Rewrite acode trees. + +(next-nx-defops) +(defvar *acode-rewrite-functions* nil) +(let* ((newsize (%i+ (next-nx-num-ops) 10)) + (old *acode-rewrite-functions*) + (oldsize (length old))) + (declare (fixnum newsize oldsize)) + (unless (>= oldsize newsize) + (let* ((v (make-array newsize :initial-element nil))) + (dotimes (i oldsize (setq *acode-rewrite-functions* v)) + (setf (svref v i) (svref old i)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-acode-rewrite (name operator-list arglist &body body) + (if (atom operator-list) + (setq operator-list (list operator-list))) + (multiple-value-bind (body decls) + (parse-body body nil t) + (collect ((let-body)) + (dolist (operator operator-list) + (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun))) + (destructuring-bind (op whole type) arglist + `(let* ((fun (nfunction ,name + (lambda (,op ,whole ,type) + (declare (ignorable ,op ,type)) + ,@decls + (block ,name ,@body))))) + ,@(let-body))))))) + +;;; Don't walk the form (that's already happened.) +(defun acode-post-form-type (form) + (when (acode-p form) + (let* ((op (acode-operator form)) + (operands (cdr form))) + (cond ((and *acode-post-trust-decls* + (eq op (%nx1-operator typed-form))) + (acode-operand 0 operands)) + ((eq op (%nx1-operator fixnum)) + 'fixnum) + ((eq op (%nx1-operator immediate)) + (type-of (acode-operand 0 operands))) + (t t))))) + +(defun acode-constant-p (form) + (let* ((form (acode-unwrapped-form-value form))) + (or (eq form *nx-nil*) + (eq form *nx-t*) + (let* ((operator (if (acode-p form) (acode-operator form)))) + (or (eq operator (%nx1-operator fixnum)) + (eq operator (%nx1-operator immediate))))))) + +(defun acode-post-form-typep (form type) + (let* ((ctype (specifier-type type)) + (form (acode-unwrapped-form-value form))) + (cond ((eq form *nx-nil*) (ctypep nil ctype)) + ((eq form *nx-t*) (ctypep t ctype)) + ((not (acode-p form)) (values nil nil)) + (t + (let* ((op (acode-operator form)) + (operands (cdr form))) + (cond ((and *acode-post-trust-decls* + (eq op (%nx1-operator typed-form))) + (subtypep (acode-operand 0 operands) type)) + ((or (eq op (%nx1-operator fixnum)) + (eq op (%nx1-operator immediate))) + (ctypep (acode-operand 0 operands) (specifier-type type))) + (t (values nil nil)))))))) + + + +(defun rewrite-acode-ref (ref &optional (type t)) + (let* ((form (car ref))) + (if (acode-p form) + (let* ((op (acode-operator form)) + (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask)))) + (when rewrite + (let* ((new (funcall rewrite op (cdr form) type))) + (when new + (setf (car ref) new) + t))))))) + +;;; Maybe ewrite the operands of a binary real arithmetic operation +(defun acode-post-binop-numeric-contagion (pform1 pform2) + (let* ((form1 (car pform1)) + (form2 (car pform2))) + (cond ((acode-post-form-typep form1 'double-float) + (unless (acode-post-form-typep form2 'double-float) + (let* ((c2 (acode-real-constant-p form2))) + (if c2 + (setf (car pform2) + (make-acode (%nx1-operator immediate) + (float c2 0.0d0))) + (if (acode-post-form-typep form2 'fixnum) + (setf (car pform2) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode (%nx1-operator %fixnum-to-double) + form2)))))))) + ((acode-post-form-typep form2 'double-float) + (let* ((c1 (acode-real-constant-p form1))) + (if c1 + (setf (car pform1) + (make-acode (%nx1-operator immediate) + (float c1 0.0d0))) + (if (acode-post-form-typep form1 'fixnum) + (setf (car pform1) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode (%nx1-operator %fixnum-to-double) + form1))))))) + ((acode-post-form-typep form1 'single-float) + (unless (acode-post-form-typep form2 'single-float) + (let* ((c2 (acode-real-constant-p form2))) + (if c2 + (setf (car pform2) (make-acode (%nx1-operator immediate) + (float c2 0.0f0))) + (if (acode-post-form-typep form2 'fixnum) + (setf (car pform2) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode (%nx1-operator %fixnum-to-single) + form2)))))))) + ((acode-post-form-typep form2 'single-float) + (let* ((c1 (acode-real-constant-p form1))) + (if c1 + (setf (car pform1) (make-acode (%nx1-operator immediate) + (float c1 0.0f0))) + + (if (acode-post-form-typep form1 'fixnum) + (setf (car pform1) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode (%nx1-operator %fixnum-to-single) + form1)))))))))) + +(defun constant-fold-acode-binop (function x y) + (let* ((constant-x (acode-real-constant-p x)) + (constant-y (acode-real-constant-p y))) + (if (and constant-x constant-y) + (let* ((result (ignore-errors (funcall function x y)))) + (when result + (nx1-form result)))))) + +(defun acode-rewrite-and-fold-binop (function args) + (rewrite-acode-ref args) + (rewrite-acode-ref (cdr args)) + (constant-fold-acode-binop function (car args) (cadr args))) + +(defun rewrite-acode-forms (forms) + (do* ((head forms (cdr head))) + ((null head)) + (rewrite-acode-ref head))) + +(defun acode-assert-type (actualtype operator operands assertedtype) + (make-acode (%nx1-operator typed-form) + (type-specifier (type-intersection (specifier-type actualtype) + (specifier-type assertedtype))) + (cons operator operands))) + +(def-acode-rewrite acode-rewrite-progn progn (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-not not (op w type) + (rewrite-acode-ref w)) + +(def-acode-rewrite acode-rewrite-%i+ %i+ (op w type) + (or + (acode-rewrite-and-fold-binop '+ w) + ;; TODO: maybe cancel overflow check, assert FIXNUM result. + (acode-assert-type 'integer op w type))) + +(def-acode-rewrite acode-rewrite-%i- %i- (op w type) + (or + (acode-rewrite-and-fold-binop '- w)) + ;; TODO: maybe cancel overflow check, assert FIXNUM result. + (acode-assert-type 'integer op w type)) + +(def-acode-rewrite acode-rewrite-%ilsl %ilsl (op w type) + (or + (acode-rewrite-and-fold-binop '%ilsl w) + (acode-assert-type 'fixnum op w type))) + +(def-acode-rewrite acode-rewrite-%ilogand2 %ilogand2 (op w type) + (or + (acode-rewrite-and-fold-binop 'logand w) + ;; If either argument's an UNSIGNED-BYTE constant, the result + ;; is an UNSIGNED-BYTE no greater than that constant. + (destructuring-bind (x y) w + (let* ((fix-x (acode-fixnum-form-p x)) + (fix-y (acode-fixnum-form-p y))) + (acode-assert-type (if fix-x + `(integer 0 ,fix-x) + (if fix-y + `(integer 0 ,fix-y) + 'fixnum)) + op w type))))) + +(def-acode-rewrite acode-rewrite-%ilogior2 %ilogior2 (op w type) + (or + (acode-rewrite-and-fold-binop 'logior w) + ;; If either argument's an UNSIGNED-BYTE constant, the result + ;; is an UNSIGNED-BYTE no greater than that constant. + (destructuring-bind (x y) w + (let* ((fix-x (acode-fixnum-form-p x)) + (fix-y (acode-fixnum-form-p y))) + (acode-assert-type (if fix-x + `(integer 0 ,fix-x) + (if fix-y + `(integer 0 ,fix-y) + 'fixnum)) + op w type))))) + +(def-acode-rewrite acode-rewrite-ilogbitp (logbitp %ilogbitp) (op w type) + (or (acode-rewrite-and-fold-binop 'logbitp w) + (acode-assert-type 'boolean op w type))) + +(def-acode-rewrite acode-rewrite-eq eq (op w type) + (or (acode-rewrite-and-fold-binop 'eq w) + (acode-assert-type 'boolean op w type))) + +(def-acode-rewrite acode-rewrite-neq neq (op w type) + (or (acode-rewrite-and-fold-binop 'neq w) + (acode-assert-type 'boolean op w type)) ) + +(def-acode-rewrite acode-rewrite-list list (op w type) + (rewrite-acode-forms (car w)) + (acode-assert-type 'list op w type)) + +(def-acode-rewrite acode-rewrite-values values (op w type) + (rewrite-acode-forms (car w))) + +(def-acode-rewrite acode-rewrite-if if (op w type) + (rewrite-acode-forms w) + (destructuring-bind (test true &optional (false *nx-nil*)) w + (if (acode-constant-p test) + (if (eq *nx-nil* (acode-unwrapped-form-value test)) + false + true)))) + +(def-acode-rewrite acode-rewrite-or or (op w type) + (rewrite-acode-forms (car w)) + ;; Try to short-circuit if there are any true constants. + ;; The constant-valued case will return a single value. + (do* ((forms w (cdr forms))) + ((null (cdr forms))) + (let* ((form (car forms))) + (when (and (acode-constant-p form) + (not (eq *nx-nil* (acode-unwrapped-form-value form)))) + (progn + (rplacd forms nil) + (return)))))) + +(def-acode-rewrite acode-rewrite-%fixnum-ref (%fixnum-ref %fixnum-ref-natural) (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-multiple-value-prog1 multiple-value-prog1 (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-multiple-value-bind multiple-value-bind (op w type) + (rewrite-acode-forms (cdr w))) + +(def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-typed-form typed-form (op w type) + (let* ((ourtype (car w))) + (rewrite-acode-ref (cdr w) ourtype) + (let* ((subform (cadr w))) + (and (acode-p subform) (eq (acode-operator subform) op) subform)))) + +;; w: vars, list of initial-value forms, body +(def-acode-rewrite acode-rewrite-let (let let*) (op w type) + (collect ((newvars) + (newvals)) + (do* ((vars (car w) (cdr vars)) + (vals (cadr w) (cdr vals))) + ((null vars) + (rplaca w (newvars)) + (rplaca (cdr w) (newvals)) + (rewrite-acode-ref (cddr w)) + (unless (car w) (caddr w))) + (rewrite-acode-ref (car vals)) + (let* ((var (car vars)) + (bits (nx-var-bits var))) + (cond ((logbitp $vbitpuntable bits) + (setf (var-bits var) + (logior (ash 1 $vbitpunted) bits) + (var-ea var) (car vals))) + (t + (newvars var) + (newvals (car vals)))))))) + + + + + + +(def-acode-rewrite acode-rewrite-lexical-reference lexical-reference (op w type) + (let* ((var (car w))) + (if (acode-punted-var-p var) + (var-ea var)))) + +(def-acode-rewrite acode-rewrite-add2 add2 (op w type) + (or (acode-rewrite-and-fold-binop '+ w) + (progn + (acode-post-binop-numeric-contagion w (cdr w)) + (let* ((xtype (acode-post-form-type (car w))) + (ytype (acode-post-form-type (cadr w)))) + (cond ((and (subtypep xtype 'double-float) + (subtypep ytype 'double-float)) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode* (%nx1-operator %double-float+-2) + w))) + ((and (subtypep xtype 'single-float) + (subtypep ytype 'single-float)) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode* (%nx1-operator %short-float+-2) + w))) + ((and (subtypep xtype 'fixnum) + (subtypep ytype 'fixnum)) + (make-acode (%nx1-operator typed-form) + 'fixnum + (make-acode (%nx1-operator %i+) + (car w) + (cadr w) + (not (subtypep type 'fixnum)))))))))) + +(def-acode-rewrite acode-rewrite-sub2 sub2 (op w type) + (or (acode-rewrite-and-fold-binop '- w) + (progn + (acode-post-binop-numeric-contagion w (cdr w)) + (let* ((xtype (acode-post-form-type (car w))) + (ytype (acode-post-form-type (cadr w)))) + (cond ((and (subtypep xtype 'double-float) + (subtypep ytype 'double-float)) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode* (%nx1-operator %double-float--2) + w))) + ((and (subtypep xtype 'single-float) + (subtypep ytype 'single-float)) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode* (%nx1-operator %short-float--2) + w))) + ((and (subtypep xtype 'fixnum) + (subtypep ytype 'fixnum)) + (make-acode (%nx1-operator typed-form) + 'fixnum + (make-acode (%nx1-operator %i-) + (car w) + (cadr w) + (not (subtypep type 'fixnum)))))))))) + + Index: /branches/qres/ccl/compiler/arch.lisp =================================================================== --- /branches/qres/ccl/compiler/arch.lisp (revision 13564) +++ /branches/qres/ccl/compiler/arch.lisp (revision 13564) @@ -0,0 +1,364 @@ +;;;-*- Mode: Lisp; Package: (ARCH :use CL) -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage "ARCH" + (:use "CL")) + +(in-package "ARCH") + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + + + +(defconstant tcr-flag-bit-foreign 0) +(defconstant tcr-flag-bit-awaiting-preset 1) +(defconstant tcr-flag-bit-alt-suspend 2) +(defconstant tcr-flag-bit-propagate-exception 3) +(defconstant tcr-flag-bit-suspend-ack-pending 4) +(defconstant tcr-flag-bit-pending-exception 5) +(defconstant tcr-flag-bit-foreign-exception 6) +(defconstant tcr-flag-bit-pending-suspend 7) + + + +) + +(defmacro make-vheader (element-count subtag) + `(logior ,subtag (ash ,element-count 8))) + + + +;;; Error numbers, as used in UU0s and such. +;;; These match constants defined in the kernel sources. +(defconstant error-reg-regnum 0) ; "real" error number is in RB field of UU0. + ; Currently only used for :errchk in emulated traps + ; The errchk macro should expand into a check-trap-error vinsn, too. +(defconstant error-udf 1) ; Undefined function (reported by symbol-function) +(defconstant error-udf-call 2) ; Attempt to call undefined function +(defconstant error-throw-tag-missing 3) +(defconstant error-alloc-failed 4) ; can't allocate (largish) vector +(defconstant error-stack-overflow 5) ; some stack overflowed. +(defconstant error-excised-function-call 6) ; excised function was called. +(defconstant error-too-many-values 7) ; too many values returned +(defconstant error-cant-take-car 8) +(defconstant error-cant-take-cdr 9) +(defconstant error-propagate-suspend 10) +(defconstant error-interrupt 11) +(defconstant error-suspend 12) +(defconstant error-suspend-all 13) +(defconstant error-resume 14) +(defconstant error-resume-all 15) +(defconstant error-kill 16) +(defconstant error-cant-call 17) ; Attempt to funcall something that is not a symbol or function. +(defconstant error-allocate-list 18) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant error-type-error 128) +) + + +(defconstant error-fpu-exception-double 1024) ; FPU exception, binary double-float op +(defconstant error-fpu-exception-single 1025) + +(defconstant error-memory-full 2048) + +;; These are now supposed to match (mod ERROR-TYPE-ERROR) the %type-error-typespecs% +;; array that %err-disp looks at. +(ccl::defenum (:start error-type-error :prefix "ERROR-OBJECT-NOT-") + array + bignum + fixnum + character + integer + list + number + sequence + simple-string + simple-vector + string + symbol + macptr + real + cons + unsigned-byte + radix + float + rational + ratio + short-float + double-float + complex + vector + simple-base-string + function + unsigned-byte-16 + unsigned-byte-8 + unsigned-byte-32 + signed-byte-32 + signed-byte-16 + signed-byte-8 + base-char + bit + unsigned-byte-24 + unsigned-byte-64 + signed-byte-64 + unsigned-byte-56 + simple-array-double-float-2d + simple-array-single-float-2d + mod-char-code-limit + array-2d + array-3d + array-t + array-bit + array-s8 + array-u8 + array-s16 + array-u16 + array-s32 + array-u32 + array-s64 + array-u64 + array-fixnum + array-single-float + array-double-float + array-char + array-t-2d + array-bit-2d + array-s8-2d + array-u8-2d + array-s16-2d + array-u16-2d + array-s32-2d + array-u32-2d + array-s64-2d + array-u64-2d + array-fixnum-2d + array-single-float-2d + array-double-float-2d + array-char-2d + simple-array-t-2d + simple-array-bit-2d + simple-array-s8-2d + simple-array-u8-2d + simple-array-s16-2d + simple-array-u16-2d + simple-array-s32-2d + simple-array-u32-2d + simple-array-s64-2d + simple-array-u64-2d + simple-array-fixnum-2d + simple-array-char-2d + array-t-3d + array-bit-3d + array-s8-3d + array-u8-3d + array-s16-3d + array-u16-3d + array-s32-3d + array-u32-3d + array-s64-3d + array-u64-3d + array-fixnum-3d + array-single-float-3d + array-double-float-3d + array-char-3d + simple-array-t-3d + simple-array-bit-3d + simple-array-s8-3d + simple-array-u8-3d + simple-array-s16-3d + simple-array-u16-3d + simple-array-s32-3d + simple-array-u32-3d + simple-array-s64-3d + simple-array-u64-3d + simple-array-fixnum-3d + simple-array-single-float-3d + simple-array-double-float-3d + simple-array-char-3d + + ;; + vector-t + bit-vector + vector-s8 + vector-u8 + vector-s16 + vector-u16 + vector-s32 + vector-u32 + vector-s64 + vector-u64 + vector-fixnum + vector-single-float + vector-double-float + + ;; Sentinel + unused-max-type-error + ) + +(assert (<= error-object-not-unused-max-type-error (* 2 error-type-error))) + + + + + +(defun builtin-function-name-offset (name) + (and name (position name ccl::%builtin-functions% :test #'eq))) + +(ccl::defenum () + storage-class-lisp ; General lisp objects + storage-class-imm ; Fixnums, chars, NIL: not relocatable + storage-class-wordptr ; "Raw" (fixnum-tagged) pointers to stack,etc + storage-class-u8 ; Unsigned, untagged, 8-bit objects + storage-class-s8 ; Signed, untagged, 8-bit objects + storage-class-u16 ; Unsigned, untagged, 16-bit objects + storage-class-s16 ; Signed, untagged, 16-bit objects + storage-class-u32 ; Unsigned, untagged, 8-bit objects + storage-class-s32 ; Signed, untagged, 8-bit objects + storage-class-address ; "raw" (untagged) 32-bit addresses. + storage-class-single-float ; 32-bit single-float objects + storage-class-double-float ; 64-bit double-float objects + storage-class-pc ; pointer to/into code vector + storage-class-locative ; pointer to/into node-misc object + storage-class-crf ; condition register field + storage-class-crbit ; condition register bit: 0-31 + storage-class-crfbit ; bit within condition register field : 0-3 + storage-class-u64 ; (unsigned-byte 64) + storage-class-s64 ; (signed-byte 64) +) + + +(defvar *known-target-archs* ()) + +(defstruct (target-arch (:conc-name target-) + (:constructor %make-target-arch)) + (name nil) + (lisp-node-size 0) + (nil-value 0) + (fixnum-shift 0) + (most-positive-fixnum 0) + (most-negative-fixnum 0) + (misc-data-offset 0) + (misc-dfloat-offset 0) + (nbits-in-word 0) + (ntagbits 0) + (nlisptagbits 0) + (uvector-subtags 0) + (max-64-bit-constant-index 0) + (max-32-bit-constant-index 0) + (max-16-bit-constant-index 0) + (max-8-bit-constant-index 0) + (max-1-bit-constant-index 0) + (word-shift 0) + (code-vector-prefix ()) + (gvector-types ()) + (1-bit-ivector-types ()) + (8-bit-ivector-types ()) + (16-bit-ivector-types ()) + (32-bit-ivector-types ()) + (64-bit-ivector-types ()) + (array-type-name-from-ctype-function ()) + (package-name ()) + (t-offset ()) + (array-data-size-function ()) + (numeric-type-name-to-typecode-function ()) + (subprims-base ()) + (subprims-shift ()) + (subprims-table ()) + (primitive->subprims ()) + (unbound-marker-value ()) + (slot-unbound-marker-value ()) + (fixnum-tag 0) + (single-float-tag nil) + (single-float-tag-is-subtag nil) + (double-float-tag nil) + (cons-tag nil) + (null-tag nil) + (symbol-tag nil) + (symbol-tag-is-subtag nil) + (function-tag nil) + (function-tag-is-subtag nil) + (big-endian t) + (target-macros (make-hash-table :test #'eq)) + (misc-subtag-offset 0) + (car-offset 0) + (cdr-offset 0) + (subtag-char 0) + (charcode-shift 0) + (fulltagmask 0) + (fulltag-misc 0) + (char-code-limit nil)) + + + + + +(defun make-target-arch (&rest keys) + (declare (dynamic-extent keys)) + (let* ((arch (apply #'%make-target-arch keys)) + (tail (member (target-name arch) *known-target-archs* + :key #'target-name + :test #'eq))) + (if tail + (rplaca tail arch) + (push arch *known-target-archs*)) + arch)) + +(defun find-target-arch (name) + (car (member name *known-target-archs* + :key #'target-name + :test #'eq))) + +(defun target-arch-macros (arch-name) + (let* ((arch (or (find-target-arch arch-name) + (error "unknown arch: ~s" arch-name)))) + (target-target-macros arch))) + +(defmacro defarchmacro (arch-name name arglist &body body &environment env) + (let* ((lambda-form (ccl::parse-macro-1 name arglist body env))) + `(progn + (setf (gethash ',name (target-arch-macros ',arch-name)) + (ccl::nfunction ,name ,lambda-form)) + ',name))) + +(defun arch-macro-function (arch-name name) + (gethash name (target-arch-macros arch-name))) + + + +;;; GC related operations +(defconstant gc-trap-function-immediate-gc -1) +(defconstant gc-trap-function-gc 0) +(defconstant gc-trap-function-purify 1) +(defconstant gc-trap-function-impurify 2) +(defconstant gc-trap-function-flash-freeze 4) +(defconstant gc-trap-function-save-application 8) +(defconstant gc-trap-function-get-lisp-heap-threshold 16) +(defconstant gc-trap-function-set-lisp-heap-threshold 17) +(defconstant gc-trap-function-use-lisp-heap-threshold 18) +(defconstant gc-trap-function-egc-control 32) +(defconstant gc-trap-function-configure-egc 64) +(defconstant gc-trap-function-set-hons-area-size 128) +(defconstant gc-trap-function-freeze 129) +(defconstant gc-trap-function-thaw 130) + +(defconstant watch-trap-function-watch 0) +(defconstant watch-trap-function-unwatch 1) + +(provide "ARCH") Index: /branches/qres/ccl/compiler/backend.lisp =================================================================== --- /branches/qres/ccl/compiler/backend.lisp (revision 13564) +++ /branches/qres/ccl/compiler/backend.lisp (revision 13564) @@ -0,0 +1,493 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "ARCH")) + +(defconstant platform-word-size-mask 64) +(defconstant platform-os-mask 7) +(defconstant platform-cpu-mask (logandc2 (1- platform-word-size-mask) + platform-os-mask)) +(defconstant platform-word-size-32 0) +(defconstant platform-word-size-64 64) +(defconstant platform-cpu-ppc (ash 0 3)) +(defconstant platform-cpu-sparc (ash 1 3)) +(defconstant platform-cpu-x86 (ash 2 3)) +(defconstant platform-os-vxworks 0) +(defconstant platform-os-linux 1) +(defconstant platform-os-solaris 2) +(defconstant platform-os-darwin 3) +(defconstant platform-os-freebsd 4) +(defconstant platform-os-windows 5) + +(defstruct backend + (name :a :type keyword) + (num-arg-regs 3 :type fixnum) ; number of args passed in registers + (num-nvrs 0 :type fixnum) ; number of callee-save node regs + (num-node-regs 0 :type fixnum) ; number of node temps/arg regs + (lap-opcodes #() :type simple-vector) + (lookup-opcode #'false :type (or symbol function)) + (lookup-macro #'false :type (or symbol function)) + (p2-dispatch #() :type simple-vector) + (p2-compile 'error :type (or symbol function)) + (p2-vinsn-templates (error "Missing arg") :type hash-table) + (p2-template-hash-name 'bogus :type symbol) + (target-specific-features () :type list) + (target-fasl-pathname "" :type (or string pathname)) + (target-platform 0 :type fixnum) + (target-os ()) + (target-arch-name nil :type symbol) + (target-foreign-type-data nil :type (or null foreign-type-data)) + (lap-macros nil) + (target-arch nil) + (define-vinsn nil) + (platform-syscall-mask 0) + (define-callback nil) + (defcallback-body nil) + (lisp-context-register 0) + ;; difference between canonical static address for arch and this + ;; target's. Usually 0. + (lowmem-bias 0)) + +(defmethod print-object ((b backend) s) + (print-unreadable-object (b s :type t :identity t) + (format s "~A" (backend-name b)))) + + +(defun target-os-name (&optional (backend *target-backend*)) + (cdr (assoc (logand platform-os-mask (backend-target-platform backend)) + *platform-os-names*))) + + +(defparameter *backend-node-regs* 0) +(defparameter *backend-node-temps* 0) +(defparameter *available-backend-node-temps* 0) +(defparameter *backend-imm-temps* 0) +(defparameter *available-backend-imm-temps* 0) +(defparameter *backend-fp-temps* 0) +(defparameter *available-backend-fp-temps* 0) +(defparameter *backend-crf-temps* 0) +(defparameter *available-backend-crf-temps* 0) +(defparameter *backend-allocate-high-node-temps* nil) + +(defparameter *mode-name-value-alist* + '((:lisp . 0) + (:u32 . 1) + (:s32 . 2) + (:u16 . 3) + (:s16 . 4) + (:u8 . 5) + (:s8 . 6) + (:address . 7) + (:u64 . 8) + (:s64 . 9))) + +(defun gpr-mode-name-value (name) + (if (eq name :natural) + (setq name + (target-word-size-case + (32 :u32) + (64 :u64))) + (if (eq name :signed-natural) + (setq name + (target-word-size-case + (32 :s32) + (64 :s64))))) + (or (cdr (assq name *mode-name-value-alist*)) + (error "Unknown gpr mode name: ~s" name))) + +(defparameter *mode-specifier-types* + (vector + (specifier-type t) ;:lisp + (specifier-type '(unsigned-byte 32)) ;:u32 + (specifier-type '(signed-byte 32)) ;:s32 + (specifier-type '(unsigned-byte 16)) ;:u16 + (specifier-type '(signed-byte 16)) ;:s16 + (specifier-type '(unsigned-byte 8)) ;:u8 + (specifier-type '(signed-byte 8)) ;:s8 + (specifier-type 'macptr) ;:address + (specifier-type '(unsigned-byte 64)) ;:u64 + (specifier-type '(signed-byte 64)))) ;:s64 + +(defun mode-specifier-type (mode-name) + (svref *mode-specifier-types* (gpr-mode-name-value mode-name))) + + +(defun use-node-temp (n) + (declare (fixnum n)) + (if (logbitp n *available-backend-node-temps*) + (setq *available-backend-node-temps* + (logand *available-backend-node-temps* (lognot (ash 1 n))))) + n) + +(defun node-reg-p (reg) + (and (= (hard-regspec-class reg) hard-reg-class-gpr) + (= (get-regspec-mode reg) hard-reg-class-gpr-mode-node))) + +(defun node-reg-value (reg) + (if (node-reg-p reg) + (hard-regspec-value reg))) + +; if EA is a register-spec of the indicated class, return +; the register #. +(defun backend-ea-physical-reg (ea class) + (declare (fixnum class)) + (and ea + (register-spec-p ea) + (= (hard-regspec-class ea) class) + (hard-regspec-value ea))) + +(defun backend-crf-p (vreg) + (backend-ea-physical-reg vreg hard-reg-class-crf)) + +(defun available-node-temp (mask) + (if *backend-allocate-high-node-temps* + (do* ((bit 31 (1- bit))) + ((< bit 0) (error "Bug: ran out of node temp registers.")) + (when (logbitp bit mask) + (return bit))) + (dotimes (bit 32 (error "Bug: ran out of node temp registers.")) + (when (logbitp bit mask) + (return bit))))) + +(defun ensure-node-target (reg) + (if (node-reg-p reg) + reg + (available-node-temp *available-backend-node-temps*))) + +(defun select-node-temp () + (let* ((mask *available-backend-node-temps*)) + (if *backend-allocate-high-node-temps* + (do* ((bit 31 (1- bit))) + ((< bit 0) (error "Bug: ran out of node temp registers.")) + (when (logbitp bit mask) + (setq *available-backend-node-temps* (bitclr bit mask)) + (return bit))) + (dotimes (bit 32 (error "Bug: ran out of node temp registers.")) + (when (logbitp bit mask) + (setq *available-backend-node-temps* (bitclr bit mask)) + (return bit)))))) + +(defun available-imm-temp (mask &optional (mode-name :natural)) + (dotimes (bit 32 (error "Bug: ran out of imm temp registers.")) + (when (logbitp bit mask) + (return (set-regspec-mode bit (gpr-mode-name-value mode-name)))))) + +(defun use-imm-temp (n) + (declare (fixnum n)) + (setq *available-backend-imm-temps* (logand *available-backend-imm-temps* (lognot (ash 1 n)))) + n) + + +(defun select-imm-temp (&optional (mode-name :u32)) + (let* ((mask *available-backend-imm-temps*)) + (dotimes (bit 32 (error "Bug: ran out of imm temp registers.")) + (when (logbitp bit mask) + (setq *available-backend-imm-temps* (bitclr bit mask)) + (return (set-regspec-mode bit (gpr-mode-name-value mode-name))))))) + +;;; Condition-register fields are PPC-specific, but we might as well have +;;; a portable interface to them. + +(defun use-crf-temp (n) + (declare (fixnum n)) + (setq *available-backend-crf-temps* (logand *available-backend-crf-temps* (lognot (ash 1 (ash n -2))))) + n) + +(defun select-crf-temp () + (let* ((mask *available-backend-crf-temps*)) + (dotimes (bit 8 (error "Bug: ran out of CR fields.")) + (declare (fixnum bit)) + (when (logbitp bit mask) + (setq *available-backend-crf-temps* (bitclr bit mask)) + (return (make-hard-crf-reg (the fixnum (ash bit 2)))))))) + +(defun available-crf-temp (mask) + (dotimes (bit 8 (error "Bug: ran out of CR fields.")) + (when (logbitp bit mask) + (return (make-hard-crf-reg (the fixnum (ash bit 2))))))) + +(defun single-float-reg-p (reg) + (and (= (hard-regspec-class reg) hard-reg-class-fpr) + (= (get-regspec-mode reg) hard-reg-class-fpr-mode-single))) + +(defun use-fp-temp (n) + (setq *available-backend-fp-temps* (logand *available-backend-fp-temps* (lognot (ash 1 n)))) + n) + +(defun available-fp-temp (mask &optional (mode-name :double-float)) + (dotimes (bit (integer-length mask) (error "Bug: ran out of node fp registers.")) + (when (logbitp bit mask) + (let* ((mode (if (eq mode-name :double-float) + hard-reg-class-fpr-mode-double + hard-reg-class-fpr-mode-single))) + (return (make-hard-fp-reg bit mode)))))) + +(defparameter *backend-all-lregs* ()) +(defun note-logical-register (l) + (push l *backend-all-lregs*) + l) + +(defun free-logical-registers () + (without-interrupts + (let* ((prev (pool.data *lreg-freelist*))) + (dolist (r *backend-all-lregs*) + (setf (lreg-value r) prev + prev r)) + (setf (pool.data *lreg-freelist*) prev) + (setq *backend-all-lregs* nil)))) + + +(defun make-unwired-lreg (value &key + (class (if value (hard-regspec-class value) 0)) + (mode (if value (get-regspec-mode value) 0)) + (type (if value (get-node-regspec-type-modes value) 0))) + (note-logical-register (make-lreg (if value (hard-regspec-value value)) class mode type nil))) + +;;; Make an lreg with the same class, mode, & type as the prototype. +(defun make-unwired-lreg-like (proto) + (make-unwired-lreg nil + :class (hard-regspec-class proto) + :mode (get-regspec-mode proto) + :type (get-node-regspec-type-modes proto))) + +(defun make-wired-lreg (value &key + (class (hard-regspec-class value)) + (mode (get-regspec-mode value)) + (type (get-node-regspec-type-modes value))) + (note-logical-register (make-lreg (hard-regspec-value value) class mode type t))) + +(defvar *backend-immediates*) + +(defun backend-new-immediate (imm) + (vector-push-extend imm *backend-immediates*)) + +(defun backend-immediate-index (imm) + (or (position imm *backend-immediates*) + (backend-new-immediate imm))) + +(defvar *backend-vinsns*) + +(defvar *backend-labels*) + +(defun backend-gen-label (seg labelnum) + (append-dll-node (aref *backend-labels* labelnum) seg) + labelnum) + +(defconstant $backend-compound-branch-target-bit 18) +(defconstant $backend-compound-branch-target-mask (ash 1 $backend-compound-branch-target-bit)) + +(defconstant $backend-mvpass-bit 19) +(defconstant $backend-mvpass-mask (ash 1 $backend-mvpass-bit)) + +(defconstant $backend-return (- (ash 1 18) 1)) +(defconstant $backend-mvpass (- (ash 1 18) 2)) + +(defconstant $backend-compound-branch-false-byte (byte 18 0)) +(defconstant $backend-compound-branch-true-byte (byte 18 20)) + + +(defun backend-get-next-label () + (let* ((lnum (length *backend-labels*))) + (if (>= lnum $backend-mvpass) + (compiler-function-overflow) + (vector-push-extend (make-vinsn-label lnum) *backend-labels*)))) + + +;;; Loop through all labels in *backend-labels*; if the label has been +;;; emitted, remove it from vinsns and return it to the +;;; *vinsn-label-freelist*. "vinsns" should then contain nothing but +;;; ... vinsns + +(defun backend-remove-labels () + (let* ((labels *backend-labels*) + (freelist *vinsn-label-freelist*)) + (dotimes (i (the fixnum (length labels))) + (let* ((lab (aref labels i))) + (if lab + (if (vinsn-label-succ lab) + (remove-and-free-dll-node lab freelist) + (free-dll-node lab freelist))))))) + +(defun backend-copy-label (from to) + (let* ((from-lab (aref *backend-labels* from)) + (to-lab (aref *backend-labels* to))) + (when (null (vinsn-label-succ from-lab)) + (error "Copy label: not defined yet!")) + (backend-merge-labels from-lab to-lab) + (setf (aref *backend-labels* to) from-lab))) + +(defun backend-merge-labels (from-lab to-lab) + (let* ((to-refs (vinsn-label-refs to-lab))) + (when to-refs + ;; Make all extant refs to TO-LAB refer to FROM-LAB + (setf (vinsn-label-refs to-lab) nil) + (dolist (vinsn to-refs) + (push vinsn (vinsn-label-refs from-lab)) + (let* ((vp (vinsn-variable-parts vinsn))) + (declare (simple-vector vp)) + (dotimes (i (the fixnum (length vp))) + (when (eq to-lab (svref vp i)) + (setf (svref vp i) from-lab)))))))) + +;;; For now, the register-spec must be +;;; a) non-nil +;;; c) of an expected class. +;;; Return the class and value. +(defun regspec-class-and-value (regspec expected) + (declare (fixnum expected)) + (let* ((class (hard-regspec-class regspec))) + (declare (type (unsigned-byte 8) class)) + (if (logbitp class expected) + (values class (if (typep regspec 'lreg) + regspec + (hard-regspec-value regspec))) + (error "bug: Register spec class (~d) is not one of ~s." class expected)))) + +(defmacro with-node-temps ((&rest reserved) (&rest nodevars) &body body) + `(let* ((*available-backend-node-temps* (logand *available-backend-node-temps* (lognot (logior ,@(mapcar #'(lambda (r) `(ash 1 (hard-regspec-value ,r))) reserved))))) + ,@(mapcar #'(lambda (v) `(,v (make-unwired-lreg (select-node-temp)))) nodevars)) + ,@body)) + +(defmacro with-imm-temps ((&rest reserved) (&rest immvars) &body body) + `(let* ((*available-backend-imm-temps* (logand *available-backend-imm-temps* (lognot (logior ,@(mapcar #'(lambda (r) `(ash 1 (hard-regspec-value ,r))) reserved))))) + ,@(mapcar #'(lambda (v) (let* ((var (if (atom v) v (car v))) + (mode-name (if (atom v) :u32 (cadr v)))) + `(,var (select-imm-temp ',mode-name)))) immvars)) + ,@body)) + + +(defmacro with-crf-target ((&rest reserved) name &body body) + `(let* ((,name (make-unwired-lreg + (available-crf-temp + (logand *available-backend-crf-temps* + (lognot (logior ,@(mapcar #'(lambda (r) `(ash 1 (ash (hard-regspec-value ,r) -2))) reserved)))))))) + ,@body)) + +(defmacro regspec-crf-gpr-case ((regspec regval) crf-form gpr-form) + (let* ((class (gensym))) + `(if ,regspec + (multiple-value-bind (,class ,regval) (regspec-class-and-value ,regspec hard-reg-class-gpr-crf-mask) + (declare (fixnum ,class)) + (if (= ,class hard-reg-class-crf) + ,crf-form + ,gpr-form))))) + +;;; The NODE case may need to use ENSURING-NODE-TARGET. +(defmacro unboxed-other-case ((regspec &rest mode-names) + unboxed-case other-case) + `(if (and ,regspec + (= (hard-regspec-class ,regspec) hard-reg-class-gpr) + (logbitp (get-regspec-mode ,regspec) + (logior ,@(mapcar #'(lambda (x) (ash 1 (gpr-mode-name-value x))) + mode-names)))) + ,unboxed-case + ,other-case)) + + + + +;;; Choose an immediate register (for targeting), but don't "reserve" it. +(defmacro with-imm-target ((&rest reserved) spec &body body) + (let* ((name (if (atom spec) spec (car spec))) + (mode-name (if (atom spec) :natural (cadr spec)))) + `(let* ((,name (make-unwired-lreg + (available-imm-temp + (logand + *available-backend-imm-temps* + (lognot (logior ,@(mapcar + #'(lambda (r) + `(ash 1 (hard-regspec-value ,r))) + reserved)))) + ',mode-name)))) + ,@body))) + +(defmacro with-node-target ((&rest reserved) name &body body) + `(let* ((,name (make-unwired-lreg + (available-node-temp + (logand + *available-backend-node-temps* + (lognot (logior ,@(mapcar + #'(lambda (r) + `(ash 1 (hard-regspec-value ,r))) + reserved)))))))) + ,@body)) + + + + +(defmacro with-fp-target ((&rest reserved) spec &body body) + (let* ((name (if (atom spec) spec (car spec))) + (mode-name (if (atom spec) :double-float (cadr spec)))) + `(let* ((,name + (make-unwired-lreg + (available-fp-temp + (logand *available-backend-fp-temps* + (lognot (logior + ,@(mapcar + #'(lambda (r) + `(ash 1 (hard-regspec-value ,r))) + reserved)))) + ',mode-name)))) + ,@body))) + +(defmacro ensuring-node-target ((target-var vreg-var) &body body) + `(let* ((*available-backend-node-temps* *available-backend-node-temps*) + (,target-var (ensure-node-target ,vreg-var))) + (declare (special *available-backend-node-temps*)) + (macrolet ((<- (&whole call &rest args) + (declare (ignore args)) + (error "Invalid use of <- inside ENSURING-NODE-TARGET: ~s" call)) + (^ (&whole call &rest args) + (declare (ignore args)) + (error "Invalid use of ^ inside ENSURING-NODE-TARGET: ~s" call))) + (progn + ,@body)) + (<- ,target-var))) + +(defun acode-invert-condition-keyword (k) + (or + (cdr (assq k '((:eq . :ne) (:ne . :eq) (:le . :gt) (:lt . :ge) (:ge . :lt) (:gt . :le)))) + (error "Unknown condition: ~s" k))) + +(defun backend-arch-macroexpand (whole env) + (let* ((expander (arch::arch-macro-function + (backend-target-arch-name *target-backend*) + (car whole)))) + (if expander + (funcall expander whole env) + (error "No arch-specific macro function for ~s in arch ~s" + (car whole) (backend-target-arch-name *target-backend*))))) + +(defmacro declare-arch-specific-macro (name) + `(progn + (setf (macro-function ',name) #'backend-arch-macroexpand) + ',name)) + +(defun target-nil-value (&optional (backend *target-backend*)) + (+ (arch::target-nil-value (backend-target-arch backend)) + (backend-lowmem-bias backend))) + +(defun target-t-value (&optional (backend *target-backend*)) + (let* ((arch (backend-target-arch backend))) + (+ (arch::target-nil-value arch) + (arch::target-t-offset arch) + (backend-lowmem-bias backend)))) + + + Index: /branches/qres/ccl/compiler/dll-node.lisp =================================================================== --- /branches/qres/ccl/compiler/dll-node.lisp (revision 13564) +++ /branches/qres/ccl/compiler/dll-node.lisp (revision 13564) @@ -0,0 +1,228 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +(defstruct (dll-node (:print-function print-dll-node)) + pred + succ) + +; Doubly-linked list header (just a distinguished type of node) +(defstruct (dll-header + (:include dll-node) + (:constructor %make-dll-header)) +) + + +(defmacro dll-header-last (h) `(dll-header-pred ,h)) +(defmacro dll-header-first (h) `(dll-header-succ ,h)) + +(defun init-dll-header (h) + (setf (dll-header-first h) h + (dll-header-last h) h)) + +(defun make-dll-header () + (init-dll-header (%make-dll-header))) + + +;;; DLL-NODEs are sort of "abstract classes", so we should rarely (if +;;; ever) have to print one. On the other hand, they're very circular +;;; abstract classes ... +(defun print-dll-node (n stream d) + (declare (ignore d)) + (print-unreadable-object (n stream :type t :identity t))) + +;;; Return NODE's list header, if it has one. +(defun dll-node-header (node) + (do* ((n node (dll-node-succ node))) + ((or (null n) (typep n 'dll-header)) n))) + +;;; Make node be the last node in header's linked list +(defun append-dll-node (node header) + (let* ((last (dll-header-last header))) + (setf (dll-node-pred node) last + (dll-header-last header) node + (dll-node-succ node) header + (dll-node-succ last) node))) + +;;; Splice one or more nodes out of the containing doubly-linked list. +;;; Return the first and last nodes in the new chain. +(defun remove-dll-node (node &optional (count 1)) + (declare (fixnum count)) + (do* ((last node (dll-node-succ last)) + (i 1 (1+ i))) + ((= i count) + (let* ((prev (dll-node-pred node)) + (after (dll-node-succ last))) + (setf (dll-node-pred after) prev + (dll-node-succ prev) after + (dll-node-pred node) nil + (dll-node-succ last) nil) + (values node last))) + (declare (fixnum i)) + ;; This check shouldn't cost much and keeps us from doing + ;; something really stupid. + (when (typep last 'dll-header) + (error "Can't remove header node .")))) + +;;; Insert one or mode nodes after a specified node. To be sane, the +;;; "chainlast" argument must be "node" or a transitive successor of +;;; "node", (and "node" EQ to or a transitive predecessor of +;;; "chainlast", and no list header should appear on the chain between +;;; "node" and "chainlast". The typical cases where this is used are +;;; to insert a freshly consed node into a list or to insert a chain +;;; of one or more freshly deleted nodes. Both of these cases satisfy +;;; the sanity check, so it isn't performed here. +(defun insert-dll-node-after (node after &optional (chainlast node)) + (let* ((after-after (dll-node-succ after))) + (setf (dll-node-pred node) after + (dll-node-succ chainlast) after-after + (dll-node-pred after-after) chainlast + (dll-node-succ after) node))) + +;;; More concise, somehow ... +(defun insert-dll-node-before (node before &optional (chainlast node)) + (insert-dll-node-after node (dll-node-pred before) chainlast)) + +(defun move-dll-nodes (node after &optional (count 1)) + (multiple-value-bind (first last) (remove-dll-node node count) + (insert-dll-node-after first after last))) + +;;; Return chain head and tail, or (values nil nil) if empty header. +(defun detach-dll-nodes (header) + (let* ((first (dll-header-first header))) + (if (eq first header) + (values nil nil) + (let* ((last (dll-header-last header))) + (setf (dll-header-first header) header + (dll-header-last header) header + (dll-node-pred first) nil + (dll-node-succ last) nil) + (values first last))))) + +(defun merge-dll-nodes (target &rest others) + (declare (dynamic-extent others)) + (dolist (other others target) + (multiple-value-bind (head tail) (detach-dll-nodes other) + (when head + (insert-dll-node-after head (dll-header-last target) tail))))) + +;;; This definition doesn't work when the body unlinks "more than" the +;;; current node. +(defmacro do-dll-nodes ((valvar header &optional result) &body body) + (let* ((headervar (make-symbol "HEADER")) + (next (make-symbol "NEXT"))) + `(do* ((,headervar ,header) + (,valvar (dll-header-first ,headervar) ,next) + (,next (dll-node-succ ,valvar) (dll-node-succ ,valvar))) + ((eq ,valvar ,headervar) + ,result) + ,@body))) + +(defun dll-header-length (header) + (let* ((count 0)) + (declare (fixnum count)) + (do-dll-nodes (n header count) + (incf count)))) + +(defun dll-node-position (node header) + (let* ((pos 0)) + (declare (fixnum pos)) + (do-dll-nodes (n header) + (if (eq n node) + (return pos) + (incf pos))))) + +;;; dll-node freelisting ... + +(defun make-dll-node-freelist () + (%cons-pool)) + +;;; header shouldn't be used after this is called +(defun return-dll-nodes (header freelist) + (without-interrupts + (let* ((pool-header (pool.data freelist))) + (if (null pool-header) + (setf (pool.data freelist) header) + (multiple-value-bind (first last) (detach-dll-nodes header) + (if first + (insert-dll-node-after first (dll-header-last pool-header) last)))) + nil))) + +;;; Pop a node off off the freelist; return NIL if the freelist is +;;; empty. Set the succ and pred slots of the node to NIL; other +;;; slots are undefined. +(defun alloc-dll-node (freelist) + (without-interrupts + (let* ((pool-header (pool.data freelist)) + (node (if pool-header (dll-header-first pool-header)))) + (if (and node (not (eq node pool-header))) + (remove-dll-node node))))) + +(defun free-dll-node (node freelist) + (without-interrupts + (let* ((pool-header (pool.data freelist))) + (if (null pool-header) + (progn + (setq pool-header (make-dll-header)) + (setf (pool.data freelist) pool-header))) + (append-dll-node node pool-header) + nil))) + +(defun remove-and-free-dll-node (node freelist) + (remove-dll-node node) + (free-dll-node node freelist)) + +(defmacro with-dll-node-freelist ((header-var freelist) &body body) + (let* ((internal-header-name (gensym)) + (internal-freelist-name (gensym)) + (constructor-name 'make-dll-header)) + (if (consp header-var) + (setq constructor-name (cadr header-var) + header-var (car header-var))) + `(let* ((,internal-header-name (,constructor-name)) + (,internal-freelist-name ,freelist)) + (unwind-protect + (let* ((,header-var ,internal-header-name)) + ,@body) + (return-dll-nodes ,internal-header-name ,internal-freelist-name))))) + +(defstruct (locked-dll-header + (:include dll-header) + (:constructor %make-locked-dll-header)) + (lock (make-lock))) + +(defun make-locked-dll-header () + (init-dll-header (%make-locked-dll-header))) + +(defmacro with-locked-dll-header ((h) &body body) + `(with-lock-grabbed ((locked-dll-header-lock ,h)) + ,@body)) + +(defun locked-dll-header-enqueue (node header) + (with-locked-dll-header (header) + (append-dll-node node header))) + +(defun locked-dll-header-dequeue (header) + (with-locked-dll-header (header) + (let* ((first (dll-header-first header))) + (unless (eq first header) + (remove-dll-node first))))) + +(provide "DLL-NODE") Index: /branches/qres/ccl/compiler/lambda-list.lisp =================================================================== --- /branches/qres/ccl/compiler/lambda-list.lisp (revision 13564) +++ /branches/qres/ccl/compiler/lambda-list.lisp (revision 13564) @@ -0,0 +1,114 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +;;; Compiler functions needed elsewhere + +(defun %lfun-info-index (fn) + (and (compiled-function-p fn) + (let ((bits (lfun-bits fn))) + (declare (fixnum bits)) + (and (logbitp $lfbits-info-bit bits) + (%i- (uvsize (function-to-function-vector fn)) + (if (logbitp $lfbits-noname-bit bits) 2 3)))))) +(defun %lfun-info (fn) + (let* ((index (%lfun-info-index fn))) + (if index (%svref (function-to-function-vector fn) index)))) + +(defun function-source-note (fn) + (getf (%lfun-info fn) '%function-source-note)) + +(defun uncompile-function (fn) + (getf (%lfun-info fn) 'function-lambda-expression )) + +;;; used-by: backtrace, arglist +(defun function-symbol-map (fn) + (getf (%lfun-info fn) 'function-symbol-map)) + +(defun find-source-note-at-pc (fn pc) + ;(declare (values source-note start-pc end-pc)) + (let* ((function-note (function-source-note fn)) + (pc-source-map (getf (%lfun-info fn) 'pc-source-map)) + (best-guess -1) + (best-length 0) + (len (length pc-source-map))) + (declare (fixnum best-guess best-length len)) + (when (and function-note pc-source-map) + (do ((q 0 (+ q 4))) + ((= q len)) + (declare (fixnum q)) + (let* ((pc-start (aref pc-source-map q)) + (pc-end (aref pc-source-map (%i+ q 1)))) + (declare (fixnum pc-start pc-end)) + (when (and (<= pc-start pc) + (< pc pc-end) + (or (eql best-guess -1) + (< (%i- pc-end pc-start) best-length))) + (setf best-guess q + best-length (- pc-end pc-start))))) + (unless (eql best-guess -1) + (values + (let ((def-pos (source-note-start-pos function-note))) + (make-source-note :source function-note + :filename (source-note-filename function-note) + :start-pos (+ def-pos (aref pc-source-map (+ best-guess 2))) + :end-pos (+ def-pos (aref pc-source-map (+ best-guess 3))))) + (aref pc-source-map best-guess) + (aref pc-source-map (+ best-guess 1))))))) + +;;; Lambda-list utilities + + + + + +;;; Lambda-list verification: + +;;; these things MUST be compiled. +(eval-when (:load-toplevel) + +(defvar *structured-lambda-list* nil) + + + + +(defun parse-body (body env &optional (doc-string-allowed t) &aux + decls + doc + (tail body) + form) + (declare (ignore env)) + (loop + (if (endp tail) (return)) ; otherwise, it has a %car and a %cdr + (if (and (stringp (setq form (%car tail))) (%cdr tail)) + (if doc-string-allowed + (setq doc form) + (return)) + (if (not (and (consp form) (symbolp (%car form)))) + (return) + (if (eq (%car form) 'declare) + (push form decls) + (return)))) + (setq tail (%cdr tail))) + (return-from parse-body (values tail (nreverse decls) doc))) + +) ; end of eval-when (load) + +;;; End of verify-lambda-list.lisp Index: /branches/qres/ccl/compiler/nx-base-app.lisp =================================================================== --- /branches/qres/ccl/compiler/nx-base-app.lisp (revision 13564) +++ /branches/qres/ccl/compiler/nx-base-app.lisp (revision 13564) @@ -0,0 +1,31 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +; Loaded instead of compiler for standalone applications. + +(in-package "CCL") + +;(require 'numbers) +(require 'sort) +(require 'hash) + +; this file is now equiv to nx-basic +(%include "ccl:compiler;nx-basic.lisp") ; get cons-var, augment-environment +; nx-basic includes lambda-list + +; End of nx-base-app.lisp Index: /branches/qres/ccl/compiler/nx-basic.lisp =================================================================== --- /branches/qres/ccl/compiler/nx-basic.lisp (revision 13564) +++ /branches/qres/ccl/compiler/nx-basic.lisp (revision 13564) @@ -0,0 +1,709 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;; used by compiler and eval - stuff here is not excised with rest of compiler + + +(in-package :ccl) + +#|| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it: +; for compiler-special-form-p, called by cheap-eval-in-environment +(defparameter *nx1-compiler-special-forms* + `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND + DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE + LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL + MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP + OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET + SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS)) +||# + +(eval-when (:compile-toplevel) + (require 'nxenv)) + +(defvar *lisp-compiler-version* 666 "I lost count.") + +(defvar *nx-compile-time-types* nil) +(defvar *nx-proclaimed-types* nil) +(defvar *nx-method-warning-name* nil) + +(defvar *nx-current-code-note*) + +;; The problem with undefind type warnings is that there is no in-language way to shut +;; them up even when the reference is intentional. (In case of undefined functions, +;; you can declare FTYPE and that will turn off any warnings without interfering with +;; the function being defined later). For now just provide this as an out. +(defvar *compiler-warn-on-undefined-type-references* #+ccl-0711 t #-ccl-0711 t) + + + +;; In lieu of a slot in acode. Don't reference this variable elsewhere because I'm +;; hoping to make it go away. +(defparameter *nx-acode-note-map* nil) + +(defun acode-note (acode &aux (hash *nx-acode-note-map*)) + (and hash (gethash acode hash))) + +(defun (setf acode-note) (note acode) + (when note + (assert *nx-acode-note-map*) + ;; Only record if have a unique key + (unless (or (atom acode) + (nx-null acode) + (nx-t acode)) + (setf (gethash acode *nx-acode-note-map*) note)))) + + +(defstruct (code-note (:constructor %make-code-note)) + ;; Code coverage state. This MUST be the first slot - see nx2-code-coverage. + code-coverage + ;; The source note of this form, or NIL if random code form (no file info, + ;; generated by macros or other source transform) + source-note + ;; the note that was being compiled when this note was emitted. + parent-note + #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused. + form) + +(defun make-code-note (&key form source-note parent-note) + (declare (ignorable form)) + (let ((note (%make-code-note + :source-note source-note + :parent-note parent-note))) + #+debug-code-notes + (when form + ;; Unfortunately, recording the macroexpanded form is problematic, since they + ;; can have references to non-dumpable forms, see e.g. loop. + (setf (code-note-form note) + (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s))))) + note)) + +(defmethod print-object ((note code-note) stream) + (print-unreadable-object (note stream :type t :identity t) + (format stream "[~s]" (code-note-code-coverage note)) + (let ((sn (code-note-source-note note))) + (if sn + (progn + (format stream " for ") + (print-source-note sn stream)) + #+debug-code-notes + (when (code-note-form note) + (format stream " form ~a" + (string-sans-most-whitespace (code-note-form note)))))))) + +(defun nx-ensure-code-note (form &optional parent-note) + (let* ((parent-note (or parent-note *nx-current-code-note*)) + (source-note (nx-source-note form))) + (unless (and source-note + ;; Look out for a case like a lambda macro that turns (lambda ...) + ;; into (FUNCTION (lambda ...)) which then has (lambda ...) + ;; as a child. Create a fresh note for the child, to avoid ambiguity. + ;; Another case is forms wrapping THE around themselves. + (neq source-note (code-note-source-note parent-note)) + ;; Don't use source notes from a different toplevel form, which could + ;; happen due to inlining etc. The result then is that the source note + ;; appears in multiple places, and shows partial coverage (from the + ;; other reference) in code that's never executed. + (loop for p = parent-note then (code-note-parent-note p) + when (null p) return t + when (code-note-source-note p) + return (eq (loop for n = source-note then s + as s = (source-note-source n) + unless (source-note-p s) return n) + (loop for n = (code-note-source-note p) then s + as s = (source-note-source n) + unless (source-note-p s) return n)))) + (setq source-note nil)) + (make-code-note :form form :source-note source-note :parent-note parent-note))) + +(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn) + (when (and source-notes + (setq sn (gethash original source-notes)) + (not (gethash new source-notes))) + (setf (gethash new source-notes) sn))) + + +(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq)) + +(let ((policy (%istruct 'compiler-policy + #'(lambda (env) + #+ccl-0711 (< (debug-optimize-quantity env) 2) + #-ccl-0711 (neq (debug-optimize-quantity env) 3)) ; allow-tail-recursion-elimination + #'(lambda (env) + (declare (ignorable env)) + #+ccl-0711 nil + #-ccl-0711 (eq (debug-optimize-quantity env) 3)) ; inhibit-register-allocation + #'(lambda (env) + (let* ((safety (safety-optimize-quantity env))) + (and (< safety 3) + (>= (speed-optimize-quantity env) + safety)))) ; trust-declarations + #'(lambda (env) + #+ccl-0711 (> (speed-optimize-quantity env) + (space-optimize-quantity env)) + #-ccl-0711 (>= (speed-optimize-quantity env) + (+ (space-optimize-quantity env) 2))) ; open-code-inline + #'(lambda (env) + (and (eq (speed-optimize-quantity env) 3) + (eq (safety-optimize-quantity env) 0))) ; inhibit-safety-checking + #'(lambda (env) + (let* ((safety (safety-optimize-quantity env))) + (or (eq safety 3) + (> safety (speed-optimize-quantity env))))) ;declarations-typecheck + #'(lambda (env) + (neq (debug-optimize-quantity env) 3)) ; inline-self-calls + #'(lambda (env) + (and (neq (compilation-speed-optimize-quantity env) 3) + (or (neq (speed-optimize-quantity env) 0) + (and (neq (safety-optimize-quantity env) 3) + (neq (debug-optimize-quantity env) 3))))) ; allow-transforms + #'(lambda (var env) ; force-boundp-checks + (declare (ignore var)) + (eq (safety-optimize-quantity env) 3)) + #'(lambda (var val env) ; allow-constant-substitution + (declare (ignore var val env)) + t) + nil ; extensions + ))) + (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p) + (inhibit-register-allocation nil ira-p) + (trust-declarations nil td-p) + (open-code-inline nil oci-p) + (inhibit-safety-checking nil ischeck-p) + (inline-self-calls nil iscall-p) + (allow-transforms nil at-p) + (force-boundp-checks nil fb-p) + (allow-constant-substitution nil acs-p) + (declarations-typecheck nil dt-p)) + (let ((p (copy-uvector policy))) + (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination)) + (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation)) + (if td-p (setf (policy.trust-declarations p) trust-declarations)) + (if oci-p (setf (policy.open-code-inline p) open-code-inline)) + (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking)) + (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls)) + (if at-p (setf (policy.allow-transforms p) allow-transforms)) + (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks)) + (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution)) + (if dt-p (setf (policy.declarations-typecheck p) declarations-typecheck)) + p)) + (defun %default-compiler-policy () policy)) + +(%include "ccl:compiler;lambda-list.lisp") + + +;Syntactic Environment Access. + +(defun declaration-information (decl-name &optional env) + (if (and env (not (istruct-typep env 'lexical-environment))) + (report-bad-arg env 'lexical-environment)) +; *** This needs to deal with things defined with DEFINE-DECLARATION *** + (case decl-name + (optimize + (list + (list 'speed (speed-optimize-quantity env)) + (list 'safety (safety-optimize-quantity env)) + (list 'compilation-speed (compilation-speed-optimize-quantity env)) + (list 'space (space-optimize-quantity env)) + (list 'debug (debug-optimize-quantity env)))) + (declaration + *nx-known-declarations*))) + +(defun function-information (name &optional env &aux decls) + (let ((name (ensure-valid-function-name name))) + (if (and env (not (istruct-typep env 'lexical-environment))) + (report-bad-arg env 'lexical-environment)) + (if (special-operator-p name) + (values :special-form nil nil) + (flet ((process-new-fdecls (fdecls) + (dolist (fdecl fdecls) + (when (eq (car fdecl) name) + (let ((decl-type (cadr fdecl))) + (when (and (memq decl-type '(dynamic-extent inline ftype)) + (not (assq decl-type decls))) + (push (cdr fdecl) decls))))))) + (declare (dynamic-extent #'process-new-fdecls)) + (do* ((root t) + (contour env (when root (lexenv.parent-env contour)))) + ((null contour) + (if (macro-function name) + (values :macro nil nil) + (if (fboundp name) + (values :function + nil + (if (assq 'inline decls) + decls + (if (proclaimed-inline-p name) + (push '(inline . inline) decls) + (if (proclaimed-notinline-p name) + (push '(inline . notinline) decls))))) + (values nil nil decls)))) + (if (istruct-typep contour 'definition-environment) + (if (assq name (defenv.functions contour)) + (return (values :macro nil nil)) + (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour)))) + (progn + (process-new-fdecls (lexenv.fdecls contour)) + (let ((found (assq name (lexenv.functions contour)))) + (when found + (return + (if (and (consp (cdr found))(eq (%cadr found) 'macro)) + (values :macro t nil) + (values :function t decls)))))))))))) + +(defun variable-information (var &optional env) + (setq var (require-type var 'symbol)) + (if (and env (not (istruct-typep env 'lexical-environment))) + (report-bad-arg env 'lexical-environment)) + (let* ((vartype nil) + (boundp nil) + (envtype nil) + (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us. + (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls))))) + (loop + (cond ((null env) + (if (constant-symbol-p var) + (setq vartype :constant decls nil) + (if (proclaimed-special-p var) + (setq vartype :special) + (let* ((not-a-symbol-macro (cons nil nil))) + (declare (dynamic-extent not-a-symbol-macro)) + (unless (eq (gethash var *symbol-macros* not-a-symbol-macro) + not-a-symbol-macro) + (setq vartype :symbol-macro))))) + (return)) + ((eq (setq envtype (istruct-type-name env)) 'definition-environment) + (cond ((assq var (defenv.constants env)) + (setq vartype :constant) + (return)) + ((assq var (defenv.symbol-macros env)) + (setq vartype :symbol-macro) + (return)) + ((assq var (defenv.specials env)) + (setq vartype :special) + (return)))) + (t + (dolist (vdecl (lexenv.vdecls env)) + (when (eq (car vdecl) var) + (let ((decltype (cadr vdecl))) + (unless (assq decltype decls) + (case decltype + (special (setq vartype :special)) + ((type dynamic-extent ignore) (push (cdr vdecl) decls))))))) + (let ((vars (lexenv.variables env))) + (unless (atom vars) + (dolist (v vars) + (when (eq (var-name v) var) + (setq boundp t) + (if (and (consp (var-ea v)) + (eq :symbol-macro (car (var-ea v)))) + (setq vartype :symbol-macro) + (unless vartype (setq vartype + (let* ((bits (var-bits v))) + (if (and (typep bits 'integer) + (logbitp $vbitspecial bits)) + :special + :lexical))))) + (return))) + (when vartype (return)))))) + (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env)))) + (values vartype boundp decls))) + +(defun nx-target-type (typespec) + ;; Could do a lot more here + (if (or (eq *host-backend* *target-backend*) + (not (eq typespec 'fixnum))) + typespec + (target-word-size-case + (32 '(signed-byte 30)) + (64 '(signed-byte 61))))) + +; Type declarations affect all references. +(defun nx-declared-type (sym &optional (env *nx-lexical-environment*)) + (loop + (when (or (null env) (istruct-typep env 'definition-environment)) (return)) + (dolist (decl (lexenv.vdecls env)) + (if (and (eq (car decl) sym) + (eq (cadr decl) 'type)) + (return-from nx-declared-type (nx-target-type (cddr decl))))) + (let ((vars (lexenv.variables env))) + (when (and (consp vars) + (dolist (var vars) + (when (eq (var-name var) sym) + (return t)))) + (return-from nx-declared-type t))) + (setq env (lexenv.parent-env env))) + (let ((decl (or (assq sym *nx-compile-time-types*) + (assq sym *nx-proclaimed-types*)))) + (if decl (%cdr decl) t))) + +(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*) args) + (when (symbolp (setq sym (maybe-setf-function-name sym))) + (let* ((ftype (find-ftype-decl sym env args)) + (ctype (and ftype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env))))) + (unless (or (null ctype) + (not (function-ctype-p ctype)) + (eq *wild-type* (function-ctype-returns ctype))) + (let ((result-type (type-specifier (single-value-type (function-ctype-returns ctype))))) + (and (neq result-type 't) result-type)))))) + +(defmacro define-declaration (decl-name lambda-list &body body &environment env) + (multiple-value-bind (body decls) + (parse-body body env) + (let ((fn `(nfunction (define-declaration ,decl-name) + (lambda ,lambda-list + ,@decls + (block ,decl-name + ,@body))))) + `(progn + (proclaim '(declaration ,decl-name)) + (setf (getf *declaration-handlers* ',decl-name) ,fn))))) + +(defun check-environment-args (variable symbol-macro function macro) + (flet ((check-all-pairs (pairlist argname) + (dolist (pair pairlist) + (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair))) + (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" + argname + pair + 'name + 'definition + pairlist)))) + (check-all-symbols (symlist argname pairs pairsname) + (dolist (v symlist) + (unless (symbolp v) + (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist)) + (when (assq v pairs) + (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs)))))) + (check-all-pairs symbol-macro :symbol-macro) + (check-all-pairs macro :macro) + (check-all-symbols variable :variable symbol-macro :symbol-macro) + (check-all-symbols function :function macro :macro))) + + +;; This -isn't- PARSE-DECLARATIONS. It can't work; neither can this ... +(defun process-declarations (env decls symbol-macros) + (let ((vdecls nil) + (fdecls nil) + (mdecls nil)) + (flet ((add-type-decl (spec) + (destructuring-bind (typespec &rest vars) spec + (dolist (var vars) + (when (non-nil-symbol-p var) + (push (list* var + 'type + (let ((already (assq 'type (nth-value 2 (variable-information var env))))) + (if already + (let ((oldtype (%cdr already))) + (if oldtype + (if (subtypep oldtype typespec) + oldtype + (if (subtypep typespec oldtype) + typespec)))) + typespec))) + vdecls)))))) + ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it. + (dolist (decl decls) + (when (eq (car decl) 'special) + (dolist (spec (%cdr decl)) + (when (non-nil-symbol-p spec) + (if (assq spec symbol-macros) + (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec)) + (push (list* spec 'special t) vdecls))))) + (dolist (decl decls) + (let ((decltype (car decl))) + (case decltype + ((inline notinline) + (dolist (spec (%cdr decl)) + (let ((fname nil)) + (if (non-nil-symbol-p spec) + (setq fname spec) + (if (setf-function-name-p spec) + (setq fname (setf-function-name (cadr spec))))) + (if fname + (push (list* fname decltype t) fdecls))))) + (optimize + (dolist (spec (%cdr decl)) + (let ((val 3) + (quantity spec)) + (if (consp spec) + (setq quantity (car spec) val (cadr spec))) + (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed))) + (push (cons quantity val) mdecls))))) + (dynamic-extent + (dolist (spec (%cdr decl)) + (if (non-nil-symbol-p spec) + (push (list* spec decltype t) vdecls) + (if (and (consp spec) (eq (%car spec) 'function)) + (let ((fname (cadr spec))) + (if (not (non-nil-symbol-p fname)) + (setq fname + (if (setf-function-name-p fname) + (setf-function-name (cadr fname))))) + (if fname (push (list* fname decltype t) fdecls))))))) + (type (add-type-decl (cdr decl))) + (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl) + (dolist (name fnames) + (let ((fname name)) + (if (not (non-nil-symbol-p fname)) + (setq fname + (if (setf-function-name-p fname) + (setf-function-name (cadr fname))))) + (if fname (push (list* fname decltype typespec) fdecls)))))) + (special) + (t + (if (memq decltype *cl-types*) + (add-type-decl decl) + (let ((handler (getf *declaration-handlers* decltype))) + (when handler + (multiple-value-bind (type info) (funcall handler decl) + (ecase type + (:variable + (dolist (v info) (push (apply #'list* v) vdecls))) + (:function + (dolist (f info) (push (apply #'list* f) fdecls))) + (:declare ;; N.B. CLtL/2 semantics + (push info mdecls))))))))))) + (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env)) + (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env)) + (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env)))))) + + +(defun cons-var (name &optional (bits 0)) + (%istruct 'var name bits nil nil nil nil nil nil)) + + +(defun augment-environment (env &key variable symbol-macro function macro declare) + (if (and env (not (istruct-typep env 'lexical-environment))) + (report-bad-arg env 'lexical-environment)) + (check-environment-args variable symbol-macro function macro) + (let* ((vars (mapcar #'cons-var variable)) + (symbol-macros (mapcar #'(lambda (s) + (let* ((sym (car s))) + (unless (and (symbolp sym) + (not (constantp sym env)) + (not (eq (variable-information sym env) :special))) + (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym)) + (let ((v (cons-var (car s)))) + (setf (var-expansion v) (cons :symbol-macro (cadr s))) + v))) + symbol-macro)) + (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro)) + (functions (mapcar #'(lambda (f) (list* f 'function nil)) function)) + (new-env (new-lexical-environment env))) + (setf (lexenv.variables new-env) (nconc vars symbol-macros) + (lexenv.functions new-env) (nconc functions macros)) + (process-declarations new-env declare symbol-macro) + new-env)) + +(defun enclose (lambda-expression &optional env) + (if (and env (not (istruct-typep env 'lexical-environment))) + (report-bad-arg env 'lexical-environment)) + (unless (lambda-expression-p lambda-expression) + (error "Invalid lambda-expression ~S." lambda-expression)) + (%make-function nil lambda-expression env)) + +#|| Might be nicer to do %declaim +(defmacro declaim (&rest decl-specs &environment env) + `(progn + (eval-when (:load-toplevel :execute) + (proclaim ',@decl-specs)) + (eval-when (:compile-toplevel) + (%declaim ',@decl-specs ,env)))) +||# + +(defmacro declaim (&environment env &rest decl-specs) + "DECLAIM Declaration* + Do a declaration or declarations for the global environment." + (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs))) + `(progn + (eval-when (:compile-toplevel) + (compile-time-proclamation ',decl-specs ,env)) + (eval-when (:load-toplevel :execute) + ,@body)))) + +(defvar *strict-checking* nil + "If true, issues warnings/errors in more cases, e.g. for valid but non-portable code") + + +;; Should be true if compiler warnings UI doesn't use source locations, false if it does. +(defvar *merge-compiler-warnings* t "If false, don't merge compiler warnings with different source locations") + +;;; If warnings have more than a single entry on their +;;; args slot, don't merge them. +(defun merge-compiler-warnings (old-warnings) + (let ((warnings nil)) + (dolist (w old-warnings) + (let* ((w-args (compiler-warning-args w))) + (if + (or (cdr w-args) + ;; See if W can be merged into an existing warning + (dolist (w1 warnings t) + (let ((w1-args (compiler-warning-args w1))) + (when (and (eq (compiler-warning-warning-type w) + (compiler-warning-warning-type w1)) + w1-args + (null (cdr w1-args)) + (eq (%car w-args) + (%car w1-args)) + (or *merge-compiler-warnings* + (eq (compiler-warning-source-note w) + (compiler-warning-source-note w1)))) + (let ((nrefs (compiler-warning-nrefs w1))) + (setf (compiler-warning-nrefs w1) + (cons (compiler-warning-source-note w) + (or nrefs + (list (compiler-warning-source-note w1))))) + (return nil)))))) + (push w warnings)))) + warnings)) + +;;; This is called by, e.g., note-function-info & so can't be -too- funky ... +;;; don't call proclaimed-inline-p or proclaimed-notinline-p with alphatized crap + +(defun nx-declared-inline-p (sym env) + (setq sym (maybe-setf-function-name sym)) + (loop + (when (listp env) + (return (and (symbolp sym) + (proclaimed-inline-p sym)))) + (dolist (decl (lexenv.fdecls env)) + (when (and (eq (car decl) sym) + (eq (cadr decl) 'inline)) + (return-from nx-declared-inline-p (eq (cddr decl) 'inline)))) + (setq env (lexenv.parent-env env)))) + +(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition))) + (destructuring-bind (callee reason args spread-p) + (compiler-warning-args condition) + (format stream "In the ~a ~s with arguments ~:s,~% " + (if spread-p "application of" "call to") + callee + args) + (ecase (car reason) + (:toomany + (destructuring-bind (provided max) + (cdr reason) + (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at most ~d ~:*~[are~;is~:;are~] accepted~& by " provided max))) + (:toofew + (destructuring-bind (provided min) + (cdr reason) + (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at least ~d ~:*~[are~;is~:;are~] required~& by " provided min))) + (:odd-keywords + (let* ((tail (cadr reason))) + (format stream "the variable portion of the argument list ~s contains an odd number~& of arguments and so can't be used to initialize keyword parameters~& for " tail))) + (:unknown-keyword + (destructuring-bind (badguy goodguys) + (cdr reason) + (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by " + (consp badguy) badguy goodguys))) + (:unknown-gf-keywords + (let ((badguys (cadr reason))) + (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys))) + (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by " + + (consp badguys) badguys)))) + (format stream + (ecase type + (:ftype-mismatch "the FTYPE declaration of ~s") + (:global-mismatch "the current global definition of ~s") + (:environment-mismatch "the definition of ~s visible in the current compilation unit.") + (:lexical-mismatch "the lexically visible definition of ~s") + ;; This can happen when compiling without compilation unit: + (:deferred-mismatch "~s")) + callee))) + +(defparameter *compiler-warning-formats* + '((:special . "Undeclared free variable ~S") + (:unused . "Unused lexical variable ~S") + (:ignore . "Variable ~S not ignored.") + (:undefined-function . "Undefined function ~S") ;; (deferred) + (:undefined-type . "Undefined type ~S") ;; (deferred) + (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored") + (:bad-declaration . "Unknown or invalid declaration ~S") + (:invalid-type . report-invalid-type-compiler-warning) + (:unknown-declaration-variable . "~s declaration for unknown variable ~s") + (:unknown-declaration-function . "~s declaration for unknown function ~s") + (:macro-used-before-definition . "Macro function ~S was used before it was defined.") + (:unsettable . "Shouldn't assign to variable ~S") + (:global-mismatch . report-compile-time-argument-mismatch) + (:environment-mismatch . report-compile-time-argument-mismatch) + (:lexical-mismatch . report-compile-time-argument-mismatch) + (:ftype-mismatch . report-compile-time-argument-mismatch) + (:deferred-mismatch . report-compile-time-argument-mismatch) + (:type . "Type declarations violated in ~S") + (:type-conflict . "Conflicting type declarations for ~S") + (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.") + (:lambda . "Suspicious lambda-list: ~s") + (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods") + (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s") + (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions") + (:result-ignored . "Function result ignored in call to ~s") + (:duplicate-definition . report-compile-time-duplicate-definition) + (:format-error . "~:{~@?~%~}") + (:program-error . "~a") + (:unsure . "Nonspecific warning"))) + +(defun report-invalid-type-compiler-warning (condition stream) + (destructuring-bind (type &optional why) (compiler-warning-args condition) + (when (typep why 'invalid-type-specifier) + (setq type (invalid-type-specifier-typespec why) why nil)) + (format stream "Invalid type specifier ~S~@[: ~A~]" type why))) + +(defun report-compile-time-duplicate-definition (condition stream) + (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition) + (format stream + "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]" + (maybe-setf-name name) from to + (and old-file new-file) + (neq old-file new-file) + old-file))) + +(defun adjust-compiler-warning-args (warning-type args) + (case warning-type + ((:undefined-function :result-ignored) (mapcar #'maybe-setf-name args)) + (t args))) + + +(defun report-compiler-warning (condition stream &key short) + (let* ((warning-type (compiler-warning-warning-type condition)) + (format-string (cdr (assq warning-type *compiler-warning-formats*))) + (warning-args (compiler-warning-args condition))) + (unless short + (let ((name (reverse (compiler-warning-function-name condition)))) + (format stream "In ") + (print-nested-name name stream) + (when (every #'null name) + (let ((position (source-note-start-pos (compiler-warning-source-note condition)))) + (when position (format stream " at position ~s" position)))) + (format stream ": "))) + (if (typep format-string 'string) + (apply #'format stream format-string (adjust-compiler-warning-args warning-type warning-args)) + (if (null format-string) + (format stream "~A: ~S" warning-type warning-args) + (funcall format-string condition stream))) + ;(format stream ".") + (let ((nrefs (compiler-warning-nrefs condition))) + (when nrefs + (format stream " (~D references)" (length nrefs)))))) + +(defun environment-structref-info (name env) + (let ((defenv (definition-environment env))) + (when defenv + (cdr (assq name (defenv.structrefs defenv)))))) + +; end Index: /branches/qres/ccl/compiler/nx.lisp =================================================================== --- /branches/qres/ccl/compiler/nx.lisp (revision 13564) +++ /branches/qres/ccl/compiler/nx.lisp (revision 13564) @@ -0,0 +1,228 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel) + (require 'nxenv) + (require 'numbers) + (require 'sequences) + (require 'optimizers)) + +(eval-when (:load-toplevel :execute :compile-toplevel) + (require 'numbers) ; just calls 'logcount' and 'integer-length' + (require 'sort) ; just calls '%sort-list-no-keys' + (require 'hash)) + +(%include "ccl:compiler;nx-basic.lisp") + +(eval-when (:load-toplevel :execute) + (require "DEFSTRUCT")) + +(defparameter *nx-start* (cons nil nil)) + + +(defvar *host-backend*) +(defvar *target-backend*) + +(defun find-backend (name) + (find name *known-backends* :key #'backend-name)) + +(eval-when (:load-toplevel :execute :compile-toplevel) + (require "DLL-NODE") + #+ppc-target + (require "PPC32-ARCH") + (require "VREG") + #+ppc-target + (require "PPC-ASM") + (require "VINSN") + (require "REG") + (require "SUBPRIMS") + #+ppc-target + (require "PPC-LAP") +) +(%include "ccl:compiler;nx0.lisp") +(%include "ccl:compiler;nx1.lisp") + +; put this in nx-basic too +;(defvar *lisp-compiler-version* 666 "I lost count.") + +; At some point, COMPILE refused to compile things that were defined +; in a non-null lexical environment (or so I remember.) That seems +; to have been broken when the change of 10/11/93 was made. +; It makes no sense to talk about compiling something that was defined +; in a lexical environment in which there are symbol or function bindings +; present; I'd thought that the old code checked for this, though it +; may well have botched it. +(defun compile (spec &optional def &aux (macro-p nil)) + "Coerce DEFINITION (by default, the function whose name is NAME) + to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P), + where if NAME is NIL, THING is the result of compilation, and + otherwise THING is NAME. When NAME is not NIL, the compiled function + is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into + (FDEFINITION NAME) otherwise." + (unless def + (setq def (fboundp spec)) + (when (and (symbolp spec) (not (lfunp def))) + (setq def (setq macro-p (macro-function spec))))) + #+have-interpreted-functions + (when (typep def 'interpreted-function) + (let ((lambda (function-lambda-expression def))) + (when lambda (setq def lambda)))) + (unless def + (nx-error "Can't find compilable definition for ~S." spec)) + (multiple-value-bind (lfun warnings) + (if (functionp def) + def + (compile-named-function def + :name spec + :keep-lambda *save-definitions* + :keep-symbols *save-local-symbols*)) + (let ((harsh nil) (some nil) (init t)) + (dolist (w warnings) + (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some)) + (setq init nil)) + (values + (if spec + (progn + (if macro-p + (setf (macro-function spec) lfun) + (setf (fdefinition spec) lfun)) + spec) + lfun) + some + harsh)))) + +(defparameter *default-compiler-policy* (new-compiler-policy)) + +(defun current-compiler-policy () *default-compiler-policy*) + +(defun set-current-compiler-policy (&optional new-policy) + (setq *default-compiler-policy* + (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy)))) + +#+ppc-target +(defun xcompile-lambda (target def) + (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit)) + (backend (find-backend target)) + (*target-ftd* (if backend + (backend-target-foreign-type-data backend) + *target-ftd*)) + (*target-backend* (or backend *target-backend*))) + (multiple-value-bind (xlfun warnings) + (compile-named-function def :target target) + (signal-or-defer-warnings warnings nil) + (ppc-xdisassemble xlfun :target target) + xlfun))) + +(defun compile-user-function (def name &optional env) + (multiple-value-bind (lfun warnings) + (compile-named-function def + :name name + :env env + :keep-lambda *save-definitions* + :keep-symbols *save-local-symbols*) + (signal-or-defer-warnings warnings env) + lfun)) + +(defun signal-or-defer-warnings (warnings env) + (let* ((defenv (definition-environment env)) + (init t) + (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*))) + (dolist (w warnings) + (if (and defer (typep w 'undefined-reference)) + (push w (deferred-warnings.warnings defer)) + (progn + (signal-compiler-warning w init nil nil nil) + (setq init nil)))))) + +(defparameter *load-time-eval-token* nil) + +(defparameter *nx-discard-xref-info-hook* nil) + +(defparameter *nx-in-frontend* nil) + +(defun compile-named-function (def &key name env policy load-time-eval-token target + function-note keep-lambda keep-symbols source-notes + (record-pc-mapping *record-pc-mapping*) + (compile-code-coverage *compile-code-coverage*)) + ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations, + ;; is used to produce and attach a pc/source map to the lfun, also to attach + ;; source locations and pc/source maps to inner lfuns. + ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun + ;; source location in preference to whatever the source-notes table assigns to it. + (when (and name *nx-discard-xref-info-hook*) + (funcall *nx-discard-xref-info-hook* name)) + (setq + def + (let* ((*load-time-eval-token* load-time-eval-token) + (*nx-source-note-map* source-notes) + (*nx-current-note* function-note) + (*record-pc-mapping* (and source-notes record-pc-mapping)) + (*compile-code-coverage* (and source-notes compile-code-coverage)) + (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*) + (make-hash-table :test #'eq :shared nil))) + (*nx-current-code-note* (and *compile-code-coverage* + (make-code-note :form def :source-note function-note))) + (env (new-lexical-environment env))) + (setf (lexenv.variables env) 'barrier) + (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*)) + (*nx-in-frontend* t) + (afunc (nx1-compile-lambda + name + def + (make-afunc) + nil + env + (or policy *default-compiler-policy*) + *load-time-eval-token*))) + (setq *nx-in-frontend* nil) + (if (afunc-lfun afunc) + afunc + (funcall (backend-p2-compile *target-backend*) + afunc + ;; will also bind *nx-lexical-environment* + (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def)) + keep-symbols))))) + (values (afunc-lfun def) (afunc-warnings def))) + +(defparameter *compiler-whining-conditions* + '((:undefined-function . undefined-function-reference) + (:undefined-type . undefined-type-reference) + (:deferred-mismatch . undefined-keyword-reference) + (:invalid-type . invalid-type-warning) + (:global-mismatch . invalid-arguments-global) + (:lexical-mismatch . invalid-arguments) + (:environment-mismatch . invalid-arguments) + (:ftype-mismatch . invalid-arguments) + (:ignore . style-warning) + (:result-ignored . style-warning) + (:lambda . style-warning) + (:format-error . style-warning) + (:unused . style-warning))) + + + +(defun compiler-bug (format &rest args) + (error (make-condition 'compiler-bug + :format-control format + :format-arguments args))) + + +(defparameter *nx-end* (cons nil nil)) +(provide 'nx) + Index: /branches/qres/ccl/compiler/nx0.lisp =================================================================== --- /branches/qres/ccl/compiler/nx0.lisp (revision 13564) +++ /branches/qres/ccl/compiler/nx0.lisp (revision 13564) @@ -0,0 +1,2834 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") + +;; :compiler:nx0.lisp - part of the compiler + + +(defstruct pending-declarations + vdecls + fdecls + mdecls) + +; Phony AFUNC "defstruct": +(defun make-afunc (&aux (v (%make-afunc))) + (setf (afunc-fn-refcount v) 0) + (setf (afunc-fn-downward-refcount v) 0) + (setf (afunc-bits v) 0) + v) + +(defvar *compile-code-coverage* nil "True to instrument for code coverage") + +(defvar *nx-blocks* nil) +(defvar *nx-tags* nil) +(defvar *nx-parent-function* nil) +(defvar *nx-current-function* nil) +(defvar *nx-lexical-environment* nil) +(defvar *nx-symbol-macros* nil) +(defvar *nx-inner-functions* nil) +(defvar *nx-cur-func-name* nil) +(defvar *nx-current-note* nil) +(defvar *nx-source-note-map* nil) ;; there might be external refs, from macros. +(defvar *nx-form-type* t) +;(defvar *nx-proclaimed-inline* nil) +;(defvar *nx-proclaimed-inline* (make-hash-table :size 400 :test #'eq)) +(defvar *nx-proclaimed-ignore* nil) +(defvar *nx-parsing-lambda-decls* nil) ; el grosso. +(defparameter *nx-standard-declaration-handlers* nil) +(defparameter *nx-hoist-declarations* t) +(defparameter *nx-loop-nesting-level* 0) +(defvar *nx-break-on-program-errors* t) + +(defvar *nx1-vcells* nil) +(defvar *nx1-fcells* nil) + +(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq)) + + +; The compiler can (generally) use temporary vectors for VARs. +(defun nx-cons-var (name &optional (bits 0)) + (%istruct 'var name bits nil nil nil nil 0 nil)) + + + + +(defvar *nx-lambdalist* (make-symbol "lambdalist")) +(defvar *nx-nil* (list (make-symbol "nil"))) +(defvar *nx-t* (list (make-symbol "t"))) + +(defparameter *nx-current-compiler-policy* (%default-compiler-policy)) + +(defvar *nx-next-method-var* nil) +(defvar *nx-call-next-method-function* nil) + +(defvar *nx-sfname* nil) +(defvar *nx-operators* ()) +(defvar *nx-warnings* nil) + +(defvar *nx1-compiler-special-forms* nil "Real special forms") + +(defmacro without-compiling-code-coverage (&body body) + "Disable code coverage in the lexical scope of the form" + `(compiler-let ((*nx-current-code-note* nil)) + ,@body)) + +(defparameter *nx-never-tail-call* + '(error cerror break warn type-error file-error + signal-program-error signal-simple-program-error + print-call-history + #-bccl %get-frame-pointer + #-bccl break-loop) + "List of functions which never return multiple values and + should never be tail-called.") + +(defvar *cross-compiling* nil "bootstrapping") + + +(defparameter *nx-operator-result-types* + '((#.(%nx1-operator list) . list) + (#.(%nx1-operator memq) . list) + (#.(%nx1-operator %temp-list) . list) + (#.(%nx1-operator assq) . list) + (#.(%nx1-operator cons) . cons) + (#.(%nx1-operator rplaca) . cons) + (#.(%nx1-operator %rplaca) . cons) + (#.(%nx1-operator rplacd) . cons) + (#.(%nx1-operator %rplacd) . cons) + (#.(%nx1-operator %temp-cons) . cons) + (#.(%nx1-operator %i+) . fixnum) + (#.(%nx1-operator %i-) . fixnum) + (#.(%nx1-operator %i*) . fixnum) + (#.(%nx1-operator %ilsl) . fixnum) + (#.(%nx1-operator %ilsr) . fixnum) + (#.(%nx1-operator %iasr) . fixnum) + (#.(%nx1-operator %ilogior2) . fixnum) + (#.(%nx1-operator %ilogand2) . fixnum) + (#.(%nx1-operator %ilogxor2) . fixnum) + (#.(%nx1-operator %code-char) . character) + (#.(%nx1-operator schar) . character) + (#.(%nx1-operator length) . fixnum) + (#.(%nx1-operator uvsize) . fixnum) + (#.(%nx1-operator %double-float/-2) . double-float) + (#.(%nx1-operator %double-float/-2!) . double-float) ; no such operator + (#.(%nx1-operator %double-float+-2) . double-float) + (#.(%nx1-operator %double-float+-2!) . double-float) + (#.(%nx1-operator %double-float--2) . double-float) + (#.(%nx1-operator %double-float--2!) . double-float) + (#.(%nx1-operator %double-float*-2) . double-float) + (#.(%nx1-operator %double-float*-2!) . double-float) + (#.(%nx1-operator %short-float/-2) . double-float) + (#.(%nx1-operator %short-float+-2) . double-float) + (#.(%nx1-operator %short-float--2) . double-float) + (#.(%nx1-operator %short-float*-2) . double-float) + (#.(%nx1-operator %double-to-single) . single-float) + (#.(%nx1-operator %single-to-double) . double-float) + (#.(%nx1-operator %fixnum-to-single) . single-float) + (#.(%nx1-operator %fixnum-to-double) . double-float) + (#.(%nx1-operator char-code) . #.`(integer 0 (,char-code-limit))) + )) + +(defparameter *nx-operator-result-types-by-name* + '((%ilognot . fixnum) + (%ilogxor . fixnum) + (%ilogand . fixnum) + (%ilogior . fixnum) + (char-code . #. `(integer 0 (,char-code-limit))))) + +(setq *nx-known-declarations* + '(special inline notinline type ftype function ignore optimize dynamic-extent ignorable + ignore-if-unused settable unsettable + notspecial global-function-name debugging-function-name resident)) + +(defun find-optimize-quantity (name env) + (let ((pair ())) + (loop + (when (listp env) (return)) + (when (setq pair (assq name (lexenv.mdecls env))) + (return (%cdr pair))) + (setq env (lexenv.parent-env env))))) + +(defun debug-optimize-quantity (env) + (or (find-optimize-quantity 'debug env) + *nx-debug*)) + +(defun space-optimize-quantity (env) + (or (find-optimize-quantity 'space env) + *nx-space*)) + +(defun safety-optimize-quantity (env) + (or (find-optimize-quantity 'safety env) + *nx-safety*)) + +(defun speed-optimize-quantity (env) + (or (find-optimize-quantity 'speed env) + *nx-speed*)) + +(defun compilation-speed-optimize-quantity (env) + (or (find-optimize-quantity 'compilation-speed env) + *nx-cspeed*)) + +(defvar *nx-ignore-if-unused* ()) +(defvar *nx-new-p2decls* ()) +(defvar *nx-inlined-self* t) +(defvar *nx-all-vars* nil) +(defvar *nx-bound-vars* nil) +(defvar *nx-punted-vars* nil) +(defvar *nx-inline-expansions* nil) +(defparameter *nx-compile-time-compiler-macros* nil) +(defvar *nx-global-function-name* nil) +(defvar *nx-can-constant-fold* ()) +(defvar *nx-synonyms* ()) +(defvar *nx-load-time-eval-token* ()) + +(define-condition compiler-function-overflow (condition) ()) + +(defun compiler-function-overflow () + (signal 'compiler-function-overflow) + (error "Function size exceeds compiler limitation.")) + +(defvar *compiler-macros* (make-hash-table :size 100 :test #'eq)) + +;;; Just who was responsible for the "FUNCALL" nonsense ? +;;; Whoever it is deserves a slow and painful death ... + +(defmacro define-compiler-macro (name arglist &body body &environment env) + "Define a compiler-macro for NAME." + (let* ((block-name name) + (def-name (validate-function-name name))) + (unless (eq def-name block-name) + (setq block-name (cadr block-name))) + (let ((body (parse-macro-1 block-name arglist body env))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (eval-when (:load-toplevel :execute) + (record-source-file ',name 'compiler-macro)) + (setf (compiler-macro-function ',name) + (nfunction (compiler-macro-function ,name) ,body)) + ',name)))) + +;;; This is silly (as may be the whole idea of actually -using- +;;; compiler-macros). Compiler-macroexpand-1 will return a second +;;; value of NIL if the value returned by the expansion function is EQ +;;; to the original form. This differs from the behavior of +;;; macroexpand-1, but users are not encouraged to write macros which +;;; return their &whole args (as the DEFINE-COMPILER-MACRO issue +;;; encourages them to do ...) Cheer up! Neither of these things have +;;; to exist! +(defun compiler-macroexpand-1 (form &optional env) + (let ((expander nil) + (newdef nil)) + (if (and (consp form) + (symbolp (car form)) + (setq expander (compiler-macro-function (car form) env))) + (values (setq newdef (funcall *macroexpand-hook* expander form env)) (neq newdef form)) + (values form nil)))) + +; ... If this exists, it should probably be exported. +(defun compiler-macroexpand (form &optional env) + (multiple-value-bind (new win) (compiler-macroexpand-1 form env) + (do* ((won-at-least-once win)) + ((null win) (values new won-at-least-once)) + (multiple-value-setq (new win) (compiler-macroexpand-1 new env))))) + + + + +(defun compiler-macro-function (name &optional env) + "If NAME names a compiler-macro in ENV, return the expansion function, else + return NIL. Can be set with SETF when ENV is NIL." + (setq name (validate-function-name name)) + (unless (nx-lexical-finfo name env) + (or (cdr (assq name *nx-compile-time-compiler-macros*)) + (values (gethash name *compiler-macros*))))) + +(defun set-compiler-macro-function (name def) + (setq name (validate-function-name name)) + (if def + (setf (gethash name *compiler-macros*) def) + (remhash name *compiler-macros*)) + def) + +(defsetf compiler-macro-function set-compiler-macro-function) + +(defparameter *nx-add-xref-entry-hook* nil + "When non-NIL, assumed to be a function of 3 arguments +which asserts that the specied relation from the current +function to the indicated name is true.") + +;; Cross-referencing +(defun nx-record-xref-info (relation name) + (let* ((axe (fboundp '%add-xref-entry))) + (when axe + (funcall axe relation *nx-cur-func-name* name)))) + + + +(defun nx-apply-env-hook (hook env &rest args) + (declare (dynamic-extent args)) + (when (fixnump hook) (setq hook (uvref *nx-current-compiler-policy* hook))) + (if hook + (if (functionp hook) + (apply hook env args) + t))) + +(defun nx-self-calls-inlineable (env) + (nx-apply-env-hook policy.inline-self-calls env)) + +(defun nx-allow-register-allocation (env) + (not (nx-apply-env-hook policy.inhibit-register-allocation env))) + +(defun nx-trust-declarations (env) + (unless (eq (safety-optimize-quantity env) 3) + (nx-apply-env-hook policy.trust-declarations env))) + +(defun nx-open-code-in-line (env) + (nx-apply-env-hook policy.open-code-inline env)) + +(defun nx-inline-car-cdr (env) + (unless (eq (safety-optimize-quantity env) 3) + (nx-apply-env-hook policy.inhibit-safety-checking env))) + +(defun nx-inhibit-safety-checking (env) + (unless (eq (safety-optimize-quantity env) 3) + (nx-apply-env-hook policy.inhibit-safety-checking env))) + +(defun nx-tailcalls (env) + (nx-apply-env-hook policy.allow-tail-recursion-elimination env)) + +(defun nx-allow-transforms (env) + (nx-apply-env-hook policy.allow-transforms env)) + +(defun nx-force-boundp-checks (var env) + (or (eq (safety-optimize-quantity env) 3) + (nx-apply-env-hook policy.force-boundp-checks var env))) + +(defun nx-substititute-constant-value (symbol value env) + (nx-apply-env-hook policy.allow-constant-substitution symbol value env)) + +(defun nx-declarations-typecheck (env) + (nx-apply-env-hook policy.declarations-typecheck env)) + + +#-bccl +(defun nx1-default-operator () + (or (gethash *nx-sfname* *nx1-operators*) + (error "Bug - operator not found for ~S" *nx-sfname*))) + +(defun nx-new-temp-var (pending &optional (pname "COMPILER-VAR")) + (let ((var (nx-new-var pending (make-symbol pname)))) + (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) + (%ilsl $vbittemporary 1) + (nx-var-bits var))) + var)) + +(defun nx-new-vdecl (pending name class &optional info) + (push (cons name (cons class info)) (pending-declarations-vdecls pending))) + +(defun nx-new-fdecl (pending name class &optional info) + (push (cons name (cons class info)) (pending-declarations-fdecls pending))) + +(defun nx-new-var (pending sym &optional (check t)) + (nx-init-var pending (nx-cons-var (nx-need-var sym check) 0))) + +(defun nx-proclaimed-special-p (sym) + (setq sym (nx-need-sym sym)) + (let* ((defenv (definition-environment *nx-lexical-environment*)) + (specials (if defenv (defenv.specials defenv)))) + (or (assq sym specials) + (proclaimed-special-p sym)))) + +(defun nx-proclaimed-parameter-p (sym) + (setq sym (nx-need-sym sym)) + (or (constantp sym) + (multiple-value-bind (special-p info) (nx-lex-info sym t) + (or + (and (eq special-p :special) info) + (let* ((defenv (definition-environment *nx-lexical-environment*))) + (if defenv + (or (%cdr (assq sym (defenv.specials defenv))) + (assq sym (defenv.constants defenv))))))))) + +(defun nx-process-declarations (pending decls &optional (env *nx-lexical-environment*) &aux s f) + (dolist (decl decls pending) + (dolist (spec (%cdr decl)) + (if (memq (setq s (car spec)) *nx-known-declarations*) + (if (setq f (getf *nx-standard-declaration-handlers* s)) + (funcall f pending spec env)) + ; Any type name is now (ANSI CL) a valid declaration. + (if (specifier-type-if-known s env) + (nx-process-type-decl pending spec s (%cdr spec) env) + (nx-bad-decls spec)))))) + +; Put all variable decls for the symbol VAR into effect in environment ENV. Now. +; Returns list of all new vdecls pertaining to VAR. +(defun nx-effect-vdecls (pending var env) + (let ((vdecls (lexenv.vdecls env)) + (own nil)) + (dolist (decl (pending-declarations-vdecls pending) (setf (lexenv.vdecls env) vdecls)) + (when (eq (car decl) var) + (when (eq (cadr decl) 'type) + (let* ((newtype (cddr decl)) + (merged-type (nx1-type-intersect var newtype (nx-declared-type var env)))) + (unless (eq merged-type newtype) + (rplacd (cdr decl) merged-type)))) + (push decl vdecls) + (push (cdr decl) own))) + own)) + + +(defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*)) + (let* ((type t) + (*nx-form-type* (if (nx-trust-declarations env) + (dolist (decl (pending-declarations-vdecls pending) type) + (when (and (eq (car decl) sym) (eq (cadr decl) 'type)) + (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl))))) + t))) + (nx1-typed-form form env))) + +; Guess. +(defun nx-effect-fdecls (pending var env) + (let ((fdecls (lexenv.fdecls env)) + (own nil)) + (dolist (decl (pending-declarations-fdecls pending) (setf (lexenv.fdecls env) fdecls)) + (when (eq (car decl) var) + (push decl fdecls) + (push (cdr decl) own))) + own)) + + + + +(defun nx-acode-form-typep (form type env) + (acode-form-typep form type (nx-trust-declarations env))) + +(defun acode-form-typep (form type trust-decls) + (if (acode-p form) + (let* ((op (acode-operator form)) + (opval-p (or (eq op (%nx1-operator fixnum)) (eq op (%nx1-operator immediate)))) + (optype (acode-form-type form trust-decls))) + (values + (if optype + (subtypep optype (nx-target-type type)) + (if opval-p (typep (%cadr form) (nx-target-type type)))))))) + +(defun nx-acode-form-type (form env) + (acode-form-type form (nx-trust-declarations env))) + +(defparameter *numeric-acode-ops* + (list (%nx1-operator add2) + (%nx1-operator sub2) + (%nx1-operator mul2))) + + + +(defun acode-form-type (form trust-decls &optional (assert t)) + (let* ((typespec + (if (nx-null form) + 'null + (if (eq form *nx-t*) + 'boolean + (nx-target-type + (if (acode-p form) + (let* ((op (acode-operator form))) + (if (eq op (%nx1-operator fixnum)) + 'fixnum + (if (eq op (%nx1-operator immediate)) + (type-of (%cadr form)) + (and trust-decls + (if (eq op (%nx1-operator type-asserted-form)) + (progn + (setq assert nil) + (%cadr form)) + (if (eq op (%nx1-operator typed-form)) + (progn + (when (and assert (null (nth 3 form))) + (setf (%car form) (%nx1-operator type-asserted-form) + assert nil)) + (if (eq (%cadr form) 'number) + (or (acode-form-type (nx-untyped-form form) trust-decls) + 'number) + (%cadr form))) + (if (eq op (%nx1-operator lexical-reference)) + (locally (declare (special *nx-in-frontend*)) + (unless *nx-in-frontend* + (let* ((var (cadr form)) + (bits (nx-var-bits var)) + (punted (logbitp $vbitpunted bits))) + (if (or punted + (eql 0 (%ilogand $vsetqmask bits))) + (var-inittype var))))) + (if (or (eq op (%nx1-operator %aref1)) + (eq op (%nx1-operator simple-typed-aref2)) + (eq op (%nx1-operator general-aref2)) + (eq op (%nx1-operator simple-typed-aref3)) + (eq op (%nx1-operator general-aref3))) + (let* ((atype (acode-form-type (cadr form) t)) + (actype (if atype (specifier-type atype)))) + (if (typep actype 'array-ctype) + (type-specifier (array-ctype-specialized-element-type + actype)))) + (if (member op *numeric-acode-ops*) + (multiple-value-bind (f1 f2) + (nx-binop-numeric-contagion (cadr form) + (caddr form) + trust-decls) + (if (and (acode-form-typep f1 'float trust-decls) + (acode-form-typep f2 'float trust-decls)) + + (if (or (acode-form-typep f1 'double-float trust-decls) + (acode-form-typep f2 'double-float trust-decls)) + 'double-float + 'single-float))) + (cdr (assq op *nx-operator-result-types*))))))))))))))))) + (when (and (acode-p form) (typep (acode-operator form) 'fixnum) assert) + (unless typespec (setq typespec t)) + (let* ((new (cons typespec (cons (cons (%car form) (%cdr form)) nil)))) + (setf (%car form) (%nx1-operator type-asserted-form) + (%cdr form) new))) + typespec)) + +(defun nx-binop-numeric-contagion (form1 form2 trust-decls) + (cond ((acode-form-typep form1 'double-float trust-decls) + (if (acode-form-typep form2 'double-float trust-decls) + (values form1 form2) + (let* ((c2 (acode-real-constant-p form2))) + (if c2 + (values form1 (make-acode (%nx1-operator immediate) + (float c2 0.0d0))) + (if (acode-form-typep form2 'fixnum trust-decls) + (values form1 (make-acode (%nx1-operator %fixnum-to-double) + form2)) + (values form1 form2)))))) + ((acode-form-typep form2 'double-float trust-decls) + (let* ((c1 (acode-real-constant-p form1))) + (if c1 + (values (make-acode (%nx1-operator immediate) + (float c1 0.0d0)) form2) + (if (acode-form-typep form1 'fixnum trust-decls) + (values (make-acode (%nx1-operator %fixnum-to-double) + form1) form2) + (values form1 form2))))) + ((acode-form-typep form1 'single-float trust-decls) + (if (acode-form-typep form2 'single-float trust-decls) + (values form1 form2) + (let* ((c2 (acode-real-constant-p form2))) + (if c2 + (values form1 (make-acode (%nx1-operator immediate) + (float c2 0.0f0))) + (if (acode-form-typep form2 'fixnum trust-decls) + (values form1 (make-acode (%nx1-operator %fixnum-to-single) + form2)) + (values form1 form2)))))) + ((acode-form-typep form2 'single-float trust-decls) + (let* ((c1 (acode-real-constant-p form1))) + (if c1 + (values (make-acode (%nx1-operator immediate) + (float c1 0.0f0)) form2) + (if (acode-form-typep form1 'fixnum trust-decls) + (values (make-acode (%nx1-operator %fixnum-to-single) + form1) form2) + (values form1 form2))))) + (t + (values form1 form2)))) + +(defun acode-punted-var-p (var) + (let ((bits (nx-var-bits var))) + (and (%ilogbitp $vbitpunted bits) + (not (%ilogbitp $vbitspecial bits))))) + +;; Use acode-unwrapped-form-value to reason about the value of a form at +;; compile time. To actually generate code, use acode-unwrapped-form. +(defun acode-unwrapped-form-value (form) + ;; Currently no difference, but if had any operators like with-code-note, + ;; would unwrap them here. + (acode-unwrapped-form form)) + +; Strip off any type info or "punted" lexical references. +; ??? Is it true that the "value" of the punted reference is unwrapped ? ??? +(defun acode-unwrapped-form (form) + (while (and (consp (setq form (nx-untyped-form form))) + (eq (%car form) (%nx1-operator lexical-reference)) + (acode-punted-var-p (cadr form))) + (setq form (var-ea (cadr form)))) + form) + +(defun acode-fixnum-form-p (x) + (setq x (acode-unwrapped-form-value x)) + (if (acode-p x) + (if (eq (acode-operator x) (%nx1-operator fixnum)) + (cadr x)))) + +(defun acode-integer-constant-p (x bits) + (let* ((int (or (acode-fixnum-form-p x) + (progn + (setq x (acode-unwrapped-form x)) + (if (acode-p x) + (if (and (eq (acode-operator x) (%nx1-operator immediate)) + (typep (cadr x) 'fixnum)) + (cadr x))))))) + (and int + (or + (typep int `(signed-byte ,bits)) + (typep int `(unsigned-byte ,bits))) + int))) + +(defun acode-real-constant-p (x) + (or (acode-fixnum-form-p x) + (progn + (setq x (acode-unwrapped-form x)) + (if (acode-p x) + (if (and (eq (acode-operator x) (%nx1-operator immediate)) + (typep (cadr x) 'real)) + (cadr x)))))) + + + +(defun nx-lookup-target-uvector-subtag (name) + (or (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch *target-backend*)))) + (nx-error "Type ~s not supported on target ~s" + name (backend-target-arch-name *target-backend*)))) + +(defun nx-target-uvector-subtag-name (subtag) + (or (car (rassoc subtag (arch::target-uvector-subtags (backend-target-arch *target-backend*)))) + (nx-error "Subtag ~s not native on target ~s" + subtag (backend-target-arch-name *target-backend*)))) + +(defun nx-error-for-simple-2d-array-type (type-keyword) + (ecase type-keyword + (:simple-vector arch::error-object-not-simple-array-t-2d) + (:simple-string arch::error-object-not-simple-array-char-2d) + (:bit-vector arch::error-object-not-simple-array-bit-2d) + (:unsigned-8-bit-vector arch::error-object-not-simple-array-u8-2d) + (:signed-8-bit-vector arch::error-object-not-simple-array-s8-2d) + (:unsigned-16-bit-vector arch::error-object-not-simple-array-u16-2d) + (:signed-16-bit-vector arch::error-object-not-simple-array-s16-2d) + (:unsigned-32-bit-vector arch::error-object-not-simple-array-u32-2d) + (:signed-32-bit-vector arch::error-object-not-simple-array-s32-2d) + (:unsigned-64-bit-vector arch::error-object-not-simple-array-u64-2d) + (:signed-64-bit-vector arch::error-object-not-simple-array-s64-2d) + (:double-float-vector arch::error-object-not-simple-array-double-float-2d) + (:single-float-vector arch::error-object-not-simple-array-single-float-2d) + (:fixnum-vector arch::error-object-not-simple-array-fixnum-2d))) + +(defun nx-error-for-simple-3d-array-type (type-keyword) + (ecase type-keyword + (:simple-vector arch::error-object-not-simple-array-t-3d) + (:simple-string arch::error-object-not-simple-array-char-3d) + (:bit-vector arch::error-object-not-simple-array-bit-3d) + (:unsigned-8-bit-vector arch::error-object-not-simple-array-u8-3d) + (:signed-8-bit-vector arch::error-object-not-simple-array-s8-3d) + (:unsigned-16-bit-vector arch::error-object-not-simple-array-u16-3d) + (:signed-16-bit-vector arch::error-object-not-simple-array-s16-3d) + (:unsigned-32-bit-vector arch::error-object-not-simple-array-u32-3d) + (:signed-32-bit-vector arch::error-object-not-simple-array-s32-3d) + (:unsigned-64-bit-vector arch::error-object-not-simple-array-u64-3d) + (:signed-64-bit-vector arch::error-object-not-simple-array-s64-3d) + (:double-float-vector arch::error-object-not-simple-array-double-float-3d) + (:single-float-vector arch::error-object-not-simple-array-single-float-3d) + (:fixnum-vector arch::error-object-not-simple-array-fixnum-3d))) + +(defun acode-s16-constant-p (x) + (setq x (acode-unwrapped-form x)) + (if (acode-p x) + (let* ((op (acode-operator x))) + (if (eql op (%nx1-operator fixnum)) + (let* ((val (cadr x))) + (if (target-word-size-case + (32 (typep val '(signed-byte #.(- 16 2)))) + (64 (typep val '(signed-byte #.(- 16 3))))) + (ash val (target-word-size-case + (32 2) + (64 3))))) + (if (eql op (%nx1-operator %unbound-marker)) + (arch::target-unbound-marker-value + (backend-target-arch *target-backend*)) + (if (eql op (%nx1-operator %slot-unbound-marker)) + (arch::target-slot-unbound-marker-value + (backend-target-arch *target-backend*)))))))) + +(defun acode-s32-constant-p (x) + (setq x (acode-unwrapped-form x)) + (if (acode-p x) + (let* ((op (acode-operator x))) + (if (eql op (%nx1-operator fixnum)) + (let* ((val (cadr x))) + (if (target-word-size-case + (32 (typep val '(signed-byte #.(- 32 2)))) + (64 (typep val '(signed-byte #.(- 32 3))))) + (ash val (target-word-size-case + (32 2) + (64 3))))) + (if (eql op (%nx1-operator %unbound-marker)) + (arch::target-unbound-marker-value + (backend-target-arch *target-backend*)) + (if (eql op (%nx1-operator %slot-unbound-marker)) + (arch::target-slot-unbound-marker-value + (backend-target-arch *target-backend*)))))))) + +(defun acode-fixnum-type-p (form trust-decls) + (or (acode-fixnum-form-p form) + (and trust-decls + (acode-p form) + (eq (acode-operator form) (%nx1-operator typed-form)) + (subtypep (cadr form) 'fixnum)))) + + +(defun nx-acode-fixnum-type-p (form env) + (acode-fixnum-type-p form (nx-trust-declarations env))) + +; Is acode-expression the result of alphatizing (%int-to-ptr ) ? +(defun acode-absolute-ptr-p (acode-expression &optional skip) + (and (acode-p acode-expression) + (or skip (prog1 (eq (acode-operator acode-expression) (%nx1-operator %macptrptr%)) + (setq acode-expression (%cadr acode-expression)))) + (eq (acode-operator acode-expression) (%nx1-operator %consmacptr%)) + (eq (acode-operator (setq acode-expression (%cadr acode-expression))) + (%nx1-operator %immediate-int-to-ptr)) + (let ((op (acode-operator (setq acode-expression (%cadr acode-expression))))) + (if (or (eq op (%nx1-operator fixnum)) + (and (eq op (%nx1-operator immediate)) + (integerp (%cadr acode-expression)))) + (%cadr acode-expression))))) + +(defun specifier-type-if-known (typespec &optional env &key whine values) + (handler-case (if values (values-specifier-type typespec env) (specifier-type typespec env)) + (parse-unknown-type (c) + (when (and whine *compiler-warn-on-undefined-type-references*) + (nx1-whine :undefined-type typespec)) + (values nil (parse-unknown-type-specifier c))) + ;; catch any errors due to destructuring in type-expand + (program-error (c) + (when whine + (nx1-whine :invalid-type typespec c)) + (values nil typespec)))) + +#+debugging-version +(defun specifier-type-if-known (typespec &optional env &key whine) + (handler-bind ((parse-unknown-type (lambda (c) + (break "caught unknown-type ~s" c) + (when (and whine *compiler-warn-on-undefined-type-references*) + (nx1-whine :undefined-type typespec)) + (return-from specifier-type-if-known + (values nil (parse-unknown-type-specifier c))))) + (program-error (lambda (c) + (break "caught program-error ~s" c) + (when whine + (nx1-whine :invalid-type typespec c)) + (return-from specifier-type-if-known + (values nil typespec))))) + (specifier-type typespec env))) + +(defun nx-check-vdecl-var-ref (decl) + (unless (eq (cadr decl) 'special) + (let* ((sym (car decl)) + (info (nx-lex-info sym))) + (when (or (eq info :symbol-macro) + (and (null info) (not (nx-proclaimed-special-p sym)))) + (nx1-whine :unknown-declaration-variable (cadr decl) sym))))) + +(defun nx-check-fdecl-var-ref (decl env &aux (sym (car decl))) + (unless (eq (cadr decl) 'ftype) + ;; Complain about forward references, since need a def to use the declaration. + ;; Perhaps should complain if regular macro, but don't for now. Compiler macros + ;; specifically allowed by spec for inline decls + (unless (or (nx-lexical-finfo sym env) + (fboundp sym) + (retrieve-environment-function-info sym env) + (gethash sym *nx1-alphatizers*) + (assq sym *nx-compile-time-compiler-macros*) + (gethash sym *compiler-macros*) + (eq sym *nx-global-function-name*)) + (nx1-whine :unknown-declaration-function (cadr decl) sym)))) + + +(defun nx-effect-other-decls (pending env) + (flet ((merge-decls (new old) + (dolist (decl new old) (pushnew decl old :test #'eq)))) + (let ((vdecls (pending-declarations-vdecls pending)) + (fdecls (pending-declarations-fdecls pending)) + (mdecls (pending-declarations-mdecls pending))) + (when vdecls + (let ((env-vdecls (lexenv.vdecls env))) + (dolist (decl vdecls (setf (lexenv.vdecls env) env-vdecls)) + (unless (memq decl env-vdecls) + (nx-check-vdecl-var-ref decl) + (when (eq (cadr decl) 'type) + (let* ((var (car decl)) + (newtype (cddr decl)) + (merged-type (nx1-type-intersect var newtype (nx-declared-type var env)))) + (unless (eq merged-type newtype) + (rplacd (cdr decl) merged-type)))) + (push decl env-vdecls))))) + (when fdecls + (let ((env-fdecls (lexenv.fdecls env))) + (dolist (decl fdecls (setf (lexenv.fdecls env) env-fdecls)) + (unless (memq decl env-fdecls) + (nx-check-fdecl-var-ref decl env) + (push decl env-fdecls))))) + (when mdecls (setf (lexenv.mdecls env) (merge-decls mdecls (lexenv.mdecls env)))) + (setq *nx-inlined-self* (and (nx-self-calls-inlineable env) + (let ((name *nx-global-function-name*)) + (and name (not (nx-declared-notinline-p name env)))))) + (unless (nx-allow-register-allocation env) + (nx-inhibit-register-allocation)) + (setq *nx-new-p2decls* + (if (eql (safety-optimize-quantity env) 3) + (logior $decl_full_safety + (if (nx-tailcalls env) $decl_tailcalls 0)) + (%ilogior + (if (nx-tailcalls env) $decl_tailcalls 0) + (if (nx-open-code-in-line env) $decl_opencodeinline 0) + (if (nx-inhibit-safety-checking env) $decl_unsafe 0) + (if (nx-trust-declarations env) $decl_trustdecls 0))))))) + +#| +(defun nx-find-misc-decl (declname env) + (loop + (unless (and env (eq (uvref env 0) 'lexical-environment)) (return)) + (dolist (mdecl (lexenv.mdecls env)) + (if (atom mdecl) + (if (eq mdecl declname) + (return-from nx-find-misc-decl t)) + (if (eq (%car mdecl) declname) + (return-from nx-find-misc-decl (%cdr mdecl))))) + (setq env (lexenv.parent-env env)))) +|# + + +(defun nx-bad-decls (decls) + (nx1-whine :bad-declaration decls)) + + +(defnxdecl special (pending decl env &aux whined) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'special) + (unless (shiftf whined t) (nx-bad-decls decl))))) + +(defnxdecl notspecial (pending decl env &aux whined) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'notspecial) + (unless (shiftf whined t) (nx-bad-decls decl))))) + +(defnxdecl dynamic-extent (pending decl env &aux whined) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'dynamic-extent t) + (if (and (consp s) + (eq (%car s) 'function) + (consp (%cdr s)) + (valid-function-name-p (cadr s)) + (setq s (validate-function-name (cadr s)))) + (nx-new-fdecl pending s 'dynamic-extent t) + (unless (shiftf whined t) (nx-bad-decls decl)))))) + +(defnxdecl ignorable (pending decl env &aux whined) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'ignorable) + (if (and (consp s) + (eq (%car s) 'function) + (consp (%cdr s)) + (valid-function-name-p (cadr s)) + (setq s (validate-function-name (cadr s)))) + (nx-new-fdecl pending s 'ignorable) + (unless (shiftf whined t) (nx-bad-decls decl)))))) + +(defnxdecl ftype (pending decl env &aux whined) + (destructuring-bind (type &rest fnames) (%cdr decl) + (let ((ctype (specifier-type-if-known type env))) + (if (null ctype) + (nx1-whine :unknown-type-in-declaration type) + (if (types-disjoint-p ctype (specifier-type 'function)) + (nx-bad-decls decl) + (dolist (s fnames) + (if (or (symbolp s) (setf-function-name-p s)) + (nx-new-fdecl pending s 'ftype type) + (unless (shiftf whined t) (nx-bad-decls decl))))))))) + +(defnxdecl settable (pending decl env) + (nx-settable-decls pending decl env t)) + +(defnxdecl unsettable (pending decl env) + (nx-settable-decls pending decl env nil)) + +(defun nx-settable-decls (pending decl env val &aux whined) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'settable val) + (unless (shiftf whined t) (nx-bad-decls decl))))) + +(defnxdecl function (pending decl env) + (nx-process-type-decl pending decl (car decl) (cdr decl) env)) + +(defnxdecl type (pending decl env) + (nx-process-type-decl pending decl (cadr decl) (cddr decl) env)) + +(defun nx-process-type-decl (pending decl type vars env &aux whined) + (if (specifier-type-if-known type env) + (dolist (sym vars) + (if (symbolp sym) + (nx-new-vdecl pending sym 'type type) + (unless (shiftf whined t) (nx-bad-decls decl)))) + (nx1-whine :unknown-type-in-declaration type))) + +(defnxdecl global-function-name (pending decl env) + (declare (ignore pending)) + (when *nx-parsing-lambda-decls* + (let ((name (cadr decl))) + (setq *nx-global-function-name* (setf (afunc-name *nx-current-function*) name)) + (setq *nx-inlined-self* (not (nx-declared-notinline-p name env)))))) + +(defnxdecl debugging-function-name (pending decl env) + (declare (ignore pending env)) + (when *nx-parsing-lambda-decls* + (setf (afunc-name *nx-current-function*) (cadr decl)))) + +(defnxdecl resident (pending decl env) + (declare (ignore env pending)) + (declare (ignore decl)) + (nx-decl-set-fbit $fbitresident)) + + +(defun nx-inline-decl (pending decl val &aux valid-name whined) + (dolist (s (%cdr decl)) + (multiple-value-setq (valid-name s) (valid-function-name-p s)) + (if valid-name + (progn + (if (nx-self-call-p s nil t) + (setq *nx-inlined-self* val)) + (nx-new-fdecl pending s 'inline (if val 'inline 'notinline))) + (unless (shiftf whined t) (nx-bad-decls decl))))) + +(defnxdecl inline (pending decl env) + (declare (ignore env)) + (nx-inline-decl pending decl t)) + +(defnxdecl notinline (pending decl env) + (declare (ignore env)) + (nx-inline-decl pending decl nil)) + +(defnxdecl ignore (pending decl env &aux whined) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'ignore t) + (if (and (consp s) + (eq (%car s) 'function) + (consp (%cdr s)) + (valid-function-name-p (cadr s)) + (setq s (validate-function-name (cadr s)))) + (nx-new-fdecl pending s 'ignore t) + (unless (shiftf whined t) (nx-bad-decls decl)))))) + +(defnxdecl ignore-if-unused (pending decl env &aux whined) + (declare (ignore env)) + (dolist (s (%cdr decl)) + (if (symbolp s) + (nx-new-vdecl pending s 'ignore-if-unused) + (unless (shiftf whined t) (nx-bad-decls decl))))) + +(defun nx-self-call-p (name &optional ignore-lexical (allow *nx-inlined-self*)) + (when (and name (symbolp name)) + (let ((current-afunc *nx-current-function*) + (target-afunc (unless ignore-lexical (nth-value 1 (nx-lexical-finfo name))))) + (or (eq current-afunc target-afunc) + (and allow + (eq name *nx-global-function-name*) + (null target-afunc) + (null (afunc-parent current-afunc))))))) + +(defun nx-check-var-usage (var) + (let* ((sym (var-name var)) + (bits (nx-var-bits var)) + (expansion (var-ea var)) + (setqed (%ilogbitp $vbitsetq bits)) + (reffed (%ilogbitp $vbitreffed bits)) + (closed (%ilogbitp $vbitclosed bits)) + (special (%ilogbitp $vbitspecial bits)) + (ignored (%ilogbitp $vbitignore bits)) + (ignoreunused (%ilogbitp $vbitignoreunused bits))) + (if (or special reffed closed) + (progn + (if ignored (nx1-whine :ignore sym)) + (nx-set-var-bits var (%ilogand (nx-check-downward-vcell var bits) (%ilognot (%ilsl $vbitignore 1))))) + (progn + (if (and setqed ignored) (nx1-whine :ignore sym)) + (or ignored ignoreunused + (progn (and (consp expansion) (eq (car expansion) :symbol-macro) (setq sym (list :symbol-macro sym))) (nx1-whine :unused sym))) + (when (%izerop (%ilogand bits (%ilogior $vrefmask $vsetqmask))) + (nx-set-var-bits var (%ilogior (%ilsl $vbitignore 1) bits))))))) + +; if an inherited var isn't setqed, it gets no vcell. If it -is- setqed, but +; all inheritors are downward, the vcell can be stack-consed. Set a bit so that +; the right thing happens when the var is bound. +; Set the bit for the next-method var even if it is not setqed. +(defun nx-check-downward-vcell (v bits) + (if (and (%ilogbitp $vbitclosed bits) + (or (%ilogbitp $vbitsetq bits) + (eq v *nx-next-method-var*)) + (nx-afuncs-downward-p v (afunc-inner-functions *nx-current-function*))) + (%ilogior (%ilsl $vbitcloseddownward 1) bits) + bits)) + +; afunc is "downward wrt v" if it doesn't inherit v or if all refs to afunc +; are "downward" and no inner function of afunc is not downward with respect to v. +(defun nx-afunc-downward-p (v afunc) + (or (dolist (i (afunc-inherited-vars afunc) t) + (when (eq (nx-root-var i) v) (return nil))) + (if (nx-afuncs-downward-p v (afunc-inner-functions afunc)) + (eq (afunc-fn-refcount afunc) + (afunc-fn-downward-refcount afunc))))) + +(defun nx-afuncs-downward-p (v afuncs) + (dolist (afunc afuncs t) + (unless (nx-afunc-downward-p v afunc) (return nil)))) + +(defun nx1-punt-bindings (vars initforms) + (dolist (v vars) + (nx1-punt-var v (pop initforms)))) + +;;; at the beginning of a binding construct, note which lexical +;;; variables are bound to other variables and the number of setqs +;;; done so far on the initform. After executing the body, if neither +;;; variable has been closed over, the new variable hasn't been +;;; setq'ed, and the old guy wasn't setq'ed in the body, the binding +;;; can be punted. +(defun nx1-note-var-binding (var initform) + (let* ((init (nx-untyped-form initform)) + (inittype (nx-acode-form-type initform *nx-lexical-environment*)) + (bits (nx-var-bits var))) + (when (%ilogbitp $vbitspecial bits) (nx-record-xref-info :binds (var-name var))) + (when inittype (setf (var-inittype var) inittype)) + (when (and (not (%ilogbitp $vbitspecial bits)) + (acode-p init)) + (let* ((op (acode-operator init))) + (if (eq op (%nx1-operator lexical-reference)) + (let* ((target (%cadr init)) + (setq-count (%ilsr 8 (%ilogand $vsetqmask (nx-var-bits target))))) + (unless (eq setq-count (%ilsr 8 $vsetqmask)) + (cons var (cons setq-count target)))) + (if (and (%ilogbitp $vbitdynamicextent bits) + (or (eq op (%nx1-operator closed-function)) + (eq op (%nx1-operator simple-function)))) + (let* ((afunc (%cadr init))) + (setf (afunc-fn-downward-refcount afunc) + (afunc-fn-refcount afunc) + (afunc-bits afunc) (logior (ash 1 $fbitdownward) (ash 1 $fbitbounddownward) + (the fixnum (afunc-bits afunc)))) + nil))))))) + + +;;; Process entries involving variables bound to other variables at +;;; the end of a binding construct. Each entry is of the form +;;; (source-var setq-count . target-var), where setq-count is the +;;; assignment count of TARGET-VAR at the time that the binding's +;;; initform was evaluated (not, in the case of LET, at the time that +;;; the bindinw was established.). If the target isn't closed-over +;;; and SETQed (somewhere), and wasn't setqed in the body (e.g., +;;; still has the same assignment-count as it had when the initform +;;; was executed), then we can "punt" the source (and replace references +;;; to it with references to the target.) +;;; It obviously makes no sense to do this if the source is SPECIAL; +;;; in some cases (LET), we create the source variable and add it to +;;; this alist before it's known whether or not the source variable +;;; is SPECIAL. so we have to ignore that case here. +(defun nx1-check-var-bindings (alist) + (dolist (pair alist) + (let* ((var (car pair)) + (target (cddr pair)) + (vbits (nx-var-bits var)) + (target-bits (nx-var-bits target))) + (unless (or + ;; var can't be special, setq'ed or closed; target can't be + ;; setq'ed AND closed. + (neq (%ilogand vbits (%ilogior (%ilsl $vbitsetq 1) + (%ilsl $vbitclosed 1) + (%ilsl $vbitspecial 1))) 0) + (eq (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1)) + (%ilogand + (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1)) + target-bits)) + (neq (%ilsr 8 (%ilogand $vsetqmask target-bits)) (cadr pair))) + (push (cons var target) *nx-punted-vars*))))) + +(defun nx1-punt-var (var initform) + (let* ((bits (nx-var-bits var)) + (mask (%ilogior (%ilsl $vbitsetq 1) (ash -1 $vbitspecial) (%ilsl $vbitclosed 1))) + (nrefs (%ilogand $vrefmask bits)) + (val (nx-untyped-form initform)) + (op (if (acode-p val) (acode-operator val)))) + (when (%izerop (%ilogand mask bits)) + (if + (or + (nx-t val) + (nx-null val) + (and (eql nrefs 1) (not (logbitp $vbitdynamicextent bits)) ( acode-absolute-ptr-p val t)) + (eq op (%nx1-operator fixnum)) + (eq op (%nx1-operator immediate))) + (progn + (nx-set-var-bits var (%ilogior (%ilsl $vbitpuntable 1) bits))))) + (when (and (%ilogbitp $vbitdynamicextent bits) + (or (eq op (%nx1-operator closed-function)) + (eq op (%nx1-operator simple-function)))) + (let* ((afunc (cadr val))) + (setf (afunc-bits afunc) (%ilogior (%ilsl $fbitbounddownward 1) (afunc-bits afunc)) + (afunc-fn-downward-refcount afunc) 1))) + nil)) + +(defnxdecl optimize (pending specs env) + (declare (ignore env)) + (let* ((q nil) + (v nil) + (mdecls (pending-declarations-mdecls pending))) + (dolist (spec (%cdr specs) (setf (pending-declarations-mdecls pending) mdecls)) + (if (atom spec) + (setq q spec v 3) + (setq q (%car spec) v (cadr spec))) + (if (and (fixnump v) (<= 0 v 3) (memq q '(speed space compilation-speed safety debug))) + (push (cons q v) mdecls) + (nx-bad-decls spec))))) + +(defun %proclaim-optimize (specs &aux q v) + (dolist (spec specs) + (if (atom spec) + (setq q spec v 3) + (setq q (%car spec) v (cadr spec))) + (or (and (fixnump v) + (<= 0 v 3) + (case q + (speed (setq *nx-speed* v)) + (space (setq *nx-space* v)) + (compilation-speed (setq *nx-cspeed* v)) + (safety (setq *nx-safety* v)) + (debug (setq *nx-debug* v)))) + (bad-proclaim-spec `(optimize ,spec))))) + +(defun nx-lexical-finfo (sym &optional (env *nx-lexical-environment*)) + (let* ((info nil) + (barrier-crossed nil)) + (if env + (loop + (when (eq 'barrier (lexenv.variables env)) + (setq barrier-crossed t)) + (when (setq info (%cdr (assq sym (lexenv.functions env)))) + (return (values info (if (and (eq (car info) 'function) + (consp (%cdr info))) + (progn + (when barrier-crossed + (nx-error "Illegal reference to lexically-defined function ~S." sym)) + (%cadr info)))))) + (if (listp (setq env (lexenv.parent-env env))) + (return (values nil nil)))) + (values nil nil)))) + +(defun nx-inline-expansion (sym &optional (env *nx-lexical-environment*) global-only) + (let* ((lambda-form nil) + (containing-env nil) + (token nil)) + (if (and (nx-declared-inline-p sym env) + (not (gethash sym *nx1-alphatizers*)) + (not *nx-current-code-note*)) + (multiple-value-bind (info afunc) (unless global-only (nx-lexical-finfo sym env)) + (if info (setq token afunc + containing-env (afunc-environment afunc) + lambda-form (afunc-lambdaform afunc))) + (setq info (cdr (retrieve-environment-function-info sym env))) + (if (def-info.lambda info) + (setq lambda-form (def-info.lambda info) + token sym + containing-env (new-lexical-environment (definition-environment env))) + (unless info + (if (cdr (setq info (assq sym *nx-globally-inline*))) + (setq lambda-form (%cdr info) + token sym + containing-env (new-lexical-environment (new-definition-environment nil)))))))) + (values lambda-form (nx-closed-environment env containing-env) token))) + +(defun nx-closed-environment (current-env target) + (when target + (let* ((intervening-functions nil)) + (do* ((env current-env (lexenv.parent-env env))) + ((or (eq env target) (null env) (istruct-typep env 'definition-environment))) + (let* ((fn (lexenv.lambda env))) + (when fn (push fn intervening-functions)))) + (let* ((result target)) + (dolist (fn intervening-functions result) + (setf (lexenv.lambda (setq result (new-lexical-environment result))) fn)))))) + +(defun nx-root-var (v) + (do* ((v v bits) + (bits (var-bits v) (var-bits v))) + ((fixnump bits) v))) + +(defun nx-reconcile-inherited-vars (more) + (let ((last nil)) ; Bop 'til ya drop. + (loop + (setq last more more nil) + (dolist (callee last) + (dolist (caller (afunc-callers callee)) + (unless (or (eq caller callee) + (eq caller (afunc-parent callee))) + (dolist (v (afunc-inherited-vars callee)) + (let ((root-v (nx-root-var v))) + (unless (dolist (caller-v (afunc-inherited-vars caller)) + (when (eq root-v (nx-root-var caller-v)) + (return t))) + ; caller must inherit root-v in order to call callee without using closure. + ; can't just bind afunc & call nx-lex-info here, 'cause caller may have + ; already shadowed another var with same name. So: + ; 1) find the ancestor of callee which bound v; this afunc is also an ancestor + ; of caller + ; 2) ensure that each afunc on the inheritance path from caller to this common + ; ancestor inherits root-v. + (let ((ancestor (afunc-parent callee)) + (inheritors (list caller))) + (until (eq (setq v (var-bits v)) root-v) + (setq ancestor (afunc-parent ancestor))) + (do* ((p (afunc-parent caller) (afunc-parent p))) + ((eq p ancestor)) + (push p inheritors)) + (dolist (f inheritors) + (setq v (nx-cons-var (var-name v) v)) + (unless (dolist (i (afunc-inherited-vars f)) + (when (eq root-v (nx-root-var i)) + (return (setq v i)))) + (pushnew f more) + (push v (afunc-inherited-vars f)) + ; change shared structure of all refs in acode with one swell foop. + (nx1-afunc-ref f)))))))))) + (unless more (return))))) + +(defun nx-inherit-var (var binder current) + (if (eq binder current) + (progn + (nx-set-var-bits var (%ilogior2 (%ilsl $vbitclosed 1) (nx-var-bits var))) + var) + (let ((sym (var-name var))) + (or (dolist (already (afunc-inherited-vars current)) + (when (eq sym (var-name already)) (return already))) + (progn + (setq var (nx-cons-var sym (nx-inherit-var var binder (afunc-parent current)))) + (push var (afunc-inherited-vars current)) + var))))) + +(defun nx-lex-info (sym &optional current-only) + (let* ((current-function *nx-current-function*) + (catch nil) + (barrier-crossed nil)) + (multiple-value-bind + (info afunc) + (do* ((env *nx-lexical-environment* (lexenv.parent-env env)) + (continue env (and env (not (istruct-typep env 'definition-environment)))) + (binder current-function (or (if continue (lexenv.lambda env)) binder))) + ((or (not continue) (and (neq binder current-function) current-only)) + (values nil nil)) + (let ((vars (lexenv.variables env))) + (if (eq vars 'catch) + (setq catch t) + (if (eq vars 'barrier) + (setq barrier-crossed t) + (let ((v (dolist (var vars) + (when (eq (var-name var) sym) (return var))))) + (when v (return (values v binder))) + (dolist (decl (lexenv.vdecls env)) + (when (and (eq (car decl) sym) + (eq (cadr decl) 'special)) + (return-from nx-lex-info (values :special nil nil))))))))) + (if info + (if (var-expansion info) + (values :symbol-macro (cdr (var-expansion info)) info) + (if (%ilogbitp $vbitspecial (nx-var-bits info)) + (values :special info nil) + (if barrier-crossed + (nx-error "Illegal reference to lexically defined variable ~S." sym) + (if (eq afunc current-function) + (values info nil catch) + (values (nx-inherit-var info afunc current-function) t catch))))) + (values nil nil nil))))) + + +(defun nx-block-info (blockname &optional (afunc *nx-current-function*) &aux + blocks + parent + (toplevel (eq afunc *nx-current-function*)) + blockinfo) + (when afunc + (setq + blocks (if toplevel *nx-blocks* (afunc-blocks afunc)) + blockinfo (assq blockname blocks) + parent (afunc-parent afunc)) + (if blockinfo + (values blockinfo nil) + (when parent + (when (setq blockinfo (nx-block-info blockname parent)) + (values blockinfo t)))))) + +(defun nx-tag-info (tagname &optional (afunc *nx-current-function*) &aux + tags + parent + index + counter + (toplevel (eq afunc *nx-current-function*)) + taginfo) + (when afunc + (setq + tags (if toplevel *nx-tags* (afunc-tags afunc)) + taginfo (assoc tagname tags) + parent (afunc-parent afunc)) + (if taginfo + (values taginfo nil) + (when (and parent (setq taginfo (nx-tag-info tagname parent))) + (unless (setq index (cadr taginfo)) + (setq counter (caddr taginfo)) + (%rplaca counter (%i+ (%car counter) 1)) + (setq index (%car counter)) + (%rplaca (%cdr taginfo) index)) + (values taginfo index))))) + +(defun nx1-transitively-punt-bindings (pairs) + (dolist (pair (nreverse pairs)) + (let* ((var (%car pair)) + (boundto (%cdr pair)) + (varbits (nx-var-bits var)) + (boundtobits (nx-var-bits boundto))) + (declare (fixnum varbits boundtobits)) + (unless (eq (%ilogior + (%ilsl $vbitsetq 1) + (%ilsl $vbitclosed 1)) + (%ilogand + (%ilogior + (%ilsl $vbitsetq 1) + (%ilsl $vbitclosed 1)) + boundtobits)) + ;; Can't happen - + (unless (%izerop (%ilogand (%ilogior + (%ilsl $vbitsetq 1) + (ash -1 $vbitspecial) + (%ilsl $vbitclosed 1)) varbits)) + (error "Bug-o-rama - \"punted\" var had bogus bits. ~ +Or something. Right? ~s ~s" var varbits)) + (let* ((varcount (%ilogand $vrefmask varbits)) + (boundtocount (%ilogand $vrefmask boundtobits))) + (nx-set-var-bits var (%ilogior + (%ilsl $vbitpuntable 1) + (%i- varbits varcount))) + (setf (var-refs var) (+ (var-refs var) (var-refs boundto))) + (nx-set-var-bits + boundto + (%i+ (%i- boundtobits boundtocount) + (%ilogand $vrefmask + (%i+ (%i- boundtocount 1) varcount))))))))) + +;;; Home-baked handler-case replacement. About 10 times as fast as full handler-case. +;;;(LET ((S 0)) (DOTIMES (I 1000000) (INCF S))) took 45,678 microseconds +;;;(LET ((S 0)) (DOTIMES (I 1000000) (BLOCK X (ERROR (CATCH 'X (RETURN-FROM X (INCF S))))))) took 57,485 +;;;(LET ((S 0)) (DOTIMES (I 1000000) (HANDLER-CASE (INCF S) (ERROR (C) C)))) took 168,947 +(defmacro with-program-error-handler (handler &body body) + (let ((tag (gensym))) + `(block ,tag + (,handler (catch 'program-error-handler (return-from ,tag (progn ,@body))))))) + +(defun runtime-program-error-form (c) + `(signal-program-error "Invalid program: ~a" ,(princ-to-string c))) + +(defun nx1-compile-lambda (name lambda-form &optional + (p (make-afunc)) + q + parent-env + (policy *default-compiler-policy*) + load-time-eval-token) + + (if q + (setf (afunc-parent p) q)) + + ;; In the case of a method function, the name will get reset at load time to the + ;; method object. However, during compilation, we want any inner functions to use + ;; the fully qualified method name, so store that. + (when (method-lambda-p lambda-form) + (setq name (or *nx-method-warning-name* name))) + + (setf (afunc-name p) + (let ((parent-name (and (afunc-parent p) (afunc-name (afunc-parent p))))) + (if parent-name + (if (and (consp parent-name) (eq (%car parent-name) :internal)) + (if name + `(:internal ,name ,@(cdr parent-name)) + parent-name) + (if name + `(:internal ,name ,parent-name) + `(:internal ,parent-name))) + name))) + + (unless (lambda-expression-p lambda-form) + (nx-error "~S is not a valid lambda expression." lambda-form)) + + (let* ((*nx-current-function* p) + (*nx-parent-function* q) + (*nx-current-note* (or *nx-current-note* (nx-source-note lambda-form))) + (*nx-lexical-environment* (new-lexical-environment parent-env)) + (*nx-load-time-eval-token* load-time-eval-token) + (*nx-all-vars* nil) + (*nx-bound-vars* nil) + (*nx-punted-vars* nil) + (*nx-current-compiler-policy* policy) + (*nx-blocks* nil) + (*nx-tags* nil) + (*nx-loop-nesting-level* 0) + (*nx-inner-functions* nil) + (*nx-global-function-name* nil) + (*nx-warnings* nil) + (*nx1-fcells* nil) + (*nx1-vcells* nil) + (*nx-inline-expansions* nil) + (*nx-parsing-lambda-decls* nil) + (*nx-next-method-var* (if q *nx-next-method-var*)) + (*nx-call-next-method-function* (if q *nx-call-next-method-function*)) + (*nx-cur-func-name* name)) + (if (%non-empty-environment-p *nx-lexical-environment*) + (setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (afunc-bits p))))) + + (setf (afunc-lambdaform p) lambda-form) + + (when *nx-current-note* + (setf (afunc-lfun-info p) + (list* '%function-source-note *nx-current-note* (afunc-lfun-info p)))) + + (with-program-error-handler + (lambda (c) + (setf (afunc-acode p) (nx1-lambda '(&rest args) `(args ,(runtime-program-error-form c)) nil))) + (handler-bind ((warning (lambda (c) + (nx1-whine :program-error c) + (muffle-warning c))) + (program-error (lambda (c) + (when *nx-break-on-program-errors* + (cerror "continue compilation ignoring this form" c)) + (when (typep c 'compile-time-program-error) + (setq c (make-condition 'simple-program-error + :format-control (simple-condition-format-control c) + :format-arguments (simple-condition-format-arguments c)))) + (unless *nx-break-on-program-errors* + (nx1-whine :program-error c)) + (throw 'program-error-handler c)))) + (multiple-value-bind (body decls) + (with-program-error-handler (lambda (c) (runtime-program-error-form c)) + (parse-body (%cddr lambda-form) *nx-lexical-environment* t)) + (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls))))) + + (nx1-transitively-punt-bindings *nx-punted-vars*) + (setf (afunc-blocks p) *nx-blocks*) + (setf (afunc-tags p) *nx-tags*) + (setf (afunc-inner-functions p) *nx-inner-functions*) + (setf (afunc-all-vars p) *nx-all-vars*) + (setf (afunc-vcells p) *nx1-vcells*) + (setf (afunc-fcells p) *nx1-fcells*) + (let* ((warnings (merge-compiler-warnings *nx-warnings*)) + (name *nx-cur-func-name*)) + (dolist (inner *nx-inner-functions*) + (dolist (w (afunc-warnings inner)) + (push name (compiler-warning-function-name w)) + (push w warnings))) + (setf (afunc-warnings p) warnings)) + p)) + +(defun method-lambda-p (form) + (and (consp form) + (consp (setq form (%cdr form))) + (eq (caar form) '&method))) + + +(defun nx1-lambda (ll body decls &aux (l ll) methvar) + (let* ((old-env *nx-lexical-environment*) + (*nx-bound-vars* *nx-bound-vars*)) + (with-nx-declarations (pending) + (let* ((*nx-parsing-lambda-decls* t)) + (nx-process-declarations pending decls)) + (when (eq (car l) '&lap) + (let ((bits nil)) + (unless (and (eq (length (%cdr l)) 1) (fixnump (setq bits (%cadr l)))) + (unless (setq bits (encode-lambda-list (%cdr l))) + (nx-error "invalid lambda-list - ~s" l))) + (return-from nx1-lambda + (make-acode + (%nx1-operator lambda-list) + (list (cons '&lap bits)) + nil + nil + nil + nil + (nx1-env-body body old-env) + *nx-new-p2decls*)))) + (when (eq (car l) '&method) + (setf (afunc-bits *nx-current-function*) + (%ilogior (%ilsl $fbitmethodp 1) + (afunc-bits *nx-current-function*))) + (setq *nx-inlined-self* nil) + (setq *nx-next-method-var* (setq methvar (let ((var (nx-new-var + pending + (%cadr ll)))) + (nx-set-var-bits var (%ilogior + (%ilsl $vbitignoreunused 1) + ;(%ilsl $vbitnoreg 1) + (nx-var-bits var))) + var))) + + (setq ll (%cddr ll))) + (multiple-value-bind (req opt rest keys auxen lexpr) + (nx-parse-simple-lambda-list pending ll) + (nx-effect-other-decls pending *nx-lexical-environment*) + (setq body (nx1-env-body body old-env)) + (nx1-punt-bindings (%car auxen) (%cdr auxen)) + (when methvar + (push methvar req) + (unless (eq 0 (%ilogand (%ilogior (%ilsl $vbitreffed 1) + (%ilsl $vbitclosed 1) + (%ilsl $vbitsetq 1)) + (nx-var-bits methvar))) + (setf (afunc-bits *nx-current-function*) + (%ilogior + (%ilsl $fbitnextmethp 1) + (afunc-bits *nx-current-function*))))) + (let ((acode (make-acode + (%nx1-operator lambda-list) + req + opt + (if lexpr (list rest) rest) + keys + auxen + body + *nx-new-p2decls*))) + (when *nx-current-code-note* + (setf (acode-note acode) *nx-current-code-note*)) + acode))))) + +(defun nx-parse-simple-lambda-list (pending ll &aux + req + opt + rest + keys + lexpr + sym) + (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail) + (verify-lambda-list ll) + (unless ok (nx-error "Bad lambda list : ~S" ll)) + (dolist (var reqsyms) + (push (nx-new-var pending var t) req)) + (when (eq (pop opttail) '&optional) + (let* (optvars optinits optsuppliedp) + (until (eq opttail resttail) + (setq sym (pop opttail)) + (let* ((var sym) + (initform nil) + (spvar nil)) + (when (consp var) + (setq sym (pop var) initform (pop var) spvar (%car var))) + (push (nx1-typed-var-initform pending sym initform) optinits) + (push (nx-new-var pending sym t) optvars) + (push (if spvar (nx-new-var pending spvar t)) optsuppliedp))) + (if optvars + (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp))) + (nx1-whine :lambda ll)))) + (let ((temp (pop resttail))) + (when (or (eq temp '&rest) + (setq lexpr (eq temp '&lexpr))) + (setq rest (nx-new-var pending (%car resttail) t)))) + (when (eq (%car keytail) '&key) + (setq keytail (%cdr keytail)) + (let* ((keysyms ()) + (keykeys ()) + (keyinits ()) + (keysupp ()) + (kallowother (not (null (memq '&allow-other-keys ll)))) + (kvar ()) + (kkey ()) + (kinit ()) + (ksupp)) + (until (eq keytail auxtail) + (unless (eq (setq sym (pop keytail)) '&allow-other-keys) + (setq kinit *nx-nil* ksupp nil) + (if (atom sym) + (setq kvar sym kkey (make-keyword sym)) + (progn + (if (consp (%car sym)) + (setq kkey (%caar sym) kvar (%cadar sym)) + (progn + (setq kvar (%car sym)) + (setq kkey (make-keyword kvar)))) + (setq kinit (nx1-typed-var-initform pending kvar (%cadr sym))) + (setq ksupp (%caddr sym)))) + (push (nx-new-var pending kvar t) keysyms) + (push kkey keykeys) + (push kinit keyinits) + (push (if ksupp (nx-new-var pending ksupp t)) keysupp))) + (setq + keys + (list + kallowother + (nreverse keysyms) + (nreverse keysupp) + (nreverse keyinits) + (apply #'vector (nreverse keykeys)))))) + (let (auxvals auxvars) + (dolist (pair (%cdr auxtail)) + (let* ((auxvar (nx-pair-name pair)) + (auxval (nx1-typed-var-initform pending auxvar (nx-pair-initform pair)))) + (push auxval auxvals) + (push (nx-new-var pending auxvar t) auxvars))) + (values + (nreverse req) + opt + rest + keys + (list (nreverse auxvars) (nreverse auxvals)) + lexpr)))) + +(defun nx-new-structured-var (pending sym) + (if sym + (nx-new-var pending sym t) + (nx-new-temp-var pending))) + +(defun nx-parse-structured-lambda-list (pending ll &optional no-acode whole-p &aux + req + opt + rest + keys + sym) + (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail all whole structured-p) + (verify-lambda-list ll t whole-p nil) + (declare (ignore all)) + (unless ok (nx-error "Bad lambda list : ~S" ll)) + (if (or whole (and whole-p structured-p)) (setq whole (nx-new-structured-var pending whole))) + (dolist (var reqsyms) + (push (if (symbolp var) + (nx-new-structured-var pending var) + (nx-structured-lambda-form pending var no-acode)) + req)) + (when (eq (pop opttail) '&optional) + (let* (optvars optinits optsuppliedp) + (until (eq opttail resttail) + (setq sym (pop opttail)) + (let* ((var sym) + (initform nil) + (spvar nil)) + (when (consp var) + (setq sym (pop var) initform (pop var) spvar (%car var))) + (push (if no-acode initform (nx1-form initform)) optinits) + (push (if (symbolp sym) + (nx-new-structured-var pending sym) + (nx-structured-lambda-form pending sym no-acode)) + optvars) + (push (if spvar (nx-new-var pending spvar)) optsuppliedp))) + (if optvars + (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp))) + (nx1-whine :lambda ll)))) + (let ((var (pop resttail))) + (when (or (eq var '&rest) + (eq var '&body)) + (setq var (pop resttail) + rest (if (symbolp var) + (nx-new-structured-var pending var) + (nx-structured-lambda-form pending var no-acode))))) + (when (eq (%car keytail) '&key) + (setq keytail (%cdr keytail)) + (let* ((keysyms ()) + (keykeys ()) + (keyinits ()) + (keysupp ()) + (kallowother (not (null (memq '&allow-other-keys ll)))) + (kvar ()) + (kkey ()) + (kinit ()) + (ksupp)) + (until (eq keytail auxtail) + (unless (eq (setq sym (pop keytail)) '&allow-other-keys) + (setq kinit *nx-nil* ksupp nil) + (if (atom sym) + (setq kvar sym kkey (make-keyword sym)) + (progn + (if (consp (%car sym)) + (setq kkey (%caar sym) kvar (%cadar sym)) + (progn + (setq kvar (%car sym)) + (setq kkey (make-keyword kvar)))) + (setq kinit (if no-acode (%cadr sym) (nx1-form (%cadr sym)))) + (setq ksupp (%caddr sym)))) + (push (if (symbolp kvar) + (nx-new-structured-var pending kvar) + (nx-structured-lambda-form pending kvar no-acode)) + keysyms) + (push kkey keykeys) + (push kinit keyinits) + (push (if ksupp (nx-new-var pending ksupp)) keysupp))) + (setq + keys + (list + kallowother + (nreverse keysyms) + (nreverse keysupp) + (nreverse keyinits) + (apply #'vector (nreverse keykeys)))))) + (let (auxvals auxvars) + (dolist (pair (%cdr auxtail)) + (let ((auxvar (nx-pair-name pair)) + (auxval (nx-pair-initform pair))) + (push (if no-acode auxval (nx1-form auxval)) auxvals) + (push (nx-new-var pending auxvar) auxvars))) + (values + (nreverse req) + opt + rest + keys + (list (nreverse auxvars) (nreverse auxvals)) + whole)))) + +(defun nx-structured-lambda-form (pending l &optional no-acode) + (multiple-value-bind (req opt rest keys auxen whole) + (nx-parse-structured-lambda-list pending l no-acode t) + (list (%nx1-operator lambda-list) whole req opt rest keys auxen))) + +(defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*)) + (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the)) + (nx-target-type (cadr form)) + t))) + (nx1-typed-form form *nx-lexical-environment*))) + +(defun nx1-typed-form (original env) + (with-program-error-handler + (lambda (c) + (let ((replacement (runtime-program-error-form c))) + (nx-note-source-transformation original replacement) + (nx1-transformed-form (nx-transform replacement env) env))) + (multiple-value-bind (form changed source) (nx-transform original env) + (declare (ignore changed)) + ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from. + (let ((*nx-current-note* (or source *nx-current-note*))) + (nx1-transformed-form form env))))) + +(defun nx1-transformed-form (form env) + (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*)) + (*nx-current-code-note* (and *nx-current-code-note* + (or (nx-ensure-code-note form *nx-current-code-note*) + (compiler-bug "No source note for ~s" form)))) + (acode (if (consp form) + (nx1-combination form env) + (let* ((symbolp (non-nil-symbol-p form)) + (constant-value (unless symbolp form)) + (constant-symbol-p nil)) + (if symbolp + (multiple-value-setq (constant-value constant-symbol-p) + (nx-transform-defined-constant form env))) + (if (and symbolp (not constant-symbol-p)) + (nx1-symbol form env) + (nx1-immediate (nx-unquote constant-value))))))) + (unless (acode-note acode) ;; leave it with most specific note + (cond (*nx-current-code-note* + (setf (acode-note acode) *nx-current-code-note*)) + (*record-pc-mapping* + (setf (acode-note acode) (nx-source-note form))))) + acode)) + +(defun nx1-prefer-areg (form env) + (nx1-form form env)) + +(defun nx1-target-fixnump (form) + (when (typep form 'integer) + (let* ((target (backend-target-arch *target-backend*))) + (and + (>= form (arch::target-most-negative-fixnum target)) + (<= form (arch::target-most-positive-fixnum target)))))) + + +(defun nx1-immediate (form) + (if (or (eq form t) (null form)) + (nx1-sysnode form) + (make-acode + (if (nx1-target-fixnump form) + (%nx1-operator fixnum) + (%nx1-operator immediate)) ; Screw: chars + form))) + +(defun nx2-constant-form-value (form) + (setq form (nx-untyped-form form)) + (and (or (nx-null form) + (nx-t form) + (and (acode-p form) + (or (eq (acode-operator form) (%nx1-operator immediate)) + (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator simple-function))))) + form)) + +(defun nx-natural-constant-p (form) + (setq form (nx-untyped-form form)) + (if (consp form) + (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator immediate))) + (cadr form)))) + (target-word-size-case + (32 (and (typep val '(unsigned-byte 32)) val)) + (64 (and (typep val '(unsigned-byte 64)) val)))))) + +(defun nx-u32-constant-p (form) + (setq form (nx-untyped-form form)) + (if (consp form) + (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator immediate))) + (cadr form)))) + (and (typep val '(unsigned-byte 32)) val)))) + +(defun nx-u31-constant-p (form) + (setq form (nx-untyped-form form)) + (if (consp form) + (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator immediate))) + (cadr form)))) + (and (typep val '(unsigned-byte 31)) val)))) + + +;;; Reference-count vcell, fcell refs. +(defun nx1-note-vcell-ref (sym) + (let* ((there (assq sym *nx1-vcells*)) + (count (expt 4 *nx-loop-nesting-level*))) + (if there + (%rplacd there (%i+ (%cdr there) count)) + (push (cons sym count) *nx1-vcells*))) + sym) + +(defun nx1-note-fcell-ref (sym) + (let* ((there (assq sym *nx1-fcells*)) + (count (expt 4 *nx-loop-nesting-level*))) + (if there + (%rplacd there (%i+ (%cdr there) count)) + (push (cons sym count) *nx1-fcells*)) + sym)) + +; Note that "simple lexical refs" may not be; that's the whole problem ... +(defun nx1-symbol (form &optional (env *nx-lexical-environment*)) + (let* ((type (nx-declared-type form)) + (form + (multiple-value-bind (info inherited-p more) + (nx-lex-info form) + (if (and info (neq info :special)) + (if (eq info :symbol-macro) + (progn + (nx-set-var-bits more (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits more))) + (if (eq type t) + (nx1-form inherited-p) + (nx1-form `(the ,(prog1 type (setq type t)) ,inherited-p)))) + (progn + (when (not inherited-p) + (nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1) (nx-var-bits info)))) + (nx-adjust-ref-count info) + (nx-make-lexical-reference info))) + (make-acode + (if (nx1-check-special-ref form info) + (progn + (nx-record-xref-info :references form) + (if (nx-global-p form env) + (%nx1-operator global-ref) + (if (and (not (nx-force-boundp-checks form env)) + (or (nx-proclaimed-parameter-p form) + (assq form *nx-compile-time-types*) + (assq form *nx-proclaimed-types*) + (nx-open-code-in-line env))) + (%nx1-operator bound-special-ref) + (%nx1-operator special-ref)))) + (%nx1-operator free-reference)) + (nx1-note-vcell-ref form)))))) + (if (eq type t) + form + (make-acode (%nx1-operator typed-form) type form)))) + +(defun nx1-check-special-ref (form auxinfo) + (or (eq auxinfo :special) + (nx-proclaimed-special-p form) + (let ((defenv (definition-environment *nx-lexical-environment*))) + (unless (and defenv (eq (car (defenv.type defenv)) :execute) (boundp form)) + (nx1-whine :special form)) + nil))) + + + +(defun nx1-whine (about &rest forms) + (push (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning) + :function-name (list *nx-cur-func-name*) + :source-note *nx-current-note* + :warning-type about + :args (or forms (list nil))) + *nx-warnings*)) + +(defun p2-whine (afunc about &rest forms) + (let* ((warning (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning) + :function-name (list (afunc-name afunc)) + :warning-type about + :args (or forms (list nil))))) + (push warning (afunc-warnings afunc)) + (do* ((p (afunc-parent afunc) (afunc-parent p))) + ((null p) warning) + (let* ((pname (afunc-name p))) + (push pname (compiler-warning-function-name warning)) + (push warning (afunc-warnings p)))))) + +(defun nx1-type-intersect (form type1 type2 &optional (env *nx-lexical-environment*)) + (let* ((ctype1 (if (typep type1 'ctype) type1 (values-specifier-type type1 env))) + (ctype2 (if (typep type2 'ctype) type2 (values-specifier-type type2 env))) + (intersection (if (or (values-ctype-p ctype1) (values-ctype-p ctype2)) + (values-type-intersection ctype1 ctype2) + (type-intersection ctype1 ctype2)))) + (when (eq intersection *empty-type*) + (let ((type1 (if (typep type1 'ctype) + (type-specifier type1) + type1)) + (type2 (if (typep type2 'ctype) + (type-specifier type2) + type2))) + (nx1-whine :type-conflict form type1 type2))) + (type-specifier intersection))) + +(defun nx-declared-notinline-p (sym env) + (setq sym (maybe-setf-function-name sym)) + (loop + (when (listp env) + (return (and (symbolp sym) + (proclaimed-notinline-p sym)))) + (dolist (decl (lexenv.fdecls env)) + (when (and (eq (car decl) sym) + (eq (cadr decl) 'inline)) + (return-from nx-declared-notinline-p (eq (cddr decl) 'notinline)))) + (setq env (lexenv.parent-env env)))) + + + +(defun nx1-combination (form env) + (destructuring-bind (sym &rest args) + form + (if (symbolp sym) + (let* ((*nx-sfname* sym) special) + (if (and (setq special (gethash sym *nx1-alphatizers*)) + (or (not (functionp (fboundp sym))) + (memq sym '(apply funcall ;; see bug #285 + %defun ;; see bug #295 + )) + (< (safety-optimize-quantity env) 3)) + ;(not (nx-lexical-finfo sym env)) + (not (nx-declared-notinline-p sym *nx-lexical-environment*))) + (funcall special form env) ; pass environment arg ... + (progn + (nx1-typed-call sym args)))) + (if (lambda-expression-p sym) + (nx1-lambda-bind (%cadr sym) args (%cddr sym)) + (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym))))) + +(defun nx1-treat-as-call (args) + (nx1-typed-call (car args) (%cdr args))) + +(defun nx1-typed-call (fn args &optional spread-p) + (let ((global-only nil) + (errors-p nil) + (result-type t)) + (when (and (acode-p fn) (eq (acode-operator fn) (%nx1-operator immediate))) + (multiple-value-bind (valid name) (valid-function-name-p (%cadr fn)) + (when valid + (setq fn name global-only t)))) + (when (non-nil-symbol-p fn) + (multiple-value-setq (errors-p args result-type) + (nx1-check-typed-call fn args spread-p global-only))) + (setq result-type (nx1-type-intersect fn *nx-form-type* result-type)) + (let ((form (nx1-call fn args spread-p global-only errors-p))) + (if (eq result-type t) + form + (make-acode (%nx1-operator typed-form) result-type form))))) + +(defvar *format-arg-functions* '((format . 1) (format-to-string . 1) (error . 0) (warn . 0) + (y-or-n-p . 0) (yes-or-no-p . 0) + (signal-simple-program-error . 0) + (signal-simple-condition . 1) + (signal-reader-error . 1) + (%method-combination-error . 0) + (%invalid-method-error . 1) + (nx-compile-time-error . 0) + (nx-error . 0) + (compiler-bug . 0))) + +(defun nx1-find-call-def (sym &optional (env *nx-lexical-environment*) (global-only nil)) + (and (or (and (not global-only) (nth-value 1 (nx-lexical-finfo sym))) + (retrieve-environment-function-info sym env) + (let ((def (fboundp sym))) + (and (functionp def) def))))) + +(defun nx1-check-typed-call (sym args &optional spread-p global-only) + (let ((env *nx-lexical-environment*) + (result-type t) + (typed-args args) + (errors-p nil) + (ftype nil) + (def nil)) + (setq ftype (find-ftype-decl sym env args spread-p)) + (setq def (nx1-find-call-def sym env global-only)) + (when ftype + (multiple-value-setq (typed-args result-type errors-p) + (nx1-analyze-ftyped-call ftype sym args spread-p env))) + (when (and def (not errors-p)) + (multiple-value-bind (deftype reason) (nx1-check-call-args def args spread-p) + (when deftype + (nx1-whine deftype sym reason args spread-p) + (setq errors-p t)))) + (unless (or def ftype (eq sym *nx-global-function-name*)) + (nx1-whine :undefined-function sym args spread-p) + (setq errors-p t)) + (unless errors-p + (let* ((format-args (and (not spread-p) + (not (typep def 'afunc)) + (let* ((n (cdr (assq sym *format-arg-functions*)))) + (and n (nthcdr n typed-args))))) + (control (pop format-args))) + (when (and (consp control) + (eq (%car control) 'the) + (consp (%cdr control)) + (consp (%cddr control))) + (setq control (%caddr control))) + (when (stringp (setq control (nx-transform control env))) + (when (nx1-check-format-call control format-args env) + (setq errors-p t))))) + + (values errors-p typed-args result-type))) + +(defun known-ftype-for-call (sym args spread-p env) + ;; Find ftype based on actual arguments. + ;; This should be more general, but for now just pick off some special cases.. + (when (and args (or (not spread-p) (cdr args))) + (cond ((or (eq sym 'aref) (eq sym 'uvref)) + (let* ((atype (nx-form-type (car args) env)) + (a-ctype (specifier-type atype))) + (when (array-ctype-p a-ctype) + ;; No point declaring the type of an arg whose type we already know + `(function (t &rest integer) ,(type-specifier (array-ctype-specialized-element-type + a-ctype)))))) + ((eq sym 'error) + (let ((condition (car args))) + (cond ((nx-form-typep condition 'condition env) + '(function (t) *)) + ((nx-form-typep condition 'symbol env) + ;; TODO: might be able to figure out actual initargs... + `(function (t &key &allow-other-keys) *)) + (t nil)))) + ((eq sym 'cerror) + (when (and (cdr args) (or (not spread-p) (cddr args))) + (let ((condition (cadr args))) + (cond ((nx-form-typep condition 'condition env) + `(function (string t &rest t) *)) + ((nx-form-typep condition 'symbol env) + `(function (string t &key &allow-other-keys) *)) + (t `(function (string t &rest t) *)))))) + (t nil)))) + +(defun find-ftype-decl (sym &optional (env *nx-lexical-environment*) (args :unknown) spread-p) + (setq sym (maybe-setf-function-name sym)) + (loop + for lexenv = env then (lexenv.parent-env lexenv) until (listp lexenv) + do (dolist (fdecl (lexenv.fdecls lexenv)) + (when (and (eq (car fdecl) sym) + (eq (car (%cdr fdecl)) 'ftype)) + (return-from find-ftype-decl (%cddr fdecl)))) + do (when (and (istruct-typep lexenv 'lexical-environment) + (assq sym (lexenv.functions lexenv))) + (return-from find-ftype-decl nil))) + (or (proclaimed-ftype sym) + (and (listp args) + (known-ftype-for-call sym args spread-p env)))) + +(defun nx1-analyze-ftyped-call (ftype sym arglist spread-p env) + (let ((ctype (if (typep ftype 'ctype) ftype (specifier-type ftype))) + (result-type t) + (errors-p nil)) + (unless (or (null ctype) (not (function-ctype-p ctype))) + (unless (function-ctype-wild-args ctype) + (let ((req (args-ctype-required ctype)) + (opt (args-ctype-optional ctype)) + (rest (args-ctype-rest ctype)) + (keyp (args-ctype-keyp ctype)) + (aokp (or spread-p (args-ctype-allowp ctype))) + (keys (args-ctype-keywords ctype)) + (typed-arglist nil) + (key-type nil) + (bad-keys nil) + (nargs (if spread-p (1- (length arglist)) (length arglist)))) + (flet ((collect-type (arg type) + (push (if (and type + (neq type *universal-type*) + (neq type *wild-type*) + (setq type (type-specifier type)) + ;; Don't record unknown types, just causes spurious warnings. + (specifier-type-if-known type env :values t)) + `(the ,type ,arg) + arg) + typed-arglist)) + (key-name (x) (key-info-name x)) + (whine (&rest reason) + (nx1-whine :ftype-mismatch sym reason arglist spread-p) + (setq errors-p t))) + (declare (dynamic-extent #'collect-type #'whine)) + (loop for arg in arglist as i below nargs + do (cond + (req (collect-type arg (pop req))) + (opt (collect-type arg (pop opt))) + (rest (collect-type arg rest)) + (key-type (collect-type arg (shiftf key-type nil))) + (keyp (if (nx-form-constant-p arg env) + (let* ((key (nx-form-constant-value arg env)) + (ki (find key keys :key #'key-name))) + (when (eq key :allow-other-keys) (setq aokp t)) + (if ki + (setq key-type (key-info-type ki)) + (unless aokp (push key bad-keys)))) + (setq aokp t)) + (collect-type arg nil) + (unless key-type (setq key-type *universal-type*))) + (t (return (whine :toomany + nargs + (+ (length (args-ctype-required ctype)) + (length (args-ctype-optional ctype))))))) + finally (cond (spread-p (collect-type arg nil)) + (req (whine :toofew + nargs + (length (args-ctype-required ctype)))) + (key-type (whine :odd-keywords + (nthcdr + (+ (length (args-ctype-required ctype)) + (length (args-ctype-optional ctype))) + arglist))) + (bad-keys (whine :unknown-keyword + (if (cdr bad-keys) + (nreverse bad-keys) + (car bad-keys)) + (map 'list #'key-name keys))))) + (unless errors-p + (setq arglist (nreverse typed-arglist)))))) + (setq result-type (type-specifier (single-value-type (function-ctype-returns ctype))))) + (values arglist (nx-target-type result-type) errors-p))) + + +(defun innermost-lfun-bits-keyvect (def) + (let* ((inner-def (closure-function (find-unencapsulated-definition def))) + (bits (lfun-bits inner-def)) + (keys (lfun-keyvect inner-def))) + (declare (fixnum bits)) + #+no + (when (and (eq (ash 1 $lfbits-gfn-bit) + (logand bits (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-method-bit)))) + (logbitp $lfbits-keys-bit bits)) + (setq bits (logior (ash 1 $lfbits-aok-bit) bits) + keys nil)) + (values bits keys))) + +(defun def-info-bits-keyvect (info) + (let ((bits (def-info.lfbits info))) + (when (and (eq (def-info.function-type info) 'defgeneric) + (logbitp $lfbits-keys-bit bits) + (not (logbitp $lfbits-aok-bit bits)) + #-BOOTSTRAPPED (fboundp 'def-info-method.keyvect) + (loop for m in (def-info.methods info) + thereis (null (def-info-method.keyvect m)))) + ;; Some method has &aok, don't bother checking keywords. + (setq bits (logior bits (ash 1 $lfbits-aok-bit)))) + (values bits (def-info.keyvect info)))) + + +(defun nx1-check-call-args (def arglist spread-p) + (multiple-value-bind (bits keyvect) + (etypecase def + (function (innermost-lfun-bits-keyvect def)) + (afunc (let ((lambda-form (afunc-lambdaform def))) + (and (lambda-expression-p lambda-form) + (encode-lambda-list (cadr lambda-form) t)))) + (cons (def-info-bits-keyvect (cdr def)))) + (when bits + (multiple-value-bind (reason defer-p) + (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred + (nx1-check-call-keywords def bits keyvect arglist spread-p)) + (when reason + #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference nil) + (return-from nx1-check-call-args nil)) + (values (if defer-p + :deferred-mismatch + (typecase def + (function :global-mismatch) + (afunc :lexical-mismatch) + (t :environment-mismatch))) + reason)))))) + +(defun nx1-check-call-bits (bits arglist spread-p) + (let* ((nargs (length arglist)) + (minargs (if spread-p (1- nargs) nargs)) + (required (ldb $lfbits-numreq bits)) + (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits) + nil + (+ required (ldb $lfbits-numopt bits))))) + ;; If the (apparent) number of args in the call doesn't + ;; match the definition, complain. If "spread-p" is true, + ;; we can only be sure of the case when more than the + ;; required number of args have been supplied. + (or (and (not spread-p) + (< minargs required) + `(:toofew ,minargs ,required)) + (and max + (> minargs max) + `(:toomany ,nargs ,max))))) + +(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *nx-lexical-environment*)) + ;; Ok, if generic function, bits and keyvect are for the generic function itself. + ;; Still, since all congruent, can check whether have variable numargs + (unless (and (logbitp $lfbits-keys-bit bits) + (not spread-p)) ; last argform may contain :allow-other-keys + (return-from nx1-check-call-keywords nil)) + (let* ((bad-keys nil) + (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args)) + (generic-p (or (generic-function-p def) + (and (consp def) + (eq (def-info.function-type (cdr def)) 'defgeneric))))) + (when (oddp (length key-args)) + (return-from nx1-check-call-keywords (list :odd-keywords key-args))) + (when (logbitp $lfbits-aok-bit bits) + (return-from nx1-check-call-keywords nil)) + (loop for key-form in key-args by #'cddr + do (unless (nx-form-constant-p key-form env) ;; could be :aok + (return-from nx1-check-call-keywords nil)) + do (let ((key (nx-form-constant-value key-form env))) + (when (eq key :allow-other-keys) + (return-from nx1-check-call-keywords nil)) + (unless (or (find key keyvect) + (and generic-p (nx1-valid-gf-keyword-p def key))) + (push key bad-keys)))) + (when bad-keys + (if generic-p + (values (list :unknown-gf-keywords bad-keys) t) + (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys)) keyvect))))) + +(defun nx1-valid-gf-keyword-p (def key) + ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit + (if (consp def) + (let ((definfo (cdr def))) + (assert (eq (def-info.function-type definfo) 'defgeneric)) + (loop for m in (def-info.methods definfo) + as keyvect = (def-info-method.keyvect m) + thereis (or (null keyvect) (find key keyvect)))) + (let ((gf (find-unencapsulated-definition def))) + (or (find key (%defgeneric-keys gf)) + (loop for m in (%gf-methods gf) + thereis (let* ((func (%inner-method-function m)) + (mbits (lfun-bits func))) + (or (and (logbitp $lfbits-aok-bit mbits) + ;; If no &rest, then either don't use the keyword in which case + ;; it's good to warn; or it's used via next-method, we'll approve + ;; it when we get to that method. + (logbitp $lfbits-rest-bit mbits)) + (find key (lfun-keyvect func))))))))) + +;;; we can save some space by going through subprims to call "builtin" +;;; functions for us. +(defun nx1-builtin-function-offset (name) + (arch::builtin-function-name-offset name)) + +(defun nx1-call-form (global-name afunc arglist spread-p &optional (env *nx-lexical-environment*)) + (if afunc + (make-acode (%nx1-operator lexical-function-call) afunc (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p) + (let* ((builtin (unless (or spread-p + (eql 3 (safety-optimize-quantity env))) + (nx1-builtin-function-offset global-name)))) + (if (and builtin + (let* ((bits (lfun-bits (fboundp global-name)))) + (and bits (eql (logand $lfbits-args-mask bits) + (dpb (length arglist) + $lfbits-numreq + 0))))) + (make-acode (%nx1-operator builtin-call) + (make-acode (%nx1-operator fixnum) builtin) + (nx1-arglist arglist)) + (make-acode (%nx1-operator call) + (if (symbolp global-name) + (nx1-immediate (nx1-note-fcell-ref global-name)) + global-name) + (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) + spread-p))))) + +;;; If "sym" is an expression (not a symbol which names a function), +;;; the caller has already alphatized it. +(defun nx1-call (sym args &optional spread-p global-only inhibit-inline) + (nx1-verify-length args 0 nil) + (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate))) + (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym)) + (when valid + (setq global-only t sym name)))) + (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*)))) + (if (nx-self-call-p sym global-only) + ;; Should check for downward functions here as well. + (multiple-value-bind (deftype reason) + (nx1-check-call-args *nx-current-function* args spread-p) + (when deftype + (nx1-whine deftype sym reason args spread-p)) + (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p)) + (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only) + (or (and (not inhibit-inline) + (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*)) + (multiple-value-bind (info afunc) (if (and (symbolp sym) (not global-only)) (nx-lexical-finfo sym)) + (when (eq 'macro (car info)) + (nx-error "Can't call macro function ~s" sym)) + (nx-record-xref-info :direct-calls sym) + (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc))) + (let ((sym (var-name (afunc-lfun afunc)))) + (nx1-form + (if spread-p + `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args) + `(funcall ,sym ,@args)))) + (let* ((val (nx1-call-form sym afunc args spread-p))) + (when afunc + (let ((callers (afunc-callers afunc)) + (self *nx-current-function*)) + (unless (or (eq self afunc) (memq self callers)) + (setf (afunc-callers afunc) (cons self callers))))) + (if (and (null afunc) (memq sym *nx-never-tail-call*)) + (make-acode (%nx1-operator values) (list val)) + val))))))))) + +(defun nx1-expand-inline-call (lambda-form env token args spread-p old-env) + (if (and (or (null spread-p) (eq (length args) 1))) + (if (and token (not (memq token *nx-inline-expansions*))) + (with-program-error-handler (lambda (c) (declare (ignore c)) nil) + (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*)) + (lambda-list (cadr lambda-form)) + (body (cddr lambda-form)) + (new-env (new-lexical-environment env))) + (setf (lexenv.mdecls new-env) + `((speed . ,(speed-optimize-quantity old-env)) + (space . ,(space-optimize-quantity old-env)) + (safety . ,(space-optimize-quantity old-env)) + (compilation-speed . ,(compilation-speed-optimize-quantity old-env)) + (debug . ,(debug-optimize-quantity old-env)))) + (if spread-p + (nx1-destructure lambda-list (car args) nil nil body new-env) + (nx1-lambda-bind lambda-list args body new-env))))))) + +; note that regforms are reversed: arg_z is always in the car +(defun nx1-arglist (args &optional (nregargs (backend-num-arg-regs *target-backend*))) + (declare (fixnum nregargs)) + (let* ((stkforms nil) + (regforms nil) + (nstkargs (%i- (length args) nregargs))) + (declare (fixnum nstkargs)) + (list + (dotimes (i nstkargs (nreverse stkforms)) + (declare (fixnum i)) + (push (nx1-form (%car args)) stkforms) + (setq args (%cdr args))) + (dolist (arg args regforms) + (push (nx1-form arg) regforms))))) + +(defun nx1-formlist (args) + (let* ((a nil)) + (dolist (arg args) + (push (nx1-form arg) a)) + (nreverse a))) + +(defun nx1-verify-length (forms min max &aux (len (list-length forms))) + (if (or (null len) + (%i> min len) + (and max (%i> len max))) + (nx-error "Wrong number of args in form ~S." (cons *nx-sfname* forms)) + len)) + +(defun nx-unquote (form) + (if (nx-quoted-form-p form) + (%cadr form) + form)) + +(defun nx-quoted-form-p (form &aux (f form)) + (and (consp form) + (eq (pop form) 'quote) + (or + (and (consp form) + (not (%cdr form))) + (nx-error "Illegally quoted form ~S." f)))) + +(defun nx-form-constant-p (form env) + (declare (ignore env)) + (or (quoted-form-p form) + (self-evaluating-p form))) + +(defun nx-form-constant-value (form env) + (declare (ignore env)) + (declare (type (satisfies nx-form-constant-p) form)) + (if (consp form) (%cadr form) form)) + +; Returns two values: expansion & win +; win is true if expansion is not EQ to form. +; This is a bootstrapping version. +; The real one is in "ccl:compiler;optimizers.lisp". +(unless (fboundp 'maybe-optimize-slot-accessor-form) + +(defun maybe-optimize-slot-accessor-form (form environment) + (declare (ignore environment)) + (values form nil)) + +) + +(defun nx-source-note (form &aux (source-notes *nx-source-note-map*)) + (when source-notes + (when (or (consp form) (vectorp form) (pathnamep form)) + (let ((note (gethash form source-notes))) + (unless (listp note) note))))) + + +(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*)) + (macrolet ((form-changed (form) + `(progn + (unless source (setq source (gethash ,form source-note-map))) + (setq changed t)))) + (prog (sym transforms lexdefs changed enabled macro-function compiler-macro (source t)) + (when source-note-map + (setq source (gethash form source-note-map))) + (go START) + LOOP + (form-changed form) + (when (and (consp form) + (or (eq (%car form) 'the) + (and sym (eq (%car form) sym)))) + (go DONE)) + START + (when (non-nil-symbol-p form) + (multiple-value-bind (newform win) (nx-transform-symbol form environment) + (unless win (go DONE)) + (setq form newform) + (go LOOP))) + (when (atom form) (go DONE)) + (unless (symbolp (setq sym (%car form))) + (go DONE)) + #+no + (when (eq sym 'the) + (destructuring-bind (typespec thing) (cdr form) + (if (constantp thing) + (progn + (setq form thing) + (go LOOP)) + (multiple-value-bind (newform win) (nx-transform thing environment source-note-map) + (when win + (form-changed newform) + (if (and (self-evaluating-p newform) + (typep newform typespec)) + (setq form newform) + (setq form `(the ,typespec ,newform))) + (go DONE)))))) + (when (nx-quoted-form-p form) + (when (self-evaluating-p (%cadr form)) + (setq form (%cadr form))) + (go DONE)) + (when (setq lexdefs (nx-lexical-finfo sym environment)) + (if (eq 'function (%car lexdefs)) + (go DONE))) + (setq transforms (setq compiler-macro (compiler-macro-function sym environment)) + macro-function (macro-function sym environment) + enabled (nx-allow-transforms environment)) + (unless macro-function + (let* ((win nil)) + (when (and enabled (functionp (fboundp sym))) + (multiple-value-setq (form win) (nx-transform-arglist form environment source-note-map)) + (when win + (form-changed form))))) + (when (and enabled + (not (nx-declared-notinline-p sym environment))) + (multiple-value-bind (value folded) (nx-constant-fold form environment) + (when folded + (setq form value) + (form-changed form) + (unless (and (consp form) (eq (car form) sym)) (go START)))) + (when compiler-macro + (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment) + (when win + (when (and (consp newform) (eq (car newform) sym) (functionp (fboundp sym))) + (setq sym nil)) + (setq form newform) + (go LOOP)))) + (multiple-value-bind (newform win) (maybe-optimize-slot-accessor-form form environment) + (when win + (setq sym nil) + (setq form newform) + (go START))) + (unless macro-function + (when (setq transforms (or (environment-structref-info sym environment) + (and (boundp '%structure-refs%) + (gethash sym %structure-refs%)))) + (setq form (defstruct-ref-transform transforms (%cdr form) environment)) + (form-changed form) + (go START)) + (when (setq transforms (assq sym *nx-synonyms*)) + (setq form (cons (%cdr transforms) (setq sym (%cdr form)))) + (go LOOP)))) + (when (and macro-function + (or lexdefs + (not (and (gethash sym *nx1-alphatizers*) (not (nx-declared-notinline-p sym environment)))))) + (nx-record-xref-info :macro-calls (function-name macro-function)) + (setq form (macroexpand-1 form environment)) + (form-changed form) + (go START)) + DONE + (if (eq source t) + (setq source nil) + (let ((this (nx-source-note form))) + (if this + (setq source this) + (when source + (unless (and (consp form) + (eq (%car form) 'the) + (eq source (gethash (caddr form) source-note-map))) + (when (or (consp form) (vectorp form) (pathnamep form)) + (unless (or (eq form (%unbound-marker)) + (eq form (%slot-unbound-marker))) + (setf (gethash form source-note-map) source)))))))) + ;; Return source for symbols, even though don't record it in hash table. + (return (values form changed source))))) + + +; Transform all of the arguments to the function call form. +; If any of them won, return a new call form (with the same operator as the original), else return the original +; call form unchanged. +(defun nx-transform-arglist (callform env source-note-map) + (let* ((any-wins nil) + (transformed-call (cons (car callform) nil)) + (ptr transformed-call) + (win nil)) + (declare (type cons ptr)) + (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil))) + (multiple-value-setq (form win) (nx-transform form env source-note-map)) + (rplacd ptr (setq ptr (cons form nil))) + (if win (setq any-wins t))))) + +;This is needed by (at least) SETF. +(defun nxenv-local-function-p (name macro-env) + (multiple-value-bind (type local-p) (function-information name macro-env) + (and local-p (eq :function type)))) + + +;;; This guy has to return multiple values. The arguments have +;;; already been transformed; if they're all constant (or quoted), try +;;; to evaluate the expression at compile-time. +(defun nx-constant-fold (original-call &optional (environment *nx-lexical-environment*) &aux + (fn (car original-call)) form mv foldable foldfn) + (flet ((quotify (x) (if (self-evaluating-p x) x (list 'quote x)))) + (if (and (nx-allow-transforms environment) + (let* ((bits (if (symbolp fn) (%symbol-bits fn) 0))) + (declare (fixnum bits)) + (if (setq foldable (logbitp $sym_fbit_constant_fold bits)) + (if (logbitp $sym_fbit_fold_subforms bits) + (setq foldfn 'fold-constant-subforms)) + (setq foldable (assq fn *nx-can-constant-fold*) + foldfn (cdr foldable))) + foldable)) + (if foldfn + (funcall foldfn original-call environment) + (progn + (let ((args nil)) + (dolist (arg (cdr original-call) (setq args (nreverse args))) + (if (quoted-form-p arg) + (setq arg (%cadr arg)) + (unless (self-evaluating-p arg) (return-from nx-constant-fold (values original-call nil)))) + (push arg args)) + (if (nx1-check-call-args (fboundp fn) args nil) + (return-from nx-constant-fold (values original-call nil)) + (setq form (multiple-value-list + (handler-case (apply fn args) + (error (condition) + (warn "Error: \"~A\" ~&signalled during compile-time evaluation of ~S ." + condition original-call) + (return-from nx-constant-fold + (values `(locally (declare (notinline ,fn)) + ,original-call) + t)))))))) + (if form + (if (null (%cdr form)) + (setq form (%car form)) + (setq mv (setq form (cons 'values (mapcar #'quotify form)))))) + (values (if mv form (quotify form)) T))) + (values original-call nil)))) + +(defun nx-transform-symbol (sym &optional (env *nx-lexical-environment*)) +; Gak. Can't call NX-LEX-INFO without establishing *nx-lexical-environment*. +; NX-LEX-INFO should take env arg!. + (let* ((*nx-lexical-environment* env)) + (multiple-value-bind (expansion win) (macroexpand-1 sym env) + (if win + (let ((type (nx-declared-type sym)) + (var (nth-value 2 (nx-lex-info sym)))) + (unless (eq t type) (setq expansion `(the ,type ,expansion))) + (if var (nx-set-var-bits var (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits var))))) + (progn + (multiple-value-setq (expansion win) + (nx-transform-defined-constant sym env)) + (if win (setq win (neq sym expansion))))) + (values expansion win)))) + +; if sym has a substitutable constant value in env (or globally), return +; (values t), else (values nil nil) +(defun nx-transform-defined-constant (sym env) + (let* ((defenv (definition-environment env)) + (val (if defenv (assq sym (defenv.constants defenv)))) + (constant-value-p val)) + (if val + (setq val (%cdr val)) + (if (constant-symbol-p sym) + (setq constant-value-p t val (%sym-global-value sym)))) + (if (and (neq val (%unbound-marker-8)) + constant-value-p + (nx-substititute-constant-value sym val env)) + (values (if (self-evaluating-p val) val (list 'quote val)) t) + (values nil nil)))) + + +(defun nx-var-bits (var) + (do* ((var var bits) + (bits (var-bits var) (var-bits var))) + ((fixnump bits) bits))) + +(defun nx-set-var-bits (var newbits) + (do* ((var var bits) + (bits (var-bits var) (var-bits var))) + ((fixnump bits) (setf (var-bits var) newbits)))) + +(defun nx-make-lexical-reference (var) + (let* ((ref (make-acode (%nx1-operator lexical-reference) var))) + (push ref (var-ref-forms var)) + ref)) + +(defun nx-adjust-ref-count (var) + (let* ((bits (nx-var-bits var)) + (temp-p (%ilogbitp $vbittemporary bits)) + (by (if temp-p 1 (expt 4 *nx-loop-nesting-level*))) + (new (%imin (%i+ (%ilogand2 $vrefmask bits) by) 255))) + (setf (var-refs var) (+ (var-refs var) by)) + (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vrefmask) bits) new)) + new)) + +;;; Treat (VALUES x . y) as X if it appears in a THE form +(defun nx-form-type (form &optional (env *nx-lexical-environment*)) + (if (nx-form-constant-p form env) + ;(type-of (nx-form-constant-value form env)) + `(member ,(nx-form-constant-value form env)) + (if (and (consp form) ; Kinda bogus now, but require-type + (eq (%car form) 'require-type) ; should be special some day + (nx-form-constant-p (caddr form) env)) + (nx-form-constant-value (%caddr form) env) + (if (nx-trust-declarations env) + (if (symbolp form) + (nx-target-type (nx-declared-type form env)) + (if (consp form) + (if (eq (%car form) 'the) + (destructuring-bind (typespec val) (%cdr form) + (declare (ignore val)) + (nx-target-type (type-specifier (single-value-type (values-specifier-type typespec))))) + (if (eq (%car form) 'setq) + (let* ((args (%cdr form)) + (n (length args))) + (if (and (evenp n) + (> n 0) + (setq args (nthcdr (- n 2) args)) + (non-nil-symbol-p (car args))) + (nx1-type-intersect (%car args) + (nx-declared-type (%car args) env) + (nx-form-type (%cadr args) env) + env) + t)) + (let* ((op (gethash (%car form) *nx1-operators*))) + (or (and op (cdr (assq op *nx-operator-result-types*))) + (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*))) + #+no (and (memq (car form) *numeric-ops*) + (grovel-numeric-form form env)) + #+no (and (memq (car form) *logical-ops*) + (grovel-logical-form form env)) + (nx-declared-result-type (%car form) env (%cdr form)) + t)))) + t)) + t)))) + + +(defparameter *numeric-ops* '(+ - / * +-2 --2 *-2 /-2)) + +(defparameter *logical-ops* '(logxor-2 logior-2 logand-2 lognot logxor)) + +(defun numeric-type-p (type &optional not-complex) + (or (memq type '(fixnum integer double-float single-float float)) + (let ((ctype (specifier-type type))) + (and (numeric-ctype-p ctype) + (or (not not-complex) + (neq (numeric-ctype-complexp ctype) :complex)))))) + +(defun grovel-numeric-form (form env) + (let* ((op (car form)) + (args (cdr form))) + (if (every #'(lambda (x) (nx-form-typep x 'float env)) args) + (if (some #'(lambda (x) (nx-form-typep x 'double-float env)) args) + 'double-float + 'single-float) + (if (every #'(lambda (x) (nx-form-typep x 'integer env)) args) + (if (or (eq op '/) (eq op '/-2)) + t + 'integer))))) + +;; now e.g. logxor of 3 known fixnums is inline as is (logior a (logxor b c)) +;; and (the fixnum (+ a (logxor b c))) + +(defun grovel-logical-form (form env) + (when (nx-trust-declarations env) + (let (;(op (car form)) + type) + (dolist (arg (cdr form)) + (let ((it (nx-form-type arg env))) + (if (not (subtypep it 'fixnum)) + (return (setq type nil)) + (setq type 'fixnum)))) + type))) + +(defun nx-form-typep (arg type &optional (env *nx-lexical-environment*)) + (setq type (nx-target-type (type-expand type))) + (if (nx-form-constant-p arg env) + (typep (nx-form-constant-value arg env) type env) + (subtypep (nx-form-type arg env) type env))) + + +(defun nx-binary-fixnum-op-p (form1 form2 env &optional ignore-result-type) + (setq form1 (nx-transform form1 env) + form2 (nx-transform form2 env)) + (and + (target-word-size-case + (32 (nx-form-typep form1 '(signed-byte 30) env)) + (64 (nx-form-typep form1 '(signed-byte 61) env))) + (target-word-size-case + (32 (nx-form-typep form2 '(signed-byte 30) env)) + (64 (nx-form-typep form2 '(signed-byte 61) env))) + (or ignore-result-type + (and (nx-trust-declarations env) + (target-word-size-case + (32 (subtypep *nx-form-type* '(signed-byte 30))) + (64 (subtypep *nx-form-type* '(signed-byte 61)))))))) + + +(defun nx-binary-natural-op-p (form1 form2 env &optional (ignore-result-type t)) + (and + (target-word-size-case + (32 + (and (nx-form-typep form1 '(unsigned-byte 32) env) + (nx-form-typep form2 '(unsigned-byte 32) env))) + (64 + (and (nx-form-typep form1 '(unsigned-byte 64) env) + (nx-form-typep form2 '(unsigned-byte 64) env)))) + (or ignore-result-type + (and (nx-trust-declarations env) + (target-word-size-case + (32 (subtypep *nx-form-type* '(unsigned-byte 32))) + (64 (subtypep *nx-form-type* '(unsigned-byte 64)))))))) + + + + +(defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop) + (let* ((use-fixop (nx-binary-fixnum-op-p arg-1 arg-2 env t)) + (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env))) + (if (or use-fixop use-naturalop intop) + (make-acode (if use-fixop fixop (if use-naturalop naturalop intop)) + (nx1-form arg-1) + (nx1-form arg-2)) + (nx1-treat-as-call whole)))) + +(defun nx-global-p (sym &optional (env *nx-lexical-environment*)) + (or + (logbitp $sym_vbit_global (the fixnum (%symbol-bits sym))) + (let* ((defenv (definition-environment env))) + (if defenv + (eq :global (%cdr (assq sym (defenv.specials defenv)))))))) + +(defun nx-need-var (sym &optional (check-bindable t)) + (if (and (nx-need-sym sym) + (not (constantp sym)) + (let* ((defenv (definition-environment *nx-lexical-environment*))) + (or (null defenv) + (not (assq sym (defenv.constants defenv)))))) ; check compile-time-constants, too + (if (and check-bindable (nx-global-p sym)) + (nx-error "~S is declared static and can not be bound" sym) + sym) + (nx-error "Can't bind or assign to constant ~S." sym))) + +(defun nx-need-sym (sym) + (if (symbolp sym) + sym + (nx-error "~S is not a symbol." sym))) + +(defun nx-need-function-name (name) + (multiple-value-bind (valid nm) (valid-function-name-p name) + (if valid nm (nx-error "Invalid function name ~S" name)))) + +(defun nx-pair-name (form) + (nx-need-sym (if (consp form) (%car form) form))) + +(defun nx-pair-initform (form) + (if (atom form) + nil + (if (and (listp (%cdr form)) (null (%cddr form))) + (%cadr form) + (nx-error "Bad initialization form: ~S." form)))) + +; some callers might assume that this guy errors out if it can't conjure up +; a fixnum. I certainly did ... +(defun nx-get-fixnum (form &aux (trans (nx-transform form *nx-lexical-environment*))) + (if (fixnump trans) + trans + form)) + +(defun nx1-func-name (gizmo) + (and (consp gizmo) + (eq (%car gizmo) 'function) + (consp (%cdr gizmo)) + (null (%cddr gizmo)) + (if (lambda-expression-p (%cadr gizmo)) + (%cadr gizmo) + (nth-value 1 (valid-function-name-p (%cadr gizmo)))))) + +; distinguish between program errors & incidental ones. +(defun nx-error (format-string &rest args) + (error (make-condition 'compile-time-program-error + :context (nx-error-context) + :format-control format-string + :format-arguments args))) + +(defun nx-compile-time-error (format-string &rest args) + (error (make-condition 'compile-time-program-error + :context (nx-error-context) + :format-control format-string + :format-arguments args))) + +; Should return information about file being compiled, nested functions, etc. ... +(defun nx-error-context () + (or *nx-cur-func-name* "an anonymous function")) + +(defparameter *warn-if-function-result-ignored* + '(sort stable-sort delete delete-if delete-if-not remf nreverse + nunion nset-intersection) + "Names of functions whose result(s) should ordinarily be used, because of their side-effects or lack of them.") Index: /branches/qres/ccl/compiler/nx1.lisp =================================================================== --- /branches/qres/ccl/compiler/nx1.lisp (revision 13564) +++ /branches/qres/ccl/compiler/nx1.lisp (revision 13564) @@ -0,0 +1,2268 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun nx1-typespec-for-typep (typespec env) + ;; Allow VALUES types here (or user-defined types that + ;; expand to VALUES types). We could do a better job + ;; of this, but treat them as wild types. + ;; Likewise, complex FUNCTION types can be legally used + ;; in type declarations, but aren't legal args to TYPEP; + ;; treat them as the simple FUNCTION type. + (labels ((ctype-spec (ctype) + (typecase ctype + (function-ctype 'function) + (values-ctype '*) + (array-ctype + (let ((new (ctype-spec (array-ctype-element-type ctype)))) + (when new + (list (if (array-ctype-complexp ctype) 'array 'simple-array) + new + (array-ctype-dimensions ctype))))) + (negation-ctype + (let ((new (ctype-spec (negation-ctype-type ctype)))) + (when new + `(not ,new)))) + (union-ctype + (let* ((types (union-ctype-types ctype)) + (new (mapcar #'ctype-spec types))) + (unless (every #'null new) + `(or ,@(mapcar (lambda (new old) (or new (type-specifier old))) new types))))) + (intersection-ctype + (let* ((types (intersection-ctype-types ctype)) + (new (mapcar #'ctype-spec types))) + (unless (every #'null new) + `(and ,@(mapcar (lambda (new old) (or new (type-specifier old))) new types))))) + (t nil)))) + (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env) + (parse-unknown-type (c) + (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c)) + *wild-type*) + (program-error (c) + (nx1-whine :invalid-type typespec c) + *wild-type*))) + (new (ctype-spec ctype))) + (nx-target-type (type-specifier (if new (specifier-type new) ctype)))))) + +(defnx1 nx1-the the (&whole call typespec form &environment env) + (let* ((typespec (nx1-typespec-for-typep typespec env)) + (*nx-form-type* typespec) + (transformed (nx-transform form env))) + (flet ((fold-the () + (do* () + ((or (atom transformed) + (not (eq (car transformed) 'the)))) + (destructuring-bind (ftype form) (cdr transformed) + (setq typespec (nx-target-type (nx1-type-intersect call typespec (nx1-typespec-for-typep ftype env))) + *nx-form-type* typespec + transformed form))))) + (fold-the) + (do* ((last transformed transformed)) + () + (setq transformed (nx-transform transformed env)) + (when (or (atom transformed) + (not (eq (car transformed) 'the))) + (return)) + (fold-the) + (when (eq transformed last) + (return))) + (if (and (nx-form-constant-p transformed env) + (or (equal typespec '(values)) + (not (typep (nx-form-constant-value transformed env) + (single-value-type (values-specifier-type typespec)))))) + (progn + (nx1-whine :type call) + (setq typespec '*)) + (setq typespec (nx-target-type + (or (nx1-type-intersect call + typespec + (nx1-typespec-for-typep (nx-form-type transformed env)env)) + '*)))) + ;; Wimp out, but don't choke on (the (values ...) form) + (when (and (consp typespec) (eq (car typespec) 'values)) + (setq typespec '*)) + (make-acode + (%nx1-operator typed-form) + typespec + (let* ((*nx-form-type* typespec)) + (nx1-transformed-form transformed env)) + (nx-declarations-typecheck env))))) + +(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset) + (if (not (fixnump (setq offset (nx-get-fixnum offset)))) + (nx1-treat-as-call whole) + (make-acode (%nx1-operator struct-ref) + (nx1-form structure) + (nx1-form offset)))) + +(defnx1 nx1-struct-set struct-set (&whole whole structure offset newval) + (if (not (fixnump (setq offset (nx-get-fixnum offset)))) + (nx1-treat-as-call whole) + (make-acode + (%nx1-operator struct-set) + (nx1-form structure) + (nx1-form offset) + (nx1-form newval)))) + +(defnx1 nx1-istruct-typep ((istruct-typep)) (&whole whole thing type &environment env) + (if (and (nx-form-constant-p type env) (non-nil-symbol-p (nx-form-constant-value type env))) + (make-acode (%nx1-operator istruct-typep) + (nx1-immediate :eq) + (nx1-form thing) + (nx1-form `(register-istruct-cell ,type))) + (nx1-treat-as-call whole))) + +(defnx1 nx1-make-list make-list (&whole whole size &rest keys &environment env) + (if (and keys + (or + (neq (list-length keys) 2) + (neq (nx-transform (%car keys) env) :initial-element))) + (nx1-treat-as-call whole) + (make-acode + (%nx1-operator make-list) + (nx1-form size) + (nx1-form (%cadr keys))))) + +;;; New semantics: expansion functions are defined in current lexical environment +;;; vice null environment. May be meaningless ... +(defnx1 nx1-macrolet macrolet (defs &body body) + (let* ((old-env *nx-lexical-environment*) + (new-env (new-lexical-environment old-env))) + (dolist (def defs) + (destructuring-bind (name arglist &body mbody) def + (push + (cons + name + (cons + 'macro + (multiple-value-bind (function warnings) + (compile-named-function (parse-macro name arglist mbody old-env) :name name :env old-env) + (setq *nx-warnings* (append *nx-warnings* warnings)) + function))) + (lexenv.functions new-env)))) + (let* ((*nx-lexical-environment* new-env)) + (with-nx-declarations (pending) + (multiple-value-bind (body decls) (parse-body body new-env) + (nx-process-declarations pending decls) + (nx1-progn-body body)))))) + +;;; Does SYMBOL-MACROLET allow declarations ? Yes ... +(defnx1 nx1-symbol-macrolet symbol-macrolet (defs &body forms) + (let* ((old-env *nx-lexical-environment*)) + (with-nx-declarations (pending) + (multiple-value-bind (body decls) + (parse-body forms old-env nil) + (nx-process-declarations pending decls) + (let ((env *nx-lexical-environment*) + (*nx-bound-vars* *nx-bound-vars*)) + (dolist (def defs) + (destructuring-bind (sym expansion) def + (let* ((var (nx-new-var pending sym)) + (bits (nx-var-bits var))) + (when (%ilogbitp $vbitspecial bits) + (nx-error "SPECIAL declaration applies to symbol macro ~s" sym)) + (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) bits)) + (setf (var-ea var) (cons :symbol-macro expansion))))) + (nx-effect-other-decls pending env) + (nx1-env-body body old-env)))))) + +(defnx1 nx1-progn progn (&body args) + (nx1-progn-body args)) + +(defnx1 nx1-with-c-frame with-c-frame (var &body body) + (make-acode (%nx1-operator with-c-frame) + (nx1-form `(let* ((,var (%foreign-stack-pointer))) + ,@body)))) + +(defnx1 nx1-with-variable-c-frame with-variable-c-frame (size var &body body) + (make-acode (%nx1-operator with-variable-c-frame) + (nx1-form size) + (nx1-form `(let* ((,var (%foreign-stack-pointer))) + ,@body)))) + + +(defun nx1-progn-body (args) + (if (null (cdr args)) + (nx1-form (%car args)) + (make-acode (%nx1-operator progn) (nx1-formlist args)))) + +(defnx1 nx1-unaryop ((%word-to-int) (uvsize) (%reference-external-entry-point) + (%symbol->symptr)) + (arg) + (make-acode + (%nx1-default-operator) (nx1-form arg))) + +(defnx1 nx1-nullaryop ((%current-tcr) (%interrupt-poll) (%foreign-stack-pointer) (%current-frame-ptr)) () + (make-acode (%nx1-default-operator))) + +(defnx1 nx1-fixnum-ref ((%fixnum-ref) (%fixnum-ref-natural)) (base &optional (offset 0)) + (make-acode (%nx1-default-operator) + (nx1-form base) + (nx1-form offset))) + +(defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag)) + (arg) + (let* ((operator + (case *nx-sfname* + ((typecode) (%nx1-operator typecode)) + ((lisptag) (%nx1-operator lisptag)) + (( fulltag) (%nx1-operator fulltag))))) + (make-acode + operator (nx1-form arg)))) + + +(defnx1 nx1-code-char ((code-char)) (arg &environment env) + (make-acode (if (nx-form-typep arg '(unsigned-byte 8) env) + (%nx1-operator %code-char) + (if (nx-form-typep arg 'valid-char-code env) + (%nx1-operator %valid-code-char) + (%nx1-operator code-char))) + (nx1-form arg))) + +(defnx1 nx1-char-code ((char-code)) (arg &environment env) + (make-acode (if (nx-form-typep arg 'character env) + (%nx1-operator %char-code) + (%nx1-operator char-code)) + (nx1-form arg))) + +(defnx1 nx1-cXr ((car) (cdr)) (arg &environment env) + (let* ((op (if (eq *nx-sfname* 'car) (%nx1-operator car) (%nx1-operator cdr))) + (inline-op (if (eq op (%nx1-operator car)) (%nx1-operator %car) (%nx1-operator %cdr)))) + (make-acode (if (or (nx-inline-car-cdr env) (nx-form-typep arg 'list env)) + inline-op + op) + (nx1-prefer-areg arg env)))) + +(defnx1 nx1-rplacX ((rplaca) (rplacd)) (pairform valform &environment env) + (let* ((op (if (eq *nx-sfname* 'rplaca) (%nx1-operator rplaca) (%nx1-operator rplacd))) + (inline-op (if (eq op (%nx1-operator rplaca)) (%nx1-operator %rplaca) (%nx1-operator %rplacd)))) + (make-acode (if (or (nx-inline-car-cdr env) + (and (nx-trust-declarations env) + (or (subtypep *nx-form-type* 'cons) + (nx-form-typep pairform 'cons env)))) + inline-op + op) + (nx1-prefer-areg pairform env) + (nx1-form valform)))) + +(defnx1 nx1-set-cXr ((set-car) (set-cdr)) (pairform valform &environment env) + (let* ((op (if (eq *nx-sfname* 'set-car) (%nx1-operator set-car) (%nx1-operator set-cdr))) + (inline-op (if (eq op (%nx1-operator set-car)) (%nx1-operator %rplaca) (%nx1-operator %rplacd))) + (inline-p (or (nx-inline-car-cdr env) + (and (nx-trust-declarations env) + (or (subtypep *nx-form-type* 'cons) + (nx-form-typep pairform 'cons env))))) + (acode (make-acode (if inline-p inline-op op) + (nx1-prefer-areg pairform env) + (nx1-form valform)))) + (if inline-p + (make-acode (if (eq op (%nx1-operator set-car)) (%nx1-operator %car) (%nx1-operator %cdr)) acode) + acode))) + +(defun nx1-cc-binaryop (op cc form1 form2) + (make-acode op (nx1-immediate cc) (nx1-form form1) (nx1-form form2))) + +(defnx1 nx1-ccEQ-unaryop ((characterp) (endp) (consp) (base-char-p)) (arg) + (make-acode (%nx1-default-operator) (nx1-immediate :EQ) (nx1-form arg))) + + + +(defnx1 nx1-ccEQ-binaryop ( (%ptr-eql) (eq)) + (form1 form2) + (nx1-cc-binaryop (%nx1-default-operator) :eq form1 form2)) + + +(defnx1 nx1-ccNE-binaryop ((neq)) + (form1 form2) + (nx1-cc-binaryop (%nx1-default-operator) :ne form1 form2)) + +(defnx1 nx1-logbitp ((logbitp)) (bitnum int &environment env) + (if (and (nx-form-typep bitnum + (target-word-size-case (32 '(integer 0 29)) + (64 '(integer 0 60))) env) + (nx-form-typep int 'fixnum env)) + (nx1-cc-binaryop (%nx1-operator %ilogbitp) :ne bitnum int) + (make-acode (%nx1-operator logbitp) (nx1-form bitnum) (nx1-form int)))) + + + +(defnx1 nx1-ccGT-unaryop ((int>0-p)) (arg) + (make-acode (%nx1-default-operator) (nx1-immediate :gt) (nx1-form arg))) + +(defnx1 nx1-macro-unaryop (multiple-value-list) (arg) + (make-acode + (%nx1-default-operator) (nx1-form arg))) + +(defnx1 nx1-atom ((atom)) (arg) + (nx1-form `(not (consp ,arg)))) + +(defnx1 nx1-locally locally (&body forms) + (with-nx-declarations (pending) + (let ((env *nx-lexical-environment*)) + (multiple-value-bind (body decls) (parse-body forms env nil) + (nx-process-declarations pending decls) + (nx-effect-other-decls pending env) + (setq body (nx1-progn-body body)) + (if decls + (make-acode (%nx1-operator %decls-body) body *nx-new-p2decls*) + body))))) + +(defnx1 nx1-%new-ptr (%new-ptr) (size &optional clear-p) + (make-acode (%nx1-operator %new-ptr) (nx1-form size) (nx1-form clear-p))) + +;;; This might also want to look at, e.g., the last form in a progn: +;;; (not (progn ... x)) => (progn ... (not x)), etc. +(defnx1 nx1-negation ((not) (null)) (arg) + (if (nx1-negate-form (setq arg (nx1-form arg))) + arg + (make-acode (%nx1-operator not) (nx1-immediate :eq) arg))) + +(defun nx1-negate-form (form) + (let* ((subform (nx-untyped-form form))) + (when (and (acode-p subform) (typep (acode-operator subform) 'fixnum)) + (let* ((op (acode-operator subform))) + (declare (fixnum op)) + (when (logbitp operator-cc-invertable-bit op) + (%rplaca + (%cdr (%cadr subform)) + (acode-invert-condition-keyword (%cadr (%cadr subform)))) + t))))) + +;;; This is called from pass 1, and therefore shouldn't mess with "puntable bindings" +;;; (assuming, of course, that anyone should ...) +(defun nx-untyped-form (form) + (while (and (consp form) + (or (and (eq (%car form) (%nx1-operator typed-form)) + (null (nth 3 form))) + (eq (%car form) (%nx1-operator type-asserted-form)))) + (setq form (%caddr form))) + form) + + + +(defnx1 nx1-cxxr ((caar) (cadr) (cdar) (cddr)) (form) + (let* ((op *nx-sfname*)) + (let* ((inner (case op + ((cdar caar) 'car) + (t 'cdr))) + (outer (case op + ((cdar cddr) 'cdr) + (t 'car)))) + (nx1-form `(,outer (,inner ,form)))))) + +(defnx1 nx1-%int-to-ptr ((%int-to-ptr)) (int) + (make-acode + (%nx1-operator %consmacptr%) + (make-acode (%nx1-operator %immediate-int-to-ptr) + (nx1-form int)))) + +(defnx1 nx1-%ptr-to-int ((%ptr-to-int)) (ptr) + (make-acode + (%nx1-operator %immediate-ptr-to-int) + (make-acode (%nx1-operator %macptrptr%) + (nx1-form ptr)))) + +(defnx1 nx1-%null-ptr-p ((%null-ptr-p)) (ptr) + (nx1-form `(%ptr-eql ,ptr (%int-to-ptr 0)))) + +(defnx1 nx1-binop ( (%ilsl) (%ilsr) (%iasr) + (cons) (%temp-cons)) + (arg1 arg2) + (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2))) + + + +(defnx1 nx1-%misc-ref ((%misc-ref)) (v i) + (make-acode (%nx1-operator uvref) (nx1-form v) (nx1-form i))) + + + + +(defnx1 nx1-schar ((schar)) (s i &environment env) + (make-acode (%nx1-operator %sbchar) (nx1-form s env) (nx1-form i env))) + + +;;; This has to be ultra-bizarre because %schar is a macro. +;;; %schar shouldn't be a macro. +(defnx1 nx1-%schar ((%schar)) (arg idx &environment env) + (let* ((arg (nx-transform arg env)) + (idx (nx-transform idx env)) + (argvar (make-symbol "STRING")) + (idxvar (make-symbol "INDEX"))) + (nx1-form `(let* ((,argvar ,arg) + (,idxvar ,idx)) + (declare (optimize (speed 3) (safety 0))) + (declare (simple-base-string ,argvar)) + (schar ,argvar ,idxvar)) env))) + +(defnx1 nx1-%scharcode ((%scharcode)) (arg idx) + (make-acode (%nx1-operator %scharcode) (nx1-form arg)(nx1-form idx))) + + +(defnx1 nx1-svref ((svref) (%svref)) (&environment env v i) + (make-acode (if (nx-inhibit-safety-checking env) + (%nx1-operator %svref) + (%nx1-default-operator)) + (nx1-prefer-areg v env) + (nx1-form i))) + +(defnx1 nx1-%slot-ref ((%slot-ref)) (instance idx) + (make-acode (%nx1-default-operator) + (nx1-form instance) + (nx1-form idx))) + + +(defnx1 nx1-%err-disp ((%err-disp)) (&rest args) + (make-acode (%nx1-operator %err-disp) + (nx1-arglist args))) + +(defnx1 nx1-macro-binop ((nth-value)) (arg1 arg2) + (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2))) + +(defnx1 nx1-%typed-miscref ((%typed-miscref) (%typed-misc-ref)) (subtype uvector index) + (make-acode (%nx1-operator %typed-uvref) + (nx1-form subtype) + (nx1-form uvector) + (nx1-form index))) + + + +(defnx1 nx1-%typed-miscset ((%typed-miscset) (%typed-misc-set)) (subtype uvector index newvalue) + (make-acode (%nx1-operator %typed-uvset) + (nx1-form subtype) + (nx1-form uvector) + (nx1-form index) + (nx1-form newvalue))) + +(defnx1 nx1-logior-2 ((logior-2)) (&whole w &environment env arg-1 arg-2) + (nx-binary-boole-op w + env + arg-1 + arg-2 + (%nx1-operator %ilogior2) + (%nx1-operator logior2) + (%nx1-operator %natural-logior))) + +(defnx1 nx1-logxor-2 ((logxor-2)) (&whole w &environment env arg-1 arg-2) + (nx-binary-boole-op w + env + arg-1 + arg-2 + (%nx1-operator %ilogxor2) + (%nx1-operator logxor2) + (%nx1-operator %natural-logxor))) + +(defnx1 nx1-logand-2 ((logand-2)) (&whole w &environment env arg-1 arg-2) + (nx-binary-boole-op w + env + arg-1 + arg-2 + (%nx1-operator %ilogand2) + (%nx1-operator logand2) + (%nx1-operator %natural-logand))) + +(defnx1 nx1-require ((require-simple-vector) + (require-simple-string) + (require-integer) + (require-list) + (require-fixnum) + (require-real) + (require-character) + (require-number) + (require-symbol) + (require-s8) + (require-u8) + (require-s16) + (require-u16) + (require-s32) + (require-u32) + (require-s64) + (require-u64)) + (arg &environment env) + + (if (nx-inhibit-safety-checking env) + (let* ((op *nx-sfname*) + (type (case op + (require-simple-vector 'simple-vector) + (require-simple-string 'simple-string) + (require-integer 'integer) + (require-list 'list) + (require-fixnum 'fixnum) + (require-real 'real) + (require-character 'character) + (require-number 'number) + (require-symbol 'symbol) + (require-s8 '(signed-byte 8)) + (require-u8 '(unsigned-byte 8)) + (require-s16 '(signed-byte 16)) + (require-u16 '(unsigned-byte 16)) + (require-s32 '(signed-byte 32)) + (require-u32 '(unsigned-byte 32)) + (require-s64 '(signed-byte 64)) + (require-u64 '(unsigned-byte 64))))) + (nx1-form `(the ,type ,arg))) + (make-acode (%nx1-default-operator) (nx1-form arg)))) + +(defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) () + (make-acode (%nx1-default-operator))) + +(defnx1 nx1-throw (throw) (tag valuesform) + (make-acode (%nx1-operator throw) (nx1-form tag) (nx1-form valuesform))) + + +;;; This is still used in inlining/lambda application. +;;; The tricky parts of handling inlining reasonably have to do with +;;; processing the body (including &optional/&key forms) in the environment +;;; in which the lambda was defined (e.g., macros and symbol-macros.) +;;; (I'm not sure that the traditional MCL/OpenMCL frontend handles +;;; these cases 100% correctly, but it seems difficult to do this +;;; correctly without being able to jerk around with the environment, +;;; for a variety of reasons.) +;;; A lambda application - ((lambda ()) ...) is applied in the same +;;; environment it's defined in, so the hard case involves inlining +;;; functions whose environment may contain syntactic constructs +;;; not present in the current environment (and which does -not- generally +;;; contain whatever randomness is floating around at the point of +;;; application.) +(defun nx1-destructure (lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*)) + (let* ((old-env body-env) + (*nx-bound-vars* *nx-bound-vars*) + (bindform (nx1-form bindform))) + (if (not (verify-lambda-list lambda-list t &whole-allowed-p)) + (nx-error "Invalid lambda-list ~s" lambda-list) + (let* ((*nx-lexical-environment* body-env)) + (with-nx-declarations (pending) + (multiple-value-bind (body decls) + (parse-body forms *nx-lexical-environment*) + (nx-process-declarations pending decls) + (multiple-value-bind (req opt rest keys auxen whole) + (nx-parse-structured-lambda-list pending lambda-list nil &whole-allowed-p) + (nx-effect-other-decls pending *nx-lexical-environment*) + (make-acode + (%nx1-operator debind) + nil + bindform + req + opt + rest + keys + auxen + whole + (nx1-env-body body old-env) + *nx-new-p2decls* + cdr-p)))))))) + + + +(defnx1 nx1-%setf-macptr ((%setf-macptr)) (ptr newval) + (let* ((arg1 (nx1-form ptr)) + (arg2 (nx1-form newval))) + (if (and (consp arg1) (eq (%car arg1) (%nx1-operator %consmacptr%))) + ;e.g. (%setf-macptr (%null-ptr) ) + (make-acode (%nx1-operator %consmacptr%) + (make-acode (%nx1-operator progn) + (list arg1 (make-acode (%nx1-operator %macptrptr%) arg2)))) + (make-acode (%nx1-operator %setf-macptr) arg1 arg2)))) + +(defnx1 nx1-%setf-double-float ((%setf-double-float)) (double-node double-val) + (make-acode (%nx1-operator %setf-double-float) (nx1-form double-node) (nx1-form double-val))) + +(defnx1 nx1-%setf-short-float ((%setf-short-float) (%setf-single-float)) (short-node short-val) + (target-word-size-case + (32 + (make-acode (%nx1-operator %setf-short-float) (nx1-form short-node) (nx1-form short-val))) + (64 + (error "%SETF-SHORT-FLOAT makes no sense on 64-bit platforms.")))) + + +(defnx1 nx1-%inc-ptr ((%inc-ptr)) (ptr &optional (increment 1)) + (make-acode (%nx1-operator %consmacptr%) + (make-acode (%nx1-operator %immediate-inc-ptr) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) + (nx1-form increment)))) + +(defnx1 nx1-svset ((svset) (%svset)) (&environment env vector index value) + (make-acode (if (nx-inhibit-safety-checking env) + (%nx1-operator %svset) + (%nx1-default-operator)) + (nx1-prefer-areg vector env) (nx1-form index) (nx1-form value))) + +(defnx1 nx1-+ ((+-2)) (&environment env num1 num2) + (let* ((f1 (nx1-form num1)) + (f2 (nx1-form num2))) + (if (nx-binary-fixnum-op-p num1 num2 env t) + (let* ((fixadd (make-acode (%nx1-operator %i+) f1 f2)) + (small-enough (target-word-size-case + (32 '(signed-byte 28)) + (64 '(signed-byte 59))))) + (if (or (and (nx-acode-form-typep f1 small-enough env) + (nx-acode-form-typep f2 small-enough env)) + (nx-binary-fixnum-op-p num1 num2 env nil)) + fixadd + (make-acode (%nx1-operator typed-form) 'integer (make-acode (%nx1-operator fixnum-overflow) fixadd)))) + (if (and (nx-form-typep num1 'double-float env) + (nx-form-typep num2 'double-float env)) + (nx1-form `(%double-float+-2 ,num1 ,num2)) + (if (and (nx-form-typep num1 'short-float env) + (nx-form-typep num2 'short-float env)) + (nx1-form `(%short-float+-2 ,num1 ,num2)) + (if (nx-binary-natural-op-p num1 num2 env nil) + (make-acode (%nx1-operator typed-form) + (target-word-size-case + (32 '(unsigned-byte 32)) + (64 '(unsigned-byte 64))) + (make-acode (%nx1-operator %natural+) f1 f2)) + (make-acode (%nx1-operator typed-form) 'number + (make-acode (%nx1-operator add2) f1 f2)))))))) + +(defnx1 nx1-%double-float-x-2 ((%double-float+-2) (%double-float--2) (%double-float*-2) (%double-float/-2 )) + (f0 f1) + (make-acode (%nx1-operator typed-form) 'double-float + (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1)))) + + +(defnx1 nx1-%short-float-x-2 ((%short-float+-2) (%short-float--2) (%short-float*-2) (%short-float/-2 )) + (f0 f1) + (make-acode (%nx1-operator typed-form) 'short-float + (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1)))) + + +(defnx1 nx1-*-2 ((*-2)) (&environment env num1 num2) + (if (nx-binary-fixnum-op-p num1 num2 env) + (make-acode (%nx1-operator %i*) (nx1-form num1 env) (nx1-form num2 env)) + (if (and (nx-form-typep num1 'double-float env) + (nx-form-typep num2 'double-float env)) + (nx1-form `(%double-float*-2 ,num1 ,num2)) + (if (and (nx-form-typep num1 'short-float env) + (nx-form-typep num2 'short-float env)) + (nx1-form `(%short-float*-2 ,num1 ,num2)) + (make-acode (%nx1-operator mul2) (nx1-form num1 env) (nx1-form num2 env)))))) + +(defnx1 nx1-%negate ((%negate)) (num &environment env) + (if (nx-form-typep num 'fixnum env) + (if (subtypep *nx-form-type* 'fixnum) + (make-acode (%nx1-operator %%ineg)(nx1-form num)) + (make-acode (%nx1-operator %ineg) (nx1-form num))) + (make-acode (%nx1-operator minus1) (nx1-form num)))) + + +(defnx1 nx1--2 ((--2)) (&environment env num0 num1) + (if (nx-binary-fixnum-op-p num0 num1 env t) + (let* ((f0 (nx1-form num0)) + (f1 (nx1-form num1)) + (fixsub (make-acode (%nx1-operator %i-) f0 f1)) + (small-enough (target-word-size-case + (32 '(signed-byte 28)) + (64 '(signed-byte 59))))) + (if (or (and (nx-acode-form-typep f0 small-enough env) + (nx-acode-form-typep f1 small-enough env)) + (nx-binary-fixnum-op-p num0 num1 env nil)) + fixsub + (make-acode (%nx1-operator fixnum-overflow) fixsub))) + (if (and (nx-form-typep num0 'double-float env) + (nx-form-typep num1 'double-float env)) + (nx1-form `(%double-float--2 ,num0 ,num1)) + (if (and (nx-form-typep num0 'short-float env) + (nx-form-typep num1 'short-float env)) + (nx1-form `(%short-float--2 ,num0 ,num1)) + (if (nx-binary-natural-op-p num0 num1 env nil) + (make-acode (%nx1-operator %natural-) + (nx1-form num0) + (nx1-form num1)) + (make-acode (%nx1-operator sub2) + (nx1-form num0) + (nx1-form num1))))))) + +(defnx1 nx1-/-2 ((/-2)) (num0 num1 &environment env) + (if (and (nx-form-typep num0 'double-float env) + (nx-form-typep num1 'double-float env)) + (nx1-form `(%double-float/-2 ,num0 ,num1)) + (if (and (nx-form-typep num0 'short-float env) + (nx-form-typep num1 'short-float env)) + (nx1-form `(%short-float/-2 ,num0 ,num1)) + (make-acode (%nx1-operator div2) (nx1-form num0) (nx1-form num1))))) + + + +(defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&environment env num1 num2) + (let* ((op *nx-sfname*) + (both-fixnums (nx-binary-fixnum-op-p num1 num2 env t)) + (both-natural (nx-binary-natural-op-p num1 num2 env )) + (both-double-floats + (let* ((dfloat-1 (nx-form-typep num1 'double-float env)) + (dfloat-2 (nx-form-typep num2 'double-float env))) + (if dfloat-1 + (or dfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'double-float)))) + (if dfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'double-float))))))) + (both-short-floats + (let* ((sfloat-1 (nx-form-typep num1 'short-float env)) + (sfloat-2 (nx-form-typep num2 'short-float env))) + (if sfloat-1 + (or sfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'short-float)))) + (if sfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'short-float)))))))) + + (if (or both-fixnums both-double-floats both-short-floats both-natural) + (make-acode + (if both-fixnums + (%nx1-operator %i<>) + (if both-natural + (%nx1-operator %natural<>) + (if both-double-floats + (%nx1-operator double-float-compare) + (%nx1-operator short-float-compare)))) + (make-acode + (%nx1-operator immediate) + (if (eq op '<-2) + :LT + (if (eq op '>=-2) + :GE + (if (eq op '<=-2) + :LE + :GT)))) + (nx1-form num1) + (nx1-form num2)) + (make-acode (%nx1-operator numcmp) + (make-acode + (%nx1-operator immediate) + (if (eq op '<-2) + :LT + (if (eq op '>=-2) + :GE + (if (eq op '<=-2) + :LE + :GT)))) + (nx1-form num1) + (nx1-form num2))))) + +(defnx1 nx1-num= ((=-2) (/=-2)) (&environment env num1 num2 ) + (let* ((op *nx-sfname*) + (2-fixnums (nx-binary-fixnum-op-p num1 num2 env t)) + (2-naturals (nx-binary-natural-op-p num1 num2 env)) + (2-rats (and (nx-form-typep num1 'rational env) + (nx-form-typep num2 'rational env))) + (2-dfloats (let* ((dfloat-1 (nx-form-typep num1 'double-float env)) + (dfloat-2 (nx-form-typep num2 'double-float env))) + (if dfloat-1 + (or dfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'double-float)))) + (if dfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'double-float))))))) + (2-sfloats (let* ((sfloat-1 (nx-form-typep num1 'short-float env)) + (sfloat-2 (nx-form-typep num2 'short-float env))) + (if sfloat-1 + (or sfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'short-float)))) + (if sfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'short-float))))))) + ) + (if (and 2-naturals (not 2-fixnums)) + (make-acode + (%nx1-operator %natural<>) + (make-acode + (%nx1-operator immediate) + (if (eq op '=-2) + :EQ + :NE)) + (nx1-form num1) + (nx1-form num2)) + (if 2-rats + (let* ((form `(,(if 2-fixnums 'eq 'eql) ,num1 ,num2))) + (nx1-form (if (eq op '=-2) form `(not ,form)))) + (if (or 2-dfloats 2-sfloats) + (make-acode + (if 2-dfloats + (%nx1-operator double-float-compare) + (%nx1-operator short-float-compare)) + (make-acode + (%nx1-operator immediate) + (if (eq op '=-2) + :EQ + :NE)) + (nx1-form num1) + (nx1-form num2)) + (make-acode (%nx1-operator numcmp) + (make-acode + (%nx1-operator immediate) + (if (eq op '=-2) + :EQ + :NE)) + (nx1-form num1) + (nx1-form num2))))))) + + +(defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value) + (make-acode (%nx1-operator uvset) + (nx1-form vector) + (nx1-form index) + (nx1-form value))) + +(defnx1 nx1-set-schar ((set-schar)) (s i v) + (make-acode (%nx1-operator %set-sbchar) (nx1-form s) (nx1-form i) (nx1-form v))) + + + +(defnx1 nx1-%set-schar ((%set-schar)) (arg idx char &environment env) + (let* ((arg (nx-transform arg env)) + (idx (nx-transform idx env)) + (char (nx-transform char env)) + (argvar (make-symbol "ARG")) + (idxvar (make-symbol "IDX")) + (charvar (make-symbol "CHAR"))) + (nx1-form `(let* ((,argvar ,arg) + (,idxvar ,idx) + (,charvar ,char)) + (declare (optimize (speed 3) (safety 0))) + (declare (simple-base-string ,argvar)) + (setf (schar ,argvar ,idxvar) ,charvar)) + env))) + +(defnx1 nx1-%set-scharcode ((%set-scharcode)) (s i v) + (make-acode (%nx1-operator %set-scharcode) + (nx1-form s) + (nx1-form i) + (nx1-form v))) + + +(defnx1 nx1-list-vector-values ((list) (vector) (values) (%temp-list)) (&rest args) + (make-acode (%nx1-default-operator) (nx1-formlist args))) + + + +(defnx1 nx1-%gvector ( (%gvector)) (&rest args) + (make-acode (%nx1-operator %gvector) (nx1-arglist args))) + +(defnx1 nx1-quote quote (form) + (nx1-immediate form)) + +(defnx1 nx1-list* ((list*)) (first &rest rest) + (make-acode (%nx1-operator list*) (nx1-arglist (cons first rest) 1))) + + +#| +(defnx1 nx1-append ((append)) (&rest args) + (make-acode (%nx1-operator append) (nx1-arglist args 2))) + + +|# + +(defnx1 nx1-or or (&whole whole &optional (firstform nil firstform-p) &rest moreforms) + (if (not firstform-p) + (nx1-form nil) + (if (null moreforms) + (nx1-form firstform) + (progn + (make-acode (%nx1-operator or) (nx1-formlist (%cdr whole))))))) + +(defun nx1-1d-vref (env arr dim0 &optional uvref-p) + (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env)) + (string-p (unless simple-vector-p + (if (nx-form-typep arr 'string env) + (or (nx-form-typep arr 'simple-string env) + (return-from nx1-1d-vref (nx1-form `(char ,arr ,dim0))))))) + (simple-1d-array-p (unless (or simple-vector-p string-p) + (nx-form-typep arr '(simple-array * (*)) env))) + + (array-type (specifier-type (nx-form-type arr env))) + (type-keyword (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + array-type))) + (if (and simple-1d-array-p type-keyword) + (make-acode (%nx1-operator %typed-uvref) + (nx1-immediate type-keyword) + (nx1-form arr) + (nx1-form dim0)) + (let* ((op (cond (simple-1d-array-p (%nx1-operator uvref)) + (string-p (%nx1-operator %sbchar)) + (simple-vector-p + (if (nx-inhibit-safety-checking env) (%nx1-operator %svref) (%nx1-operator svref))) + (uvref-p (%nx1-operator uvref)) + (t (%nx1-operator %aref1))))) + (make-acode op (nx1-form arr) (nx1-form dim0)))))) + +(defnx1 nx1-aref ((aref)) (&whole whole &environment env arr &optional (dim0 nil dim0-p) + &rest other-dims) + (if (and dim0-p (null other-dims)) + (nx1-1d-vref env arr dim0) + (nx1-treat-as-call whole))) + +(defnx1 nx1-uvref ((uvref)) (&environment env arr dim0) + (nx1-1d-vref env arr dim0 t)) + +(defnx1 nx1-%aref2 ((%aref2)) (&whole whole &environment env arr i j) + ;; Bleah. Breaks modularity. Specialize later. + (target-arch-case + (:x8632 + (return-from nx1-%aref2 (nx1-treat-as-call whole)))) + + (let* ((arch (backend-target-arch *target-backend*)) + (ctype (specifier-type (nx-form-type arr env))) + (atype (if (csubtypep ctype (specifier-type '(array * (* *)))) ctype)) + (simple-atype (if (and atype + (csubtypep atype (specifier-type '(simple-array * (* *))))) + atype)) + (type-keyword (if atype + (funcall + (arch::target-array-type-name-from-ctype-function arch) + atype)))) + (if (and type-keyword simple-atype) + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims))) + (make-acode (%nx1-operator simple-typed-aref2) + (nx1-form type-keyword) + (nx1-form arr) + (nx1-form i) + (nx1-form j) + (nx1-form (if (typep dim0 'fixnum) dim0)) + (nx1-form (if (typep dim1 'fixnum) dim1)))) + (make-acode (%nx1-operator general-aref2) + (nx1-form arr) + (nx1-form i) + (nx1-form j))))) + +(defnx1 nx1-%aref3 ((%aref3)) (&whole whole &environment env arr i j k) + ;; Bleah. Breaks modularity. Specialize later. + (target-arch-case + (:x8632 + (return-from nx1-%aref3 (nx1-treat-as-call whole)))) + + (let* ((arch (backend-target-arch *target-backend*)) + (ctype (specifier-type (nx-form-type arr env))) + (atype (if (csubtypep ctype (specifier-type '(array * (* * *)))) ctype)) + (simple-atype (if (and atype + (csubtypep atype (specifier-type '(simple-array * (* * *))))) + atype)) + (type-keyword (if atype + (funcall + (arch::target-array-type-name-from-ctype-function arch) + atype)))) + (if (and type-keyword simple-atype) + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims)) + (dim2 (caddr dims))) + (make-acode (%nx1-operator simple-typed-aref3) + (nx1-form type-keyword) + (nx1-form arr) + (nx1-form i) + (nx1-form j) + (nx1-form k) + (nx1-form (if (typep dim0 'fixnum) dim0)) + (nx1-form (if (typep dim1 'fixnum) dim1)) + (nx1-form (if (typep dim2 'fixnum) dim2)))) + (make-acode (%nx1-operator general-aref3) + (nx1-form arr) + (nx1-form i) + (nx1-form j) + (nx1-form k))))) + +(defun nx1-1d-vset (arr newval dim0 env) + (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env)) + (string-p (unless simple-vector-p + (if (nx-form-typep arr 'string env) + (or (nx-form-typep arr 'simple-string env) + (return-from nx1-1d-vset (nx1-form `(set-char ,arr ,newval ,dim0))))))) + (simple-1d-array-p (unless (or simple-vector-p string-p) + (nx-form-typep arr '(simple-array * (*)) env))) + (array-type (specifier-type (nx-form-type arr env))) + (type-keyword (funcall + (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + array-type))) + (if (and type-keyword simple-1d-array-p) + (make-acode (%nx1-operator %typed-uvset) + (nx1-immediate type-keyword) + (nx1-form arr) + (nx1-form newval) + (nx1-form dim0)) + (let* ((op (cond (simple-1d-array-p (%nx1-operator uvset)) + (string-p (%nx1-operator %set-sbchar)) + (simple-vector-p (if (nx-inhibit-safety-checking env) (%nx1-operator %svset) (%nx1-operator svset))) + (t (%nx1-operator aset1))))) + (if op + (make-acode + op + (nx1-form arr) + (nx1-form newval) + (nx1-form dim0)) + (nx1-form `(,(if string-p 'set-schar '%aset1) ,arr ,newval ,dim0))))))) + +(defnx1 nx1-aset ((aset)) (&whole whole + arr newval + &optional (dim0 nil dim0-p) + &environment env + &rest other-dims) + (if (and dim0-p (null other-dims)) + (nx1-1d-vset arr newval dim0 env) + (nx1-treat-as-call whole))) + +(defnx1 nx1-%aset2 ((%aset2)) (&whole whole &environment env arr i j new) + ;; Bleah. Breaks modularity. Specialize later. + (target-arch-case + (:x8632 + (return-from nx1-%aset2 (nx1-treat-as-call whole)))) + + (let* ((arch (backend-target-arch *target-backend*)) + (ctype (specifier-type (nx-form-type arr env))) + (atype (if (csubtypep ctype (specifier-type '(array * (* *)))) ctype)) + (simple-atype (if (and atype + (csubtypep atype (specifier-type '(simple-array * (* *))))) + atype)) + (type-keyword (if atype + (funcall + (arch::target-array-type-name-from-ctype-function arch) + atype)))) + + (if (and type-keyword simple-atype) + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims))) + (make-acode (%nx1-operator simple-typed-aset2) + (nx1-form type-keyword) + (nx1-form arr) + (nx1-form i) + (nx1-form j) + (nx1-form new) + (nx1-form (if (typep dim0 'fixnum) dim0)) + (nx1-form (if (typep dim1 'fixnum) dim1)))) + (make-acode (%nx1-operator general-aset2) + (nx1-form arr) + (nx1-form i) + (nx1-form j) + (nx1-form new))))) + +(defnx1 nx1-%aset3 ((%aset3)) (&whole whole &environment env arr i j k new) + ;; Bleah. Breaks modularity. Specialize later. + (target-arch-case + (:x8632 + (return-from nx1-%aset3 (nx1-treat-as-call whole)))) + + (let* ((arch (backend-target-arch *target-backend*)) + (ctype (specifier-type (nx-form-type arr env))) + (atype (if (csubtypep ctype (specifier-type '(array * (* * *)))) ctype)) + (simple-atype (if (and atype + (csubtypep atype (specifier-type '(simple-array * (* * *))))) + atype)) + (type-keyword (if atype + (funcall + (arch::target-array-type-name-from-ctype-function arch) + atype)))) + + (if (and type-keyword simple-atype) + (let* ((dims (array-ctype-dimensions atype)) + (dim0 (car dims)) + (dim1 (cadr dims)) + (dim2 (caddr dims))) + (make-acode (%nx1-operator simple-typed-aset3) + (nx1-form type-keyword) + (nx1-form arr) + (nx1-form i) + (nx1-form j) + (nx1-form k) + (nx1-form new) + (nx1-form (if (typep dim0 'fixnum) dim0)) + (nx1-form (if (typep dim1 'fixnum) dim1)) + (nx1-form (if (typep dim2 'fixnum) dim2)))) + (make-acode (%nx1-operator general-aset3) + (nx1-form arr) + (nx1-form i) + (nx1-form j) + (nx1-form k) + (nx1-form new))))) + +(defnx1 nx1-prog1 (prog1 multiple-value-prog1) (save &body args + &aux (l (list (nx1-form save)))) + (make-acode + (%nx1-default-operator) + (dolist (arg args (nreverse l)) + (push (nx1-form arg) l)))) + +(defnx1 nx1-if if (test true &optional false) + (if (null true) + (if (null false) + (return-from nx1-if (nx1-form `(progn ,test nil))) + (psetq test `(not ,test) true false false true))) + (let ((test-form (nx1-form test)) + ;; Once hit a conditional, no more duplicate warnings + (*compiler-warn-on-duplicate-definitions* nil)) + (make-acode (%nx1-operator if) test-form (nx1-form true) (nx1-form false)))) + +(defnx1 nx1-%debug-trap dbg (&optional arg) + (make-acode (%nx1-operator %debug-trap) (nx1-form arg))) + +(defnx1 nx1-setq setq (&whole whole &rest args &environment env &aux res) + (when (%ilogbitp 0 (length args)) + (nx-error "Odd number of forms in ~s ." whole)) + (while args + (let* ((sym (nx-need-var (%car args) nil)) + (val (%cadr args)) + (declared-type (nx-declared-type sym env))) + (when (nx-declarations-typecheck env) + (unless (or (eq declared-type t) + (and (consp val) (eq (%car val) 'the) (equal (cadr val) declared-type))) + (setq val `(the ,declared-type ,val)) + (nx-note-source-transformation (caddr val) val))) + (multiple-value-bind (expansion win) (macroexpand-1 sym env) + (if win + (push (nx1-form `(setf ,expansion ,val)) res) + (multiple-value-bind (info inherited catchp) + (nx-lex-info sym) + (push + (if (eq info :symbol-macro) + (progn + (nx-set-var-bits catchp + (%ilogior + (%ilsl $vbitsetq 1) + (%ilsl $vbitreffed 1) + (nx-var-bits catchp))) + (nx1-form `(setf ,inherited ,val))) + (let ((valtype (nx-form-type val env))) + (let ((*nx-form-type* declared-type)) + (setq val (nx1-typed-form val env))) + (if (and info (neq info :special)) + (progn + (nx1-check-assignment sym env) + (let ((inittype (var-inittype info))) + (if (and inittype (not (subtypep valtype inittype))) + (setf (var-inittype info) nil))) + (if inherited + (nx-set-var-bits info (%ilogior (%ilsl $vbitsetq 1) + (%ilsl $vbitnoreg 1) ; I know, I know ... Someday ... + (nx-var-bits info))) + (nx-set-var-bits info (%ilogior2 (%ilsl $vbitsetq 1) (nx-var-bits info)))) + (nx-adjust-setq-count info 1 catchp) ; In the hope that that day will come ... + (make-acode (%nx1-operator setq-lexical) info val)) + (make-acode + (if (nx1-check-special-ref sym info) + (progn + (nx-record-xref-info :references sym) + (nx-record-xref-info :sets sym) + (if (nx-global-p sym env) + (%nx1-operator global-setq) + (%nx1-operator setq-special))) + (%nx1-operator setq-free)) ; Screw: no object lisp. Still need setq-free ? For constants ? + (nx1-note-vcell-ref sym) + val)))) + res))) + (setq args (%cddr args))))) + (make-acode (%nx1-operator progn) (nreverse res))) + +;;; See if we're trying to setq something that's currently declared "UNSETTABLE"; whine if so. +;;; If we find a contour in which a "SETTABLE NIL" vdecl for the variable exists, whine. +;;; If we find a contour in which a "SETTABLE T" vdecl for the variable exists. or +;;; the contour in which the variable's bound, return nil. +;;; Should find something ... +(defun nx1-check-assignment (sym env) + (loop + (unless (and env (istruct-typep env 'lexical-environment)) + (return)) + (dolist (decl (lexenv.vdecls env)) + (when (and (eq (car decl) sym) + (eq (cadr decl) 'settable)) + (unless (cddr decl) + (nx1-whine :unsettable sym)) + (return-from nx1-check-assignment nil))) + (let ((vars (lexenv.variables env))) + (unless (atom vars) + (dolist (var vars) + (when (eq (var-name var) sym) (return-from nx1-check-assignment nil))))) + (setq env (lexenv.parent-env env)))) + +;;; The cleanup issue is a little vague (ok, it's a -lot- vague) about the environment in +;;; which the load-time form is defined, although it apparently gets "executed in a null +;;; lexical environment". Ignoring the fact that it's meaningless to talk of executing +;;; something in a lexical environment, we can sort of infer that it must also be defined +;;; in a null lexical environment. + +(defnx1 nx1-load-time-value (load-time-value) (&environment env form &optional read-only-p) + ;; Validate the "read-only-p" argument + (if (and read-only-p (neq read-only-p t)) (require-type read-only-p '(member t nil))) + ;; Then ignore it. + (if *nx-load-time-eval-token* + (multiple-value-bind (function warnings) + (compile-named-function + `(lambda () ,form) + ;; pass in the definition env for special decls + :env (definition-environment env) + :load-time-eval-token *nx-load-time-eval-token* + :target (backend-name *target-backend*)) + (setq *nx-warnings* (append *nx-warnings* warnings)) + (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function)))) + (nx1-immediate (eval form)))) + +(defnx1 nx1-catch (catch) (operation &body body) + (make-acode (%nx1-operator catch) (nx1-form operation) (nx1-catch-body body))) + +(defnx1 nx1-%badarg ((%badarg)) (badthing right-type &environment env) + (make-acode (%nx1-operator %badarg2) + (nx1-form badthing) + (nx1-form (or (if (nx-form-constant-p right-type env) (%typespec-id (nx-form-constant-value right-type env))) + right-type)))) + +(defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form) + (if cleanup-form + (make-acode (%nx1-operator unwind-protect) + (nx1-catch-body (list protected-form)) + (nx1-progn-body cleanup-form)) + (nx1-form protected-form))) + +(defnx1 nx1-progv progv (symbols values &body body) + (make-acode (%nx1-operator progv) + (nx1-form `(check-symbol-list ,symbols)) + (nx1-form values) + (nx1-catch-body body))) + +(defun nx1-catch-body (body) + (let* ((temp (new-lexical-environment *nx-lexical-environment*))) + (setf (lexenv.variables temp) 'catch) + (let* ((*nx-lexical-environment* (new-lexical-environment temp))) + (nx1-progn-body body)))) + + +(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &environment env) + (let ((last (%car (last (push arg args))))) + (if (and (nx-form-constant-p last env) + (null (nx-form-constant-value last env))) + (nx1-form (let ((new `(funcall ,fn ,@(butlast args)))) + (nx-note-source-transformation call new) + new)) + (nx1-apply-fn fn args t)))) + +(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (fn arg &rest args) + (nx1-apply-fn fn (cons arg args) 0)) + +(defun nx1-apply-fn (fn args spread) + (let* ((sym (nx1-func-name fn)) + (afunc (and (non-nil-symbol-p sym) (nth-value 1 (nx-lexical-finfo sym))))) + (when (and afunc (eq afunc *nx-call-next-method-function*)) + (setq fn (let ((new (list 'quote (if (or (car args) (cdr args)) + '%call-next-method-with-args + '%call-next-method)))) + (nx-note-source-transformation fn new) + new) + sym nil + args (cons (var-name *nx-next-method-var*) args))) + (nx1-typed-call (if (non-nil-symbol-p sym) sym (nx1-form fn)) args spread))) + + +(defnx1 nx1-%defun %defun (&whole w def &optional (doc nil doc-p) &environment env) + (declare (ignorable doc doc-p)) + ; Pretty bogus. + (if (and (consp def) + (eq (%car def) 'nfunction) + (consp (%cdr def)) + (or (symbolp (%cadr def)) (setf-function-name-p (%cadr def)))) + (note-function-info (%cadr def) (caddr def) env)) + (nx1-treat-as-call w)) + + +(defnx1 nx1-function function (arg &aux fn afunc) + (if (symbolp arg) + (progn + (when (macro-function arg *nx-lexical-environment*) + (nx-error + "~S can't be used to reference lexically visible macro ~S." + 'function arg)) + (if (multiple-value-setq (fn afunc) (nx-lexical-finfo arg)) + (progn + (when afunc + (incf (afunc-fn-refcount afunc)) + (when (%ilogbitp $fbitbounddownward (afunc-bits afunc)) + (incf (afunc-fn-downward-refcount afunc)))) + (nx1-symbol (%cddr fn))) + (progn + (while (setq fn (assq arg *nx-synonyms*)) + (setq arg (%cdr fn))) + (nx1-form `(%function ',arg))))) + (if (and (consp arg) (eq (%car arg) 'setf)) + (nx1-form `(function ,(nx-need-function-name arg))) + (nx1-ref-inner-function nil arg)))) + +(defnx1 nx1-nfunction nfunction (name def) + (nx1-ref-inner-function name def)) + +(defun nx1-ref-inner-function (name def &optional afunc) + (setq afunc (nx1-compile-inner-function name def afunc)) + (setf (afunc-fn-refcount afunc) 1) + (nx1-afunc-ref afunc)) + +(defun nx1-compile-inner-function (name def p + &optional (env *nx-lexical-environment*) + &aux (q *nx-current-function*)) + (unless p (setq p (make-afunc))) + (setf (afunc-parent p) q) + (setf (afunc-parent q) *nx-parent-function*) + (setf (afunc-tags q) *nx-tags*) + (setf (afunc-blocks q) *nx-blocks*) + (setf (afunc-inner-functions q) (push p *nx-inner-functions*)) + (setf (lexenv.lambda env) q) + (if *nx-current-code-note* + (let* ((*nx-current-code-note* (nx-ensure-code-note def *nx-current-code-note*))) + (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p. + (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*))) + +(defun nx1-afunc-ref (afunc) + (let ((op (if (afunc-inherited-vars afunc) + (%nx1-operator closed-function) + (%nx1-operator simple-function))) + (ref (acode-unwrapped-form (afunc-ref-form afunc)))) + (if ref + (%rplaca ref op) ; returns ref + (setf (afunc-ref-form afunc) + (make-acode + op + afunc))))) + +(defnx1 nx1-%function %function (form &aux symbol) + (let ((sym (nx1-form form))) + (if (and (eq (car sym) (%nx1-operator immediate)) + (setq symbol (cadr sym)) + (symbolp symbol)) + (let ((env *nx-lexical-environment*)) + (unless (or (nx1-find-call-def symbol env) + (find-ftype-decl symbol env) + (eq symbol *nx-global-function-name*)) + (nx1-whine :undefined-function symbol)) + (make-acode (%nx1-default-operator) symbol)) + (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym)))))) + +(defnx1 nx1-tagbody tagbody (&rest args) + (let* ((newtags nil) + (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*)) + (pending (make-pending-declarations)) + (*nx-bound-vars* *nx-bound-vars*) + (catchvar (nx-new-temp-var pending "tagbody-catch-tag")) + (indexvar (nx-new-temp-var pending "tagbody-tag-index")) + (counter (list 0)) + (looplabel (cons nil nil)) + (*nx-tags* *nx-tags*)) + (dolist (form args) + (when (atom form) + (if (or (symbolp form) (integerp form)) + (if (assoc form newtags) + (nx-error "Duplicate tag in TAGBODY: ~S." form) + (push (list form nil counter catchvar nil nil) newtags)) + (nx-error "Illegal form in TAGBODY: ~S." form)))) + (dolist (tag (setq newtags (nreverse newtags))) + (push tag *nx-tags*)) + (let* ((body nil) + (*nx-loop-nesting-level* (1+ *nx-loop-nesting-level*))) + (dolist (form args (setq body (nreverse body))) + (push + (if (atom form) + (let ((info (nx-tag-info form))) + (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t) + (cons (%nx1-operator tag-label) info)) + (nx1-form form)) + body)) + (if (eq 0 (%car counter)) + (make-acode (%nx1-operator local-tagbody) newtags body) + (progn + (nx-set-var-bits catchvar (logior (nx-var-bits catchvar) + (%ilsl $vbitdynamicextent 1))) + (nx-inhibit-register-allocation) ; There are alternatives ... + (dolist (tag (reverse newtags)) + (when (%cadr tag) + (push + (nx1-form `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag)))) + body))) + (make-acode + (%nx1-operator let*) + (list catchvar indexvar) + (list (make-acode (%nx1-operator cons) *nx-nil* *nx-nil*) *nx-nil*) + (make-acode + (%nx1-operator local-tagbody) + (list looplabel) + (list + (cons (%nx1-operator tag-label) looplabel) + (make-acode + (%nx1-operator if) + (make-acode + (%nx1-operator setq-lexical) + indexvar + (make-acode + (%nx1-operator catch) + (nx1-form (var-name catchvar)) + (make-acode + (%nx1-operator local-tagbody) + newtags + body))) + (make-acode (%nx1-operator local-go) looplabel) + *nx-nil*))) + 0)))))) + + + +(defnx1 nx1-go go (tag) + (multiple-value-bind (info closed) + (nx-tag-info tag) + (unless info (nx-error "Can't GO to tag ~S." tag)) + (if (not closed) + (let ((defnbackref (cdr (cdr (cdr (cdr info)))))) + (if (car defnbackref) + (rplaca (cdr defnbackref) t)) + (make-acode (%nx1-operator local-go) info)) + (progn + + (make-acode + (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed)))))) + + + + +;;; address-expression should return a fixnum; that's our little +;;; secret. result spec can be NIL, :void, or anything that an +;;; arg-spec can be. arg-spec can be :double, :single, :address, +;;; :signed-doubleword, :unsigned-doubleword, :signed-fullword, +;;; :unsigned-fullword, :signed-halfword, :unsigned-halfword, +;;; :signed-byte, or :unsigned-byte +;;; On ppc64, :hybrid-int-float, :hybrid-float-float, and :hybrid-float-int +;;; can also be used to express some struct-by-value cases. + +(defparameter *arg-spec-keywords* + '(:double-float :single-float :address :signed-doubleword + :unsigned-doubleword :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword :signed-byte :unsigned-byte + :hybrid-int-float :hybrid-float-int :hybrid-float-float)) + + +(defnx1 nx1-ff-call ((%ff-call)) (address-expression &rest arg-specs-and-result-spec) + (nx1-ff-call-internal + address-expression arg-specs-and-result-spec + (ecase (backend-name *target-backend*) + (:linuxppc32 (%nx1-operator eabi-ff-call)) + ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call)) + ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call)) + ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call))))) + +(defnx1 nx1-syscall ((%syscall)) (idx &rest arg-specs-and-result-spec) + (flet ((map-to-representation-types (list) + (collect ((out)) + (do* ((l list (cddr l))) + ((null (cdr l)) + (if l + (progn + (out (foreign-type-to-representation-type (car l))) + (out)) + (error "Missing result type in ~s" list))) + (out (foreign-type-to-representation-type (car l))) + (out (cadr l)))))) + (nx1-ff-call-internal + idx (map-to-representation-types arg-specs-and-result-spec) + (ecase (backend-name *target-backend*) + (:linuxppc32 (%nx1-operator eabi-syscall)) + ((:darwinppc32 :darwinppc64 :linuxppc64) + (%nx1-operator poweropen-syscall)) + ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall)) + ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall)))))) + +(defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator ) + (let* ((specs ()) + (vals ()) + (register-spec-seen nil) + (arg-specs (butlast arg-specs-and-result-spec)) + (result-spec (car (last arg-specs-and-result-spec)))) + (unless (evenp (length arg-specs)) + (error "odd number of arg-specs")) + (loop + (when (null arg-specs) (return)) + (let* ((arg-keyword (pop arg-specs)) + (value (pop arg-specs))) + (if (or (memq arg-keyword *arg-spec-keywords*) + (typep arg-keyword 'unsigned-byte)) + (progn + (push arg-keyword specs) + (push value vals)) + (if (eq arg-keyword :registers) + (if register-spec-seen + (error "duplicate :registers in ~s" arg-specs-and-result-spec) + (progn + (setq register-spec-seen t) + (push arg-keyword specs) + (push value vals))) + (error "Unknown argument spec: ~s" arg-keyword))))) + (unless (or (eq result-spec :void) + (memq result-spec *arg-spec-keywords*)) + (error "Unknown result spec: ~s" result-spec)) + (make-acode operator + (nx1-form address-expression) + (nreverse specs) + (mapcar #'nx1-form (nreverse vals)) + result-spec + nil))) + +(defnx1 nx1-block block (blockname &body forms) + (let* ((*nx-blocks* *nx-blocks*) + (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*)) + (*nx-bound-vars* *nx-bound-vars*) + (tagvar (nx-new-temp-var (make-pending-declarations))) + (thisblock (cons (setq blockname (nx-need-sym blockname)) tagvar)) + (body nil)) + (push thisblock *nx-blocks*) + (setq body (nx1-progn-body forms)) + (%rplacd thisblock nil) + (let ((tagbits (nx-var-bits tagvar))) + (if (not (%ilogbitp $vbitclosed tagbits)) + (if (neq 0 (%ilogand $vrefmask tagbits)) + (make-acode + (%nx1-operator local-block) + thisblock + body) + body) + (progn + (nx-set-var-bits tagvar (%ilogior (%ilsl $vbitdynamicextent 1) tagbits)) + (nx-inhibit-register-allocation) ; Could also set $vbitnoreg in all setqed vars, or keep track better + (make-acode + (%nx1-operator local-block) + thisblock + (make-acode + (%nx1-operator let) + (list tagvar) + (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil))) + (make-acode + (%nx1-operator catch) + (nx-make-lexical-reference tagvar) + body) + 0))))))) + +(defnx1 nx1-return-from return-from (blockname &optional value) + (multiple-value-bind (info closed) + (nx-block-info (setq blockname (nx-need-sym blockname))) + (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname)) + (unless closed (nx-adjust-ref-count (cdr info))) + (make-acode + (if closed + (%nx1-operator throw) + (%nx1-operator local-return-from)) + (if closed + (nx1-symbol (var-name (cdr info))) + info) + (nx1-form value)))) + +(defnx1 nx1-funcall ((funcall)) (&whole call func &rest args &environment env) + (let ((name (nx1-func-name func))) + (if (or (null name) + (and (symbolp name) (macro-function name env))) + (nx1-typed-call (nx1-form func) args nil) + (progn + (when (consp name) ;; lambda expression + (nx-note-source-transformation func name)) + ;; This picks up call-next-method evil. + (nx1-form (let ((new-form (cons name args))) + (nx-note-source-transformation call new-form) + new-form)))))) + +(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args) + (make-acode (%nx1-default-operator) + (nx1-form value-form) + (nx1-formlist args))) + +(defnx1 nx1-compiler-let compiler-let (bindings &body forms) + (let* ((vars nil) + (varinits nil)) + (dolist (pair bindings) + (push (nx-pair-name pair) vars) + (push (eval (nx-pair-initform pair)) varinits)) + (progv (nreverse vars) (nreverse varinits) (nx1-catch-body forms)))) + +(defnx1 nx1-fbind fbind (fnspecs &body body &environment old-env) + (let* ((fnames nil) + (vars nil) + (vals nil)) + (dolist (spec fnspecs (setq vals (nreverse vals))) + (destructuring-bind (fname initform) spec + (push (setq fname (nx-need-function-name fname)) fnames) + (push (nx1-form initform) vals))) + (let* ((new-env (new-lexical-environment old-env)) + (*nx-bound-vars* *nx-bound-vars*) + (*nx-lexical-environment* new-env) + (pending (make-pending-declarations))) + (dolist (fname fnames) + (let ((var (nx-new-var pending (make-symbol (symbol-name fname))))) + (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) + (nx-var-bits var))) + (let ((afunc (make-afunc))) + (setf (afunc-bits afunc) (%ilsl $fbitruntimedef 1)) + (setf (afunc-lfun afunc) var) + (push var vars) + (push (cons fname (cons 'function (cons afunc (var-name var)))) (lexenv.functions new-env))))) + (make-acode + (%nx1-operator let) + vars + vals + (nx1-env-body body old-env) + *nx-new-p2decls*)))) + +(defun maybe-warn-about-nx1-alphatizer-binding (funcname) + (when (and (symbolp funcname) + (gethash funcname *nx1-alphatizers*)) + (nx1-whine :special-fbinding funcname))) + +(defnx1 nx1-flet flet (defs &body forms) + (with-nx-declarations (pending) + (let* ((env *nx-lexical-environment*) + (*nx-lexical-environment* env) + (*nx-bound-vars* *nx-bound-vars*) + (new-env (new-lexical-environment env)) + (names nil) + (funcs nil) + (pairs nil) + (fname nil) + (name nil)) + (multiple-value-bind (body decls) (parse-body forms env nil) + (nx-process-declarations pending decls) + (dolist (def defs (setq names (nreverse names) funcs (nreverse funcs))) + (destructuring-bind (funcname lambda-list &body flet-function-body) def + (setq fname (nx-need-function-name funcname)) + (maybe-warn-about-nx1-alphatizer-binding funcname) + (multiple-value-bind (body decls) + (parse-body flet-function-body env) + (let ((func (make-afunc)) + (expansion `(lambda ,lambda-list + ,@decls + (block ,(if (consp funcname) (%cadr funcname) funcname) + ,@body)))) + (nx-note-source-transformation def expansion) + (setf (afunc-environment func) env + (afunc-lambdaform func) expansion) + (push func funcs) + (when (and *nx-next-method-var* + (eq funcname 'call-next-method) + (null *nx-call-next-method-function*)) + (setq *nx-call-next-method-function* func)) + (push (cons funcname func) pairs) + (if (consp funcname) + (setq funcname fname)) + (push (setq name (make-symbol (symbol-name funcname))) names) + (push (cons funcname (cons 'function (cons func name))) (lexenv.functions new-env)))))) + (let ((vars nil) + (rvars nil) + (rfuncs nil)) + (dolist (sym names vars) (push (nx-new-var pending sym) vars)) + (nx-effect-other-decls pending new-env) + (setq body (let* ((*nx-lexical-environment* new-env)) + (nx1-dynamic-extent-functions vars new-env) + (nx1-env-body body env))) + (dolist (pair pairs) + (let ((afunc (cdr pair)) + (var (pop vars))) + (when (or (afunc-callers afunc) + (neq 0 (afunc-fn-refcount afunc)) + (neq 0 (afunc-fn-downward-refcount afunc))) + (push (nx1-compile-inner-function (%car pair) + (afunc-lambdaform afunc) + afunc + (afunc-environment afunc)) + rfuncs) + (push var rvars)))) + (nx-reconcile-inherited-vars rfuncs) + (dolist (f rfuncs) (nx1-afunc-ref f)) + (make-acode + (%nx1-operator flet) + rvars + rfuncs + body + *nx-new-p2decls*)))))) + +(defun nx1-dynamic-extent-functions (vars env) + (let ((bits nil) + (varinfo nil)) + (dolist (decl (lexenv.fdecls env)) + (let ((downward-guy (if (eq (cadr decl) 'dynamic-extent) (car decl)))) + (when downward-guy + (multiple-value-bind (finfo afunc) (nx-lexical-finfo downward-guy) + (when (and afunc + (not (%ilogbitp $fbitdownward (setq bits (afunc-bits afunc)))) + (setq varinfo (and (consp (%cdr finfo)) (nx-lex-info (%cddr finfo)))) + (memq varinfo vars)) + (setf (afunc-bits afunc) + (%ilogior + bits + (%ilsl $fbitdownward 1) + (%ilsl $fbitbounddownward 1))) + (nx-set-var-bits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits varinfo)))))))))) + +(defnx1 nx1-labels labels (defs &body forms) + (with-nx-declarations (pending) + (let* ((env *nx-lexical-environment*) + (old-env (lexenv.parent-env env)) + (*nx-bound-vars* *nx-bound-vars*) + (func nil) + (funcs nil) + (funcrefs nil) + (bodies nil) + (vars nil) + (blockname nil) + (fname nil) + (name nil)) + (multiple-value-bind (body decls) (parse-body forms env nil) + (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies))) + (destructuring-bind (funcname lambda-list &body labels-function-body) def + (maybe-warn-about-nx1-alphatizer-binding funcname) + (push (setq func (make-afunc)) funcs) + (setq blockname funcname) + (setq fname (nx-need-function-name funcname)) + (when (consp funcname) + (setq blockname (%cadr funcname) funcname fname)) + (let ((var (nx-new-var pending (setq name (make-symbol (symbol-name funcname)))))) + (nx-set-var-bits var (%ilsl $vbitignoreunused 1)) + (push var vars)) + (push func funcrefs) + (multiple-value-bind (body decls) + (parse-body labels-function-body old-env) + (push (cons funcname (cons 'function (cons func name))) (lexenv.functions env)) + (let* ((expansion `(lambda ,lambda-list + ,@decls + (block ,blockname + ,@body)))) + (nx-note-source-transformation def expansion) + (setf (afunc-lambdaform func) expansion + (afunc-environment func) env) + (push (cons funcname expansion) + bodies))))) + (nx1-dynamic-extent-functions vars env) + (dolist (def bodies) + (nx1-compile-inner-function (car def) (cdr def) (setq func (pop funcs)))) + (nx-process-declarations pending decls) + (nx-effect-other-decls pending env) + (setq body (nx1-env-body body old-env)) + (nx-reconcile-inherited-vars funcrefs) + (dolist (f funcrefs) (nx1-afunc-ref f)) + (make-acode + (%nx1-operator labels) + (nreverse vars) + (nreverse funcrefs) + body + *nx-new-p2decls*))))) + + + +(defnx1 nx1-set-bit ((%set-bit)) (ptr offset &optional (newval nil newval-p)) + (unless newval-p (setq newval offset offset 0)) + (make-acode + (%nx1-operator %set-bit) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) + (nx1-form offset) + (nx1-form newval))) + +(defnx1 nx1-set-xxx ((%set-ptr) (%set-long) (%set-word) (%set-byte) + (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte)) + (ptr offset &optional (newval nil new-val-p) &aux (op *nx-sfname*)) + (unless new-val-p (setq newval offset offset 0)) + (make-acode + (%nx1-operator %immediate-set-xxx) + (case op + (%set-ptr 0) + (%set-word 2) + (%set-unsigned-word (logior 32 2)) + (%set-byte 1) + (%set-unsigned-byte (logior 32 1)) + (%set-unsigned-long (logior 32 4)) + (t 4)) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) + (nx1-form offset) + (nx1-form newval))) + +(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) + (&whole w ptr offset newval &aux (op *nx-sfname*)) + (target-word-size-case + (32 (nx1-treat-as-call w)) + (64 + (make-acode + (%nx1-operator %immediate-set-xxx) + (case op + (%%set-signed-longlong 8) + (t (logior 32 8))) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) + (nx1-form offset) + (nx1-form newval))))) + + +(defnx1 nx1-get-bit ((%get-bit)) (ptrform &optional (offset 0)) + (make-acode + (%nx1-operator typed-form) + 'bit + (make-acode + (%nx1-operator %get-bit) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) + (nx1-form offset)))) + +(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong)) + (&whole w ptrform offsetform) + (target-word-size-case + (32 (nx1-treat-as-call w)) + (64 + (let* ((flagbits (case *nx-sfname* + (%%get-unsigned-longlong 8) + (%%get-signed-longlong (logior 32 8)))) + (signed (logbitp 5 flagbits))) + (make-acode (%nx1-operator typed-form) + (if signed + '(signed-byte 64) + '(unsigned-byte 64)) + (make-acode + (%nx1-operator immediate-get-xxx) + flagbits + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) + (nx1-form offsetform))))))) + +(defnx1 nx1-get-xxx ((%get-long) (%get-full-long) (%get-signed-long) + (%get-fixnum) + (%get-word) (%get-unsigned-word) + (%get-byte) (%get-unsigned-byte) + (%get-signed-word) + (%get-signed-byte) + (%get-unsigned-long)) + (ptrform &optional (offset 0)) + (let* ((sfname *nx-sfname*) + (flagbits (case sfname + ((%get-long %get-full-long %get-signed-long) (logior 4 32)) + (%get-fixnum (logior 4 32 64)) + + ((%get-word %get-unsigned-word) 2) + (%get-signed-word (logior 2 32)) + ((%get-byte %get-unsigned-byte) 1) + (%get-signed-byte (logior 1 32)) + (%get-unsigned-long 4))) + (signed (logbitp 5 flagbits))) + (declare (fixnum flagbits)) + (make-acode (%nx1-operator typed-form) + (case (logand 15 flagbits) + (4 (if (logbitp 6 flagbits) + 'fixnum + (if signed + '(signed-byte 32) + '(unsigned-byte 32)))) + (2 (if signed + '(signed-byte 16) + '(unsigned-byte 16))) + (1 (if signed + '(signed-byte 8) + '(unsigned-byte 8)))) + (make-acode + (%nx1-operator immediate-get-xxx) + flagbits + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) + (nx1-form offset))))) + +(defnx1 nx1-%get-ptr ((%get-ptr) ) (ptrform &optional (offset 0)) + (make-acode + (%nx1-operator %consmacptr%) + (make-acode + (%nx1-operator immediate-get-ptr) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) + (nx1-form offset)))) + +(defnx1 nx1-%get-float ((%get-single-float) + (%get-double-float)) (ptrform &optional (offset 0)) + (make-acode + (%nx1-operator typed-form) + (if (eq *nx-sfname* '%get-single-float) + 'single-float + 'double-float) + (make-acode + (%nx1-default-operator) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) + (nx1-form offset)))) + +(defnx1 nx1-%set-float ((%set-single-float) + (%set-double-float)) (ptrform offset &optional (newval nil newval-p)) + (unless newval-p + (setq newval offset + offset 0)) + (make-acode + (%nx1-operator typed-form) + (if (eq *nx-sfname* '%set-single-float) + 'single-float + 'double-float) + (make-acode + (%nx1-default-operator) + (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) + (nx1-form offset) + (nx1-form newval)))) + +(defnx1 nx1-let let (pairs &body forms &environment old-env) + (collect ((vars) + (vals) + (varbindings)) + (with-nx-declarations (pending) + (multiple-value-bind (body decls) + (parse-body forms *nx-lexical-environment* nil) + (nx-process-declarations pending decls) + ;; Make sure that the initforms are processed in the outer + ;; environment (in case any declaration handlers side-effected + ;; the environment.) + + (let* ((*nx-lexical-environment* old-env)) + (dolist (pair pairs) + (let* ((sym (nx-need-var (nx-pair-name pair))) + (var (nx-cons-var sym)) + (val (nx1-typed-var-initform pending sym (nx-pair-initform pair))) + (binding (nx1-note-var-binding var val))) + (vars var) + (vals val) + (when binding (varbindings binding))))) + (let* ((*nx-bound-vars* *nx-bound-vars*) + (varbindings (varbindings))) + (dolist (v (vars)) (nx-init-var pending v)) + (let* ((form + (make-acode + (%nx1-operator let) + (vars) + (vals) + (progn + (nx-effect-other-decls pending *nx-lexical-environment*) + (nx1-env-body body old-env)) + *nx-new-p2decls*))) + (nx1-check-var-bindings varbindings) + (nx1-punt-bindings (vars) (vals)) + form)))))) + + + +;((lambda (lambda-list) . body) . args) +(defun nx1-lambda-bind (lambda-list args body &optional (body-environment *nx-lexical-environment*)) + (let* ((old-env body-environment) + (arg-env *nx-lexical-environment*) + (arglist nil) + var-bound-vars + vars vals vars* vals*) + ;; If the lambda list contains &LEXPR, we can't do it. Yet. + (multiple-value-bind (ok req opttail resttail) (verify-lambda-list lambda-list) + (declare (ignore req opttail)) + (when (and ok (eq (%car resttail) '&lexpr)) + (return-from nx1-lambda-bind (nx1-call (nx1-form `(lambda ,lambda-list ,@body)) args)))) + (let* ((*nx-lexical-environment* body-environment) + (*nx-bound-vars* *nx-bound-vars*)) + (with-nx-declarations (pending) + (multiple-value-bind (body decls) (parse-body body *nx-lexical-environment*) + (nx-process-declarations pending decls) + (multiple-value-bind (req opt rest keys auxen) + (nx-parse-simple-lambda-list pending lambda-list) + (let* ((*nx-lexical-environment* arg-env)) + (setq arglist (nx1-formlist args))) + (nx-effect-other-decls pending *nx-lexical-environment*) + (setq body (nx1-env-body body old-env)) + (while req + (when (null arglist) + (nx-error "Not enough args ~S for (LAMBDA ~s ...)" args lambda-list)) + (let* ((var (pop req)) + (val (pop arglist)) + (binding (nx1-note-var-binding var val))) + (push var vars) + (push val vals) + (when binding (push binding var-bound-vars)))) + (nx1-check-var-bindings var-bound-vars) + (nx1-punt-bindings vars vals) + (destructuring-bind (&optional optvars inits spvars) opt + (while optvars + (if arglist + (progn + (push (%car optvars) vars) (push (%car arglist) vals) + (when (%car spvars) (push (%car spvars) vars) (push *nx-t* vals))) + (progn + (push (%car optvars) vars*) (push (%car inits) vals*) + (when (%car spvars) (push (%car spvars) vars*) (push *nx-nil* vals*)))) + (setq optvars (%cdr optvars) spvars (%cdr spvars) inits (%cdr inits) + arglist (%cdr arglist)))) + (if arglist + (when (and (not keys) (not rest)) + (nx-error "Extra args ~s for (LAMBDA ~s ...)" args lambda-list)) + (when rest + (push rest vars*) (push *nx-nil* vals*) + (nx1-punt-bindings (cons rest nil) (cons *nx-nil* nil)) + (setq rest nil))) + (when keys + (let* ((punt nil)) + (destructuring-bind (kallowother keyvars spvars inits keyvect) keys + (do* ((pairs arglist (%cddr pairs))) + ((null pairs)) + (let* ((keyword (car pairs))) + (when (or (not (acode-p keyword)) + (neq (acode-operator keyword) (%nx1-operator immediate)) + (eq (%cadr keyword) :allow-other-keys)) + (return (setq punt t))))) + (do* ((nkeys (length keyvect)) + (keyargs (make-array nkeys :initial-element nil)) + (argl arglist (%cddr argl)) + (n 0 (%i+ n 1)) + idx arg hit) + ((null argl) + (unless rest + (while arglist + (push (%cadr arglist) vals) + (setq arglist (%cddr arglist)))) + (dotimes (i (the fixnum nkeys)) + (push (%car keyvars) vars*) + (push (or (%svref keyargs i) (%car inits)) vals*) + (when (%car spvars) + (push (%car spvars) vars*) + (push (if (%svref keyargs i) *nx-t* *nx-nil*) vals*)) + (setq keyvars (%cdr keyvars) inits (%cdr inits) spvars (%cdr spvars))) + (setq keys hit)) + (setq arg (%car argl)) + (unless (and (not punt) + (%cdr argl)) + (let ((var (nx-new-temp-var pending))) + (when (or (null rest) (%ilogbitp $vbitdynamicextent (nx-var-bits rest))) + (nx-set-var-bits var (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits var)))) + (setq body (make-acode + (%nx1-operator debind) + nil + (nx-make-lexical-reference var) + nil + nil + rest + keys + auxen + nil + body + *nx-new-p2decls* + nil) + rest var keys nil auxen nil) + (return nil))) + (unless (or (setq idx (position (%cadr arg) keyvect)) + (eq (%cadr arg) :allow-other-keys) + (and kallowother (symbolp (%cadr arg)))) + (nx-error "Invalid keyword ~s in ~s for (LAMBDA ~S ...)" + (%cadr arg) args lambda-list)) + (when (and idx (null (%svref keyargs idx))) + (setq hit t) + (%svset keyargs idx n)))))) + (destructuring-bind (&optional auxvars auxvals) auxen + (let ((vars!% (nreconc vars* auxvars)) + (vals!& (nreconc vals* auxvals))) + (make-acode (%nx1-operator lambda-bind) + (append (nreverse vals) arglist) + (nreverse vars) + rest + keys + (list vars!% vals!&) + body + *nx-new-p2decls*))))))))) + +(defun nx-inhibit-register-allocation (&optional (why 0)) + (let ((afunc *nx-current-function*)) + (setf (afunc-bits afunc) + (%ilogior (%ilsl $fbitnoregs 1) + why + (afunc-bits afunc))))) + + + +(defnx1 nx1-lap-function (ppc-lap-function) (name bindings &body body) + (declare (ftype (function (t t t)) %define-ppc-lap-function)) + (require "PPC-LAP" "ccl:compiler;ppc;ppc-lap") + (setf (afunc-lfun *nx-current-function*) + (%define-ppc-lap-function name `((let ,bindings ,@body)) + (dpb (length bindings) $lfbits-numreq 0)))) + +(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body) + (declare (ftype (function (t t t)) %define-x86-lap-function)) + (require "X86-LAP") + (setf (afunc-lfun *nx-current-function*) + (%define-x86-lap-function name `((let ,bindings ,@body)) + (dpb (length bindings) $lfbits-numreq 0)))) + + + +(defun nx1-env-body (body old-env &optional (typecheck (nx-declarations-typecheck *nx-lexical-environment*))) + (do* ((form (nx1-progn-body body)) + (typechecks nil) + (env *nx-lexical-environment* (lexenv.parent-env env))) + ((or (eq env old-env) (null env)) + (if typechecks + (make-acode + (%nx1-operator progn) + (nconc (nreverse typechecks) (list form))) + form)) + (let ((vars (lexenv.variables env))) + (when (consp vars) + (dolist (var vars) + (nx-check-var-usage var) + (when (and typecheck + (let ((expansion (var-expansion var))) + (or (atom expansion) (neq (%car expansion) :symbol-macro)))) + (let* ((sym (var-name var)) + (type (nx-declared-type sym))) + (unless (eq type t) + (let ((old-bits (nx-var-bits var))) + (push (nx1-form `(the ,type ,sym)) typechecks) + (when (%izerop (%ilogand2 old-bits + (%ilogior (%ilsl $vbitspecial 1) + (%ilsl $vbitreffed 1) + (%ilsl $vbitclosed 1) + $vrefmask + $vsetqmask))) + (nx-set-var-bits var (%ilogand2 (nx-var-bits var) + (%ilognot (%ilsl $vbitignore 1)))))))))))))) + + +(defnx1 nx1-let* (let*) (varspecs &body forms) + (let* ((vars nil) + (vals nil) + (val nil) + (var-bound-vars nil) + (*nx-bound-vars* *nx-bound-vars*) + (old-env *nx-lexical-environment*)) + (with-nx-declarations (pending) + (multiple-value-bind (body decls) + (parse-body forms *nx-lexical-environment* nil) + (nx-process-declarations pending decls) + (dolist (pair varspecs) + (let* ((sym (nx-need-var (nx-pair-name pair))) + (var (progn + (push (setq val (nx1-typed-var-initform pending sym (nx-pair-initform pair))) vals) + (nx-new-var pending sym))) + (binding (nx1-note-var-binding var val))) + (when binding (push binding var-bound-vars)) + (push var vars))) + (nx-effect-other-decls pending *nx-lexical-environment*) + (let* ((result + (make-acode + (%nx1-default-operator) + (setq vars (nreverse vars)) + (setq vals (nreverse vals)) + (nx1-env-body body old-env) + *nx-new-p2decls*))) + (nx1-check-var-bindings var-bound-vars) + (nx1-punt-bindings vars vals) + result))))) + +(defnx1 nx1-multiple-value-bind multiple-value-bind + (varspecs bindform &body forms) + (if (= (length varspecs) 1) + (nx1-form `(let* ((,(car varspecs) ,bindform)) ,@forms)) + (let* ((vars nil) + (*nx-bound-vars* *nx-bound-vars*) + (old-env *nx-lexical-environment*) + (mvform (nx1-form bindform))) + (with-nx-declarations (pending) + (multiple-value-bind (body decls) + (parse-body forms *nx-lexical-environment* nil) + (nx-process-declarations pending decls) + (dolist (sym varspecs) + (push (nx-new-var pending sym t) vars)) + (nx-effect-other-decls pending *nx-lexical-environment*) + (make-acode + (%nx1-operator multiple-value-bind) + (nreverse vars) + mvform + (nx1-env-body body old-env) + *nx-new-p2decls*)))))) + + +;;; This isn't intended to be user-visible; there isn't a whole lot of +;;; sanity-checking applied to the subtag. +(defnx1 nx1-%alloc-misc ((%alloc-misc)) (element-count subtag &optional (init nil init-p)) + (if init-p ; ensure that "init" is evaluated before miscobj is created. + (make-acode (%nx1-operator %make-uvector) + (nx1-form element-count) + (nx1-form subtag) + (nx1-form init)) + (make-acode (%nx1-operator %make-uvector) + (nx1-form element-count) + (nx1-form subtag)))) + +(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) (base offset) + (make-acode (%nx1-operator %lisp-word-ref) + (nx1-form base) + (nx1-form offset))) + +(defnx1 nx1-%single-to-double ((%single-to-double)) (arg) + (make-acode (%nx1-operator %single-to-double) + (nx1-form arg))) + +(defnx1 nx1-%double-to-single ((%double-to-single)) (arg) + (make-acode (%nx1-operator %double-to-single) + (nx1-form arg))) + +(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) (arg) + (make-acode (%nx1-operator %fixnum-to-double) + (nx1-form arg))) + +(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) (arg) + (make-acode (%nx1-operator %fixnum-to-single) + (nx1-form arg))) + +(defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p)) + (declare (ignore result)) + (if result-p + (nx1-treat-as-call whole) + (make-acode (%nx1-operator %double-float) (nx1-form arg)))) + +(defnx1 nx1-%short-float ((%short-float)) (&whole whole arg &optional (result nil result-p)) + (declare (ignore result)) + (if result-p + (nx1-treat-as-call whole) + (make-acode (%nx1-operator %single-float) (nx1-form arg)))) + + +(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) (arg) + (make-acode (%nx1-default-operator) (nx1-form arg))) + + +(defnx1 nx1-ash (ash) (&whole call &environment env num amt) + (let* ((unsigned-natural-type (target-word-size-case + (32 '(unsigned-byte 32)) + (64 '(unsigned-byte 64)))) + (max (target-word-size-case (32 32) (64 64))) + (maxbits (target-word-size-case + (32 29) + (64 60)))) + (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env)) + ((and (fixnump amt) + (< amt 0)) + (if (nx-form-typep num 'fixnum env) + (make-acode (%nx1-operator %iasr) + (make-acode (%nx1-operator fixnum) + (- amt)) + (nx1-form num)) + (if (nx-form-typep num unsigned-natural-type env) + (if (< (- amt) max) + (make-acode (%nx1-operator natural-shift-right) + (nx1-form num) + (make-acode (%nx1-operator fixnum) + (- amt))) + (nx1-form `(progn (require-type ,num 'integer) 0) env)) + (nx1-treat-as-call call)))) + ((and (fixnump amt) + (<= 0 amt maxbits) + (or (nx-form-typep num `(signed-byte ,(- (1+ maxbits) amt)) env) + (and (nx-form-typep num 'fixnum env) + (nx-trust-declarations env) + (subtypep *nx-form-type* 'fixnum)))) + (nx1-form `(%ilsl ,amt ,num))) + ((and (fixnump amt) + (< amt max) + (nx-form-typep num unsigned-natural-type env) + (nx-trust-declarations env) + (subtypep *nx-form-type* unsigned-natural-type)) + (make-acode (%nx1-operator natural-shift-left) + (nx1-form num) + (nx1-form amt))) + (t (nx1-treat-as-call call))))) + + + +(defun nx-badformat (&rest args) + (nx-error "Bad argument format in ~S ." args)) + +(defnx1 nx1-eval-when eval-when (when &body body) + (nx1-progn-body (if (or (memq 'eval when) (memq :execute when)) body))) + +(defnx1 nx1-misplaced (declare) (&rest args) + (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args))) + Index: /branches/qres/ccl/compiler/nx2.lisp =================================================================== --- /branches/qres/ccl/compiler/nx2.lisp (revision 13564) +++ /branches/qres/ccl/compiler/nx2.lisp (revision 13564) @@ -0,0 +1,273 @@ +;;;-*-Mode: LISP; Package: ccl -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Shared compiler backend utilities and infrastructure. + +(in-package "CCL") + + +(defun nx2-bigger-cdr-than (x y) + (declare (cons x y)) + (> (the fixnum (cdr x)) (the fixnum (cdr y)))) + +;;; Return an unordered list of "varsets": each var in a varset can be +;;; assigned a register and all vars in a varset can be assigned the +;;; same register (e.g., no scope conflicts.) + +(defun nx2-partition-vars (vars inherited-vars) + (labels ((var-weight (var) + (let* ((bits (nx-var-bits var))) + (declare (fixnum bits)) + (if (eql 0 (logand bits (logior + (ash 1 $vbitpuntable) + (ash -1 $vbitspecial) + (ash 1 $vbitnoreg)))) + (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq)) + (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq)))) + 0 + (var-refs var)) + 0))) + (sum-weights (varlist) + (let ((sum 0)) + (dolist (v varlist sum) (incf sum (var-weight v))))) + (vars-disjoint-p (v1 v2) + (if (eq v1 v2) + nil + (if (memq v1 (var-binding-info v2)) + nil + (if (memq v2 (var-binding-info v1)) + nil + t))))) + (dolist (iv inherited-vars) + (dolist (v vars) (push iv (var-binding-info v))) + (push iv vars)) + (setq vars (%sort-list-no-key + ;;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars) + (do* ((handle (cons nil vars)) + (splice handle)) + ((null (cdr splice)) (cdr handle)) + (declare (dynamic-extent handle) (type cons handle splice)) + (if (eql 0 (var-weight (%car (cdr splice)))) + (rplacd splice (%cdr (cdr splice))) + (setq splice (cdr splice)))) + #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2))))) + ;; This isn't optimal. It partitions all register-allocatable + ;; variables into sets such that 1) no variable is a member of + ;; more than one set and 2) all variables in a given set are + ;; disjoint from each other A set might have exactly one member. + ;; If a register is allocated for any member of a set, it's + ;; allocated for all members of that set. + (let* ((varsets nil)) + (do* ((all vars (cdr all))) + ((null all)) + (let* ((var (car all))) + (when (dolist (already varsets t) + (when (memq var (car already)) (return))) + (let* ((varset (cons var nil))) + (dolist (v (cdr all)) + (when (dolist (already varsets t) + (when (memq v (car already)) (return))) + (when (dolist (d varset t) + (unless (vars-disjoint-p v d) (return))) + (push v varset)))) + (let* ((weight (sum-weights varset))) + (declare (fixnum weight)) + (if (>= weight 3) + (push (cons (nreverse varset) weight) varsets))))))) + varsets))) + +;;; Maybe globally allocate registers to symbols naming functions & variables, +;;; and to simple lexical variables. +(defun nx2-allocate-global-registers (fcells vcells all-vars inherited-vars nvrs) + (if (null nvrs) + (progn + (dolist (c fcells) (%rplacd c nil)) + (dolist (c vcells) (%rplacd c nil)) + (values 0 nil)) + (let* ((maybe (nx2-partition-vars all-vars inherited-vars))) + (dolist (c fcells) + (if (>= (the fixnum (cdr c)) 3) (push c maybe))) + (dolist (c vcells) + (if (>= (the fixnum (cdr c)) 3) (push c maybe))) + (do* ((things (%sort-list-no-key maybe #'nx2-bigger-cdr-than) (cdr things)) + (n 0 (1+ n)) + (registers nvrs) + (regno (pop registers) (pop registers)) + (constant-alist ())) + ((or (null things) (null regno)) + (dolist (cell fcells) (%rplacd cell nil)) + (dolist (cell vcells) (%rplacd cell nil)) + (values n constant-alist)) + (declare (list things) + (fixnum n regno)) + (let* ((thing (car things))) + (if (or (memq thing fcells) + (memq thing vcells)) + (push (cons thing regno) constant-alist) + (dolist (var (car thing)) + (setf (var-nvr var) regno)))))))) + +(defun nx2-assign-register-var (v) + (var-nvr v)) + + +(defun nx2-constant-form-p (form) + (setq form (nx-untyped-form form)) + (if form + (or (nx-null form) + (nx-t form) + (and (consp form) + (or (eq (acode-operator form) (%nx1-operator immediate)) + (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator simple-function))))))) + +(defun nx2-lexical-reference-p (form) + (when (acode-p form) + (let ((op (acode-operator (setq form (acode-unwrapped-form-value form))))) + (when (or (eq op (%nx1-operator lexical-reference)) + (eq op (%nx1-operator inherited-arg))) + (%cadr form))))) + +;;; Returns true iff lexical variable VAR isn't setq'ed in FORM. +;;; Punts a lot ... +(defun nx2-var-not-set-by-form-p (var form) + (let* ((bits (nx-var-bits var))) + (or (not (%ilogbitp $vbitsetq bits)) + (nx2-setqed-var-not-set-by-form-p var form (logbitp $vbitclosed bits))))) + +(defun nx2-setqed-var-not-set-by-form-p (var form &optional closed) + (setq form (acode-unwrapped-form form)) + (or (atom form) + (nx2-constant-form-p form) + (nx2-lexical-reference-p form) + (let ((op (acode-operator form)) + (subforms nil)) + (if (eq op (%nx1-operator setq-lexical)) + (and (neq var (cadr form)) + (nx2-setqed-var-not-set-by-form-p var (caddr form))) + (and (or (not closed) + (logbitp operator-side-effect-free-bit op)) + (flet ((not-set-in-formlist (formlist) + (dolist (subform formlist t) + (unless (nx2-setqed-var-not-set-by-form-p var subform closed) (return))))) + (if + (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form))) + ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form)))) + (not-set-in-formlist subforms) + (and (or (eq op (%nx1-operator call)) + (eq op (%nx1-operator lexical-function-call))) + (nx2-setqed-var-not-set-by-form-p var (cadr form)) + (setq subforms (caddr form)) + (not-set-in-formlist (car subforms)) + (not-set-in-formlist (cadr subforms)))))))))) + +(defun nx2-node-gpr-p (reg) + (and reg + (eql (hard-regspec-class reg) hard-reg-class-gpr) + (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node))) + +;;; ENTRIES is a list of recorded-symbol entries, built by pushing +;;; info for each variable referenced by the function AFUNC as it +;;; comes into scope. (Inherited variables "come into scope" before +;;; anything else, then required arguments, etc.) Supplied-p variables +;;; may come into scope before "real" arglist entries do, which confuses +;;; functions that try to construct a function's arglist from the symbol +;;; map. I -think- that confusion only exists when supplied-p variables +;;; are involved, so this returns its first argument unless they are; +;;; otherwise, it ensures that all toplevel arglist symbols are followed +;;; only by any inherited variables, and that the arglist symbols are +;;; in the correct (reversed) order +(defun nx2-recorded-symbols-in-arglist-order (entries afunc) + (let* ((alambda (afunc-acode afunc))) + (when (and (acode-p alambda) + (eq (acode-operator alambda) (%nx1-operator lambda-list))) + (destructuring-bind (req opt rest keys &rest ignore) (cdr alambda) + (declare (ignore ignore)) + (when (or (dolist (sp (caddr opt)) + (when sp (return t))) + (dolist (sp (caddr keys)) + (when sp (return t)))) + (let* ((new ())) + (flet ((info-for-var (var) + (assoc var entries :test #'eq))) + (flet ((add-new-info (var) + (let* ((info (info-for-var var))) + (when info + (push info new))))) + (setq entries (nreverse entries)) + (dolist (var (afunc-inherited-vars afunc)) + (add-new-info var)) + (dolist (r req) + (add-new-info r)) + (dolist (o (car opt)) + (add-new-info o)) + (when (consp rest) + (setq rest (car rest))) + (when rest + (add-new-info rest)) + (dolist (k (cadr keys)) + (add-new-info k)) + (dolist (e entries) + (unless (member e new :test #'eq) + (push e new))) + (setq entries new))))))) + entries)) + +(defun nx2-replace-var-refs (var value) + (when (acode-p value) + (let* ((op (acode-operator value)) + (operands (acode-operands value))) + (when (typep op 'fixnum) + (dolist (ref (var-ref-forms var) (setf (var-ref-forms var) nil)) + (when (acode-p ref) + (setf (acode-operator ref) op + (acode-operands ref) operands))))))) + +(defun acode-immediate-operand (x) + (let* ((x (acode-unwrapped-form x))) + (if (eq (acode-operator x) (%nx1-operator immediate)) + (cadr x) + (compiler-bug "not an immediate: ~s" x)))) + +(defun nx2-constant-index-ok-for-type-keyword (idx keyword) + (when (>= idx 0) + (let* ((arch (backend-target-arch *target-backend*)) + (limit + (case keyword + ((:bignum + :single-float + :double-float + :xcode-vector + :signed-32-bit-vector + :unsigned-32-bit-vector + :single-float-vector + :simple-string) + (arch::target-max-32-bit-constant-index arch)) + (:bit-vector (arch::target-max-1-bit-constant-index arch)) + ((:signed-8-bit-vector :unsigned-8-bit-vector) + (arch::target-max-8-bit-constant-index arch)) + ((:signed-16-bit-vector :unsigned-16-bit-vector) + (arch::target-max-16-bit-constant-index arch)) + ((:signed-64-bit-vector + :unsigned-64-bit-vector + :double-float-vector) + (arch::target-max-64-bit-constant-index arch)) + (t + ;; :fixnum or node + (target-word-size-case + (32 (arch::target-max-32-bit-constant-index arch)) + (64 (arch::target-max-64-bit-constant-index arch))))))) + (and limit (< idx limit))))) Index: /branches/qres/ccl/compiler/nxenv.lisp =================================================================== --- /branches/qres/ccl/compiler/nxenv.lisp (revision 13564) +++ /branches/qres/ccl/compiler/nxenv.lisp (revision 13564) @@ -0,0 +1,601 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;; Compile-time environment for the compiler. + + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require'backquote) + (require 'lispequ) +) + +#-bootstrapped +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (and (macro-function 'var-decls) + (not (macro-function 'var-ref-forms))) + (setf (macro-function 'var-ref-forms) + (macro-function 'var-decls)))) + +#+ppc-target (require "PPCENV") +#+x8632-target (require "X8632ENV") +#+x8664-target (require "X8664ENV") + +(defconstant $vbittemporary 16) ; a compiler temporary +(defconstant $vbitreg 17) ; really wants to live in a register. +(defconstant $vbitnoreg 18) ; something inhibits register allocation +(defconstant $vbitdynamicextent 19) +(defconstant $vbitparameter 20) ; iff special +(defconstant $vbitpunted 20) ; iff lexical +(defconstant $vbitignoreunused 21) +(defconstant $vbitignorable 21) +(defconstant $vbitcloseddownward 22) +(defconstant $vbitsetq 23) +(defconstant $vbitpuntable 24) +(defconstant $vbitclosed 25) +(defconstant $vbitignore 26) +(defconstant $vbitreffed 27) +(defconstant $vbitspecial 28) +(defconstant $vsetqmask #xff00) +(defconstant $vrefmask #xff) + +(defconstant $decl_optimize (%ilsl 16 0)) ; today's chuckle +(defconstant $decl_tailcalls (ash 1 16)) +(defconstant $decl_opencodeinline (ash 4 16)) +(defconstant $decl_eventchk (ash 8 16)) +(defconstant $decl_unsafe (ash 16 16)) +(defconstant $decl_trustdecls (ash 32 16)) +(defconstant $decl_full_safety (ash 64 16)) + +(defconstant $regnote-ea 1) + +(defmacro nx-null (x) + `(eq ,x *nx-nil*)) + +(defmacro nx-t (x) + `(eq ,x *nx-t*)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (defconstant operator-id-mask (1- (%ilsl 10 1))) + (defconstant operator-acode-subforms-bit 10) + (defconstant operator-acode-subforms-mask (%ilsl operator-acode-subforms-bit 1)) + (defconstant operator-acode-list-bit 11) + (defconstant operator-acode-list-mask (%ilsl operator-acode-list-bit 1)) + (defconstant operator-side-effect-free-bit 12) ; operator is side-effect free; subforms may not be ... + (defconstant operator-side-effect-free-mask + (%ilsl operator-side-effect-free-bit 1)) + (defconstant operator-single-valued-bit 13) + (defconstant operator-single-valued-mask + (%ilsl operator-single-valued-bit 1)) + (defconstant operator-assignment-free-bit 14) + (defconstant operator-assignment-free-mask + (%ilsl operator-assignment-free-bit 1)) + (defconstant operator-cc-invertable-bit 15) + (defconstant operator-cc-invertable-mask (ash 1 operator-cc-invertable-bit)) + (defconstant operator-boolean-bit 16) + (defconstant operator-boolean-mask (ash 1 operator-boolean-bit)) + (defconstant operator-returns-address-bit 17) + (defconstant operator-returns-address-mask (ash 1 operator-returns-address-bit)) + + ) + +(defparameter *next-nx-operators* + (reverse + '((%primitive . 0) + (progn . #.(logior operator-acode-list-mask operator-assignment-free-mask operator-side-effect-free-mask)) + (not . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (%i+ . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%i- . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (cxxr . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%dfp-combine . 0) + (%ilsl . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%ilogand2 . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%ilogior2 . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%ilogbitp . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (eq . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (neq . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (list . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-list-mask operator-side-effect-free-mask)) + (values . #.(logior operator-acode-list-mask operator-assignment-free-mask operator-side-effect-free-mask)) + (if . #.(logior operator-acode-subforms-mask operator-side-effect-free-mask)) + (or . 0) + (without-interrupts . 0) + (%fixnum-ref . #.operator-single-valued-mask) + (%fixnum-ref-natural . #.operator-single-valued-mask) + (%current-tcr . #.operator-single-valued-mask) + (%stack-trap . #.operator-single-valued-mask) + (multiple-value-prog1 . 0) + (multiple-value-bind . 0) + (multiple-value-call . 0) + (put-xxx . #.operator-single-valued-mask) + (get-xxx . #.operator-single-valued-mask) + (typed-form . 0) + (let . 0) + (let* . 0) + (tag-label . 0) + (local-tagbody . #.operator-single-valued-mask) + (%fixnum-set-natural . #.operator-single-valued-mask) + (type-asserted-form . 0) + (spushp . #.operator-single-valued-mask) + (simple-function . #.operator-single-valued-mask) + (closed-function . #.operator-single-valued-mask) + (setq-lexical . #.operator-single-valued-mask) + (lexical-reference . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (free-reference . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (immediate . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (fixnum . #.(logior operator-assignment-free-mask operator-single-valued-mask )) + (call . 0) + (local-go . 0) + (local-block . 0) + (local-return-from . 0) + (%car . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%cdr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%rplaca . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (%rplacd . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (cons . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask)) + (simple-typed-aref2 . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) + (setq-free . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (prog1 . 0) + (catch . 0) + (throw . 0) + (unwind-protect . 0) + (characterp . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (multiple-value-list . 0) + (%izerop . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (%immediate-ptr-to-int . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%immediate-int-to-ptr . #.(logior operator-returns-address-mask operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (immediate-get-xxx . 0) + (immediate-put-xxx . 0) + (setq-special . 0) + (special-ref . 0) + (1+ . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (1- . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (add2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (sub2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (numeric-comparison . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-cc-invertable-mask)) + (numcmp . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-single-valued-mask operator-cc-invertable-mask)) + (struct-ref . 0) + (struct-set . 0) + (%aref1 . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask operator-side-effect-free-mask)) + (embedded-nlexit . 0) + (embedded-conditional . 0) + (%word-to-int . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (%svref . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) + (%svset . #.(logior operator-acode-subforms-mask operator-single-valued-mask)) + (%consmacptr% . 0) + (%macptrptr% . 0) + (%ptr-eql . #.operator-cc-invertable-mask) + (%setf-macptr . 0) + (bound-special-ref . 0) + (%char-code . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%code-char . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (lap . 0) + (lap-inline . 0) + (%function . #.operator-single-valued-mask) + (%valid-code-char . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%ttag . #.operator-single-valued-mask) + (uvsize . #.operator-single-valued-mask) + (endp . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (sequence-type . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (fixnum-overflow . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (vector . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (%immediate-inc-ptr . #.(logior operator-returns-address-mask operator-single-valued-mask)) + (general-aref3 . #.(logior operator-acode-subforms-mask operator-single-valued-mask)) + (general-aset2 . #.(logior operator-acode-subforms-mask operator-single-valued-mask)) + (%new-ptr . 0) + (%schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%set-schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) ;?? + (debind . 0) + (lambda-bind . 0) + (general-aset3 . #.(logior operator-acode-subforms-mask operator-single-valued-mask)) + (simple-typed-aref3 . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) + (simple-typed-aset3 . #.(logior operator-acode-subforms-mask operator-single-valued-mask)) + (nth-value . 0) + (progv . 0) + (svref . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (svset . #.operator-single-valued-mask) + (make-list . #.(logior operator-assignment-free-mask operator-single-valued-mask)) ; exists only so we can stack-cons + (%badarg1 . 0) + (%badarg2 . 0) + (newblocktag . 0) + (newgotag . 0) + (flet . 0) ; may not be necessary - for dynamic-extent, mostly + ; for dynamic-extent, forward refs, etc. + (labels . 0) ; removes 75% of LABELS bogosity + (lexical-function-call . 0) ; most of other 25% + (with-downward-closures . 0) + (self-call . 0) + (inherited-arg . #.operator-single-valued-mask) + (ff-call . 0) + (commutative-subprim-binop . 0) + (%immediate-set-xxx . #.(logior operator-acode-subforms-mask)) + (symbol-name . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (memq . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (assq . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (simple-typed-aset2 . #.(logior operator-acode-subforms-mask operator-single-valued-mask)) + (consp . #.(logior operator-cc-invertable-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask)) + (aset1 . #.(logior operator-acode-subforms-mask)) + (syscall . 0) + (car . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (cdr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (length . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (list-length . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (ensure-simple-string . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%ilsr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (set . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (eql . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask)) + (%iasr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (logand2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (logior2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (logxor2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%i<> . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (set-car . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (set-cdr . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (rplaca . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (rplacd . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (with-variable-c-frame . #.(logior operator-acode-list-mask operator-assignment-free-mask)) + (uvref . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (uvset . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (%temp-cons . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%temp-List . #.(logior operator-single-valued-mask operator-side-effect-free-mask)) + (%make-uvector . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-side-effect-free-mask)) + (%decls-body . 0) + (%old-gvector . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%typed-uvref . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%typed-uvset . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (set-schar . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (code-char . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (char-code . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (list* . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-side-effect-free-mask)) + (append . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-side-effect-free-mask)) + (symbolp . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask)) + (integer-point-h . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (integer-point-v . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (int>0-p . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (immediate-constant . #.(logior operator-assignment-free-mask operator-single-valued-mask )) + (with-stack-double-floats . 0) + (short-float . #.operator-single-valued-mask) + (istruct-typep . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (%ilogxor2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%err-disp . 0) + (%quo2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (minus1 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%ineg . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%i* . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (logbitp . #.(logior operator-single-valued-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask)) + (%sbchar . 0) + (%sechar . 0) + (%set-sbchar . 0) + (%scharcode . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%set-scharcode . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (lambda-list . 0) + (ppc-lap-function . 0) + (lisptag . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (fulltag . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (typecode . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-simple-vector . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-simple-string . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-integer . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-fixnum . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-real . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-list . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-character . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-number . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-symbol . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (base-char-p . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (%vect-subtype . #.operator-single-valued-mask) + (%unbound-marker . #.operator-single-valued-mask) + (%slot-unbound-marker . #.operator-single-valued-mask) + (%gvector . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (immediate-get-ptr . #.operator-returns-address-mask) + (%lisp-word-ref . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (%lisp-lowbyte-ref . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (poweropen-ff-call . 0) + (double-float-compare . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (builtin-call . 0) + (%setf-double-float . 0) + (%double-float+-2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (%double-float--2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (%double-float*-2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (%double-float/-2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (%double-float+-2! . 0) + (%double-float--2! . 0) + (%double-float*-2! . 0) + (%double-float/-2! . 0) + (poweropen-syscall . 0) + (%debug-trap . 0) + (%%ineg . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%setf-short-float . 0) + (%short-float+-2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (%short-float--2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (%short-float*-2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (%short-float/-2 . #.(logior operator-single-valued-mask operator-side-effect-free-mask operator-acode-subforms-mask)) + (short-float-compare . 0) + (eabi-ff-call . 0) + (%reference-external-entry-point . 0) + (eabi-syscall . 0) + (%get-bit . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%set-bit . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (%natural+ . 0) + (%natural- . 0) + (%natural-logand . 0) + (%natural-logior . 0) + (%natural-logxor . 0) + (%natural<> . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-cc-invertable-mask)) + (%get-double-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%get-single-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%set-double-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%set-single-float . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (natural-shift-right . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (natural-shift-left . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (global-ref . 0) + (global-setq . 0) + (disable-interrupts . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + + (%interrupt-poll . #.(logior operator-assignment-free-mask operator-single-valued-mask)) + (with-c-frame . #.(logior operator-acode-list-mask operator-assignment-free-mask operator-side-effect-free-mask)) + (%current-frame-ptr . 0) + (%slot-ref . 0) + (%illegal-marker . #.operator-single-valued-mask) + (%symbol->symptr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%single-to-double . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%double-to-single . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%symptr->symvector . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%symvector->symptr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%foreign-stack-pointer . 0) + (mul2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (div2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%fixnum-to-single . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (%fixnum-to-double . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask)) + (require-s8 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-u8 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-s16 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-u16 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-s32 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-u32 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-s64 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (require-u64 . #.(logior operator-single-valued-mask operator-acode-subforms-mask)) + (general-aref2 . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) + (%single-float . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) + (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) + (i386-ff-call . 0) + (i386-syscall . 0)))) + +(defmacro %nx1-operator (sym) + (let ((op (assq sym *next-nx-operators*))) + (if op (logior (%cdr op) (length (%cdr (memq op *next-nx-operators*)))) + (error "Bug - operator not found for ~S" sym)))) + +(declaim (special *nx1-alphatizers* *nx1-operators*)) + +(defmacro %nx1-default-operator () + #-bccl + `(nx1-default-operator) + #+bccl + `(gethash *nx-sfname* *nx1-operators*)) + +(defmacro defnx1 (name sym arglist &body forms) + (let ((fn `(nfunction ,name ,(parse-macro name arglist forms))) + (theprogn ()) + (ysym (gensym))) + `(let ((,ysym ,fn)) + ,(if (symbolp sym) + `(progn + (setf (gethash ',sym *nx1-alphatizers*) ,ysym) + ;(proclaim '(inline ,sym)) + (pushnew ',sym *nx1-compiler-special-forms*)) + (dolist (x sym `(progn ,@(nreverse theprogn))) + (if (consp x) + (setq x (%car x)) + (push `(pushnew ',x *nx1-compiler-special-forms*) theprogn)) + ;(push `(proclaim '(inline ,x)) theprogn) + (push `(setf (gethash ',x *nx1-alphatizers*) ,ysym) theprogn))) + (record-source-file ',name 'function) + ,ysym))) + +(defmacro next-nx-num-ops () + (length *next-nx-operators*)) + +(defmacro next-nx-defops (&aux (ops (gensym)) + (num (gensym)) + (flags (gensym)) + (op (gensym))) + `(let ((,num ,(length *next-nx-operators*)) + (,ops ',*next-nx-operators*) + (,flags nil) + (,op nil)) + (while ,ops + (setq ,op (%car ,ops) ,flags (cdr ,op)) + (setf (gethash (car ,op) *nx1-operators*) + (logior ,flags (setq ,num (%i- ,num 1)))) + (setq ,ops (cdr ,ops))))) + +(defconstant $fbitnextmethargsp 0) +(defconstant $fbitmethodp 1) +(defconstant $fbitnextmethp 2) +(defconstant $fbitnoregs 3) +(defconstant $fbitdownward 4) +(defconstant $fbitresident 5) +(defconstant $fbitbounddownward 6) +(defconstant $fbitembeddedlap 7) +(defconstant $fbitruntimedef 8) +(defconstant $fbitnonnullenv 9) +(defconstant $fbitccoverage 10) + +(defconstant $eaclosedbit 24) + +#+what? +(progn +;;; condition codes : +;;; These are 68K condition code values, but the frontend uses them and +;;; both backends need to understand them. +;;; They're really backend-specific; it wouldn't hurt to have the frontend +;;; use a more "neutral" representation. +(defconstant $ccT 0) +(defconstant $ccEQ 7) +(defconstant $ccNE 6) +(defconstant $ccVC 8) +(defconstant $ccMI 11) +(defconstant $ccPL 10) +(defconstant $ccGE 12) +(defconstant $ccLT 13) +(defconstant $ccGT 14) +(defconstant $ccLE 15) +) + + +(defmacro %temp-push (value place &environment env) + (if (not (consp place)) + `(setq ,place (%temp-cons ,value ,place)) + (multiple-value-bind (dummies vals store-var setter getter) + (get-setf-expansion place env) + (let ((valvar (gensym))) + `(let* ((,valvar ,value) + ,@(mapcar #'list dummies vals) + (,(car store-var) (%temp-cons ,valvar ,getter))) + ,@dummies + ,(car store-var) + ,setter))))) + +; undo tokens : + +(defconstant $undocatch 0) ; do some nthrowing +(defconstant $undovalues 1) ; flush pending multiple values +(defconstant $undostkblk 2) ; discard "variable stack block" +(defconstant $undospecial 3) ; restore dynamic binding +(defconstant $undointerruptlevel 4) ; restore dynamic binding of *interrupt-level* +(defconstant $undomvexpect 5) ; stop expecting values +(defconstant $undoregs 6) ; allocated regs when dynamic extent var bound. + +; Stuff having to do with lisp: + +(defmacro make-acode (operator &rest args) + `(%temp-list ,operator ,@args)) + +(defmacro make-acode* (operator &rest args) + `(%temp-cons ,operator (mapcar #'nx1-form ,@args))) + +; More Bootstrapping Shit. +(defmacro acode-operator (form) + ;; Gak. + `(%car ,form)) + +(defmacro acode-operand (n form) + ;; Gak. Gak. + `(nth ,n (the list ,form))) + +(defmacro acode-operands (form) + ;; Gak. Gak. Gak. + `(%cdr ,form)) + +(defmacro acode-p (x) + " A big help this is ..." + `(consp ,x)) + + +(defmacro defnxdecl (sym lambda-list &body forms) + (multiple-value-bind (body decls) (parse-body forms nil t) + `(setf (getf *nx-standard-declaration-handlers* ',sym ) + (function (lambda ,lambda-list + ,@decls + ,@body))))) + +(defmacro with-declarations ((pending new-env-var &optional old-env) &body body) + `(let* ((,pending (make-pending-declarations)) + (,new-env-var (new-lexical-environment ,old-env))) + ,@body)) + +(defmacro with-nx-declarations ((pending) &body body) + `(let* ((*nx-new-p2decls* nil) + (*nx-inlined-self* *nx-inlined-self*)) + (with-declarations (,pending *nx-lexical-environment* *nx-lexical-environment*) + ,@body))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(declaim (inline + nx-decl-set-fbit + nx-adjust-setq-count + nx-init-var + nx1-sysnode + )) + +(defun nx-init-var (state node) + (let* ((sym (var-name node)) + (env *nx-lexical-environment*) + (bits (%i+ + (if (nx-proclaimed-special-p sym) + (if (nx-proclaimed-parameter-p sym) + (%ilogior (ash -1 $vbitspecial) (%ilsl $vbitparameter 1)) + (ash -1 $vbitspecial)) + 0) + (if (proclaimed-ignore-p sym) (%ilsl $vbitignore 1) 0)))) + (push node (lexenv.variables env)) + (%temp-push node *nx-all-vars*) + (setf (var-binding-info node) *nx-bound-vars*) + (%temp-push node *nx-bound-vars*) + (dolist (decl (nx-effect-vdecls state sym env) (setf (var-bits node) bits)) + (case (car decl) + (special (setq bits (%ilogior bits (ash -1 $vbitspecial) (%ilsl $vbitparameter 1)))) + (ignore (setq bits (%ilogior bits (%ilsl $vbitignore 1)))) + ((ignorable ignore-if-unused) (setq bits (%ilogior bits (%ilsl $vbitignoreunused 1)))) + (dynamic-extent (setq bits (%ilogior bits (%ilsl $vbitdynamicextent 1)))))) + node)) + +(defun nx-decl-set-fbit (bit) + (when *nx-parsing-lambda-decls* + (let* ((afunc *nx-current-function*)) + (setf (afunc-bits afunc) + (%ilogior (%ilsl bit 1) + (afunc-bits afunc)))))) + +(defun nx-adjust-setq-count (var &optional (by 1) catchp) + (let* ((bits (nx-var-bits var)) + (scaled-by (if (%ilogbitp $vbittemporary bits) + by + (expt 4 *nx-loop-nesting-level*))) + (new (%i+ (%ilsr 8 (%ilogand2 $vsetqmask bits)) scaled-by))) + (if (%i> new 255) (setq new 255)) + (setq bits (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vsetqmask) bits) (%ilsl 8 new)))) + ;; If a variable is setq'ed from a catch nested within the construct that + ;; bound it, it can't be allocated to a register. * + ;; * unless it can be proved that the variable isn't referenced + ;; after that catch construct has been exited. ** + ;; ** or unless the saved value of the register in the catch frame + ;; is also updated. + (when catchp + (nx-set-var-bits var (%ilogior2 bits (%ilsl $vbitnoreg 1)))) + (setf (var-refs var) (+ (the fixnum (var-refs var)) by)) + new)) + + +(defun nx1-sysnode (form) + (if form + (if (eq form t) + *nx-t*) + *nx-nil*)) +) + +(defmacro make-mask (&rest weights) + `(logior ,@(mapcar #'(lambda (w) `(ash 1 ,w)) weights))) + +(provide "NXENV") + Index: /branches/qres/ccl/compiler/optimizers.lisp =================================================================== --- /branches/qres/ccl/compiler/optimizers.lisp (revision 13564) +++ /branches/qres/ccl/compiler/optimizers.lisp (revision 13564) @@ -0,0 +1,2501 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; Optimizers.lisp - compiler optimizers + +(in-package "CCL") + +(eval-when (eval compile) + (require'backquote) + (require'lispequ) + (require "ARCH")) + +(declaim (special *nx-can-constant-fold* *nx-synonyms*)) + +(defvar *dont-find-class-optimize* nil) ; t means dont + +#| +;;; can-constant-fold had a bug in the way it called #'proclaim-inline +|# + +;;; There seems to be some confusion about what #'proclaim-inline does. +;;; The value of the alist entry in *nx-proclaimed-inline* indicates +;;; whether or not the compiler is allowed to use any special knowledge +;;; about the symbol in question. That's a necessary but not sufficient +;;; condition to enable inline expansion; that's governed by declarations +;;; in the compile-time environment. +;;; If someone observed a symptom whereby calling CAN-CONSTANT-FOLD +;;; caused unintended inline-expansion, the bug's elsewhere ... +;;; The bug is that nx-declared-inline-p calls proclaimed-inline-p +;;; which looks at what proclaim-inline sets. Presumably, that +;;; means that someone fixed it because it showed evidence of +;;; being broken. +;;; The two concepts (the compiler should/should not make assumptions about +;;; the signature of known functions, the compiler should/should not arrange +;;; to keep the lambda expression around) need to be sorted out. + +(defun can-constant-fold (names &aux handler inlines) + (dolist (name names) + (if (atom name) + (setq handler nil) + (setq handler (cdr name) name (car name))) + (when (and handler (not (eq handler 'fold-constant-subforms))) + (warn "Unknown constant-fold handler : ~s" handler) + (setq handler nil)) + (let* ((bits (%symbol-bits name))) + (declare (fixnum bits)) + (%symbol-bits name (logior + (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold)) + (ash 1 $sym_fbit_constant_fold)) + bits))) + (push name inlines)) + '(apply #'proclaim-inline t inlines) +) + +;;; There's a bit somewhere. This is very partial. Should be a bit +;;; somewhere, there are too many of these to keep on a list. +(can-constant-fold '(specfier-type %ilsl %ilsr 1- 1+ eql eq + byte make-point - / (+ . fold-constant-subforms) (* . fold-constant-subforms) ash character + char-code code-char lsh + (logior . fold-constant-subforms) (logand . fold-constant-subforms) + (logxor . fold-constant-subforms) logcount logorc2 listp consp expt + logorc1 logtest lognand logeqv lognor lognot logandc2 logandc1 + numerator denominator ldb-test byte-position byte-size isqrt gcd + floor mod truncate rem round boole max min ldb dpb mask-field deposit-field + length aref svref char schar bit sbit getf identity list-length + car cdr cadr cddr nth nthcdr last load-byte deposit-byte byte-mask + member search count position assoc rassoc integer-length + float not null char-int expt abs + = /= < <= > >=)) + +(defun %binop-cassoc (call) + (unless (and (cddr call) (null (cdr (%cddr call)))) + (return-from %binop-cassoc call)) + (let ((func (%car call)) + (arg1 (%cadr call)) + (arg2 (%caddr call)) + (val)) + (cond ((and (fixnump arg1) (fixnump arg2)) + (funcall func arg1 arg2)) + ((or (fixnump arg1) (fixnump arg2)) + (if (fixnump arg2) (psetq arg1 arg2 arg2 arg1)) + (if (and (consp arg2) + (eq (%car arg2) func) + (cddr arg2) + (null (cdr (%cddr arg2))) + (or (fixnump (setq val (%cadr arg2))) + (fixnump (setq val (%caddr arg2))))) + (list func + (funcall func arg1 val) + (if (eq val (%cadr arg2)) (%caddr arg2) (%cadr arg2))) + call)) + (t call)))) + +(defun fixnumify (args op &aux (len (length args))) + (if (eq len 2) + (cons op args) + (list op (%car args) (fixnumify (%cdr args) op)))) + +(defun generic-to-fixnum-n (call env op &aux (args (%cdr call)) targs) + (block nil + (if (and (%i> (length args) 1) + (and (nx-trust-declarations env) + (or (neq op '%i+) (subtypep *nx-form-type* 'fixnum)))) + (if (dolist (arg args t) + (if (nx-form-typep arg 'fixnum env) + (push arg targs) + (return))) + (return + (fixnumify (nreverse targs) op)))) + call)) + +;;; True if arg is an alternating list of keywords and args, only +;;; recognizes keywords in keyword package. Historical note: this +;;; used to try to ensure that the keyword appeared at most once. Why +;;; ? (Even before destructuring, pl-search/getf would have dtrt.) +;;; Side effects: it's not the right thing to simply pick the value +;;; associated with the first occurrence of a keyword if the value +;;; associated with subsequent occurrence could have a side-effect. +;;; (We -can- ignore a duplicate key if the associated value is +;;; side-effect free.) +(defun constant-keywords-p (keys) + (when (plistp keys) + (do* ((seen ()) + (keys keys (cddr keys))) + ((null keys) t) + (let* ((key (car keys))) + (if (or (not (keywordp key)) + (and (memq key seen) + (not (constantp (cadr keys))))) + (return)) + (push key seen))))) + + +(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly) + (if (null keys) + `(,default ,item ,list) + (if (constant-keywords-p keys) + (destructuring-bind (&key (test nil test-p) + (test-not nil test-not-p) + (key nil key-p)) + keys + (declare (ignore test-not)) + (if (and test-p + (not test-not-p) + (or (not key-p) + (and (consp key) + (consp (%cdr key)) + (null (%cddr key)) + (or (eq (%car key) 'function) + (eq (%car key) 'quote)) + (eq (%cadr key) 'identity))) + (consp test) + (consp (%cdr test)) + (null (%cddr test)) + (or (eq (%car test) 'function) + (eq (%car test) 'quote))) + (let* ((testname (%cadr test)) + (reduced (cdr (assoc testname alist)))) + (if reduced + `(,reduced ,item ,list) + `(,testonly ,item ,list ,test)))))))) + + +(defun eql-iff-eq-p (thing env) + (if (nx-form-constant-p thing env) + (setq thing (nx-form-constant-value thing env)) + (return-from eql-iff-eq-p + (or (nx-form-typep thing 'symbol env) + (nx-form-typep thing 'character env) + (nx-form-typep thing + '(or fixnum + #+64-bit-target single-float + symbol character + (and (not number) (not macptr))) env)))) + (or (fixnump thing) #+64-bit-target (typep thing 'single-float) + (symbolp thing) (characterp thing) + (and (not (numberp thing)) (not (macptrp thing))))) + +(defun equal-iff-eql-p (thing env) + (if (nx-form-constant-p thing env) + (setq thing (nx-form-constant-value thing env)) + (return-from equal-iff-eql-p + (nx-form-typep thing + '(and (not cons) (not string) (not bit-vector) (not pathname)) env))) + (not (typep thing '(or cons string bit-vector pathname)))) + + +(defun fold-constant-subforms (call env) + (let* ((constants nil) + (forms nil)) + (declare (list constants forms)) + (dolist (form (cdr call)) + (setq form (nx-transform form env)) + (if (numberp form) + (setq constants (%temp-cons form constants)) + (setq forms (%temp-cons form forms)))) + (if constants + (let* ((op (car call)) + (constant (if (cdr constants) (handler-case (apply op constants) + (error (c) (declare (ignore c)) + (return-from fold-constant-subforms (values call t)))) + (car constants)))) + (values (if forms (cons op (cons constant (reverse forms))) constant) t)) + (values call nil)))) + +;;; inline some, etc. in some cases +;;; in all cases, add dynamic-extent declarations +(defun some-xx-transform (call env) + (destructuring-bind (func predicate sequence &rest args) call + (multiple-value-bind (func-constant end-value loop-test) + (case func + (some (values $some nil 'when)) + (notany (values $notany t 'when)) + (every (values $every t 'unless)) + (notevery (values $notevery nil 'unless))) + (if args + (let ((func-sym (gensym)) + (seq-sym (gensym)) + (list-sym (gensym))) + `(let ((,func-sym ,predicate) + (,seq-sym ,sequence) + (,list-sym (list ,@args))) + (declare (dynamic-extent ,func-sym ,list-sym ,seq-sym)) + (some-xx-multi ,func-constant ,end-value ,func-sym ,seq-sym ,list-sym))) + (let ((loop-function (nx-form-sequence-iterator sequence env))) + ;; inline if we know the type of the sequence and if + ;; the predicate is a lambda expression + ;; otherwise, it blows up the code for not much gain + (if (and loop-function + (function-form-p predicate) + (lambda-expression-p (second predicate))) + (let ((elt-var (gensym))) + (case func + (some + `(,loop-function (,elt-var ,sequence ,end-value) + (let ((result (funcall ,predicate ,elt-var))) + (when result (return result))))) + ((every notevery notany) + `(,loop-function (,elt-var ,sequence ,end-value) + (,loop-test (funcall ,predicate ,elt-var) + (return ,(not end-value))))))) + (let ((func-sym (gensym)) + (seq-sym (gensym))) + `(let ((,func-sym ,predicate) + (,seq-sym ,sequence)) + (declare (dynamic-extent ,func-sym ,seq-sym)) + (some-xx-one ,func-constant ,end-value ,func-sym ,seq-sym))))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The new (roughly alphabetical) order. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Compiler macros on functions can assume that their arguments have +;;; already been transformed. + + +(defun transform-real-n-ary-comparision (whole binary-name) + (destructuring-bind (n0 &optional (n1 0 n1-p) &rest more) (cdr whole) + (if more + (if (cdr more) + whole + (let* ((n2 (car more)) + (n (gensym))) + `(let* ((,n ,n0)) + (if (,binary-name ,n (setq ,n ,n1)) + (,binary-name ,n ,n2))))) + (if (not n1-p) + `(require-type ,n0 'real) + `(,binary-name ,n0 ,n1))))) + + + +(define-compiler-macro < (&whole whole &rest ignore) + (declare (ignore ignore)) + (transform-real-n-ary-comparision whole '<-2)) + +(define-compiler-macro > (&whole whole &rest ignore) + (declare (ignore ignore)) + (transform-real-n-ary-comparision whole '>-2)) + +(define-compiler-macro <= (&whole whole &rest ignore) + (declare (ignore ignore)) + (transform-real-n-ary-comparision whole '<=-2)) + +(define-compiler-macro >= (&whole whole &rest ignore) + (declare (ignore ignore)) + (transform-real-n-ary-comparision whole '>=-2)) + + +(define-compiler-macro 1- (x) + `(- ,x 1)) + +(define-compiler-macro 1+ (x) + `(+ ,x 1)) + +(define-compiler-macro append (&whole call + &optional arg0 + &rest + (&whole tail + &optional (junk nil arg1-p) + &rest more)) + ;(append (list x y z) A) -> (list* x y z A) + (if (and arg1-p + (null more) + (consp arg0) + (eq (%car arg0) 'list)) + (cons 'list* (append (%cdr arg0) tail)) + (if (and arg1-p (null more)) + `(append-2 ,arg0 ,junk) + call))) + + +(define-compiler-macro apply (&whole call fn arg0 &rest args) + ;; Special-case (apply #'make-instance 'name ...) + ;; Might be good to make this a little more general, e.g., there + ;; may be other things that can be strength-reduced even if we can't + ;; get rid of the APPLY. + (if (and (consp fn) + (or (eq (car fn) 'quote) + (eq (car fn) 'function)) + (consp (cdr fn)) + (null (cddr fn)) + (eq (cadr fn) 'make-instance) + (consp arg0) + (eq (car arg0) 'quote) + (consp (cdr arg0)) + (symbolp (cadr arg0))) + (let* ((name (cadr arg0)) + (class-cell (gensym))) + `(let* ((,class-cell (load-time-value (find-class-cell ',name t)))) + (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args))) + (let ((original-fn fn)) + (if (and arg0 + (null args) + (consp fn) + (eq (%car fn) 'function) + (null (cdr (%cdr fn))) + (consp (setq fn (%cadr fn))) + (eq (%car fn) 'lambda)) + (destructuring-bind (lambda-list &body body) (%cdr fn) + `(destructuring-bind ,lambda-list ,arg0 ,@body)) + (let ((last (%car (last (push arg0 args))))) + (if (and (consp last) (memq (%car last) '(cons list* list))) + (cons (if (eq (%car last) 'list) 'funcall 'apply) + (cons + original-fn + (nreconc (cdr (reverse args)) (%cdr last)))) + (if (and (consp last) + (eq (car last) 'quote) + (proper-list-p (cadr last))) + (flet ((quotify (arg) + (if (self-evaluating-p arg) + arg + (list 'quote arg)))) + (cons 'funcall (cons original-fn + (nreconc (cdr (reverse args)) (mapcar #'quotify (%cadr last)))))) + call))))))) + + + + +(define-compiler-macro assoc (&whole call item list &rest keys) + (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test) + call)) + +(define-compiler-macro assequal (&whole call &environment env item list) + (if (or (equal-iff-eql-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list)))) + `(asseql ,item ,list) + call)) + +(define-compiler-macro asseql (&whole call &environment env item list) + (if (or (eql-iff-eq-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list)))) + `(assq ,item ,list) + call)) + +(define-compiler-macro assq (item list) + (let* ((itemx (gensym)) + (listx (gensym)) + (pair (gensym))) + `(let* ((,itemx ,item) + (,listx ,list)) + (dolist (,pair ,listx) + (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair)))))) + +(define-compiler-macro caar (form) + `(car (car ,form))) + +(define-compiler-macro cadr (form) + `(car (cdr ,form))) + +(define-compiler-macro cdar (form) + `(cdr (car ,form))) + +(define-compiler-macro cddr (form) + `(cdr (cdr ,form))) + +(define-compiler-macro caaar (form) + `(car (caar ,form))) + +(define-compiler-macro caadr (form) + `(car (cadr ,form))) + +(define-compiler-macro cadar (form) + `(car (cdar ,form))) + +(define-compiler-macro caddr (form) + `(car (cddr ,form))) + +(define-compiler-macro cdaar (form) + `(cdr (caar ,form))) + +(define-compiler-macro cdadr (form) + `(cdr (cadr ,form))) + +(define-compiler-macro cddar (form) + `(cdr (cdar ,form))) + +(define-compiler-macro cdddr (form) + `(cdr (cddr ,form))) + +(define-compiler-macro caaaar (form) + `(car (caaar ,form))) + +(define-compiler-macro caaadr (form) + `(car (caadr ,form))) + +(define-compiler-macro caadar (form) + `(car (cadar ,form))) + +(define-compiler-macro caaddr (form) + `(car (caddr ,form))) + +(define-compiler-macro cadaar (form) + `(car (cdaar ,form))) + +(define-compiler-macro cadadr (form) + `(car (cdadr ,form))) + +(define-compiler-macro caddar (form) + `(car (cddar ,form))) + +(define-compiler-macro cadddr (form) + `(car (cdddr ,form))) + +(define-compiler-macro cdaaar (form) + `(cdr (caaar ,form))) + +(define-compiler-macro cdaadr (form) + `(cdr (caadr ,form))) + +(define-compiler-macro cdadar (form) + `(cdr (cadar ,form))) + +(define-compiler-macro cdaddr (form) + `(cdr (caddr ,form))) + +(define-compiler-macro cddaar (form) + `(cdr (cdaar ,form))) + +(define-compiler-macro cddadr (form) + `(cdr (cdadr ,form))) + +(define-compiler-macro cdddar (form) + `(cdr (cddar ,form))) + +(define-compiler-macro cddddr (form) + `(cdr (cdddr ,form))) + + + + +(define-compiler-macro cons (&whole call x y &aux dcall ddcall) + (if (consp (setq dcall y)) + (cond + ((or (eq (%car dcall) 'list) (eq (%car dcall) 'list*)) + ;(CONS A (LIST[*] . args)) -> (LIST[*] A . args) + (list* (%car dcall) x (%cdr dcall))) + ((or (neq (%car dcall) 'cons) (null (cddr dcall)) (cdddr dcall)) + call) + ((null (setq ddcall (%caddr dcall))) + ;(CONS A (CONS B NIL)) -> (LIST A B) + `(list ,x ,(%cadr dcall))) + ((and (consp ddcall) + (eq (%car ddcall) 'cons) + (eq (list-length ddcall) 3)) + ;(CONS A (CONS B (CONS C D))) -> (LIST* A B C D) + (list* 'list* x (%cadr dcall) (%cdr ddcall))) + (t call)) + call)) + +(define-compiler-macro dotimes (&whole call (i n &optional result) + &body body + &environment env) + (multiple-value-bind (body decls) (parse-body body env) + (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env) + (let* ((limit (gensym)) + (upper (if (nx-form-constant-p n env) (nx-form-constant-value n env) most-positive-fixnum)) + (top (gensym)) + (test (gensym))) + `(let* ((,limit ,n) (,i 0)) + ,@decls + (declare (fixnum ,limit) + (type (integer 0 ,(if (<= upper 0) 0 upper)) ,i) + (unsettable ,i)) + (block nil + (tagbody + (go ,test) + ,top + ,@body + (locally + (declare (settable ,i)) + (setq ,i (1+ ,i))) + ,test + (when (< ,i ,limit) (go ,top))) + ,result))) + call))) + +(define-compiler-macro dpb (&whole call value byte integer) + (cond ((and (integerp byte) (> byte 0)) + (if (integerp value) + `(logior ,(dpb value byte 0) (logand ,(lognot byte) ,integer)) + `(deposit-field (ash ,value ,(byte-position byte)) ,byte ,integer))) + ((and (consp byte) + (eq (%car byte) 'byte) + (eq (list-length (%cdr byte)) 2)) + `(deposit-byte ,value ,(%cadr byte) ,(%caddr byte) ,integer)) + (t call))) + +(define-compiler-macro eql (&whole call &environment env v1 v2) + (if (or (eql-iff-eq-p v1 env) (eql-iff-eq-p v2 env)) + `(eq ,v1 ,v2) + call)) + +(define-compiler-macro every (&whole call &environment env &rest ignore) + (declare (ignore ignore)) + (some-xx-transform call env)) + + +(define-compiler-macro identity (form) form) + +(define-compiler-macro if (&whole call test true &optional false &environment env) + (let ((test-val (nx-transform test env))) + (if (nx-form-constant-p test-val env) + (if (nx-form-constant-value test-val env) + true + false) + call))) + +(define-compiler-macro %ilsr (&whole call shift value) + (if (eql shift 0) + value + (if (eql value 0) + `(progn ,shift 0) + call))) + +(defun string-designator-p (object) + (typecase object + (character t) + (symbol t) + (string t))) + +(define-compiler-macro ldb (&whole call &environment env byte integer) + (cond ((and (integerp byte) (> byte 0)) + (let ((size (byte-size byte)) + (position (byte-position byte))) + (cond ((nx-form-typep integer 'fixnum env) + `(logand ,(byte-mask size) + (the fixnum (ash ,integer ,(- position))))) + (t `(load-byte ,size ,position ,integer))))) + ((and (consp byte) + (eq (%car byte) 'byte) + (eq (list-length (%cdr byte)) 2)) + (let ((size (%cadr byte)) + (position (%caddr byte))) + (if (and (nx-form-typep integer 'fixnum env) (fixnump position)) + ;; I'm not sure this is worth doing + `(logand (byte-mask ,size) (the fixnum (ash ,integer ,(- position)))) + ;; this IS worth doing + `(load-byte ,size ,position ,integer)))) + (t call))) + +(define-compiler-macro length (&whole call &environment env seq) + (if (nx-form-typep seq '(simple-array * (*)) env) + `(uvsize ,seq) + call)) + +(define-compiler-macro let (&whole call (&optional (first nil first-p) &rest rest) &body body) + (if first-p + (if rest + call + `(let* (,first) ,@body)) + `(locally ,@body))) + +(define-compiler-macro let* (&whole call (&rest bindings) &body body) + (if bindings + call + `(locally ,@body))) + +(define-compiler-macro list* (&whole call &rest rest &aux (n (list-length rest)) last) + (cond ((%izerop n) nil) + ((null (setq last (%car (last call)))) + (cons 'list (nreverse (cdr (reverse (cdr call)))))) + ((and (consp last) (memq (%car last) '(list* list cons))) + (cons (if (eq (%car last) 'cons) 'list* (%car last)) + (nreconc (cdr (reverse (cdr call))) (%cdr last)))) + ((eq n 1) (list 'values last)) + ((eq n 2) (cons 'cons (%cdr call))) + (t call))) + + + +;;;(CONS X NIL) is same size as (LIST X) and faster. +(define-compiler-macro list (&whole call &optional (first nil first-p) &rest more) + (if more + call + (if first-p + `(cons ,first nil)))) + + +(define-compiler-macro locally (&whole call &body body &environment env) + (multiple-value-bind (body decls) (parse-body body env nil) + (if decls + call + `(progn ,@body)))) + +(defun target-element-type-type-keyword (typespec &optional env) + (let ((ctype (specifier-type-if-known `(array ,typespec) env))) + (when ctype + (funcall (arch::target-array-type-name-from-ctype-function + (backend-target-arch *target-backend*)) + ctype)))) + +(defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env) + (let* ((ctype (make-array-ctype :complexp (or displaced-to-p fill-pointer-p adjustable-p)))) + (if (nx-form-constant-p dims env) + (let* ((dims (nx-form-constant-value dims env))) + (if (listp dims) + (progn + (unless (every #'fixnump dims) + (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims)) + (setf (array-ctype-dimensions ctype) dims)) + (progn + (unless (typep dims 'fixnum) + (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims)) + (setf (array-ctype-dimensions ctype) (list dims))))) + (if (atom dims) + (if (nx-form-typep dims 'fixnum env) + (setf (array-ctype-dimensions ctype) + (if (typep (setq dims (nx-transform dims env)) 'fixnum) + (list dims) + (list '*))) + (setf (array-ctype-dimensions ctype) '*)) + (if (eq (car dims) 'list) + (setf (array-ctype-dimensions ctype) + (mapcar #'(lambda (d) + (if (typep (setq d (nx-transform d env)) 'fixnum) + d + '*)) + (cdr dims))) + ;; Wimp out + (setf (array-ctype-dimensions ctype) + '*)))) + (let* ((typespec (if element-type-p + (if (nx-form-constant-p element-type env) + (nx-form-constant-value element-type env) + '*) + t)) + (element-type (specifier-type-if-known typespec env :whine t))) + (setf (array-ctype-element-type ctype) (or element-type *wild-type*)) + (specialize-array-type ctype)) + (type-specifier ctype))) + + + +(define-compiler-macro make-array (&whole call &environment env dims &rest keys) + (if (constant-keywords-p keys) + (destructuring-bind (&key (element-type t element-type-p) + (displaced-to () displaced-to-p) + (displaced-index-offset () displaced-index-offset-p) + (adjustable () adjustable-p) + (fill-pointer () fill-pointer-p) + (initial-element () initial-element-p) + (initial-contents () initial-contents-p)) + keys + (declare (ignorable element-type element-type-p + displaced-to displaced-to-p + displaced-index-offset displaced-index-offset-p + adjustable adjustable-p + fill-pointer fill-pointer-p + initial-element initial-element-p + initial-contents initial-contents-p)) + (let* ((element-type-keyword nil) + (expansion + (cond ((and initial-element-p initial-contents-p) + (signal-program-error "Incompatible arguments :INITIAL-ELEMENT and :INITIAL-CONTENTS in ~s" call) + call) + (displaced-to-p + (if (or initial-element-p initial-contents-p element-type-p) + (comp-make-array-1 dims keys) + (comp-make-displaced-array dims keys))) + ((or displaced-index-offset-p + (not (nx-form-constant-p element-type env)) + (null (setq element-type-keyword + (target-element-type-type-keyword + (nx-form-constant-value element-type env) env)))) + (comp-make-array-1 dims keys)) + ((and (typep element-type-keyword 'keyword) + (nx-form-typep dims 'fixnum env) + (null (or adjustable fill-pointer initial-contents + initial-contents-p))) + (if + (or (null initial-element-p) + (cond ((eql element-type-keyword :double-float-vector) + (eql initial-element 0.0d0)) + ((eql element-type-keyword :single-float-vector) + (eql initial-element 0.0s0)) + ((eql element-type :simple-string) + (eql initial-element #\Null)) + (t (eql initial-element 0)))) + `(allocate-typed-vector ,element-type-keyword ,dims) + `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) + (t ;Should do more here + (comp-make-uarray dims keys (type-keyword-code element-type-keyword))))) + (type (if (nx-trust-declarations env) + (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env) + t))) + `(the ,type ,expansion))) + + call)) + +(defun comp-make-displaced-array (dims keys) + (let* ((call-list (make-list 4 :initial-element nil)) + (dims-var (make-symbol "DIMS")) + (let-list (comp-nuke-keys keys + '((:displaced-to 0) + (:fill-pointer 1) + (:adjustable 2) + (:displaced-index-offset 3)) + call-list + `((,dims-var ,dims))))) + + `(let ,let-list + (%make-displaced-array ,dims-var ,@call-list t)))) + +(defun comp-make-uarray (dims keys subtype) + (if (null keys) + `(%make-simple-array ,subtype ,dims) + (let* ((call-list (make-list 6)) + (dims-var (make-symbol "DIMS")) + (let-list (comp-nuke-keys keys + '((:adjustable 0) + (:fill-pointer 1) + (:initial-element 2 3) + (:initial-contents 4 5)) + call-list + `((,dims-var ,dims))))) + `(let ,let-list + (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil))))) + +(defun comp-make-array-1 (dims keys) + (let* ((call-list (make-list 10 :initial-element nil)) + (dims-var (make-symbol "DIMS")) + (let-list (comp-nuke-keys keys + '((:element-type 0 1) + (:displaced-to 2) + (:displaced-index-offset 3) + (:adjustable 4) + (:fill-pointer 5) + (:initial-element 6 7) + (:initial-contents 8 9)) + call-list + `((,dims-var ,dims))))) + `(let ,let-list + (make-array-1 ,dims-var ,@call-list nil)))) + +(defun comp-nuke-keys (keys key-list call-list &optional required-bindings) + ; side effects call list, returns a let-list + (let* ((let-list (reverse required-bindings)) + (seen nil)) + (do ((lst keys (cddr lst))) + ((null lst) nil) + (let* ((key (car lst)) + (val (cadr lst)) + (ass (assq key key-list)) + (vpos (cadr ass)) + (ppos (caddr ass))) + (when ass + (unless (memq vpos seen) + (push vpos seen) + (when (not (constantp val)) + (let ((gen (gensym))) + (setq let-list (cons (list gen val) let-list)) ; reverse him + (setq val gen))) + (rplaca (nthcdr vpos call-list) val) + (if ppos (rplaca (nthcdr ppos call-list) t)))))) + (nreverse let-list))) + +(define-compiler-macro make-instance (&whole call class &rest initargs) + (if (and (listp class) + (eq (car class) 'quote) + (symbolp (cadr class)) + (null (cddr class))) + (let* ((cell (gensym))) + `(let* ((,cell (load-time-value (find-class-cell ,class t)))) + (funcall (class-cell-instantiate ,cell) ,cell ,@initargs))) + call)) + + + + + + + +(define-compiler-macro mapc (&whole call fn lst &rest more) + (if more + call + (let* ((temp-var (gensym)) + (elt-var (gensym)) + (fn-var (gensym))) + `(let* ((,fn-var ,fn) + (,temp-var ,lst)) + (dolist (,elt-var ,temp-var ,temp-var) + (funcall ,fn-var ,elt-var)) + )))) + +(define-compiler-macro mapcar (&whole call fn lst &rest more) + (if more + call + (let* ((temp-var (gensym)) + (result-var (gensym)) + (elt-var (gensym)) + (fn-var (gensym))) + `(let* ((,temp-var (cons nil nil)) + (,result-var ,temp-var) + (,fn-var ,fn)) + (declare (dynamic-extent ,temp-var) + (type cons ,temp-var ,result-var)) + (dolist (,elt-var ,lst (cdr ,result-var)) + (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var))))))))) + +(define-compiler-macro member (&whole call item list &rest keys) + (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test) + call)) + +(define-compiler-macro memequal (&whole call &environment env item list) + (if (or (equal-iff-eql-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list)))) + `(memeql ,item ,list) + call)) + +(define-compiler-macro memeql (&whole call &environment env item list) + (if (or (eql-iff-eq-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list)))) + `(memq ,item ,list) + call)) + +(define-compiler-macro memq (item list) + ;;(memq x '(y)) => (if (eq x 'y) '(y)) + ;;Would it be worth making a two elt list into an OR? Maybe if + ;;optimizing for speed... + (if (and (or (quoted-form-p list) + (null list)) + (null (cdr (%cadr list)))) + (if list `(if (eq ,item ',(%caadr list)) ,list)) + (let* ((x (gensym)) + (tail (gensym))) + `(do* ((,x ,item) + (,tail ,list (cdr (the list ,tail)))) + ((null ,tail)) + (if (eq (car ,tail) ,x) (return ,tail)))))) + +(define-compiler-macro minusp (x) + `(< ,x 0)) + +(define-compiler-macro notany (&whole call &environment env &rest ignore) + (declare (ignore ignore)) + (some-xx-transform call env)) + +(define-compiler-macro notevery (&whole call &environment env &rest ignore) + (declare (ignore ignore)) + (some-xx-transform call env)) + +(define-compiler-macro nth (count list) + (if (and (fixnump count) + (%i>= count 0) + (%i< count 3)) + `(,(svref '#(car cadr caddr) count) ,list) + `(car (nthcdr ,count ,list)))) + +(define-compiler-macro nthcdr (count list) + (if (and (fixnump count) + (%i>= count 0) + (%i< count 4)) + (if (%izerop count) + `(require-type ,list 'list) + `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list)) + (let* ((i (gensym)) + (n (gensym)) ; evaluation order + (tail (gensym))) + `(let* ((,n (require-type ,count 'unsigned-byte)) + (,tail (require-type ,list 'list))) + (dotimes (,i ,n ,tail) + (unless (setq ,tail (cdr ,tail)) + (return nil))))))) + +(define-compiler-macro plusp (x) + `(> ,x 0)) + +(define-compiler-macro progn (&whole call &optional (first nil first-p) &rest rest) + (if first-p + (if rest call first))) + +;;; This isn't quite right... The idea is that (car (require-type foo +;;; 'list)) ;can become just ( foo) [regardless of +;;; optimize settings], ;but I don't think this can be done just with +;;; optimizers... For now, at least try to get it to become (%car +;;; ( foo)). +(define-compiler-macro require-type (&whole call &environment env arg type &aux ctype) + (cond ((and (or (eq type t) + (and (nx-form-constant-p type env) + (setq type (nx-form-constant-value type env)))) + (setq ctype (specifier-type-if-known type env :whine t))) + (cond ((nx-form-typep arg type env) arg) + ((and (nx-trust-declarations env) ;; if don't trust declarations, don't bother. + (cond ((eq type 'simple-vector) + `(the simple-vector (require-simple-vector ,arg))) + ((eq type 'simple-string) + `(the simple-string (require-simple-string ,arg))) + ((eq type 'integer) + `(the integer (require-integer ,arg))) + ((eq type 'fixnum) + `(the fixnum (require-fixnum ,arg))) + ((eq type 'real) + `(the real (require-real ,arg))) + ((eq type 'list) + `(the list (require-list ,arg))) + ((eq type 'character) + `(the character (require-character ,arg))) + ((eq type 'number) + `(the number (require-number ,arg))) + ((eq type 'symbol) + `(the symbol (require-symbol ,arg))) + ((type= ctype + (specifier-type '(signed-byte 8))) + `(the (signed-byte 8) (require-s8 ,arg))) + ((type= ctype + (specifier-type '(unsigned-byte 8))) + `(the (unsigned-byte 8) (require-u8 ,arg))) + ((type= ctype + (specifier-type '(signed-byte 16))) + `(the (signed-byte 16) (require-s16 ,arg))) + ((type= ctype + (specifier-type '(unsigned-byte 16))) + `(the (unsigned-byte 16) (require-u16 ,arg))) + ((type= ctype + (specifier-type '(signed-byte 32))) + `(the (signed-byte 32) (require-s32 ,arg))) + ((type= ctype + (specifier-type '(unsigned-byte 32))) + `(the (unsigned-byte 32) (require-u32 ,arg))) + ((type= ctype + (specifier-type '(signed-byte 64))) + `(the (signed-byte 64) (require-s64 ,arg))) + ((type= ctype + (specifier-type '(unsigned-byte 64))) + `(the (unsigned-byte 64) (require-u64 ,arg))) + #+nil + ((and (symbolp type) + (let ((simpler (type-predicate type))) + (if simpler `(the ,type (%require-type ,arg ',simpler)))))) + #+nil + ((and (symbolp type)(find-class type nil env)) + `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t)))) + (t (let* ((val (gensym))) + `(the ,type + (let* ((,val ,arg)) + (if (typep ,val ',type) + ,val + (%kernel-restart $xwrongtype ,val ',type))))))))) + (t (let* ((val (gensym))) + `(let* ((,val ,arg)) + (if (typep ,val ',type) + ,val + (%kernel-restart $xwrongtype ,val ',type))))))) + (t call))) + +(define-compiler-macro proclaim (&whole call decl) + (if (and (quoted-form-p decl) + (eq (car (setq decl (%cadr decl))) 'special)) + (do ((vars (%cdr decl) (%cdr vars)) (decls ())) + ((null vars) + (cons 'progn (nreverse decls))) + (unless (and (car vars) + (neq (%car vars) t) + (symbolp (%car vars))) + (return call)) + (push (list '%proclaim-special (list 'quote (%car vars))) decls)) + call)) + + +(define-compiler-macro some (&whole call &environment env &rest ignore) + (declare (ignore ignore)) + (some-xx-transform call env)) + +(define-compiler-macro struct-ref (&whole call &environment env struct offset) + (if (nx-inhibit-safety-checking env) + `(%svref ,struct ,offset) + call)) + +;;; expand find-if and find-if-not + +(define-compiler-macro find-if (test sequence &rest keys) + `(find ,test ,sequence + :test #'funcall + ,@keys)) + +(define-compiler-macro find-if-not (test sequence &rest keys) + `(find ,test ,sequence + :test-not #'funcall + ,@keys)) + +;;; inline some cases, and use a positional function in others + +(define-compiler-macro find (&whole call &environment env + item sequence &rest keys) + (if (constant-keywords-p keys) + (destructuring-bind (&key from-end test test-not (start 0) end key) keys + (if (and (eql start 0) + (null end) + (null from-end) + (not (and test test-not))) + (let ((find-test (or test test-not '#'eql)) + (loop-test (if test-not 'unless 'when)) + (loop-function (nx-form-sequence-iterator sequence env))) + (if loop-function + (let ((item-var (unless (or (nx-form-constant-p item env) + (and (equal find-test '#'funcall) + (function-form-p item))) + (gensym))) + (elt-var (gensym))) + `(let (,@(when item-var `((,item-var ,item)))) + (,loop-function (,elt-var ,sequence) + (,loop-test (funcall ,find-test ,(or item-var item) + (funcall ,(or key '#'identity) ,elt-var)) + (return ,elt-var))))) + (let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key)) + (item-var (gensym)) + (sequence-var (gensym)) + (test-var (gensym)) + (key-var (gensym))) + `(let ((,item-var ,item) + (,sequence-var ,sequence) + (,test-var ,(or test test-not)) + (,key-var ,key)) + (declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var)) + (,find-function ,item-var ,sequence-var ,test-var ,key-var))))) + call)) + call)) + +;;; expand position-if and position-if-not + +(define-compiler-macro position-if (test sequence &rest keys) + `(position ,test ,sequence + :test #'funcall + ,@keys)) + +(define-compiler-macro position-if-not (test sequence &rest keys) + `(position ,test ,sequence + :test-not #'funcall + ,@keys)) + +;;; inline some cases, and use positional functions for others + +(define-compiler-macro position (&whole call &environment env + item sequence &rest keys) + (if (constant-keywords-p keys) + (destructuring-bind (&key from-end test test-not (start 0) end key) keys + (if (and (eql start 0) + (null end) + (null from-end) + (not (and test test-not))) + (let ((position-test (or test test-not '#'eql)) + (loop-test (if test-not 'unless 'when))) + (cond ((nx-form-typep sequence 'list env) + (let ((item-var (unless (or (nx-form-constant-p item env) + (and (equal position-test '#'funcall) + (function-form-p item))) + (gensym))) + (elt-var (gensym)) + (position-var (gensym))) + `(let (,@(when item-var `((,item-var ,item))) + (,position-var 0)) + (dolist (,elt-var ,sequence) + (,loop-test (funcall ,position-test ,(or item-var item) + (funcall ,(or key '#'identity) ,elt-var)) + (return ,position-var)) + (incf ,position-var))))) + ((nx-form-typep sequence 'vector env) + (let ((item-var (unless (or (nx-form-constant-p item env) + (and (equal position-test '#'funcall) + (function-form-p item))) + (gensym))) + (sequence-var (gensym)) + (position-var (gensym))) + `(let (,@(when item-var `((,item-var ,item))) + (,sequence-var ,sequence)) + ,@(let ((type (nx-form-type sequence env))) + (unless (eq type t) + `((declare (type ,type ,sequence-var))))) + (dotimes (,position-var (length ,sequence-var)) + (,loop-test (funcall ,position-test ,(or item-var item) + (funcall ,(or key '#'identity) + (locally (declare (optimize (speed 3) (safety 0))) + (aref ,sequence ,position-var)))) + (return ,position-var)))))) + (t + (let ((position-function (if test-not + 'position-positional-test-not-key + 'position-positional-test-key)) + (item-var (gensym)) + (sequence-var (gensym)) + (test-var (gensym)) + (key-var (gensym))) + `(let ((,item-var ,item) + (,sequence-var ,sequence) + (,test-var ,(or test test-not)) + (,key-var ,key)) + (declare (dynamic-extent ,sequence-var ,test-var ,key-var)) + (,position-function ,item-var ,sequence-var ,test-var ,key-var)))))) + call)) + call)) + +;;; inline some cases of remove-if and remove-if-not + +(define-compiler-macro remove-if (&whole call &environment env &rest ignore) + (declare (ignore ignore)) + (remove-if-transform call env)) + +(define-compiler-macro remove-if-not (&whole call &environment env &rest ignore) + (declare (ignore ignore)) + (remove-if-transform call env)) + +(defun remove-if-transform (call env) + (destructuring-bind (function test sequence &rest keys) call + (if (constant-keywords-p keys) + (destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys + (if (and (eql start 0) + (null end) + (null from-end) + (null count) + (nx-form-typep sequence 'list env)) + ;; only do the list case, since it's hard to collect vector results + (let ((temp-var (gensym)) + (result-var (gensym)) + (elt-var (gensym)) + (loop-test (ecase function (remove-if 'unless) (remove-if-not 'when)))) + `(the list + (let* ((,temp-var (cons nil nil)) + (,result-var ,temp-var)) + (declare (dynamic-extent ,temp-var)) + (dolist (,elt-var ,sequence (%cdr ,result-var)) + (,loop-test (funcall ,test (funcall ,key ,elt-var)) + (setq ,temp-var + (%cdr + (%rplacd ,temp-var (list ,elt-var))))))))) + call)) + call))) + + + +(define-compiler-macro struct-set (&whole call &environment env struct offset new) + (if (nx-inhibit-safety-checking env) + `(%svset ,struct ,offset ,new) + call)) + +(define-compiler-macro zerop (arg &environment env) + (let* ((z (if (nx-form-typep arg 'float env) + (coerce 0 (nx-form-type arg env)) + 0))) + `(= ,arg ,z))) + + +(define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more) + (if (not n1p) + `(require-type ,n0 'number) + (if more + w + `(=-2 ,n0 ,n1)))) + +(define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more) + (if (not n1p) + `(require-type ,n0 'number) + (if more + w + `(/=-2 ,n0 ,n1)))) + +(define-compiler-macro + (&optional (n0 nil n0p) (n1 nil n1p) &rest more &environment env) + (if more + (if (and (nx-trust-declarations env) + (subtypep *nx-form-type* 'fixnum) + (nx-form-typep n0 'fixnum env) + (nx-form-typep n1 'fixnum env) + (dolist (m more t) + (unless (nx-form-typep m 'fixnum env) + (return nil)))) + `(+-2 ,n0 (the fixnum (+ ,n1 ,@more))) + `(+ (+-2 ,n0 ,n1) ,@more)) + (if n1p + `(+-2 ,n0 ,n1) + (if n0p + `(require-type ,n0 'number) + 0)))) + +(define-compiler-macro - (n0 &optional (n1 nil n1p) &rest more) + (if more + `(- (--2 ,n0 ,n1) ,@more) + (if n1p + `(--2 ,n0 ,n1) + `(%negate ,n0)))) + +(define-compiler-macro * (&optional (n0 nil n0p) (n1 nil n1p) &rest more) + (if more + `(*-2 ,n0 (* ,n1 ,@more)) + (if n1p + `(*-2 ,n0 ,n1) + (if n0p + `(require-type ,n0 'number) + 1)))) + +(define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more) + (if more + w + (if n1p + `(/-2 ,n0 ,n1) + `(%quo-1 ,n0)))) + +;;; beware of limits - truncate of most-negative-fixnum & -1 ain't a +;;; fixnum - too bad +(define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p)) + (let ((*nx-form-type* t)) + (if (nx-form-typep n0 'fixnum env) + (if (not n1p) + n0 + (if (nx-form-typep n1 'fixnum env) + `(%fixnum-truncate ,n0 ,n1) + w)) + w))) + +(define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p)) + (let ((*nx-form-type* t)) + (if (nx-form-typep n0 'fixnum env) + (if (not n1p) + n0 + (if (nx-form-typep n1 'fixnum env) + `(%fixnum-floor ,n0 ,n1) + w)) + w))) + +(define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p)) + (let ((*nx-form-type* t)) ; it doesn't matter what the result type is declared to be + (if (nx-form-typep n0 'fixnum env) + (if (not n1p) + n0 + (if (nx-form-typep n1 'fixnum env) + `(%fixnum-round ,n0 ,n1) + w)) + w))) + +(define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p)) + (let ((*nx-form-type* t)) + (if (nx-form-typep n0 'fixnum env) + (if (not n1p) + n0 + (if (nx-form-typep n1 'fixnum env) + `(%fixnum-ceiling ,n0 ,n1) + w)) + w))) + +(define-compiler-macro oddp (&whole w &environment env n0) + (if (nx-form-typep n0 'fixnum env) + `(logbitp 0 (the fixnum ,n0)) + w)) + +(define-compiler-macro evenp (&whole w &environment env n0) + (if (nx-form-typep n0 'fixnum env) + `(not (logbitp 0 (the fixnum ,n0))) + w)) + + +(define-compiler-macro logandc2 (n0 n1) + (let ((n1var (gensym)) + (n0var (gensym))) + `(let ((,n0var ,n0) + (,n1var ,n1)) + (logandc1 ,n1var ,n0var)))) + +(define-compiler-macro logorc2 (n0 n1) + (let ((n1var (gensym)) + (n0var (gensym))) + `(let ((,n0var ,n0) + (,n1var ,n1)) + (logorc1 ,n1var ,n0var)))) + +(define-compiler-macro lognand (n0 n1) + `(lognot (logand ,n0 ,n1))) + +(define-compiler-macro lognor (n0 n1) + `(lognot (logior ,n0 ,n1))) + + +(defun transform-logop (whole identity binop &optional (transform-complement t)) + (destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole + (if (and n1p (eql n0 identity)) + `(,op ,n1 ,@more) + (if (and transform-complement n1p (eql n0 (lognot identity))) + `(progn + (,op ,n1 ,@more) + ,(lognot identity)) + (if more + (if (cdr more) + whole + `(,binop ,n0 (,binop ,n1 ,(car more)))) + (if n1p + `(,binop ,n0 ,n1) + (if n0p + `(require-type ,n0 'integer) + identity))))))) + +(define-compiler-macro logand (&whole w &rest all) + (declare (ignore all)) + (transform-logop w -1 'logand-2)) + +(define-compiler-macro logior (&whole w &rest all) + (declare (ignore all)) + (transform-logop w 0 'logior-2)) + +(define-compiler-macro logxor (&whole w &rest all) + (declare (ignore all)) + (transform-logop w 0 'logxor-2 nil)) + +(define-compiler-macro lognot (&whole w &environment env n1) + (if (nx-form-typep n1 'fixnum env) + `(%ilognot ,n1) + w)) + +(define-compiler-macro logtest (&whole w &environment env n1 n2) + (if (and (nx-form-typep n1 'fixnum env) + (nx-form-typep n2 'fixnum env)) + `(not (eql 0 (logand ,n1 ,n2))) + w)) + + +(defmacro defsynonym (from to) + ;Should maybe check for circularities. + `(progn + (setf (compiler-macro-function ',from) nil) + (let ((pair (assq ',from *nx-synonyms*))) + (if pair (rplacd pair ',to) + (push (cons ',from ',to) + *nx-synonyms*)) + ',to))) + +(defsynonym first car) +(defsynonym second cadr) +(defsynonym third caddr) +(defsynonym fourth cadddr) +(defsynonym rest cdr) + + +(defsynonym functionp lfunp) +(defsynonym null not) +(defsynonym char-int char-code) + +;;; Improvemets file by Bob Cassels +;;; Just what are "Improvemets", anyway ? + +;;; Optimize some CL sequence functions, mostly by inlining them in +;;; simple cases when the type of the sequence is known. In some +;;; cases, dynamic-extent declarations are automatically inserted. +;;; For some sequence functions, if the type of the sequence is known +;;; at compile time, the function is inlined. If the type isn't known +;;; but the call is "simple", a call to a faster (positional-arg) +;;; function is substituted. + + +(defun nx-form-sequence-iterator (sequence-form env) + (cond ((nx-form-typep sequence-form 'vector env) 'dovector) + ((nx-form-typep sequence-form 'list env) 'dolist))) + +(defun function-form-p (form) + ;; c.f. quoted-form-p + (and (consp form) + (eq (%car form) 'function) + (consp (%cdr form)) + (null (%cdr (%cdr form))))) + + +;; Return a form that checks to see if THING is if type CTYPE, or +;; NIL if we can't do that for some reason. +(defun optimize-ctypep (thing ctype) + (when (eq *target-backend* *host-backend*) + (typecase ctype + (numeric-ctype + (cond ((eq :real (numeric-ctype-complexp ctype)) + (let* ((low (numeric-ctype-low ctype)) + (high (numeric-ctype-high ctype)) + (class (numeric-ctype-class ctype)) + (format (numeric-ctype-format ctype)) + (type (if (eq class 'float) + (or format class) + (or class 'real)))) + (cond ((and low (eql low high) (or (not (eq class 'float)) + format)) + `(eql ,thing ,low)) + ((and (eq type 'float) + (or low high) + (or (null low) + (typep low 'single-float) + (not (null (ignore-errors + (coerce (if (atom low) + low + (car low)) + 'single-float))))) + (or (null high) + (typep high 'single-float) + (not (null (ignore-errors + (coerce (if (atom high) + high + (car high)) + 'single-float)))))) + (let* ((temp (gensym))) + (flet ((bounded-float (type low high) + `(,type + ,(if low + (if (listp low) + (list (coerce (car low) type)) + (coerce low type)) + '*) + ,(if high + (if (listp high) + (list (coerce (car high) type)) + (coerce high type)) + '*)))) + `(let* ((,temp ,thing)) + (or (typep ,temp ',(bounded-float 'single-float low high)) + (typep ,temp ',(bounded-float 'double-float low high))))))) + (t + (let* ((temp (gensym))) + (if (and (typep low 'fixnum) (typep high 'fixnum) + (eq class 'integer)) + (setq type 'fixnum)) + (if (or low high) + `(let* ((,temp ,thing)) + (and (typep ,temp ',type) + ,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low)))) + ,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high)))))) + `(typep ,thing ',type))))))) + (t `(numeric-%%typep ,thing ,ctype)))) + (array-ctype + (or + (let* ((typecode (array-ctype-typecode ctype)) + (dims (array-ctype-dimensions ctype))) + (cond ((and typecode (consp dims) (null (cdr dims))) + (case (array-ctype-complexp ctype) + ((nil) + (if (eq (car dims) '*) + `(eql (typecode ,thing) ,typecode) + (let* ((temp (gensym))) + `(let* ((,temp ,thing)) + (and (eql (typecode ,temp) ,typecode) + (eq (uvsize ,temp) ,(car dims))))))) + ((* :maybe) + (let* ((temp (gensym)) + (tempcode (gensym))) + `(let* ((,temp ,thing) + (,tempcode (typecode ,temp))) + (or (and (eql ,tempcode ,typecode) + ,@(unless (eq (car dims) '*) + `((eq (uvsize ,temp) ,(car dims))))) + (and (eql ,tempcode target::subtag-vectorH) + (eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode) + ,@(unless (eq (car dims) '*) + `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims))))))))))))) + `(values (array-%%typep ,thing ,ctype))))))) + + +(defun optimize-typep (thing type env) + ;; returns a new form, or nil if it can't optimize + (let ((ctype (specifier-type-if-known type env :whine t))) + (when ctype + (let* ((type (type-specifier ctype)) + (predicate (if (typep type 'symbol) (type-predicate type)))) + (if (and predicate (symbolp predicate)) + `(,predicate ,thing) + (let* ((pair (assq type *istruct-cells*)) + (class (and pair (%wrapper-class (istruct-cell-info pair))))) + (if (and class (not (%class-direct-subclasses class))) + `(istruct-typep ,thing ',type) + (or (optimize-ctypep thing ctype) + (cond ((symbolp type) + (cond ((%deftype-expander type) + ;; recurse here, rather than returning the + ;; partially-expanded form mostly since it doesn't + ;; seem to further optimize the result otherwise + (let ((expanded-type (type-expand type))) + (or (optimize-typep thing expanded-type env) + ;; at least do the first expansion + `(typep ,thing ',expanded-type)))) + ((structure-class-p type env) + `(structure-typep ,thing ',(find-class-cell type t))) + ((find-class type nil env) + ;; If we know for sure that the class + ;; is one whose instances are all + ;; STANDARD-INSTANCEs (not funcallable, + ;; not foreign), we can use + ;; STD-INSTANCE-CLASS-CELL-TYPEP, which + ;; can be a little faster then the more + ;; general CLASS-CELL-TYPEP. We can + ;; only be sure of that if the class + ;; exists (as a non-COMPILE-TIME-CLASS) + (let* ((class (find-class type nil nil)) + (fname + (if (and class + (subtypep class 'standard-object) + (not (subtypep class 'foreign-standard-object)) + (not (subtypep class 'funcallable-standard-object))) + 'std-instance-class-cell-typep + 'class-cell-typep))) + `(,fname ,thing (load-time-value (find-class-cell ',type t))))) + ((info-type-builtin type) ; bootstrap troubles here? + `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) + (t nil))) + ((consp type) + (cond + ((info-type-builtin type) ; byte types + `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) + (t + (case (%car type) + (satisfies `(funcall ',(cadr type) ,thing)) + (eql `(eql ,thing ',(cadr type))) + (member `(not (null (member ,thing ',(%cdr type))))) + (not `(not (typep ,thing ',(cadr type)))) + ((or and) + (let ((thing-sym (gensym))) + `(let ((,thing-sym ,thing)) + (,(%car type) + ,@(mapcar #'(lambda (type-spec) + (or (optimize-typep thing-sym type-spec env) + `(typep ,thing-sym ',type-spec))) + (%cdr type)))))) + ((signed-byte unsigned-byte integer mod) ; more byte types + `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) + (t nil))))) + (t nil)))))))))) + +(define-compiler-macro typep (&whole call &environment env thing type &optional e) + (if (nx-form-constant-p type env) + (let ((type-val (nx-form-constant-value type env))) + (if (eq type-val t) + `(progn ,thing t) + (if (and (nx-form-constant-p thing env) + (specifier-type-if-known type-val env)) + (typep (nx-form-constant-value thing env) type-val env) + (or (and (null e) (optimize-typep thing type-val env)) + call)))) + call)) + +(define-compiler-macro structure-typep (&whole w thing type) + (if (not (quoted-form-p type)) + (progn + (warn "Non-quoted structure-type in ~s" w) + w) + (let* ((type (nx-unquote type))) + (if (symbolp type) + `(structure-typep ,thing ',(find-class-cell type t)) + w)))) + +(define-compiler-macro true (&rest args) + `(progn + ,@args + t)) + + +(define-compiler-macro false (&rest args) + `(progn + ,@args + nil)) + +(define-compiler-macro find-class (&whole call type &optional (errorp t) env) + (if (and (quoted-form-p type)(not *dont-find-class-optimize*)(not env)) + `(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp) + call)) + + +(define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest) + (if rest + call + (if n1-p + `(gcd-2 ,n0 ,n1) + (if n0-p + `(%integer-abs ,n0) + 0)))) + +(define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest) + (if rest + call + (if n1-p + `(lcm-2 ,n0 ,n1) + (if n0-p + `(%integer-abs ,n0) + 1)))) + +(define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest) + (if rest + call + (if n1-p + (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env)) + `(imax-2 ,n0 ,n1) + `(max-2 ,n0 ,n1)) + `(require-type ,n0 'real)))) + +(define-compiler-macro max-2 (n0 n1) + (let* ((g0 (gensym)) + (g1 (gensym))) + `(let* ((,g0 ,n0) + (,g1 ,n1)) + (if (> ,g0 ,g1) ,g0 ,g1)))) + +(define-compiler-macro imax-2 (n0 n1) + (let* ((g0 (gensym)) + (g1 (gensym))) + `(let* ((,g0 ,n0) + (,g1 ,n1)) + (if (%i> ,g0 ,g1) ,g0 ,g1)))) + + + + +(define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest) + (if rest + call + (if n1-p + (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env)) + `(imin-2 ,n0 ,n1) + `(min-2 ,n0 ,n1)) + `(require-type ,n0 'real)))) + +(define-compiler-macro min-2 (n0 n1) + (let* ((g0 (gensym)) + (g1 (gensym))) + `(let* ((,g0 ,n0) + (,g1 ,n1)) + (if (< ,g0 ,g1) ,g0 ,g1)))) + +(define-compiler-macro imin-2 (n0 n1) + (let* ((g0 (gensym)) + (g1 (gensym))) + `(let* ((,g0 ,n0) + (,g1 ,n1)) + (if (%i< ,g0 ,g1) ,g0 ,g1)))) + + +(defun eq-test-p (test) + (or (equal test ''eq) (equal test '#'eq))) + +(defun eql-test-p (test) + (or (equal test ''eql) (equal test '#'eql))) + +(define-compiler-macro adjoin (&whole whole elt list &rest keys) + (if (constant-keywords-p keys) + (destructuring-bind (&key (test ''eql) test-not key) keys + (or (and (null test-not) + (null key) + (cond ((eq-test-p test) + `(adjoin-eq ,elt ,list)) + ((eql-test-p test) + `(adjoin-eql ,elt ,list)) + (t nil))) + whole)) + whole)) + +(define-compiler-macro union (&whole whole list1 list2 &rest keys) + (if (constant-keywords-p keys) + (destructuring-bind (&key (test ''eql) test-not key) keys + (or (and (null test-not) + (null key) + (cond ((eq-test-p test) + `(union-eq ,list1 ,list2)) + ((eql-test-p test) + `(union-eql ,list1 ,list2)) + (t nil))) + whole)) + whole)) + +(define-compiler-macro slot-value (&whole whole &environment env + instance slot-name-form) + (declare (ignore env)) + (let* ((name (and (quoted-form-p slot-name-form) + (typep (cadr slot-name-form) 'symbol) + (cadr slot-name-form)))) + (if name + `(slot-id-value ,instance (load-time-value (ensure-slot-id ',name))) + whole))) + + +(define-compiler-macro set-slot-value (&whole whole &environment env + instance slot-name-form value-form) + (declare (ignore env)) + (let* ((name (and (quoted-form-p slot-name-form) + (typep (cadr slot-name-form) 'symbol) + (cadr slot-name-form)))) + (if name + `(set-slot-id-value + ,instance + (load-time-value (ensure-slot-id ',name)) + ,value-form) + whole))) + + +(define-compiler-macro slot-boundp (&whole whole instance slot-name-form) + (let* ((name (and (quoted-form-p slot-name-form) + (typep (cadr slot-name-form) 'symbol) + (cadr slot-name-form)))) + (if name + `(slot-id-boundp ,instance (load-time-value (ensure-slot-id ',name))) + whole))) + +(defsynonym %get-unsigned-byte %get-byte) +(defsynonym %get-unsigned-word %get-word) +(defsynonym %get-signed-long %get-long) + + + + +(define-compiler-macro arrayp (arg) + `(>= (the fixnum (typecode ,arg)) + ,(nx-lookup-target-uvector-subtag :array-header))) + +(define-compiler-macro vectorp (arg) + `(>= (the fixnum (typecode ,arg)) + ,(nx-lookup-target-uvector-subtag :vector-header))) + + + +(define-compiler-macro fixnump (arg) + (let* ((fixnum-tag + (arch::target-fixnum-tag (backend-target-arch *target-backend*)))) + `(eql (lisptag ,arg) ,fixnum-tag))) + + + +(define-compiler-macro double-float-p (n) + (let* ((tag (arch::target-double-float-tag (backend-target-arch *target-backend*)))) + `(eql (typecode ,n) ,tag))) + + +(define-compiler-macro short-float-p (n) + (let* ((arch (backend-target-arch *target-backend*)) + (tag (arch::target-single-float-tag arch)) + (op (if (arch::target-single-float-tag-is-subtag arch) + 'typecode + 'fulltag))) + `(eql (,op ,n) ,tag))) + + +(define-compiler-macro floatp (n) + (let* ((typecode (make-symbol "TYPECODE")) + (arch (backend-target-arch *target-backend*)) + (single (arch::target-single-float-tag arch)) + (double (arch::target-double-float-tag arch))) + `(let* ((,typecode (typecode ,n))) + (declare (fixnum ,typecode)) + (or (= ,typecode ,single) + (= ,typecode ,double))))) + +(define-compiler-macro functionp (n) + (let* ((arch (backend-target-arch *target-backend*)) + (tag (arch::target-function-tag arch)) + (op (if (arch::target-function-tag-is-subtag arch) + 'typecode + 'fulltag))) + `(eql (,op ,n) ,tag))) + +(define-compiler-macro symbolp (s) + (let* ((arch (backend-target-arch *target-backend*)) + (symtag (arch::target-symbol-tag arch)) + (op (if (arch::target-symbol-tag-is-subtag arch) + 'typecode + 'fulltag)) + (niltag (arch::target-null-tag arch))) + (if (eql niltag symtag) + `(eql (,op ,s) ,symtag) + (let* ((sym (gensym))) + `(let* ((,sym ,s)) + (if ,sym (eql (,op ,sym) ,symtag) t)))))) + +;;; If NIL isn't tagged as a symbol, assume that LISPTAG only looks +;;; at bits that NIL shares with a cons. +(define-compiler-macro listp (n) + (let* ((arch (backend-target-arch *target-backend*)) + (cons-tag (arch::target-cons-tag arch)) + (nil-tag (arch::target-null-tag arch)) + (symbol-tag (arch::target-symbol-tag arch))) + (if (= nil-tag symbol-tag) + (let* ((nvar (gensym))) + `(let* ((,nvar ,n)) + (if ,nvar (consp ,nvar) t))) + `(eql (lisptag ,n) ,cons-tag)))) + +(define-compiler-macro consp (&whole call n) + (let* ((arch (backend-target-arch *target-backend*)) + (cons-tag (arch::target-cons-tag arch)) + (nil-tag (arch::target-null-tag arch))) + (if (= nil-tag cons-tag) + call + `(eql (fulltag ,n) ,cons-tag)))) + +(define-compiler-macro bignump (n) + `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :bignum))) + +(define-compiler-macro ratiop (n) + `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :ratio))) + +(define-compiler-macro complexp (n) + `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :complex))) + +(define-compiler-macro macptrp (n) + `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :macptr))) + +(define-compiler-macro basic-stream-p (n) + `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :basic-stream))) + +(define-compiler-macro aref (&whole call a &rest subscripts &environment env) + (let* ((ctype (if (nx-form-typep a 'array env) + (specifier-type (nx-form-type a env) env))) + (ectype (typecase ctype + (array-ctype (array-ctype-specialized-element-type ctype)) + (union-ctype (when (every #'array-ctype-p (union-ctype-types ctype)) + (%type-union + (mapcar (lambda (ct) (array-ctype-specialized-element-type ct)) + (union-ctype-types ctype))))))) + (etype (and ectype (type-specifier ectype))) + (useful (unless (or (eq etype *) (eq etype t)) + etype))) + (if (= 2 (length subscripts)) + (setq call `(%aref2 ,a ,@subscripts)) + (if (= 3 (length subscripts)) + (setq call `(%aref3 ,a ,@subscripts)))) + (if useful + `(the ,useful ,call) + call))) + + +(define-compiler-macro aset (&whole call a &rest subs&val) + (if (= 3 (length subs&val)) + `(%aset2 ,a ,@subs&val) + (if (= 4 (length subs&val)) + `(%aset3 ,a ,@subs&val) + call))) + + +(define-compiler-macro make-sequence (&whole call typespec len &rest keys &key initial-element) + (declare (ignore typespec len keys initial-element)) + call) + +(define-compiler-macro make-string (&whole call &environment env size &rest keys) + (if (constant-keywords-p keys) + (destructuring-bind (&key (element-type () element-type-p) + (initial-element () initial-element-p)) + keys + (if (and element-type-p + (nx-form-constant-p element-type env)) + (let* ((element-type (nx-form-constant-value element-type env))) + (if (subtypep element-type 'base-char) + `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element))) + call)) + (if (not element-type-p) + `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element))) + call))) + call)) + +(define-compiler-macro make-string-output-stream (&whole whole &rest keys) + (if (null keys) + '(make-simple-string-output-stream) + whole)) + + +(define-compiler-macro write-string (&environment env &whole call + string &optional (stream nil) &rest keys) + (if (nx-form-typep string 'simple-string env) + (if keys + `((lambda (string stream &key (start 0) end) + (write-simple-string string stream start end)) + ,string ,stream ,@keys) + `(write-simple-string ,string ,stream 0 nil)) + call)) + +(define-compiler-macro format (&environment env &whole call stream string &rest args) + (if (stringp string) + (cond ((and (string-equal string "~a") args (null (cdr args))) + (destructuring-bind (object) args + (cond ((null stream) + `(princ-to-string ,object)) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(progn (princ ,object ,(and (neq stream t) stream)) nil)) + (t `(let ((stream ,stream) + (object ,object)) + (if (or (null stream) (stringp stream)) + (format-to-string stream ,string object) + (progn (princ object (and (neq stream t) stream)) nil))))))) + ((and (string-equal string "~s") args (null (cdr args))) + (destructuring-bind (object) args + (cond ((null stream) + `(prin1-to-string ,object)) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(progn (prin1 ,object ,(and (neq stream t) stream)) nil)) + (t `(let ((stream ,stream) + (object ,object)) + (if (or (null stream) (stringp stream)) + (format-to-string stream ,string object) + (progn (prin1 object (and (neq stream t) stream)) nil))))))) + ((and (null (position #\~ string)) (null args)) + (cond ((null stream) + string) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(progn (write-string ,string ,(and (neq stream t) stream)) nil)) + (t `(let ((stream ,stream)) + (if (or (null stream) (stringp stream)) + (format-to-string stream ,string) + (progn (write-string ,string (and (neq stream t) stream)) nil)))))) + ((let ((new (format-string-sans~newlines string))) + (and (neq new string) (setq string new))) + `(format ,stream ,string ,@args)) + ((optimize-format-call stream string args env)) + (t call)) + call)) + +(defun format-string-sans~newlines (string) + (loop as pos = 0 then (position #\Newline string :start pos) while pos + as ch = (and (> pos 0) (schar string (1- pos))) + do (cond ((not (or (eq ch #\~) + (and (or (eq ch #\:) (eq ch #\@)) + (> pos 1) (eq (schar string (- pos 2)) #\~)))) + (incf pos)) + ((eq ch #\:) + (decf pos 2) + (setq string (%str-cat (subseq string 0 pos) (subseq string (+ pos 3))))) + ((eq ch #\@) + (setq string (%str-cat (subseq string 0 (- pos 2)) + "~%" + (subseq string (or + (position-if-not #'whitespacep string + :start (1+ pos)) + (1+ pos)))))) + ((eq ch #\~) + (decf pos) + (setq string (%str-cat (subseq string 0 pos) + (subseq string (or (position-if-not #'whitespacep string + :start (1+ pos)) + (1+ pos)))))))) + string) + +(defun count-known-format-args (string start end) + (declare (fixnum end)) + (loop with count = 0 + do (setq start (position #\~ string :start start :end end)) + when (null start) + do (return count) + unless (< (incf start) end) + do (return nil) + do (let ((ch (aref string start))) + (cond ((memq ch '(#\a #\A #\s #\S)) (incf count)) + ((memq ch '(#\~ #\% #\&))) + (t (return nil))) + (incf start)))) + +(defun optimize-format-call (stream string args env) + (let* ((start (or (search "~/" string) + (return-from optimize-format-call nil))) + (ipos (+ start 2)) + (epos (or (position #\/ string :start ipos) + (return-from optimize-format-call nil))) + (nargs (or (count-known-format-args string 0 start) + (return-from optimize-format-call nil)))) + (when (and + ;; Must be able to split args + (< nargs (length args)) + ;; Don't deal with packages + (not (position #\: string :start ipos :end epos))) + (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user)) + (prev (and (< 0 start) (subseq string 0 start))) + (prev-args (subseq args 0 nargs)) + (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos)))) + (rest-args (nthcdr nargs args)) + (obj (pop rest-args)) + (stream-var (gensym)) + (body `(,@(and prev `((format ,stream-var ,prev ,@prev-args))) + (,func ,stream-var ,obj nil nil) + ,(if rest `(format ,stream-var ,rest ,@rest-args) `nil)))) + (cond ((null stream) + `(with-output-to-string (,stream-var) + (declare (type stream ,stream-var)) + ,@body)) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(let ((,stream-var ,(if (eq stream t) '*standard-output* stream))) + (declare (type stream ,stream-var)) + ,@body)) + (t + `(let ((,stream-var ,stream)) + (if (or (null ,stream-var) (stringp ,stream-var)) + (format-to-string ,stream-var ,string ,@args) + (let ((,stream-var + (if (eq ,stream-var t) *standard-output* ,stream-var))) + ;; For the purposes of body, it's ok to assume stream-var + ;; is a stream. method dispatch will signal any errors + ;; at runtime if it's not true... + (declare (type stream ,stream-var)) + ,@body))))))))) + + +(define-compiler-macro sbit (&whole call v &optional sub0 &rest others) + (if (and sub0 (null others)) + `(aref (the simple-bit-vector ,v) ,sub0) + call)) + +(define-compiler-macro %sbitset (&whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1) + (if (and newval-p (not newval-was-really-sub1) ) + `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval) + call)) + +(define-compiler-macro simple-base-string-p (thing) + `(= (the fixnum (typecode ,thing)) ,(nx-lookup-target-uvector-subtag :simple-string))) + +(define-compiler-macro simple-string-p (thing) + `(simple-base-string-p ,thing)) + +(define-compiler-macro stringp (thing) + `(base-string-p ,thing)) + +(define-compiler-macro base-string-p (thing) + (let* ((gthing (gensym)) + (gtype (gensym))) + `(let* ((,gthing ,thing) + (,gtype (typecode ,gthing))) + (declare (type (unsigned-byte 8) ,gtype)) + (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header)) + (= (the (unsigned-byte 8) + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell)))) + ,(nx-lookup-target-uvector-subtag :simple-string)) + (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string)))))) + + + +(defsetf %misc-ref %misc-set) + +(define-compiler-macro lockp (lock) + (let* ((tag (nx-lookup-target-uvector-subtag :lock))) + `(eq ,tag (typecode ,lock)))) + +(define-compiler-macro structurep (s) + (let* ((tag (nx-lookup-target-uvector-subtag :struct))) + `(eq ,tag (typecode ,s)))) + + +(define-compiler-macro integerp (thing) + (let* ((typecode (gensym)) + (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*))) + (bignum-tag (nx-lookup-target-uvector-subtag :bignum))) + `(let* ((,typecode (typecode ,thing))) + (declare (fixnum ,typecode)) + (if (= ,typecode ,fixnum-tag) + t + (= ,typecode ,bignum-tag))))) + +(define-compiler-macro realp (&whole call x) + (if (not (eq *host-backend* *target-backend*)) + call + (let* ((typecode (gensym))) + `(let* ((,typecode (typecode ,x))) + (declare (type (unsigned-byte 8) ,typecode)) + #+(or ppc32-target x8632-target) + (or (= ,typecode target::tag-fixnum) + (and (>= ,typecode target::min-numeric-subtag) + (<= ,typecode target::max-real-subtag))) + #+ppc64-target + (if (<= ,typecode ppc64::subtag-double-float) + (logbitp (the (integer 0 #.ppc64::subtag-double-float) ,typecode) + (logior (ash 1 ppc64::tag-fixnum) + (ash 1 ppc64::subtag-single-float) + (ash 1 ppc64::subtag-double-float) + (ash 1 ppc64::subtag-bignum) + (ash 1 ppc64::subtag-ratio)))) + #+x8664-target + (if (<= ,typecode x8664::subtag-double-float) + (logbitp (the (integer 0 #.x8664::subtag-double-float) ,typecode) + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::subtag-bignum) + (ash 1 x8664::tag-single-float) + (ash 1 x8664::subtag-double-float) + (ash 1 x8664::subtag-ratio)))))))) + +(define-compiler-macro %composite-pointer-ref (size pointer offset) + (if (constantp size) + `(%inc-ptr ,pointer ,offset) + `(progn + ,size + (%inc-ptr ,pointer ,offset)))) + + +(define-compiler-macro char= (&whole call ch &optional (other nil other-p) &rest others) + (if (null others) + (if other-p + `(eq (char-code ,ch) (char-code ,other)) + `(progn (char-code ,ch) t)) + (if (null (cdr others)) + (let* ((third (car others)) + (code (gensym)) + (code2 (gensym)) + (code3 (gensym))) + `(let* ((,code (char-code ,ch)) + (,code2 (char-code ,other)) + (,code3 (char-code ,third))) + (and (eq ,code ,code2) + (eq ,code2 ,code3)))) + call))) + +(define-compiler-macro char-equal (&whole call ch &optional (other nil other-p) &rest others) + (if (null others) + (if other-p + `(eq (%char-code-upcase (char-code ,ch)) (%char-code-upcase (char-code ,other))) + `(progn (char-code ,ch) t)) + (if (null (cdr others)) + (let* ((third (car others)) + (code (gensym)) + (code2 (gensym)) + (code3 (gensym))) + `(let* ((,code (%char-code-upcase (char-code ,ch))) + (,code2 (%char-code-upcase (char-code ,other))) + (,code3 (%char-code-upcase (char-code ,third)))) + (and (eq ,code ,code2) + (eq ,code ,code3)))) + call))) + +(define-compiler-macro char/= (&whole call ch &optional (other nil other-p) &rest others) + (if (null others) + (if other-p + `(not (eq (char-code ,ch) (char-code ,other))) + `(progn (char-code ,ch) t)) + call)) + + +(define-compiler-macro char< (&whole call ch &optional (other nil other-p) &rest others) + (if (null others) + (if other-p + `(< (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) + `(progn (char-code ,ch) t)) + (if (null (cdr others)) + (let* ((third (car others)) + (code (gensym)) + (code2 (gensym)) + (code3 (gensym))) + ;; We have to evaluate all forms for side-effects. + ;; Hopefully, there won't be any + `(let* ((,code (char-code ,ch)) + (,code2 (char-code ,other)) + (,code3 (char-code ,third))) + (declare (fixnum ,code ,code2 ,code3)) + (and (< ,code ,code2) + (< ,code2 ,code3)))) + call))) + +(define-compiler-macro char<= (&whole call ch &optional (other nil other-p) &rest others) + (if (null others) + (if other-p + `(<= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) + `(progn (char-code ,ch) t)) + (if (null (cdr others)) + (let* ((third (car others)) + (code (gensym)) + (code2 (gensym)) + (code3 (gensym))) + `(let* ((,code (char-code ,ch)) + (,code2 (char-code ,other)) + (,code3 (char-code ,third))) + (declare (fixnum ,code ,code2 ,code3)) + (and (<= ,code ,code2) + (<= ,code2 ,code3)))) + call))) + +(define-compiler-macro char> (&whole call ch &optional (other nil other-p) &rest others) + (if (null others) + (if other-p + `(> (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) + `(progn (char-code ,ch) t)) + (if (null (cdr others)) + (let* ((third (car others)) + (code (gensym)) + (code2 (gensym)) + (code3 (gensym))) + `(let* ((,code (char-code ,ch)) + (,code2 (char-code ,other)) + (,code3 (char-code ,third))) + (declare (fixnum ,code ,code2 ,code3)) + (and (> ,code ,code2) + (> ,code2 ,code3)))) + call))) + +(define-compiler-macro char>= (&whole call ch &optional (other nil other-p) &rest others) + (if (null others) + (if other-p + `(>= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other))) + `(progn (char-code ,ch) t)) + (if (null (cdr others)) + (let* ((third (car others)) + (code (gensym)) + (code2 (gensym)) + (code3 (gensym))) + `(let* ((,code (char-code ,ch)) + (,code2 (char-code ,other)) + (,code3 (char-code ,third))) + (declare (fixnum ,code ,code2 ,code3)) + (and (>= ,code ,code2) + (>= ,code2 ,code3)))) + call))) + +(define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env) + + (cond ((and (typep other 'single-float) + (nx-form-typep number 'double-float env)) + `(the single-float (%double-to-single ,number))) + ((and (typep other 'double-float) + (nx-form-typep number 'single-float env)) + `(the double-float (%single-to-double ,number))) + ((and other-p (typep other 'single-float)) + `(the single-float (%short-float ,number))) + ((typep other 'double-float) + `(the double-float (%double-float ,number))) + ((null other-p) + (let* ((temp (gensym))) + `(let* ((,temp ,number)) + (if (typep ,temp 'double-float) + ,temp + (the single-float (%short-float ,temp)))))) + (t call))) + +(define-compiler-macro coerce (&whole call &environment env thing type) + (cond ((nx-form-constant-p type env) + (setq type (nx-form-constant-value type env)) + (let ((ctype (specifier-type-if-known type env :whine t))) + (if ctype + (if (csubtypep ctype (specifier-type 'single-float)) + `(float ,thing 0.0f0) + (if (csubtypep ctype (specifier-type 'double-float)) + `(float ,thing 0.0d0) + (let ((simple nil) + (extra nil)) + (if (and (typep ctype 'array-ctype) + (equal (array-ctype-dimensions ctype) '(*))) + (if (eq (array-ctype-specialized-element-type ctype) + (specifier-type 'character)) + (setq simple '%coerce-to-string) + (if (and (eq *host-backend* *target-backend*) + (array-ctype-typecode ctype)) + (setq simple '%coerce-to-vector + extra (list (array-ctype-typecode ctype))))) + (if (eq ctype (specifier-type 'list)) + (setq simple '%coerce-to-list))) + (if simple + (let* ((temp (gensym))) + `(let* ((,temp ,thing)) + (if (typep ,temp ',(type-specifier ctype)) + ,temp + (,simple ,temp ,@extra)))) + call)))) + call))) + (t call))) + +(define-compiler-macro equal (&whole call x y &environment env) + (if (or (equal-iff-eql-p x env) + (equal-iff-eql-p y env)) + `(eql ,x ,y) + call)) + +(define-compiler-macro instance-slots (instance &environment env) + (if (and (nx-form-constant-p instance env) + (eql (typecode (nx-form-constant-value instance env)) (nx-lookup-target-uvector-subtag :instance))) + `(instance.slots ,instance) + (let* ((itemp (gensym)) + (typecode (gensym))) + `(let* ((,itemp ,instance) + (,typecode (typecode ,itemp))) + (declare (type (unsigned-byte 8) ,typecode)) + (if (eql ,typecode ,(nx-lookup-target-uvector-subtag :instance)) + (instance.slots ,itemp) + (%non-standard-instance-slots ,itemp ,typecode)))))) + +(define-compiler-macro instance-class-wrapper (instance) + (let* ((itemp (gensym))) + `(let* ((,itemp ,instance)) + (if (eql (the (unsigned-byte 8) (typecode ,itemp)) + ,(nx-lookup-target-uvector-subtag :instance)) + (instance.class-wrapper ,itemp) + (non-standard-instance-class-wrapper ,itemp))))) + +;; Instance must be a standard-instance. +(define-compiler-macro %class-of-instance (instance) + `(%wrapper-class (instance.class-wrapper ,instance))) + +(define-compiler-macro standard-object-p (thing) + (let* ((temp (gensym)) + (typecode (gensym))) + `(let* ((,temp ,thing) + (,typecode (typecode ,temp))) + (declare (type (unsigned-byte 8) ,typecode)) + (if (= ,typecode ,(nx-lookup-target-uvector-subtag :instance)) + (instance.class-wrapper ,temp) + (if (= ,typecode ,(nx-lookup-target-uvector-subtag :macptr)) + (foreign-instance-class-wrapper ,temp)))))) + +(define-compiler-macro %class-ordinal (class &optional error) + (let* ((temp (gensym))) + `(let* ((,temp ,class)) + (if (eql (the (unsigned-byte 8) (typecode ,temp)) + ,(nx-lookup-target-uvector-subtag :instance)) + (instance.hash ,temp) + (funcall '%class-ordinal ,temp ,error))))) + +(define-compiler-macro native-class-p (class) + (let* ((temp (gensym))) + `(let* ((,temp ,class)) + (if (eql (the (unsigned-byte 8) (typecode ,temp)) + ,(nx-lookup-target-uvector-subtag :instance)) + (< (the fixnum (instance.hash ,temp)) max-class-ordinal))))) + + + +(define-compiler-macro unsigned-byte-p (x) + (if (typep (nx-unquote x) 'unsigned-byte) + t + (let* ((val (gensym))) + `(let* ((,val ,x)) + (and (integerp ,val) (not (< ,val 0))))))) + +(define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv) + (if (and (consp t1) + (consp (cdr t1)) + (null (cddr t1)) + (eq (car t1) 'type-of)) + ;; People really write code like this. I've seen it. + `(typep ,(cadr t1) ,t2 ,@(and rtenv `(,rtenv))) + (if (and (null rtenv) (quoted-form-p t2)) + `(cell-csubtypep-2 ,t1 (load-time-value (register-type-cell ,t2))) + w))) + + +(define-compiler-macro string-equal (s1 s2 &rest keys) + (if (null keys) + `(%fixed-string-equal ,s1 ,s2) + (let* ((s1-arg (gensym)) + (s2-arg (gensym))) + `(funcall + (lambda (,s1-arg ,s2-arg &key start1 end1 start2 end2) + (%bounded-string-equal ,s1-arg ,s2-arg start1 end1 start2 end2)) + ,s1 ,s2 ,@keys)))) + +;;; Try to use "package-references" to speed up package lookup when +;;; a package name is used as a constant argument to some functions. + +(defun package-ref-form (arg env) + (when (and arg (nx-form-constant-p arg env) + (typep (setq arg (nx-form-constant-value arg env)) + '(or symbol string))) + `(load-time-value (register-package-ref ,(string arg))))) + + + +(define-compiler-macro intern (&whole w string &optional package &environment env) + (let* ((ref (package-ref-form package env))) + (if (or ref + (setq ref (and (consp package) + (eq (car package) 'find-package) + (consp (cdr package)) + (null (cddr package)) + (package-ref-form (cadr package) env)))) + `(%pkg-ref-intern ,string ,ref) + w))) + +(define-compiler-macro find-symbol (&whole w string &optional package &environment env) + (let* ((ref (package-ref-form package env))) + (if (or ref + (setq ref (and (consp package) + (eq (car package) 'find-package) + (consp (cdr package)) + (null (cddr package)) + (package-ref-form (cadr package) env)))) + `(%pkg-ref-find-symbol ,string ,ref) + w))) + +(define-compiler-macro find-package (&whole w package &environment env) + (let* ((ref (package-ref-form package env))) + (if ref + `(package-ref.pkg ,ref) + w))) + +(define-compiler-macro pkg-arg (&whole w package &optional allow-deleted &environment env) + (let* ((ref (unless allow-deleted (package-ref-form package env)))) + (if ref + (let* ((r (gensym))) + `(let* ((,r ,ref)) + (or (package-ref.pkg ,ref) + (%kernel-restart $xnopkg (package-ref.pkg ,r))))) + w))) + + +;;; In practice, things that're STREAMP are almost always +;;; BASIC-STREAMs or FUNDAMENTAL-STREAMs, but STREAMP is a generic +;;; function. +(define-compiler-macro streamp (arg) + (let* ((s (gensym))) + `(let* ((,s ,arg)) + (or (typep ,s 'basic-stream) + (typep ,s 'fundamental-stream) + ;; Don't recurse + (funcall 'streamp ,s))))) + + +(define-compiler-macro %char-code-case-fold (&whole w code vector &environment env) + (if (nx-open-code-in-line env) + (let* ((c (gensym)) + (table (gensym))) + `(let* ((,c ,code) + (,table ,vector)) + (declare (type (mod #x110000) ,c) + (type (simple-array (signed-byte 16) (*)) ,table)) + (if (< ,c (length ,table)) + (the fixnum (+ ,c (the (signed-byte 16) + (locally (declare (optimize (speed 3) (safety 0))) + (aref ,table ,c))))) + ,c))) + w)) + +(define-compiler-macro %char-code-upcase (code) + (if (typep code '(mod #x110000)) + (%char-code-upcase code) + `(%char-code-case-fold ,code *lower-to-upper*))) + +(define-compiler-macro %char-code-downcase (code) + (if (typep code '(mod #x110000)) + (%char-code-downcase code) + `(%char-code-case-fold ,code *upper-to-lower*))) + +(define-compiler-macro char-upcase (char) + `(code-char (the valid-char-code (%char-code-upcase (char-code ,char))))) + +(define-compiler-macro char-downcase (char) + `(code-char (the valid-char-code (%char-code-downcase (char-code ,char))))) + + +(define-compiler-macro register-istruct-cell (&whole w arg &environment env) + (if (and (nx-form-constant-p arg env) + (setq arg (nx-form-constant-value arg env)) + (symbolp arg)) + `',(register-istruct-cell arg) + w)) + +(define-compiler-macro get-character-encoding (&whole w name) + (or (if (typep name 'keyword) (lookup-character-encoding name)) + w)) + +(define-compiler-macro read-char (&optional stream (eof-error-p t) eof-value recursive-p) + `(read-char-internal ,stream ,eof-error-p (values ,eof-value ,recursive-p))) + + +(provide "OPTIMIZERS") Index: /branches/qres/ccl/compiler/reg.lisp =================================================================== --- /branches/qres/ccl/compiler/reg.lisp (revision 13564) +++ /branches/qres/ccl/compiler/reg.lisp (revision 13564) @@ -0,0 +1,238 @@ +;;;-*- Mode: Lisp; Package: CCL-*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +(in-package "CCL") + +;;; A "register spec" is a fixnum. Bit 28 is clear; bits 24-26 +;;; (inclusive) define the type of register-spec in question. Of +;;; course, a register spec can also be a "logical register" (lreg) +;;; structure. Someday soon, these might totally replace the fixnum +;;; "hard regspecs" that're described in this file, and might be used +;;; to refer to stack-based values as well as registers. In the +;;; meantime, we have to bootstrap a bit. + +(defmacro register-spec-p (regspec) + `(%register-spec-p ,regspec)) + +(defun %register-spec-p (regspec) + (if (typep regspec 'fixnum) + (not (logbitp 28 (the fixnum regspec))) + (typep regspec 'lreg))) + +(defconstant regspec-type-byte (byte 3 24)) +(defmacro regspec-type (regspec) + `(%regspec-type ,regspec)) + +(defun %regspec-type (regspec) + (if (typep regspec 'fixnum) + (the fixnum (ldb regspec-type-byte (the fixnum regspec))) + (if (typep regspec 'lreg) + (the fixnum (lreg-type regspec)) + (error "bad regspec: ~s" regspec)))) + +;;; Physical registers. +;;; A regspec-type of 0 denotes some type of "physical" (machine) register: +;;; a GPR, FPR, CR field, CR bit, or SPR. +(defconstant regspec-hard-reg-type 0) +; There are at most 32 members of any class of hard reg, so bytes 5-8 are +; used to encode that information; the "value" of the hard reg in question +; is in bits 0-4. +; In some cases, we can also attach a "mode" to a hard-reg-spec. +; Usually, non-0 values of the "mode" field are attached to the +; "imm" (unboxed) registers. +; A GPR whose "mode" is hard-reg-class-gpr-mode-node can have a "type" +; field which asserts that the register's contents map onto one or more +; of the primitive non-node types. This information can help some of +; the functions that copy between GPRs of different "mode" elide some +; type-checking. +(defconstant regspec-hard-reg-type-value-byte (byte 8 0)) +(defconstant regspec-hard-reg-type-class-byte (byte 3 8)) +(defconstant regspec-hard-reg-type-mode-byte (byte 4 11)) +(defconstant regspec-hard-reg-type-type-byte (byte 8 15)) + +(defconstant hard-reg-class-gpr 0) +(defconstant hard-reg-class-fpr 1) +; This is ppc-specific +(defconstant hard-reg-class-crf 2) ; Value is one of 0, 4, 8, ... 28 +(defconstant hard-reg-class-crbit 3) +(defconstant hard-reg-class-spr 4) + +; "mode" values for GPRs. +(defconstant hard-reg-class-gpr-mode-node 0) ; a tagged lisp object +(defconstant hard-reg-class-gpr-mode-u32 1) ; unboxed unsigned 32-bit value +(defconstant hard-reg-class-gpr-mode-s32 2) ; unboxed signed 32-bit value +(defconstant hard-reg-class-gpr-mode-u16 3) ; unboxed unsigned 16-bit value +(defconstant hard-reg-class-gpr-mode-s16 4) ; unboxed signed 16-bit value +(defconstant hard-reg-class-gpr-mode-u8 5) ; unboxed unsigned 8-bit value +(defconstant hard-reg-class-gpr-mode-s8 6) ; unboxed signed 8-bit value +(defconstant hard-reg-class-gpr-mode-address 7) ; unboxed unsigned 32-bit address +(defconstant hard-reg-class-gpr-mode-u64 8) +(defconstant hard-reg-class-gpr-mode-s64 9) + +(defconstant hard-reg-class-gpr-mode-invalid -1) ; Never a valid mode. + +; "mode" values for FPRs. +(defconstant hard-reg-class-fpr-mode-double 0) ; unboxed IEEE double +(defconstant hard-reg-class-fpr-mode-single 1) ; unboxed IEEE single + +; "type" values for FPRs - type of SOURCE may be encoded herein +(defconstant hard-reg-class-fpr-type-double 0) ; IEEE double +(defconstant hard-reg-class-fpr-type-single 1) ; IEEE single + + +(defmacro set-regspec-mode (regspec mode) + `(%set-regspec-mode ,regspec ,mode)) + +(defun %set-regspec-mode (regspec mode) + (if (typep regspec 'fixnum) + (dpb (the fixnum mode) regspec-hard-reg-type-mode-byte regspec) + (if (typep regspec 'lreg) + (progn (setf (lreg-mode regspec) mode) regspec) + (error "bad regspec: ~s" regspec)))) + +(defmacro get-regspec-mode (regspec) + `(%get-regspec-mode ,regspec)) + +(defun %get-regspec-mode (regspec) + (if (typep regspec 'fixnum) + (ldb regspec-hard-reg-type-mode-byte regspec) + (if (typep regspec 'lreg) + (lreg-mode regspec) + (error "bad regspec: ~s" regspec)))) + + +(defmacro node-regspec-type-modes (modes) + `(the fixnum (logior ,@(mapcar #'(lambda (x) `(ash 1 ,x)) modes)))) + +(defmacro set-node-regspec-type-modes (regspec &rest modes) + `(%set-node-regspec-type-modes ,regspec (node-regspec-type-modes ,modes))) + +(defun %set-node-regspec-type-modes (regspec modes) + (if (typep regspec 'fixnum) + (dpb (the fixnum modes) regspec-hard-reg-type-type-byte (the fixnum regspec)) + (if (typep regspec 'lreg) + (progn (setf (lreg-type regspec) modes) regspec) + (error "bad regspec: ~s" regspec)))) + +(defmacro get-node-regspec-type-modes (regspec) + `(%get-regspec-type-modes ,regspec)) + +(defun %get-regspec-type-modes (regspec) + (if (typep regspec 'fixnum) + (ldb regspec-hard-reg-type-type-byte (the fixnum regspec)) + (if (typep regspec 'lreg) + (lreg-type regspec) + (error "bad regspec: ~s" regspec)))) + +(defmacro hard-reg-class-mask (&rest classes) + `(the fixnum (logior ,@(mapcar #'(lambda (x) `(ash 1 ,x)) classes)))) + +(defconstant hard-reg-class-gpr-mask (hard-reg-class-mask hard-reg-class-gpr)) +(defconstant hard-reg-class-gpr-crf-mask (hard-reg-class-mask hard-reg-class-gpr hard-reg-class-crf)) + +; Assuming that "regspec" denotes a physical register, return its class. +(defmacro hard-regspec-class (regspec) + `(%hard-regspec-class ,regspec)) + +(defun %hard-regspec-class (regspec) + (if (typep regspec 'fixnum) + (the fixnum (ldb regspec-hard-reg-type-class-byte (the fixnum regspec))) + (if (typep regspec 'lreg) + (lreg-class regspec) + (error "bad regspec: ~s" regspec)))) + +; Return physical regspec's value: +(defmacro hard-regspec-value (regspec) + `(%hard-regspec-value ,regspec)) + +(defun %hard-regspec-value (regspec) + (if (typep regspec 'fixnum) + (the fixnum (ldb regspec-hard-reg-type-value-byte (the fixnum regspec))) + (if (typep regspec 'lreg) + (lreg-value regspec) + (error "bad regspec: ~s" regspec)))) + +;;; Logical (as opposed to "physical") registers are represented by structures +;;; of type LREG. The structures let us track information about assignments +;;; and references to lregs, and the indirection lets us defer decisions about +;;; storage mapping (register assignment, etc.) until later. + +;; A GPR which is allowed to hold any lisp object (but NOT an object header.) +(defconstant regspec-lisp-reg-type 1) + +;; A GPR which is allowed to contain any -non- lisp object. +(defconstant regspec-unboxed-reg-type 2) + +;; A GPR which can contain either an immediate lisp object (fixnum, immediate) +;; or any non-lisp object. +(defconstant regspec-any-gpr-reg-type (logior regspec-lisp-reg-type regspec-unboxed-reg-type)) + +;; An FPR. All FPRs are created equal; there's no reason to +;; worry about whether an FPR's holding a 32 or 64-bit float. +(defconstant regspec-fpr-reg-type 4) + +;; One of the 8 fields of the Condition Register. +(defconstant regspec-crf-reg-type 5) + +;; One of the 32 bits of the Condition Register. +(defconstant regspec-crbit-reg-type 6) + +(defmacro make-hard-crf-reg (crf) + `(dpb hard-reg-class-crf regspec-hard-reg-type-class-byte (the fixnum ,crf))) + +(defmacro make-hard-fp-reg (regnum &optional (mode hard-reg-class-fpr-mode-double)) + `(dpb (the fixnum ,mode) + regspec-hard-reg-type-mode-byte + (dpb hard-reg-class-fpr regspec-hard-reg-type-class-byte (the fixnum ,regnum)))) + +;;; "Memory specs" have bit 28 set. Since bit 28 is the sign bit in 68K MCL, +;;; we have to be a little careful when creating them to ensure that the result +;;; is a fixnum. + +(defmacro memory-spec-p (thing) + `(if (typep ,thing 'fixnum) (logbitp 28 (the fixnum ,thing)))) + +(defmacro make-memory-spec (thing) + `(logior (ash -1 28) (the fixnum ,thing))) + +;;; Bits 24-26 (inclusive) of a memory-spec define the type of memory-spec in question. +(defconstant memspec-type-byte (byte 3 24)) +(defmacro memspec-type (memspec) + `(ldb memspec-type-byte (the fixnum ,memspec))) + +;;; A slot in the value-stack frame. This needs to get interpreted +;;; relative to the top of the vsp. The low 15 bits denote the +;;; offset in the frame; the low 2 bits are always clear, since the +;;; vstack is always aligned on a 32-bit boundary. +(defconstant memspec-frame-address 0) + + + +;;; Address-specs - whether memory- or register-based - might be used to indicate the +;;; canonical address of a variable. Sometimes, this address is actually the address +;;; of a "value cell" object; if so, bit 27 will be set in the indicated address. + +(defun addrspec-vcell-p (x) + (logbitp 27 x)) + +(defmacro make-vcell-memory-spec (x) + `(logior (ash 1 27) (the fixnum ,x))) + +(defmacro memspec-frame-address-offset (m) + `(logand (the fixnum ,m) #xffff)) + + +(provide "REG") Index: /branches/qres/ccl/compiler/risc-lap.lisp =================================================================== --- /branches/qres/ccl/compiler/risc-lap.lisp (revision 13564) +++ /branches/qres/ccl/compiler/risc-lap.lisp (revision 13564) @@ -0,0 +1,198 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Lap data structures & some generic code (at least for RISC backends.) + +(in-package "CCL") + +(defvar *lap-labels* ()) +(defvar *lap-instructions* ()) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "ARCH") + (require "DLL-NODE") + (require "SUBPRIMS")) + + +;;; For assembly/disassembly, at least on RISC platforms. +(defstruct opcode + (name (error "Opcode name must be present") :type (or string symbol)) + (opcode 0 :type (unsigned-byte 32)) + (majorop 0 :type (unsigned-byte 6)) + (mask #xffffffff :type (unsigned-byte 32)) + (flags 0 :type (unsigned-byte 32)) + (operands () :type list) + (min-args 0 :type (unsigned-byte 3)) + (max-args 0 :type (unsigned-byte 3)) + (op-high 0 :type (unsigned-byte 16)) + (op-low 0 :type (unsigned-byte 16)) + (mask-high #xffff :type (unsigned-byte 16)) + (mask-low #xffff :type (unsigned-byte 16)) + (vinsn-operands () :type list) + (min-vinsn-args 0 :type fixnum) + (max-vinsn-args 0 :type fixnum)) + +(defmethod print-object ((p opcode) stream) + (print-unreadable-object (p stream :type t) + (format stream "~a" (string (opcode-name p))))) + +(defmethod make-load-form ((p opcode) &optional env) + (make-load-form-saving-slots p :environment env)) + +(defstruct operand + (index 0 :type unsigned-byte) + (width 0 :type (mod 32)) + (offset 0 :type (mod 32)) + (insert-function nil :type (or null symbol function)) + (extract-function 'nil :type (or symbol function)) + (flags 0 :type fixnum)) + +(defmethod make-load-form ((o operand) &optional env) + (make-load-form-saving-slots o :environment env)) + +(defconstant operand-optional 27) +(defconstant operand-fake 28) + +(eval-when (:execute :load-toplevel) + (defstruct (instruction-element (:include dll-node)) + address) + + (defstruct (lap-instruction (:include instruction-element) + (:constructor %make-lap-instruction (opcode))) + opcode + parsed-operands + ) + + (defstruct (lap-note (:include instruction-element)) + peer + id) + + (defstruct (lap-note-begin (:include lap-note))) + (defstruct (lap-note-end (:include lap-note))) + + (defstruct (lap-label (:include instruction-element) + (:constructor %%make-lap-label (name))) + name + refs)) + +(def-standard-initial-binding *lap-label-freelist* (make-dll-node-freelist)) +(def-standard-initial-binding *lap-instruction-freelist* (make-dll-node-freelist)) + +(def-standard-initial-binding *operand-vector-freelist* (%cons-pool)) + +(defconstant lap-operand-vector-size #+ppc-target 5) + +(defun alloc-lap-operand-vector (&optional (size lap-operand-vector-size)) + (declare (fixnum size)) + (if (eql size lap-operand-vector-size) + (without-interrupts + (let* ((freelist *operand-vector-freelist*) + (v (pool.data freelist))) + (if v + (progn + (setf (pool.data freelist) + (svref v 0)) + (%init-misc nil v) + v) + (make-array lap-operand-vector-size :initial-element nil)))) + (make-array size :initial-element nil))) + +(defun free-lap-operand-vector (v) + (when (= (length v) lap-operand-vector-size) + (without-interrupts + (setf (svref v 0) (pool.data *operand-vector-freelist*) + (pool.data *operand-vector-freelist*) nil)))) + +(defun %make-lap-label (name) + (let* ((lab (alloc-dll-node *lap-label-freelist*))) + (if lab + (progn + (setf (lap-label-address lab) nil + (lap-label-refs lab) nil + (lap-label-name lab) name) + lab) + (%%make-lap-label name)))) + +(defun make-lap-instruction (opcode) + (let* ((insn (alloc-dll-node *lap-instruction-freelist*))) + (if (typep insn 'lap-instruction) + (progn + (setf (lap-instruction-address insn) nil + (lap-instruction-parsed-operands insn) nil + (lap-instruction-opcode insn) opcode) + insn) + (%make-lap-instruction opcode)))) + +(defmacro do-lap-labels ((lab &optional result) &body body) + (let* ((thunk-name (gensym)) + (k (gensym)) + (xlab (gensym))) + `(flet ((,thunk-name (,lab) ,@body)) + (if (listp *lap-labels*) + (dolist (,xlab *lap-labels*) + (,thunk-name ,xlab)) + (maphash #'(lambda (,k ,xlab) + (declare (ignore ,k)) + (,thunk-name ,xlab)) + *lap-labels*)) + ,result))) + +(defun make-lap-label (name) + (let* ((lab (%make-lap-label name))) + (if (typep *lap-labels* 'hash-table) + (setf (gethash name *lap-labels*) lab) + (progn + (push lab *lap-labels*) + (if (> (length *lap-labels*) 255) + (let* ((hash (make-hash-table :size 512 :test #'eq))) + (dolist (l *lap-labels* (setq *lap-labels* hash)) + (setf (gethash (lap-label-name l) hash) l)))))) + lab)) + +(defun find-lap-label (name) + (if (typep *lap-labels* 'hash-table) + (gethash name *lap-labels*) + (car (member name *lap-labels* :test #'eq :key #'lap-label-name)))) + +(defun lap-note-label-reference (labx insn) + '(unless (and labx (symbolp labx)) + (error "Label names must be symbols; otherwise, all hell might break loose.")) + (let* ((lab (or (find-lap-label labx) + (make-lap-label labx)))) + (push insn (lap-label-refs lab)) + lab)) + +;;; A label can only be emitted once. Once it's been emitted, its pred/succ +;;; slots will be non-nil. + +(defun lap-label-emitted-p (lab) + (not (null (lap-label-pred lab)))) + + +(defun emit-lap-label (name) + (let* ((lab (find-lap-label name))) + (if lab + (when (lap-label-emitted-p lab) + (error "Label ~s: multiply defined." name)) + (setq lab (make-lap-label name))) + (append-dll-node lab *lap-instructions*))) + +(defun emit-lap-note (note) + (append-dll-node note *lap-instructions*)) + +(provide "RISC-LAP") + Index: /branches/qres/ccl/compiler/subprims.lisp =================================================================== --- /branches/qres/ccl/compiler/subprims.lisp (revision 13564) +++ /branches/qres/ccl/compiler/subprims.lisp (revision 13564) @@ -0,0 +1,50 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defstruct subprimitive-info + name + offset + nailed-down + argument-mask + registers-used + ) + +(defmethod make-load-form ((s subprimitive-info) &optional env) + (make-load-form-saving-slots s :environment env)) + +(defmethod print-object ((s subprimitive-info) stream) + (print-unreadable-object (s stream :type t) + (format stream "~A @ #x~x" + (subprimitive-info-name s) + (subprimitive-info-offset s)))) + +(defun %subprim-name->offset (name table) + (let* ((sprec (find name table + :test #'string-equal + :key #'subprimitive-info-name))) + (if sprec + (subprimitive-info-offset sprec) + (error "subprim named ~s not found." name)))) + +(defun subprim-name->offset (name &optional (backend *target-backend*)) + (+ (backend-lowmem-bias backend) + (%subprim-name->offset name (arch::target-subprims-table + (backend-target-arch backend))))) + +(provide "SUBPRIMS") Index: /branches/qres/ccl/compiler/vinsn.lisp =================================================================== --- /branches/qres/ccl/compiler/vinsn.lisp (revision 13564) +++ /branches/qres/ccl/compiler/vinsn.lisp (revision 13564) @@ -0,0 +1,774 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (require "DLL-NODE") + (require "BACKEND")) + + +(cl:in-package "CCL") + +;;; Specifying the same name for a result and an argument basically +;;; says that it's ok for the vinsn to clobber that argument. (In all +;;; other cases, arguments are assumed to be "read-only", and damned +;;; well better be.) Any results that are also arguments must follow +;;; all results that aren't in the "results" list; any arguments that +;;; are also results must precede all arguments that aren't in the +;;; "arguments" list, and all hybrids must appear in the same order in +;;; both lists. This is what "nhybrids" is about (and why it defaults +;;; to 0 ...) Sometimes (often) these hybrid "results" aren't very +;;; interesting as results;;; it might be clearer to consider +;;; "mutable" arguments as quasi-temporaries. +(defstruct vinsn-template + name ; a symbol in the target package + result-vreg-specs ; one or more vreg specs for values defined by the vinsn + argument-vreg-specs ; may ultimately overlap some result vreg(s) + ; one or more vreg specs for temporaries used in vinsn. + ; all such temporaries are assumed to have lifetimes which span all + ; machine instructions in the vinsn (e.g., they can't conflict with any + ; registers used for args/results and may have further constraints. + temp-vreg-specs + local-labels + body ; list of target instructions, local labels + (nhybrids 0) + (nvp 0) + results&args ; + (attributes 0) ; attribute bitmask + opcode-alist ; ((number1 . name1) (number2 . name2) ...) +) + +(defmethod make-load-form ((v vinsn-template) &optional env) + (make-load-form-saving-slots v :environment env)) + + +(defun get-vinsn-template-cell (name templates) + (let* ((n (intern (string name) *ccl-package*))) + (or (gethash n templates) + (setf (gethash n templates) (cons n nil))))) + +(defun need-vinsn-template (name templates) + (or (cdr (if (consp name) name (get-vinsn-template-cell name templates))) + (error "Unknown vinsn: ~s" name))) + +(defun set-vinsn-template (name template templates) + (setf (cdr (get-vinsn-template-cell name templates)) template)) + +(defstruct (vinsn (:include dll-node) + (:print-function print-vinsn) + (:constructor %make-vinsn (template))) + template ; The vinsn-template of which this is an instance + variable-parts ; vector of result-vregs, arguments, temps, local-labels + annotation + (gprs-set 0) + (fprs-set 0) +) + +(def-standard-initial-binding *vinsn-freelist* (make-dll-node-freelist)) + +(defun make-vinsn (template) + (let* ((vinsn (alloc-dll-node *vinsn-freelist*))) + (loop + ; Sometimes, the compiler seems to return its node list + ; to the freelist without first removing the vinsn-labels in it. + (if (or (null vinsn) (typep vinsn 'vinsn)) (return)) + (setq vinsn (alloc-dll-node *vinsn-freelist*))) + (if vinsn + (progn + (setf (vinsn-template vinsn) template + (vinsn-variable-parts vinsn) nil + (vinsn-annotation vinsn) nil + (vinsn-gprs-set vinsn) 0 + (vinsn-fprs-set vinsn) 0) + vinsn) + (%make-vinsn template)))) + +(eval-when (:load-toplevel :execute) +(defstruct (vinsn-label (:include dll-node) + (:print-function print-vinsn-label) + (:predicate %vinsn-label-p) + (:constructor %make-vinsn-label (id))) + id + refs ; vinsns in which this label appears as an operand + info ; code-generation stuff +) +) + +(def-standard-initial-binding *vinsn-label-freelist* (make-dll-node-freelist)) + +(defun make-vinsn-label (id) + (let* ((lab (alloc-dll-node *vinsn-label-freelist*))) + (if lab + (progn + (setf (vinsn-label-id lab) id + (vinsn-label-refs lab) nil + (vinsn-label-info lab) nil) + lab) + (%make-vinsn-label id)))) + +; "Real" labels have fixnum IDs. +(defun vinsn-label-p (l) + (if (%vinsn-label-p l) + (typep (vinsn-label-id l) 'fixnum))) + + +(defun print-vinsn-label (l s d) + (declare (ignore d)) + (print-unreadable-object (l s :type t) + (format s "~d" (vinsn-label-id l)))) + +;;; Notes are attached to (some) vinsns. They're used to attach +;;; semantic information to an execution point. The vinsn +;;; points to the note via its LABEL-ID; the note has a backpointer to +;;; the vinsn. + +(defstruct (vinsn-note + (:constructor %make-vinsn-note) + (:print-function print-vinsn-note)) + (label (make-vinsn-label nil)) + (peer nil :type (or null vinsn-note)) + (class nil) + (info nil :type (or null simple-vector))) + + +(defun print-vinsn-note (n s d) + (declare (ignore d)) + (print-unreadable-object (n s :type t) + (format s "~d" (vinsn-note-class n)) + (let* ((info (vinsn-note-info n))) + (when info (format s " / ~S" info))))) + +(defun make-vinsn-note (class info) + (let* ((n (%make-vinsn-note :class class :info (if info (apply #'vector info)))) + (lab (vinsn-note-label n))) + (setf (vinsn-label-id lab) n) + n)) + +(defun close-vinsn-note (n) + (let* ((end (%make-vinsn-note :peer n))) + (setf (vinsn-label-id (vinsn-note-label end)) end + (vinsn-note-peer end) n + (vinsn-note-peer n) end) + end)) + + +(defun vinsn-vreg-description (value spec) + (case (cadr spec) + ((:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm) + (let* ((mode (if (typep value 'fixnum) + (get-regspec-mode value)))) + (if (and mode (not (eql 0 mode))) + (list (hard-regspec-value value) + (car (rassoc mode *mode-name-value-alist* :test #'eq))) + value))) + (t value))) + +(defun collect-vinsn-variable-parts (v start n &optional specs) + (declare (fixnum start n)) + (let* ((varparts (vinsn-variable-parts v))) + (when varparts + (let* ((head (cons nil nil)) + (tail head)) + (declare (dynamic-extent head) (cons head tail)) + (do* ((j start (1+ j)) + (i 0 (1+ i))) + ((= i n) (cdr head)) + (declare (fixnum i j)) + (setq tail (cdr (rplacd tail (cons (vinsn-vreg-description (svref varparts j) (pop specs)) nil))))))))) + + +(defun collect-vinsn-results (v) + (let* ((template (vinsn-template v)) + (result-specs (vinsn-template-result-vreg-specs template))) + (collect-vinsn-variable-parts v 0 (length result-specs) result-specs))) + +(defun collect-vinsn-arguments (v) + (let* ((template (vinsn-template v)) + (arg-specs (vinsn-template-argument-vreg-specs template))) + (collect-vinsn-variable-parts v + (- (length (vinsn-template-result-vreg-specs template)) + (vinsn-template-nhybrids template)) + (length arg-specs) + arg-specs))) + +(defun collect-vinsn-temps (v) + (let* ((template (vinsn-template v))) + (collect-vinsn-variable-parts v + (+ + (length (vinsn-template-result-vreg-specs template)) + (length (vinsn-template-argument-vreg-specs template))) + (length (vinsn-template-temp-vreg-specs template))))) + +(defun template-infix-p (template) + (declare (ignore template)) + nil) + +(defun print-vinsn (v stream d) + (declare (ignore d)) + (let* ((template (vinsn-template v)) + (results (collect-vinsn-results v)) + (args (collect-vinsn-arguments v)) + (opsym (if (cdr results) :== :=)) + (infix (and (= (length args) 2) (template-infix-p template))) + (opname (vinsn-template-name template))) + (print-unreadable-object (v stream) + (if results (format stream "~A ~S " (if (cdr results) results (car results)) opsym)) + (if infix + (format stream "~A ~A ~A" (car args) opname (cadr args)) + (format stream "~A~{ ~A~}" opname args)) + (let* ((annotation (vinsn-annotation v))) + (when annotation + (format stream " ||~a|| " annotation)))))) + +(defparameter *known-vinsn-attributes* + '( + :jump ; an unconditional branch + :branch ; a conditional branch + :call ; a jump that returns + :funcall ; A full function call, assumed to bash all volatile registers + :subprim-call ; A subprimitive call; bashes some volatile registers + :jumpLR ; Jumps to the LR, possibly stopping off at a function along the way. + :lrsave ; saves LR in LOC-PC + :lrrestore ; restores LR from LOC-PC + :lispcontext ; references lisp frame LOC-PC, FN, and entry VSP + :node ; saves/restores a node value in stack-like memory + :word ; saves/restores an unboxed word in stack-like memory + :doubleword ; saves/restores an unboxed doubleword (fp-reg) in stack-like memory + :vsp ; uses the vsp to save/restore + :tsp ; uses the tsp to save/restore + :csp ; uses sp to save/restore + :push ; saves something + :pop ; restores something + :multiple ; saves/restores multiple nodes/words/doublewords + :ref ; references memory + :set ; sets memory + :outgoing-argument ; e.g., pushed as an argument, not to avoid clobbering + :xref ; makes some label externally visible + :jump-unknown ; Jumps, but we don't know where ... + :constant-ref + :sets-cc ; vinsn sets condition codes based on result + :discard ; adjusts a stack pointer + )) + +(defparameter *nvp-max* 10 "size of *vinsn-varparts* freelist elements") +(def-standard-initial-binding *vinsn-varparts* (%cons-pool)) + +(defun alloc-varparts-vector () + (without-interrupts + (let* ((v (pool.data *vinsn-varparts*))) + (if v + (progn + (setf (pool.data *vinsn-varparts*) + (svref v 0)) + (%init-misc 0 v) + v) + (make-array (the fixnum *nvp-max*) :initial-element 0))))) + +(defun free-varparts-vector (v) + (without-interrupts + (setf (svref v 0) (pool.data *vinsn-varparts*) + (pool.data *vinsn-varparts*) v) + nil)) + +(defun elide-vinsn (vinsn) + (let* ((nvp (vinsn-template-nvp (vinsn-template vinsn))) + (vp (vinsn-variable-parts vinsn))) + (dotimes (i nvp) + (let* ((v (svref vp i))) + (when (typep v 'lreg) + (setf (lreg-defs v) (delete vinsn (lreg-defs v))) + (setf (lreg-refs v) (delete vinsn (lreg-refs v)))))) + (free-varparts-vector vp) + (remove-dll-node vinsn))) + +(defun encode-vinsn-attributes (attribute-list) + (flet ((attribute-weight (k) + (let* ((pos (position k *known-vinsn-attributes*))) + (if pos (ash 1 pos) (error "Unknown vinsn attribute: ~s" k))))) + (let* ((attr 0)) + (declare (fixnum attr)) + (dolist (a attribute-list attr) + (setq attr (logior attr (the fixnum (attribute-weight a)))))))) + + +(defun %define-vinsn (backend vinsn-name results args temps body) + (funcall (backend-define-vinsn backend) + backend + vinsn-name + results + args + temps + body)) + + +;; Fix the opnum's in the vinsn-template-body to agree with the +;; backend's opcode hash table. +(defun fixup-vinsn-template (orig-template opcode-hash) + (let ((template (cdr orig-template))) + (when template + (unless (vinsn-template-p template) + (setq template (require-type template 'vinsn-template))) + (let ((new-opcode-alist nil) + (changes nil) + (opcode-alist (vinsn-template-opcode-alist template))) + ;; this is patterned after ppc2-expand-vinsn + (labels ((walk-form (f) + (unless (atom f) + (if (fixnump (car f)) + (got-one f) + (dolist (subform (cdr f)) + (walk-form subform))))) + (got-one (f) + (let* ((old-opcode (car f)) + (name (cdr (assq old-opcode opcode-alist))) + (new-opcode (and name (gethash name opcode-hash)))) + (unless new-opcode + (cerror "Continue" "Can't find new opcode number ~ + for ~s in ~s" (car f) template)) + (setf (assq new-opcode new-opcode-alist) name) + (unless (eq new-opcode old-opcode) + (push (cons f new-opcode) changes))))) + (mapc #'walk-form (vinsn-template-body template)) + (without-interrupts + (dolist (change changes) + (setf (caar change) (cdr change))) + (setf (vinsn-template-opcode-alist template) + new-opcode-alist)))) + orig-template))) + +(defun fixup-vinsn-templates (templates opcode-hash-table) + (maphash #'(lambda (name template) + (declare (ignore name)) + (fixup-vinsn-template template opcode-hash-table)) + templates)) + +;;; Could probably split this up and do some arg checking at macroexpand time. +(defun match-template-vregs (template vinsn supplied-vregs) + (declare (list supplied-vregs)) + (let* ((nsupp (length supplied-vregs)) + (results&args (vinsn-template-results&args template)) + (nra (length results&args)) + (temp-specs (vinsn-template-temp-vreg-specs template)) + (ntemps (length temp-specs)) + (nvp (vinsn-template-nvp template)) + (vp (alloc-varparts-vector)) + (*available-backend-node-temps* *available-backend-node-temps*) + (*available-backend-fp-temps* *available-backend-fp-temps*) + (*available-backend-imm-temps* *available-backend-imm-temps*) + (*available-backend-crf-temps* *available-backend-crf-temps*)) + (declare (fixnum nvp ntemps nsupp) + (list temp-specs)) + (unless (= nsupp nra) + (error "Vinsn ~A expects ~D result/argument specs, received ~D ." + (vinsn-template-name template) nra nsupp)) + (do* ((i 0 (1+ i)) + (supp supplied-vregs (cdr supp)) + (spec results&args (cdr spec))) + ((null supp)) + (declare (fixnum i) (list spec supp)) + (setf (svref vp i) (match-vreg (car supp) (cadar spec) vinsn vp i))) + ;; Allocate some temporaries. + (do* ((i (- nvp ntemps) (1+ i)) + (temps temp-specs (cdr temps))) + ((null temps) vp) + (declare (fixnum i)) + (let* ((spec (cadar temps))) + (if (and (consp spec) (eq (car spec) :label)) + (let* ((label (aref *backend-labels* (cadr spec)))) + (push vinsn (vinsn-label-refs label)) + (setf (svref vp i) label)) + (let* ((lreg (allocate-temporary-vreg (car temps))) + (class (hard-regspec-class lreg)) + (value (hard-regspec-value lreg))) + (when value + (case class + (#.hard-reg-class-gpr (note-vinsn-sets-gpr vinsn value)) + (#.hard-reg-class-fpr (note-vinsn-sets-fpr vinsn value)))) + (setf (svref vp i) lreg) + (pushnew vinsn (lreg-defs lreg)) + (pushnew vinsn (lreg-refs lreg)))))))) + +;;; "spec" is ( ). +;;; is keyword or ( ) +(defun allocate-temporary-vreg (spec) + (setq spec (cadr spec)) + (let* ((class (if (atom spec) spec (car spec))) + (value (if (atom spec) nil (cadr spec)))) + (if value + (ecase class + (:crf (make-wired-lreg (use-crf-temp value) :class hard-reg-class-crf)) + ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64) + (make-wired-lreg (use-imm-temp value) + :class hard-reg-class-gpr + :mode (gpr-mode-name-value class))) + (:lisp (make-wired-lreg + (use-node-temp value) + :class hard-reg-class-gpr + :mode hard-reg-class-gpr-mode-node))) + (ecase class + ((:imm :wordptr) + (make-unwired-lreg + (if (= *available-backend-imm-temps* 0) (select-node-temp) (select-imm-temp)) + :class hard-reg-class-gpr + :mode hard-reg-class-gpr-mode-node)) + ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64) + (make-unwired-lreg (select-imm-temp) + :class hard-reg-class-gpr + :mode (gpr-mode-name-value class))) + (:lisp + (make-unwired-lreg + (select-node-temp) + :class hard-reg-class-gpr + :mode hard-reg-class-gpr-mode-node)) + (:crf + (make-unwired-lreg (select-crf-temp) :class hard-reg-class-crf)))))) + + + +(defun select-vinsn (template-or-name template-hash vregs) + (let* ((template (need-vinsn-template template-or-name template-hash)) + (vinsn (make-vinsn template))) + (setf (vinsn-variable-parts vinsn) (match-template-vregs template vinsn vregs)) + vinsn)) + +(defun %emit-vinsn (vlist name vinsn-table &rest vregs) + (append-dll-node (select-vinsn name vinsn-table vregs) vlist)) + +(defun varpart-matches-reg (varpart-value class regval spec) + (setq spec (if (atom spec) spec (car spec))) + (and + (or + (and (eq class hard-reg-class-fpr) + (memq spec '(:single-float :double-float))) + (and (eq class hard-reg-class-gpr) + (memq spec '(:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm)))) + (eq (hard-regspec-value varpart-value) regval))) + +(defun vinsn-sets-reg-p (element reg) + (if (typep element 'vinsn) + (if (vinsn-attribute-p element :call) + t + (let* ((class (hard-regspec-class reg)) + (value (hard-regspec-value reg))) + (if (eq class hard-reg-class-gpr) + (logbitp value (vinsn-gprs-set element)) + (if (eq class hard-reg-class-fpr) + (logbitp value (vinsn-fprs-set element)))))))) + +;;; Return bitmasks of all GPRs and all FPRs set in the vinsns between +;;; START and END, exclusive. Any :call vinsn implicitly clobbers +;;; all registers. +(defun regs-set-in-vinsn-sequence (start end) + (let* ((gprs-set 0) + (fprs-set 0)) + (do* ((element (vinsn-succ start) (vinsn-succ element))) + ((eq element end) (values gprs-set fprs-set))n + (if (typep element 'vinsn) + (if (vinsn-attribute-p element :call) + (return (values #xffffffff #xffffffff)) + (setq gprs-set (logior (vinsn-gprs-set element)) + fprs-set (logior (vinsn-fprs-set element)))))))) + +;;; Return T if any vinsn between START and END (exclusive) sets REG. +(defun vinsn-sequence-sets-reg-p (start end reg) + (do* ((element (vinsn-succ start) (vinsn-succ element))) + ((eq element end)) + (if (vinsn-sets-reg-p element reg) + (return t)))) + + +;;; Return T if any vinsn between START and END (exclusive) has all +;;; attributes set in MASK set. +(defun %vinsn-sequence-has-attribute-p (start end attr) + (do* ((element (vinsn-succ start) (vinsn-succ element))) + ((eq element end)) + (when (typep element 'vinsn) + (when (eql attr (logand (vinsn-template-attributes (vinsn-template element)))) + (return t))))) + +(defmacro vinsn-sequence-has-attribute-p (start end &rest attrs) + `(%vinsn-sequence-has-attribute-p ,start ,end ,(encode-vinsn-attributes attrs))) + + +;;; Flow-graph nodes (FGNs) + +(defstruct (fgn (:include dll-header)) + (id 0 :type unsigned-byte) + (inedges ()) ; list of nodes which reference this node + (visited nil) ; Boolean +) + + + +;;; FGNs which don't terminate with an "external jump" +;;; (jump-return-pc/jump-subprim, etc) jump to their successor, either +;;; explicitly or by falling through. We can introduce or remove +;;; jumps when linearizing the program. +(defstruct (jumpnode (:include fgn) + (:constructor %make-jumpnode (id))) + (outedge) ; the FGN we jump/fall in to. +) + +(defun make-jumpnode (id) + (init-dll-header (%make-jumpnode id))) + +;;; A node that ends in a conditional branch, followed by an implicit +;;; or explicit jump. Keep track of the conditional branch and the +;;; node it targets. +(defstruct (condnode (:include jumpnode) + (:constructor %make-condnode (id))) + (condbranch) ; the :branch vinsn + (branchedge) ; the FGN it targets +) + +(defun make-condnode (id) + (init-dll-header (%make-condnode id))) + +;;; A node that terminates with a return i.e., a jump-return-pc or +;;; jump-subprim. +(defstruct (returnnode (:include fgn) + (:constructor %make-returnnode (id))) +) + +(defun make-returnnode (id) + (init-dll-header (%make-returnnode id))) + +;;; Some specified attribute is true. +(defun %vinsn-attribute-p (vinsn mask) + (declare (fixnum mask)) + (if (vinsn-p vinsn) + (let* ((template (vinsn-template vinsn))) + (not (eql 0 (logand mask (the fixnum (vinsn-template-attributes template)))))))) + +;;; All specified attributes are true. +(defun %vinsn-attribute-= (vinsn mask) + (declare (fixnum mask)) + (if (vinsn-p vinsn) + (let* ((template (vinsn-template vinsn))) + (= mask (the fixnum (logand mask (the fixnum (vinsn-template-attributes template)))))))) + +(defmacro vinsn-attribute-p (vinsn &rest attrs) + `(%vinsn-attribute-p ,vinsn ,(encode-vinsn-attributes attrs))) + +(defmacro vinsn-attribute-= (vinsn &rest attrs) + `(%vinsn-attribute-= ,vinsn ,(encode-vinsn-attributes attrs))) + +;;; Ensure that conditional branches that aren't followed by jumps are +;;; followed by (jump lab-next) @lab-next. Ensure that JUMPs and +;;; JUMPLRs are followed by labels. It's easiest to do this by +;;; walking backwards. When we're all done, labels will mark the +;;; start of each block. + +(defun normalize-vinsns (header) + (do* ((prevtype :label currtype) + (current (dll-header-last header) (dll-node-pred current)) + (currtype nil)) + ((eq current header) + (unless (eq prevtype :label) + (insert-dll-node-after + (aref *backend-labels* (backend-get-next-label)) + current))) + (setq currtype (cond ((vinsn-label-p current) :label) + ((vinsn-attribute-p current :branch) :branch) + ((vinsn-attribute-p current :jump) :jump) + ((vinsn-attribute-p current :jumplr) :jumplr))) + (case currtype + ((:jump :jumplr) + (unless (eq prevtype :label) + (let* ((lab (aref *backend-labels* (backend-get-next-label)))) + (insert-dll-node-after lab current)))) + (:branch + (unless (eq prevtype :jump) + (let* ((lab + (if (eq prevtype :label) + (dll-node-succ current) + (aref *backend-labels* (backend-get-next-label)))) + (jump (select-vinsn "JUMP" *backend-vinsns* (list lab)))) + (unless (eq prevtype :label) + (insert-dll-node-after lab current)) + (insert-dll-node-after jump current)))) + ((nil) + (if (eq prevtype :label) + (let* ((lab (dll-node-succ current))) + (when (vinsn-label-p lab) + (insert-dll-node-after + (select-vinsn "JUMP" *backend-vinsns* (list lab)) + current)))))))) + + +;;; Unless the header is empty, remove the last vinsn and all preceding +;;; vinsns up to and including the preceding label. (Since the vinsns +;;; have been normalized, there will always be a preceding label.) +;;; Return the label and the last vinsn, or (values nil nil.) +(defun remove-last-basic-block (vinsns) + (do* ((i 1 (1+ i)) + (current (dll-header-last vinsns) (dll-node-pred current))) + ((eq current vinsns) (values nil nil)) + (declare (fixnum i)) + (if (vinsn-label-p current) + (return (remove-dll-node current i))))) + +;;; Create a flow graph from vinsns and return the entry node. +(defun create-flow-graph (vinsns) + (let* ((nodes ())) + (flet ((label->fgn (label) (dll-node-pred label))) + (loop + (multiple-value-bind (label last) (remove-last-basic-block vinsns) + (when (null label) (return)) + (let* ((id (vinsn-label-id label)) + (node (if (vinsn-attribute-p last :jumpLR) + (make-returnnode id) + (if (vinsn-attribute-p (dll-node-pred last) :branch) + (make-condnode id) + (make-jumpnode id))))) + (declare (fixnum id)) + (insert-dll-node-after label node last) + (push node nodes)))) + (dolist (node nodes nodes) + (if (typep node 'jumpnode) + (let* ((jump (dll-header-last node)) + (jmptarget (branch-target-node jump))) + (setf (jumpnode-outedge node) jmptarget) + (pushnew node (fgn-inedges jmptarget)) + (if (typep node 'condnode) ; a subtype of jumpnode + (let* ((branch (dll-node-pred jump)) + (branchtarget (branch-target-node branch))) + (setf (condnode-condbranch node) branch) + (pushnew node (fgn-inedges branchtarget)))))))))) + + +(defun delete-unreferenced-labels (labels) + (delete #'(lambda (l) + (unless (vinsn-label-refs l) + (when (vinsn-label-succ l) + (remove-dll-node l)) + t)) labels :test #'funcall)) + +(defun branch-target-node (v) + (dll-node-pred (svref (vinsn-variable-parts v) 0))) + +(defun replace-label-refs (vinsn old-label new-label) + (let ((vp (vinsn-variable-parts vinsn))) + (dotimes (i (length vp)) + (when (eq (svref vp i) old-label) + (setf (svref vp i) new-label))))) + +;;; Try to remove jumps/branches to jumps. +(defun maximize-jumps (header) + (do* ((prev nil next) + (next (dll-header-first header) (dll-node-succ next))) + ((eq next header)) + (when (and (vinsn-attribute-p next :jump) + (vinsn-label-p prev)) + (let* ((target (svref (vinsn-variable-parts next) 0))) + (unless (eq target prev) + (dolist (ref (vinsn-label-refs prev) (setf (vinsn-label-refs prev) nil)) + (replace-label-refs ref prev target) + (push ref (vinsn-label-refs target)))))))) + +(defun optimize-vinsns (header) + ;; Delete unreferenced labels that the compiler might have emitted. + ;; Subsequent operations may cause other labels to become + ;; unreferenced. + (let* ((labels (collect ((labs)) + (do-dll-nodes (v header) + (when (vinsn-label-p v) (labs v))) + (labs)))) + ;; Look for pairs of adjacent, referenced labels. + ;; Merge them together (so that one of them becomes unreferenced.) + ;; Repeat the process until no pairs are found. + (do* ((repeat t)) + ((not repeat)) + (setq repeat nil + labels (delete-unreferenced-labels labels)) + (dolist (l labels) + (let* ((succ (vinsn-label-succ l))) + (when (vinsn-label-p succ) + (backend-merge-labels l succ) + (setq repeat t) + (return))))) + (maximize-jumps header) + (delete-unreferenced-labels labels) + (normalize-vinsns header) + )) + +(defun show-vinsns (vinsns indent) + (do-dll-nodes (n vinsns) + (format t "~&~v@t~s" indent n))) + +(defun show-fgn (node) + (format t "~&~s (~d) {~a}" (type-of node) (fgn-id node) (mapcar #'fgn-id (fgn-inedges node))) + (show-vinsns node 2) + (terpri) + (terpri)) + +(defun dfs-walk (fgns &key + process-before process-after + process-succ-before process-succ-after) + (labels ((dfs (node) + (when process-before + (funcall process-before node)) + (setf (fgn-visited node) t) + (when (typep node 'jumpnode) + (let* ((outedge (jumpnode-outedge node))) + (unless (fgn-visited outedge) + (when process-succ-before + (funcall process-succ-before outedge)) + (dfs outedge) + (when process-succ-after + (funcall process-succ-after outedge)))) + (when (typep node 'condnode) + (let* ((branchedge (branch-target-node + (condnode-condbranch node)))) + (unless (fgn-visited branchedge) + (when process-succ-before + (funcall process-succ-before branchedge)) + (dfs branchedge) + (when process-succ-after + (funcall process-succ-after branchedge)))))) + (when process-after + (funcall process-after node)))) + (dolist (n fgns) + (setf (fgn-visited n) nil)) + (dfs (car fgns)))) + +(defun dfs-postorder (fgns) + (let* ((n (length fgns)) + (v (make-array n)) + (p -1) + (process-after #'(lambda (node) + (setf (svref v (incf p)) node)))) + (declare (fixnum p) (dynamic-extent process-after)) + (dfs-walk fgns :process-after process-after) + v)) + +;;; This generally only gives a meaningful result if pass 2 of the +;;; compiler has been compiled in the current session. +;;; TODO (maybe): keep track of the "expected missing vinsns" for +;;; each backend, call this function after compiling pass 2. That's +;;; a little weird, since it'd require modifying backend X whenever +;;; backend Y changes, but it's probably better than blowing up when +;;; compiling user code. +(defun missing-vinsns (&optional (backend *target-backend*)) + (let* ((missing ())) + (maphash #'(lambda (name info) + (unless (cdr info) + (push name missing))) + (backend-p2-vinsn-templates backend)) + missing)) + +(provide "VINSN") Index: /branches/qres/ccl/compiler/vreg.lisp =================================================================== --- /branches/qres/ccl/compiler/vreg.lisp (revision 13564) +++ /branches/qres/ccl/compiler/vreg.lisp (revision 13564) @@ -0,0 +1,310 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (ccl::require "ARCH")) + +(in-package "CCL") + +(defvar *logical-register-counter* -1) + +(def-standard-initial-binding *lreg-freelist* (%cons-pool)) + +(defstruct (lreg + (:print-function print-lreg) + (:constructor %make-lreg)) + (value nil :type t) ; physical reg or frame address or ... + (id (incf (the fixnum *logical-register-counter*)) :type fixnum) ; for printing + (class 0 :type fixnum) ; target storage class: GPR, FPR, CRF ... + (mode 0 :type fixnum) ; mode (:u8, :address, etc) + (type 0 :type fixnum) ; type + (defs () :type list) ; list of vinsns which assign to this reg + (refs () :type list) ; list of vinsns which reference this vreg + (conflicts () :type list) ; other lregs which can't map to the same physical reg + (wired t :type boolean) ; when true, targeted value must be preserved. + (info nil) ; Whatever; used in printing. +) + +(defun free-lreg (l) + (without-interrupts ; explicitly + (let* ((p *lreg-freelist*)) + (setf (lreg-value l) (pool.data p) + (pool.data p) l) + nil))) + +(defun alloc-lreg () + (let* ((p *lreg-freelist*)) + (without-interrupts + (let* ((l (pool.data p))) + (when l + (setf (pool.data p) (lreg-value l)) + (setf (lreg-defs l) nil + (lreg-refs l) nil + (lreg-conflicts l) nil + (lreg-id l) (incf *logical-register-counter*) + (lreg-wired l) t) + l))))) + +(defun make-lreg (value class mode type wired) + (let* ((l (alloc-lreg))) + (cond (l + (setf (lreg-value l) value + (lreg-class l) class + (lreg-type l) type + (lreg-mode l) mode + (lreg-wired l) wired) + l) + (t (%make-lreg :value value :class class :type type :mode mode :wired wired))))) + + +(defun print-lreg (l s d) + (declare (ignore d)) + (print-unreadable-object (l s :type t) + (format s "~d" (lreg-id l)) + (let* ((value (lreg-value l)) + (class (lreg-class l)) + (mode-name (if (eq class hard-reg-class-gpr) + (car (rassoc (lreg-mode l) *mode-name-value-alist*))))) + (format s " ~a " + (case class + (#.hard-reg-class-fpr "FPR") + (#.hard-reg-class-gpr "GPR") + (#.hard-reg-class-crf "CRF") + (t (format nil "class ~d" class)))) + (if value + (format s (if (lreg-wired l) "[~s]" "{~s}") value) + (progn + (if mode-name + (format s "{?/~a}" mode-name) + (format s "{?}"))))))) + +(def-standard-initial-binding *lcell-freelist* (%cons-pool)) +(defvar *next-lcell-id* -1) + +(defstruct (lcell + (:print-function print-lcell) + (:constructor %make-lcell (kind parent width attributes info))) + (kind :node) ; for printing + (id (incf (the fixnum *next-lcell-id*)) :type fixnum) ; + (parent nil) ; backpointer to unique parent + (children nil) ; list of children + (width 4) ; size in bytes or NIL if deleted + (offset nil) ; sum of ancestor's widths or 0, NIL if deleted + (refs nil) ; vinsns which load/store into this cell + (attributes 0 :type fixnum) ; bitmask + (info nil)) ; whatever + +(defun print-lcell (c s d) + (declare (ignore d)) + (print-unreadable-object (c s :type t) + (format s "~d" (lcell-id c)) + (let* ((offset (lcell-offset c))) + (when offset + (format s "@#x~x" offset))))) + +(defun free-lcell (c) + (without-interrupts ; explicitly + (let* ((p *lcell-freelist*)) + (setf (lcell-kind c) (pool.data p) + (pool.data p) c) + nil))) + +(defun alloc-lcell (kind parent width attributes info) + (let* ((p *lcell-freelist*)) + (without-interrupts + (let* ((c (pool.data p))) + (when c + (setf (pool.data p) (lcell-kind c)) + (setf (lcell-kind c) kind + (lcell-parent c) parent + (lcell-width c) width + (lcell-attributes c) (the fixnum attributes) + (lcell-info c) info + (lcell-offset c) nil + (lcell-refs c) nil + (lcell-children c) nil + (lcell-id c) (incf *next-lcell-id*)) + c))))) + +(defun make-lcell (kind parent width attributes info) + (let* ((c (or (alloc-lcell kind parent width attributes info) + (%make-lcell kind parent width attributes info)))) + (when parent (push c (lcell-children parent))) + c)) + +; Recursively calculate, but don't cache (or pay attention to previously calculated offsets) +(defun calc-lcell-offset (c) + (if c + (let* ((p (lcell-parent c))) + (if (null p) + 0 + (+ (calc-lcell-offset p) (or (lcell-width p) 0)))) + 0)) + +; A cell's "depth" is its offset + its width +(defun calc-lcell-depth (c) + (if c + (+ (calc-lcell-offset c) (or (lcell-width c) 0)) + 0)) + +; I don't know why "compute" means "memoize", but it does. +(defun compute-lcell-offset (c) + (or (lcell-offset c) + (setf (lcell-offset c) + (let* ((p (lcell-parent c))) + (if (null p) + 0 + (+ (compute-lcell-offset p) (or (lcell-width p) 0))))))) + +(defun compute-lcell-depth (c) + (if c + (+ (compute-lcell-offset c) (or (lcell-width c) 0)) + 0)) + + + + + +(defparameter *spec-class-storage-class-alist* + `((:lisp . ,arch::storage-class-lisp) + (:imm . ,arch::storage-class-imm) + (:wordptr . ,arch::storage-class-wordptr) + (:u8 . ,arch::storage-class-u8) + (:s8 . ,arch::storage-class-s8) + (:u16 . ,arch::storage-class-u16) + (:s16 . ,arch::storage-class-s16) + (:u32 . ,arch::storage-class-u32) + (:s32 . ,arch::storage-class-s32) + (:u64 . ,arch::storage-class-u64) + (:s64 . ,arch::storage-class-s64) + (:address . ,arch::storage-class-address) + (:single-float . ,arch::storage-class-single-float) + (:double-float . ,arch::storage-class-double-float) + (:pc . ,arch::storage-class-pc) + (:locative . ,arch::storage-class-locative) + (:crf . ,arch::storage-class-crf) + (:crbit . ,arch::storage-class-crbit) + (:crfbit . ,arch::storage-class-crfbit) + (t . nil))) + +(defun spec-class->storage-class (class-name) + (or (cdr (assoc class-name *spec-class-storage-class-alist* :test #'eq)) + (error "Unknown storage-class specifier: ~s" class-name))) + +(defun vreg-ok-for-storage-class (vreg sclass) + (declare (ignore vreg sclass)) + t) + + + +(defparameter *vreg-specifier-constant-constraints* + `((:u8const . ,(specifier-type '(unsigned-byte 8))) + (:u16const . ,(specifier-type '(unsigned-byte 16))) + (:u32const . ,(specifier-type '(unsigned-byte 32))) + (:u64const . ,(specifier-type '(unsigned-byte 64))) + (:s8const . ,(specifier-type '(signed-byte 8))) + (:s16const . ,(specifier-type '(signed-byte 16))) + (:s32const . ,(specifier-type '(signed-byte 32))) + (:s64const . ,(specifier-type '(signed-byte 64))) + (:lcell . ,(specifier-type 'lcell)))) + +(defun match-vreg-value (vreg value) + (declare (ignorable vreg value)) ; at least until this -does- something. + ;(format t "~&vreg = ~s, value = ~s" vreg value) + t) + +(defun match-vreg-constraint (constraint vreg template valvect n) + (let* ((res&args (vinsn-template-results&args template)) + (target (cadr constraint)) + (matchspec (assq target res&args)) + (matchpos (if matchspec (position matchspec res&args)))) + (unless matchpos + (warn "Unknown template vreg name ~s in constraint ~s." target constraint)) + (unless (< matchpos n) + (warn "Forward-referenced vreg name ~s in constraint ~s." target constraint)) + (let* ((target-val (svref valvect matchpos))) + (unless (ecase (car constraint) (:eq (eq vreg target-val)) (:ne (neq vreg target-val))) + (warn "~& use of vreg ~s conflicts with value already assigned ~ + to ~s wrt constraint ~s ." vreg (car matchspec) constraint))))) + +(defun note-vinsn-sets-gpr (vinsn gpr) + (setf (vinsn-gprs-set vinsn) (logior (vinsn-gprs-set vinsn) (ash 1 gpr)))) + +(defun note-vinsn-sets-fpr (vinsn fpr) + (setf (vinsn-fprs-set vinsn) (logior (vinsn-fprs-set vinsn) (ash 1 fpr)))) + +(defun match-vreg (vreg spec vinsn vp n) + (declare (fixnum n)) + (let* ((class (if (atom spec) spec (car spec))) + (value (if (atom spec) nil (cadr spec))) + (template (vinsn-template vinsn)) + (result-p (< n (the fixnum (length (vinsn-template-result-vreg-specs template)))))) + (let* ((spec-class (assoc class *spec-class-storage-class-alist* :test #'eq))) + (if spec-class + (let* ((vreg-value (hard-regspec-value vreg))) + (if (typep vreg 'fixnum) + (setq vreg vreg-value) + (if (typep vreg 'lreg) + (if result-p + (pushnew vinsn (lreg-defs vreg)) + (pushnew vinsn (lreg-refs vreg))) + (error "Bad vreg: ~s" vreg))) + (when vreg-value + (case class + (:crf (use-crf-temp vreg-value)) + ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64 :address) + (when result-p (note-vinsn-sets-gpr vinsn vreg-value)) + (use-imm-temp vreg-value)) + ((:single-float :double-float) + (use-fp-temp vreg-value) + (when result-p (note-vinsn-sets-fpr vinsn vreg-value))) + ((:imm t) + (when result-p (note-vinsn-sets-gpr vinsn vreg-value)) + (if (logbitp vreg-value *backend-imm-temps*) + (use-imm-temp vreg-value) + (use-node-temp vreg-value))) + (:lisp + (use-node-temp vreg-value) + (when result-p (note-vinsn-sets-gpr vinsn vreg-value))))) + (unless (or (eq class 't) (vreg-ok-for-storage-class vreg class)) + (warn "~s was expected to have storage class matching specifier ~s" vreg class)) + (when value + (if (atom value) + (match-vreg-value vreg-value value) + (match-vreg-constraint value vreg-value template vp n)))) + (if (eq class :label) + (progn + (unless (typep vreg 'vinsn-label) + (error "Label expected, found ~s." vreg)) + (push vinsn (vinsn-label-refs vreg))) + (let* ((ctype (cdr (assoc class *vreg-specifier-constant-constraints* :test #'eq)))) + (unless ctype (error "Unknown vreg constraint : ~s ." class)) + (unless (ctypep vreg ctype) + (error "~S : value doesn't match constraint ~s in template for ~s ." vreg class (vinsn-template-name template))))))) + (when (typep vreg 'lcell) + (pushnew vinsn (lcell-refs vreg))) + vreg)) + +(defun note-lreg-conflict (lreg conflicts-with) + (and (typep lreg 'lreg) + (typep conflicts-with 'lreg) + (pushnew conflicts-with (lreg-conflicts lreg)) + (pushnew lreg (lreg-conflicts conflicts-with)) + t)) + +(ccl::provide "VREG") Index: /branches/qres/ccl/l1-fasls/.cvsignore =================================================================== --- /branches/qres/ccl/l1-fasls/.cvsignore (revision 13564) +++ /branches/qres/ccl/l1-fasls/.cvsignore (revision 13564) @@ -0,0 +1,3 @@ +*fsl + + Index: /branches/qres/ccl/level-0/.cvsignore =================================================================== --- /branches/qres/ccl/level-0/.cvsignore (revision 13564) +++ /branches/qres/ccl/level-0/.cvsignore (revision 13564) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/qres/ccl/level-0/X86/.cvsignore =================================================================== --- /branches/qres/ccl/level-0/X86/.cvsignore (revision 13564) +++ /branches/qres/ccl/level-0/X86/.cvsignore (revision 13564) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/qres/ccl/level-0/X86/X8664/.cvsignore =================================================================== --- /branches/qres/ccl/level-0/X86/X8664/.cvsignore (revision 13564) +++ /branches/qres/ccl/level-0/X86/X8664/.cvsignore (revision 13564) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/qres/ccl/level-0/X86/X8664/x8664-bignum.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/X8664/x8664-bignum.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/X8664/x8664-bignum.lisp (revision 13564) @@ -0,0 +1,429 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; The caller has allocated a two-digit bignum (quite likely on the stack). +;;; If we can fit in a single digit (if the high word is just a sign +;;; extension of the low word), truncate the bignum in place (the +;;; trailing words should already be zeroed. +(defx86lapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z)) + (movq (% fixnum) (% arg_x)) + (shl ($ (- 32 x8664::fixnumshift)) (% arg_x)) + (sar ($ (- 32 x8664::fixnumshift)) (% arg_x)) + (unbox-fixnum fixnum imm0) + (cmp (% arg_x) (% fixnum)) + (je @chop) + (movq (% imm0) (@ x8664::misc-data-offset (% bignum))) + (single-value-return) + @chop + (movq ($ x8664::one-digit-bignum-header) (@ x8664::misc-header-offset (% bignum))) + (movl (% imm0.l) (@ x8664::misc-data-offset (% bignum))) + (single-value-return)) + +;; multiply x[i] by y and add to result starting at digit idx +(defx86lapfunction %multiply-and-add-loop + ((x 16) (y 8) #|(ra 0)|# (r arg_x) (idx arg_y) (ylen arg_z)) + (let ((cc mm2) + (xx mm3) + (yy mm4) + (rr mm5) + (i imm0) + (j imm1)) + (unbox-fixnum idx i) + (movq (@ x (% rsp)) (% temp0)) + (movd (@ x8664::misc-data-offset (% temp0) (% i) 4) (% xx)) ;x[i] + (movq (@ y (% rsp)) (% temp0)) + (movq (% r) (% temp1)) + (pxor (% cc) (% cc)) + (xorq (% j) (% j)) + @loop + (movd (@ x8664::misc-data-offset (% temp0) (% j) 4) (% yy)) ;y[j] + (pmuludq (% xx) (% yy)) + ;; 64-bit product now in %yy + (movd (@ x8664::misc-data-offset (% temp1) (% i) 4) (% rr)) + ;; add in digit from r[i] + (paddq (% yy) (% rr)) + ;; add in carry + (paddq (% cc) (% rr)) + (movd (% rr) (@ x8664::misc-data-offset (% temp1) (% i) 4)) ;update r[i] + (movq (% rr) (% cc)) + (psrlq ($ 32) (% cc)) ;get carry digit into low word + (addq ($ 1) (% i)) + (addq ($ 1) (% j)) + (subq ($ '1) (% ylen)) + (jg @loop) + (movd (% cc) (@ x8664::misc-data-offset (% temp1) (% i) 4)) + (single-value-return 4))) + +(defx86lapfunction %multiply-and-add-loop64 + ((xs 16) (ys 8) #|(ra 0)|# (r arg_x) (i arg_y) (ylen arg_z)) + (let ((y temp2) + (j temp0) + (c imm2)) + (movq (@ xs (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% temp0) (% i)) (% mm0)) ;x[i] + (movq (@ ys (% rsp)) (% y)) + (xorl (%l j) (%l j)) + (xorl (%l c) (%l c)) + @loop + ;; It's a pity to have to reload this every time, but there's no + ;; imm3. (Give him 16 registers, and he still complains...) + (movd (% mm0) (% rax)) + (mulq (@ x8664::misc-data-offset (% y) (% j))) ;128-bit x * y[j] in rdx:rax + (addq (@ x8664::misc-data-offset (% r) (% i)) (% rax)) ;add in r[i] + (adcq ($ 0) (% rdx)) + ;; add in carry digit + (addq (% c) (% rax)) + (movl ($ 0) (%l c)) + (adcq (% rdx) (% c)) ;new carry digit + (movq (% rax) (@ x8664::misc-data-offset (% r) (% i))) ;update r[i] + (addq ($ '1) (% i)) + (addq ($ '1) (% j)) + (subq ($ '1) (% ylen)) + (ja @loop) + (movq (% c) (@ x8664::misc-data-offset (% r) (% i))) + (single-value-return 4))) + +;;; Multiply the (32-bit) digits X and Y, producing a 64-bit result. +;;; Add the 32-bit "prev" digit and the 32-bit carry-in digit to that 64-bit +;;; result; return the halves as (VALUES high low). +(defx86lapfunction %multiply-and-add4 ((x 8) #|(ra 0)|# (y arg_x) (prev arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-prev imm0) + (unboxed-carry-in imm0) + (unboxed-low imm0) + (high arg_y) + (low arg_z)) + (pop (% ra0)) + (popq (% temp0)) + (discard-reserved-frame) + (push (% ra0)) + (unbox-fixnum temp0 unboxed-x) + (unbox-fixnum y unboxed-y) + (mull (%l unboxed-y)) + (shlq ($ 32) (% unboxed-y)) + (orq (% unboxed-x) (% unboxed-y)) ; I got yer 64-bit product right here + (unbox-fixnum prev unboxed-prev) + (addq (% unboxed-prev) (% unboxed-y)) + (unbox-fixnum carry-in unboxed-carry-in) + (addq (% unboxed-carry-in) (% unboxed-y)) + (movl (%l unboxed-y) (%l unboxed-low)) + (box-fixnum unboxed-low low) + (shr ($ 32) (% unboxed-y)) + (box-fixnum unboxed-y high) + (movq (% rsp) (% temp0)) + (pushq (% high)) + (pushq (% low)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +(defx86lapfunction %multiply-and-add3 ((x arg_x) (y arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-carry-in imm0) + (unboxed-low imm0) + (high arg_y) + (low arg_z)) + (unbox-fixnum arg_x unboxed-x) + (unbox-fixnum y unboxed-y) + (mull (%l unboxed-y)) + (shlq ($ 32) (% unboxed-y)) + (orq (% unboxed-x) (% unboxed-y)) + (unbox-fixnum carry-in unboxed-carry-in) + (addq (% unboxed-carry-in) (% unboxed-y)) + (movl (%l unboxed-y) (%l unboxed-low)) + (box-fixnum unboxed-low low) + (shr ($ 32) (% unboxed-y)) + (box-fixnum unboxed-y high) + (movq (% rsp) (% temp0)) + (pushq (% high)) + (pushq (% low)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +;;; Return the (possibly truncated) 32-bit quotient and remainder +;;; resulting from dividing hi:low by divisor. +(defx86lapfunction %floor ((num-high arg_x) (num-low arg_y) (divisor arg_z)) + (let ((unboxed-high imm1) + (unboxed-low imm0) + (unboxed-quo imm0) + (unboxed-rem imm1) + (unboxed-divisor imm2)) + (unbox-fixnum divisor unboxed-divisor) + (unbox-fixnum num-high unboxed-high) + (unbox-fixnum num-low unboxed-low) + (divl (%l unboxed-divisor)) + (box-fixnum unboxed-quo arg_y) + (box-fixnum unboxed-rem arg_z) + (movq (% rsp) (% temp0)) + (pushq (% arg_y)) + (pushq (% arg_z)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +;;; Multiply two (UNSIGNED-BYTE 32) arguments, return the high and +;;; low halves of the 64-bit result +(defx86lapfunction %multiply ((x arg_y) (y arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-high imm1) + (unboxed-low imm0)) + (unbox-fixnum x unboxed-x) + (unbox-fixnum y unboxed-y) + (mull (%l unboxed-y)) + (box-fixnum unboxed-high arg_y) + (box-fixnum unboxed-low arg_z) + (movq (% rsp) (% temp0)) + (pushq (% arg_y)) + (pushq (% arg_z)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +;;; Any words in the "tail" of the bignum should have been +;;; zeroed by the caller. +(defx86lapfunction %set-bignum-length ((newlen arg_y) (bignum arg_z)) + (movq (% newlen) (% imm0)) + (shl ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% imm0)) + (movb ($ x8664::subtag-bignum) (%b imm0)) + (movq (% imm0) (@ x8664::misc-header-offset (% bignum))) + (single-value-return)) + +;;; Count the sign bits in the most significant digit of bignum; +;;; return fixnum count. +(defx86lapfunction %bignum-sign-bits ((bignum arg_z)) + (vector-size bignum imm0 imm0) + (movl (@ (- x8664::misc-data-offset 4) (% bignum) (% imm0) 4) (%l imm0)) + (movl (% imm0.l) (% imm1.l)) + (notl (% imm0.l)) + (testl (% imm1.l) (% imm1.l)) + (js @wasneg) + (notl (% imm0.l)) + @wasneg + (bsrl (% imm0.l) (% imm0.l)) + (sete (% imm1.b)) + (xorl ($ 31) (% imm0)) + (addb (% imm1.b) (% imm0.b)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %signed-bignum-ref ((bignum arg_y) (index arg_z)) + (uuo-error-debug-trap) + (unbox-fixnum index imm0) + (movslq (@ x8664::misc-data-offset (% bignum) (% imm0) 4) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +;;; If the bignum is a one-digit bignum, return the value of the +;;; single digit as a fixnum. Otherwise, if it's a two-digit-bignum +;;; and the two words of the bignum can be represented in a fixnum, +;;; return that fixnum; else return nil. +(defx86lapfunction %maybe-fixnum-from-one-or-two-digit-bignum ((bignum arg_z)) + (getvheader bignum imm1) + (cmpq ($ x8664::one-digit-bignum-header) (% imm1)) + (je @one) + (cmpq ($ x8664::two-digit-bignum-header) (% imm1)) + (jne @no) + (movq (@ x8664::misc-data-offset (% bignum)) (% imm0)) + (box-fixnum imm0 arg_z) + (unbox-fixnum arg_z imm1) + (cmpq (% imm0) (% imm1)) + (je @done) + @no + (movq ($ nil) (% arg_z)) + (single-value-return) + @one + (movslq (@ x8664::misc-data-offset (% bignum)) (% imm0)) + (box-fixnum imm0 arg_z) + @done + (single-value-return)) + +;;; Again, we're out of imm regs: a variable shift count has to go in %cl. +;;; Make sure that the rest of %rcx is 0, to keep the GC happy. +;;; %rcx == temp2 +(defx86lapfunction %digit-logical-shift-right ((digit arg_y) (count arg_z)) + (unbox-fixnum digit imm0) + (unbox-fixnum count imm2) + (shrq (% imm2.b) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + + +(defx86lapfunction %ashr ((digit arg_y) (count arg_z)) + (unbox-fixnum digit imm0) + (unbox-fixnum count imm2) + (movslq (%l imm0) (% imm0)) + (sarq (% imm2.b) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %ashl ((digit arg_y) (count arg_z)) + (unbox-fixnum digit imm0) + (unbox-fixnum count imm2) + (shlq (% imm2.b) (% imm0)) + (movl (%l imm0) (%l imm0)) ;zero-extend + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction macptr->fixnum ((ptr arg_z)) + (macptr-ptr arg_z ptr) + (single-value-return)) + +(defx86lapfunction fix-digit-logand ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (movq (@ x8664::misc-data-offset (% big)) (% w2)) + (unbox-fixnum fix w1) + (andq (% w2) (% w1)) + (cmp-reg-to-nil dest) + (jne @store) + (box-fixnum w1 arg_z) + (single-value-return) + @store + (movq (% w1) (@ x8664::misc-data-offset (% dest))) + (single-value-return))) + +(defx86lapfunction fix-digit-logandc2 ((fix arg_x) (big arg_y) (dest arg_z)) + (let ((w1 imm0) + (w2 imm1)) + (movq (@ x8664::misc-data-offset (% big)) (% w2)) + (unbox-fixnum fix w1) + (notq (% w2)) + (andq (% w2) (% w1)) + (cmp-reg-to-nil dest) + (jne @store) + (box-fixnum w1 arg_z) + (single-value-return) + @store + (movq (% w1) (@ x8664::misc-data-offset (% dest))) + (single-value-return))) + + +(defx86lapfunction fix-digit-logandc1 ((fix arg_x) (big arg_y) (dest arg_z)) + (let ((w1 imm0) + (w2 imm1)) + (movq (@ x8664::misc-data-offset (% big)) (% w2)) + (unbox-fixnum fix w1) + (notq (% w1)) + (andq (% w2) (% w1)) + (cmp-reg-to-nil dest) + (jne @store) + (box-fixnum w1 arg_z) + (single-value-return) + @store + (movq (% w1) (@ x8664::misc-data-offset (% dest))) + (single-value-return))) + +;;; Do LOGIOR on the N 32-bit words in A and B, storing the result in +;;; C. (It's legal and desirable to do this more than 32 bits at a time.) + +(defx86lapfunction %bignum-logior ((n 8) #|ra 0|# (a arg_x) (b arg_y) (c arg_z)) + (movq (@ n (% rsp)) (% imm0)) + (shrq (% imm0)) + (testl ($ 4) (%l imm0)) + (je @check128) + (subq ($ 4) (% imm0)) + (movl (@ x8664::misc-data-offset (% a) (% imm0)) (%l imm1)) + (orl (@ x8664::misc-data-offset (% b) (% imm0)) (%l imm1)) + (movl (%l imm1) (@ x8664::misc-data-offset (% c) (% imm0))) + (jmp @check128) + @loop64 + (movq (@ x8664::misc-data-offset (% a) (% imm0)) (% imm1)) + (orq (@ x8664::misc-data-offset (% b) (% imm0)) (% imm1)) + (movq (% imm1) (@ x8664::misc-data-offset (% c) (% imm0))) + @test64 + (subq ($ 8) (% imm0)) + (jge @loop64) + (single-value-return 3) + ;; See if we can do some of this using the SSE2 hardware. + ;; That's only possible if we have 6 or more words. + @check128 + (rcmpq (% imm0) ($ (* 6 4))) + (jl @test64) + ;; We'll have to do the first 2 words in a 64-bit operation. + ;; If the total number of words is a multiple of 4, we have + ;; to do the last 2 words without using SSE2, as well. + (testl ($ 8) (%l imm0)) + (jne @test128) + (movq (@ (- x8664::misc-data-offset 8) (% a) (% imm0)) (% imm1)) + (orq (@ (- x8664::misc-data-offset 8) (% b) (% imm0)) (% imm1)) + (movq (% imm1) (@ (- x8664::misc-data-offset 8) (% c) (% imm0))) + (subq ($ (+ 16 8)) (% imm0)) + @loop128 + (movaps (@ x8664::misc-data-offset (% a) (% imm0)) (% xmm0)) + (por (@ x8664::misc-data-offset (% b) (% imm0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% c) (% imm0))) + @test128 + (subq ($ 16) (% imm0)) + (jg @loop128) + (movq (@ x8664::misc-data-offset (% a)) (% imm1)) + (orq (@ x8664::misc-data-offset (% b)) (% imm1)) + (movq (% imm1) (@ x8664::misc-data-offset (% c))) + (single-value-return 3)) + + + +;;; Do LOGAND on the N 32-bit words in A and B, storing the result in +;;; C. (It's legal and desirable to do this more than 32 bits at a time.) + +(defx86lapfunction %bignum-logand ((n 8) #|ra 0|# (a arg_x) (b arg_y) (c arg_z)) + (movq (@ n (% rsp)) (% imm0)) + (shrq (% imm0)) + (testl ($ 4) (%l imm0)) + (je @check128) + (subq ($ 4) (% imm0)) + (movl (@ x8664::misc-data-offset (% a) (% imm0)) (%l imm1)) + (andl (@ x8664::misc-data-offset (% b) (% imm0)) (%l imm1)) + (movl (%l imm1) (@ x8664::misc-data-offset (% c) (% imm0))) + (jmp @check128) + @loop64 + (movq (@ x8664::misc-data-offset (% a) (% imm0)) (% imm1)) + (andq (@ x8664::misc-data-offset (% b) (% imm0)) (% imm1)) + (movq (% imm1) (@ x8664::misc-data-offset (% c) (% imm0))) + @test64 + (subq ($ 8) (% imm0)) + (jge @loop64) + (single-value-return 3) + ;; See if we can do some of this using the SSE2 hardware. + ;; That's only possible if we have 6 or more words. + @check128 + (rcmpq (% imm0) ($ (* 6 4))) + (jl @test64) + ;; We'll have to do the first 2 words in a 64-bit operation. + ;; If the total number of words is a multiple of 4, we have + ;; to do the last 2 words without using SSE2, as well. + (testl ($ 8) (%l imm0)) + (jne @test128) + (movq (@ (- x8664::misc-data-offset 8) (% a) (% imm0)) (% imm1)) + (andq (@ (- x8664::misc-data-offset 8) (% b) (% imm0)) (% imm1)) + (movq (% imm1) (@ (- x8664::misc-data-offset 8) (% c) (% imm0))) + (subq ($ (+ 16 8)) (% imm0)) + @loop128 + (movaps (@ x8664::misc-data-offset (% a) (% imm0)) (% xmm0)) + (pand (@ x8664::misc-data-offset (% b) (% imm0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% c) (% imm0))) + @test128 + (subq ($ 16) (% imm0)) + (jg @loop128) + (movq (@ x8664::misc-data-offset (% a)) (% imm1)) + (and (@ x8664::misc-data-offset (% b)) (% imm1)) + (movq (% imm1) (@ x8664::misc-data-offset (% c))) + (single-value-return 3)) + Index: /branches/qres/ccl/level-0/X86/x86-array.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-array.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-array.lisp (revision 13564) @@ -0,0 +1,569 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + #+x8632-target + (require "X8632-ARCH") + #+x8664-target + (require "X8664-ARCH") + (require "X86-LAPMACROS")) + + + +#+x8664-target +(progn +;;; None of the stores in here can be intergenerational; the vector +;;; is known to be younger than the initial value +(defx86lapfunction %init-gvector ((len arg_x) (value arg_y) (vector arg_z)) + (jmp @test) + @loop + (movq (% value) (@ x8664::misc-data-offset (% vector) (% len))) + @test + (subq ($ x8664::fixnumone) (% len)) + (jns @loop) + (single-value-return)) + +;;; "val" is either a fixnum or a uvector with 64-bits of data +;;; (small bignum, DOUBLE-FLOAT). +(defx86lapfunction %%init-ivector64 ((len arg_x) (value arg_y) (vector arg_z)) + (unbox-fixnum value imm0) + (testb ($ x8664::fixnummask) (%b value)) + (je @test) + (movq (@ x8664::misc-data-offset (% value)) (% imm0)) + (jmp @test) + @loop + (movq (% imm0) (@ x8664::misc-data-offset (% vector) (% len))) + @test + (subq ($ x8664::fixnumone) (% len)) + (jns @loop) + (single-value-return)) + +(defun %init-ivector64 (typecode len val uvector) + (declare (type (mod 256) typecode)) + (%%init-ivector64 len + (case typecode + (#.x8664::subtag-fixnum-vector + (require-type val 'fixnum)) + (#.x8664::subtag-double-float-vector + (if (typep val 'double-float) + val + (require-type val 'double-float))) + (#.x8664::subtag-s64-vector + (require-type val '(signed-byte 64))) + (#.x8664::subtag-u64-vector + (require-type val '(unsigned-byte 64))) + (t (report-bad-arg uvector + '(or (simple-array fixnum (*)) + (simple-array double-float (*)) + (simple-array (signed-byte 64) (*)) + (simple-array (unsigned-byte 64) (*)))))) + uvector)) + + +(eval-when (:compile-toplevel :execute) + (declaim (inline %init-ivector-u32))) + +(defun %init-ivector-u32 (len u32val uvector) + (declare (type index len) + (type (unsigned-byte 32) u32val) + (type (simple-array (unsigned-byte 32) (*)) uvector) + (optimize (speed 3) (safety 0))) + (dotimes (i len uvector) + (setf (aref uvector i) u32val))) + +(eval-when (:compile-toplevel :execute) + (declaim (inline %init-ivector-u16))) + +(defun %init-ivector-u16 (len val uvector) + (declare (type index len) + (type (unsigned-byte 16) val) + (type (simple-array (unsigned-byte 16) (*)) uvector) + (optimize (speed 3) (safety 0))) + (dotimes (i len uvector) + (setf (aref uvector i) val))) + + + +(defun %init-ivector32 (typecode len val uvector) + (declare (type (unsigned-byte 32) typecode) + (type index len)) + (let* ((u32val (case typecode + (#.x8664::subtag-s32-vector + (logand (the (signed-byte 32) + (require-type val '(signed-byte 32))) + #xffffffff)) + (#.x8664::subtag-single-float-vector + (single-float-bits (require-type val 'single-float))) + (#.x8664::subtag-simple-base-string + (char-code val)) + (t + (require-type val '(unsigned-byte 32)))))) + (declare (type (unsigned-byte 32) u32val)) + (%init-ivector-u32 len u32val uvector))) + +(defun %init-misc (val uvector) + (let* ((len (uvsize uvector)) + (typecode (typecode uvector)) + (fulltag (logand x8664::fulltagmask typecode))) + (declare (type index len) + (type (unsigned-byte 8) typecode) + (type (mod 16) fulltag)) + (if (or (= fulltag x8664::fulltag-nodeheader-0) + (= fulltag x8664::fulltag-nodeheader-1)) + (%init-gvector len val uvector) + (if (= fulltag x8664::ivector-class-64-bit) + (%init-ivector64 typecode len val uvector) + (if (= fulltag x8664::ivector-class-32-bit) + (%init-ivector32 typecode len val uvector) + ;; Value must be a fixnum, 1, 8, 16 bits + (case typecode + (#.x8664::subtag-u16-vector + (%init-ivector-u16 len + (require-type val '(unsigned-byte 16)) + uvector)) + (#.x8664::subtag-s16-vector + (%init-ivector-u16 len + (logand (the (signed-byte 16) + (require-type val '(signed-byte 16))) + #xffff) + uvector)) + (#.x8664::subtag-u8-vector + (let* ((v0 (require-type val '(unsigned-byte 8))) + (l0 (ash (the fixnum (1+ len)) -1))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%init-ivector-u16 l0 + (logior (the (unsigned-byte 16) (ash v0 8)) + v0) + uvector))) + (#.x8664::subtag-s8-vector + (let* ((v0 (logand #xff + (the (signed-byte 8) + (require-type val '(signed-byte 8))))) + (l0 (ash (the fixnum (1+ len)) -1))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%init-ivector-u16 l0 + (logior (the (unsigned-byte 16) (ash v0 8)) + v0) + uvector))) + (#.x8664::subtag-bit-vector + (let* ((v0 (case val + (1 -1) + (0 0) + (t (report-bad-arg val 'bit)))) + (l0 (ash (the fixnum (+ len 63)) -6))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%%init-ivector64 l0 v0 uvector))) + (t (report-bad-arg uvector + '(or simple-bit-vector + (simple-array (signed-byte 8) (*)) + (simple-array (unsigned-byte 8) (*)) + (simple-array (signed-byte 16) (*)) + (simple-array (unsigned-byte 16) (*))))))))))) + + +) + +#-x8664-target +(defun %init-misc (val uvector) + (dotimes (i (uvsize uvector) uvector) + (setf (uvref uvector i) val))) + + +;;; Make a new vector of size newsize whose subtag matches that of oldv-arg. +;;; Blast the contents of the old vector into the new one as quickly as +;;; possible; leave remaining elements of new vector undefined (0). +;;; Return new-vector. +(defun %extend-vector (start oldv newsize) + (declare (fixnum start)) + (let* ((new (%alloc-misc newsize (typecode oldv))) + (oldsize (uvsize oldv))) + (declare (fixnum oldsize)) + (do* ((i 0 (1+ i)) + (j start (1+ j))) + ((= i oldsize) new) + (declare (fixnum i j)) + (setf (uvref new j) (uvref oldv i))))) + + + + + +;;; argument is a vector header or an array header. Or else. +(defx86lapfunction %array-header-data-and-offset ((a arg_z)) + (let ((offset arg_y) + (temp temp1)) + (movq (% rsp) (% temp0)) + (movl ($ '0) (%l offset)) + (movq (% a) (% temp)) + @loop + (movq (@ target::arrayH.data-vector (% temp)) (% a)) + (extract-subtag a imm0) + (addq (@ target::arrayH.displacement (% temp)) (% offset)) + (rcmp (% imm0) ($ target::subtag-vectorH)) + (movq (% a) (% temp)) + (jle @loop) + (push (% a)) + (push (% offset)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + + +;;; In each of these "simple BOOLE functions", the LEN argument +;;; describes the size of the bit vectors in whole or partial +;;; native-sized words. The 0th word (and, if the number of +;;; words is even, the last word) are not aligned on 16-byte +;;; boundaries; any intervening pairs of words are aligned on +;;; 16-byte boundaries, and we can use aligned SSE2 instructions +;;; to process these bits 128 at a time. + +(defx86lapfunction %boole-clr ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ 1) (%l temp0)) + (pxor (% xmm0) (% xmm0)) + (jmp @test) + @loop + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq ($ 0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-set ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm0) (% xmm0)) + (jmp @test) + @loop + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq ($ -1) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3) + (:align 4)) + +(defx86lapfunction %boole-1 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-2 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-c1 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (orl ($ '1) (%l temp0)) + (jmp @test) + @loop + (movdqa (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (movdqa (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-c2 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (orl ($ '1) (%l temp0)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-and ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (pand (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (andq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-ior ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (por (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (orq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-xor ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (pxor (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (xorq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-eqv ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (pxor (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (movaps(% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (xorq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-nand ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (pand (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (movaps(% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (andq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-nor ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (por (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (movaps(% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (orq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-andc1 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (pand (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (notq (% imm0)) + (andq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-andc2 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (pand (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (notq (% imm0)) + (andq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-orc1 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (por (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (movaps (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (notq (% imm0)) + (orq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx86lapfunction %boole-orc2 ((len 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ len (% rsp)) (% temp0)) + (orl ($ '1) (%l temp0)) + (pcmpeqb (% xmm1) (% xmm1)) + (jmp @test) + @loop + (movaps (@ x8664::misc-data-offset (% b1) (% temp0)) (% xmm0)) + (pxor (% xmm1) (% xmm0)) + (por (@ x8664::misc-data-offset (% b0) (% temp0)) (% xmm0)) + (movq (% xmm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + @test + (subq ($ '2) (% temp0)) + (jg @loop) + (movq (@ x8664::misc-data-offset (% b1)) (% imm0)) + (notq (% imm0)) + (orq (@ x8664::misc-data-offset (% b0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest))) + (single-value-return 3)) + +(defparameter *simple-bit-boole-functions* ()) + +(setq *simple-bit-boole-functions* + (vector + #'%boole-clr + #'%boole-set + #'%boole-1 + #'%boole-2 + #'%boole-c1 + #'%boole-c2 + #'%boole-and + #'%boole-ior + #'%boole-xor + #'%boole-eqv + #'%boole-nand + #'%boole-nor + #'%boole-andc1 + #'%boole-andc2 + #'%boole-orc1 + #'%boole-orc2)) + +(defun %simple-bit-boole (op b1 b2 result) + (funcall (svref *simple-bit-boole-functions* op) + (ash (the fixnum (+ (length result) 63)) -6) + b1 + b2 + result)) + +(defx86lapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z)) + (check-nargs 3) + (jmp-subprim .SParef2)) + +(defx86lapfunction %aref3 ((array 8) #|(ra 0)|# (i arg_x) (j arg_y) (k arg_z)) + (check-nargs 4) + (pop (% ra0)) + (pop (% temp0)) + (discard-reserved-frame) + (push (% ra0)) + (jmp-subprim .SParef3)) + +(defx86lapfunction %aset2 ((array 8) #|(ra 0)|# (i arg_x) (j arg_y) (newval arg_z)) + (check-nargs 4) + (pop (% ra0)) + (pop (% temp0)) + (discard-reserved-frame) + (push (% ra0)) + (jmp-subprim .SPaset2)) + +(defx86lapfunction %aset3 ((array 16) (i 8) #|(ra 0)|# (j arg_x) (k arg_y) (newval arg_z)) + (check-nargs 5) + (pop (% ra0)) + (pop (% temp0)) + (pop (% temp1)) + (discard-reserved-frame) + (push (% ra0)) + (jmp-subprim .SPaset3)) + +) ; #+x8664-target + Index: /branches/qres/ccl/level-0/X86/x86-clos.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-clos.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-clos.lisp (revision 13564) @@ -0,0 +1,274 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +#+x8664-target +(progn + +;;; It's easier to keep this is LAP; we want to play around with its +;;; constants. + + +;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL. +;;; The map is a vector of (UNSIGNED-BYTE 8); this should +;;; be used when there are fewer than 255 slots in the class. +(defx86lapfunction %small-map-slot-id-lookup ((slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @have-table-index) + (movq (% arg_x) (% imm1)) + (shrq ($ x8664::word-shift) (% imm1)) + (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + @have-table-index + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (single-value-return)) + +;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32). +(defx86lapfunction %large-map-slot-id-lookup ((slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @have-table-index) + (movq (% arg_x) (% imm1)) + (shrq ($ 1) (% imm1)) + (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + @have-table-index + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (movq (% arg_x) (% imm1)) + (shrq ($ x8664::word-shift) (% imm1)) + (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (movq (@ 'class (% fn)) (% arg_x)) + (set-nargs 3) + (jmp (@ '%maybe-std-slot-value-using-class (% fn))) + @missing ; (%slot-id-ref-missing instance id) + (set-nargs 2) + (jmp (@'%slot-id-ref-missing (% fn)))) + +(defx86lapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (movq (% arg_x) (% imm1)) + (shrq ($ 1) (% imm1)) + (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (movq (@ 'class (% fn)) (% arg_x)) + (set-nargs 3) + (jmp (@ '%maybe-std-slot-value-using-class (% fn))) + @missing ; (%slot-id-ref-missing instance id) + (set-nargs 2) + (jmp (@'%slot-id-ref-missing (% fn)))) + + +(defx86lapfunction %small-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index imm1) + (vector-length temp1 imm0) + (rcmpq (% imm1) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (shrq ($ x8664::word-shift) (% rdx)) + (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (popq (% ra0)) + (pushq ($ 0)) ; reserve frame + (pushq ($ 0)) + (pushq (@ 'class (% fn))) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_y)) + (set-nargs 4) + (pushq (% ra0)) + (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn))) + @missing ; (%slot-id-set-missing instance id new-value) + (set-nargs 3) + (jmp (@ '%slot-id-set-missing (% fn)))) + + +(defx86lapfunction %large-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index imm1) + (vector-length temp1 imm0) + (rcmpq (% imm1) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (shrq ($ 1) (% rdx)) + (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (popq (% ra0)) + (pushq ($ 0)) ; reserve frame + (pushq ($ 0)) + (pushq (@ 'class (% fn))) + (pushq (% ra0)) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_y)) + (set-nargs 4) + (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn))) + @missing ; (%slot-id-set-missing instance id new-value) + (set-nargs 3) + (jmp (@'%slot-id-ref-missing (% fn)))) + + +;;; All of the generic function trampoline functions have to be +;;; exactly the same size (x8664::gf-code-size) in words. The +;;; largest of these - the general-case *GF-PROTO* - is currently +;;; "really" a little under 15 words, so X8664::GF-CODE-SIZE is +;;; just a little bigger than that. +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (x86-lap-function + gag + () + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) + (movq (@ (% rsp)) (% ra0)) + (save-frame-variable-arg-count) + (push-argregs) + (pushq (%q nargs)) + (movq (% rsp) (% arg_z)) + (ref-global.l ret1valaddr imm0) + (cmpq (% ra0) (% imm0)) + (je @multiple) + (ref-global.l lexpr-return1v ra0) + (jmp @call) + @multiple + (pushq (@ (+ (target-nil-value) (x8664::%kernel-global 'lexpr-return)))) + (movq (% imm0) (% ra0)) + @call + (push (% ra0)) + (movq (@ 'dispatch-table (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn))) ; dcode function + )))) + +;;; is a winner - saves ~15% +(defx86lapfunction gag-one-arg ((arg arg_z)) + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) + (check-nargs 1) + (movq (@ 'dispatch-table (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn)))) + +(defx86lapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z)) + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) + (check-nargs 2) + (movq (@ 'dispatch-table (% fn)) (% arg_x)) + (set-nargs 3) + (jmp (@ 'dcode (% fn)))) + + +(defx86lapfunction funcallable-trampoline () + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + (jmp (@ 'dcode (% fn)))) + + +;;; This is in LAP so that it can reference itself in the error message. +;;; (It needs to be cloned, so %fn will be unique to each copy.) +;;; It can't work for this to reference any of its own constants. +(defx86lapfunction unset-fin-trampoline () + (:code-size x8664::gf-code-size) + (save-frame-variable-arg-count) + (call-subprim .SPheap-rest-arg) + (pop (% arg_z)) + (movq ($ '#.$XNOFINFUNCTION) (% arg_x)) + (movq (% fn) (% arg_y)) + (set-nargs 3) + (call-subprim .SPksignalerr) + ;(movq ($ (target-nil-value)) (% arg_z)) + (leave) + (single-value-return)) + + + +(defparameter *cm-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (x86-lap-function + gag + () + (:fixed-constants (thing dcode gf bits)) + (movq (@ (% rsp)) (% ra0)) + (save-frame-variable-arg-count) + (push-argregs) + (pushq (%q nargs)) + (movq (% rsp) (% arg_z)) + (ref-global ret1valaddr imm0) + (cmpq (% ra0) (% imm0)) + (je @multiple) + (ref-global lexpr-return1v ra0) + (jmp @call) + @multiple + (pushq (@ (+ (target-nil-value) (x8664::%kernel-global 'lexpr-return)))) + (movq (% imm0) (% ra0)) + @call + (push (% ra0)) + (movq (@ 'thing (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn))))))) + + + + +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-def.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-def.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-def.lisp (revision 13564) @@ -0,0 +1,736 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(defx86lapfunction %function-vector-to-function ((arg arg_z)) + (trap-unless-typecode= arg x8664::subtag-function) + (addb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %function-to-function-vector ((arg arg_z)) + (trap-unless-fulltag= arg x8664::fulltag-function) + (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %function-code-words ((fun arg_z)) + (trap-unless-fulltag= fun x8664::fulltag-function) + (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %nth-immediate ((fun arg_y) (n arg_z)) + (trap-unless-fulltag= fun x8664::fulltag-function) + (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l)) + (lea (@ (% n) (% imm0) 8) (% imm0)) + (movq (@ (- x8664::node-size x8664::fulltag-function) (% fun) (% imm0)) + (% arg_z)) + (single-value-return)) + +(defx86lapfunction %set-nth-immediate ((fun arg_x) (n arg_y) (new arg_z)) + (trap-unless-fulltag= fun x8664::fulltag-function) + (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l)) + (lea (@ (% n) (% imm0) 8) (% arg_y)) + (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (%b arg_x)) + (jmp-subprim .SPgvset)) + +(defx86lapfunction %function-code-byte ((fun arg_y) (pc arg_z)) + (unbox-fixnum pc imm0) + (movzbl (@ (% fun) (% imm0)) (% imm0.l)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +;;; Returns 3 values: mask of registers used in the function, stack location +;;; from which they'd be restored, relative PC at which they're saved. If +;;; the mask is 0, the values NIL NIL NIL are returned. If either the stack +;;; location or relative PC is #xff, both of those values will be returned +;;; as NIL. +(defx86lapfunction %function-register-usage ((f arg_z)) + (check-nargs 1) + (trap-unless-fulltag= f x8664::fulltag-function) + (movzbl (@ -1 (% f)) (% imm0.l)) + (shll ($ 8) (% imm0.l)) + (box-fixnum imm0 arg_x) + (movq (% rsp) (% temp0)) + (set-nargs 3) + (je @no-regs) + (movzbl (@ -2 (% f)) (% imm0.l)) + (movzbl (@ -3 (% f)) (% imm1.l)) + (cmpb ($ #xff) (% imm0.b)) + (je @unencodable) + (cmpb ($ #xff) (% imm1.b)) + (je @unencodable) + (box-fixnum imm0 arg_y) + (box-fixnum imm1 arg_z) + (push (% arg_x)) + (push (% arg_y)) + (push (% arg_z)) + (jmp-subprim .SPvalues) + @unencodable + (push (% arg_x)) + (pushq ($ nil)) + (pushq ($ nil)) + (jmp-subprim .SPvalues) + @no-regs + (pushq ($ nil)) + (pushq ($ nil)) + (pushq ($ nil)) + (jmp-subprim .SPvalues)) + + + +(defx86lapfunction %make-code-executable ((codev arg_z)) + (single-value-return)) + +;;; Make a new function, with PROTO's code and the specified immediates. +;;; IMMEDIATES should contain lfun-bits as the last element. +(defun %clone-x86-function (proto &rest immediates) + (declare (dynamic-extent immediates)) + (let* ((protov (%function-to-function-vector proto)) + (code-words (%function-code-words proto)) + (numimms (length immediates)) + (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms))))) + (declare (fixnum code-words numimms)) + (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) + (do* ((k code-words (1+ k)) + (imms immediates (cdr imms))) + ((null imms) (%function-vector-to-function newv)) + (declare (fixnum k) (list imms)) + (setf (%svref newv k) (car imms))))) + +(defun %copy-function (proto &optional target) + (let* ((protov (%function-to-function-vector proto)) + (code-words (%function-code-words proto)) + (total-words (uvsize protov)) + (newv (if target + (%function-to-function-vector target) + (allocate-typed-vector :function total-words)))) + (declare (fixnum code-words total-words)) + (when target + (unless (and (eql code-words (%function-code-words target)) + (eql total-words (uvsize newv))) + (error "Wrong size target ~s" target))) + (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) + (loop for k fixnum from code-words below total-words + do (setf (%svref newv k) (%svref protov k))) + (%function-vector-to-function newv))) + +(defun replace-function-code (target proto) + (let* ((target-words (%function-code-words target)) + (proto-words (%function-code-words proto))) + (declare (fixnum target-words proto-words)) + (if (= target-words proto-words) + (progn + (%copy-ivector-to-ivector (%function-to-function-vector proto) + 0 + (%function-to-function-vector target) + 0 + (the fixnum (ash target-words + target::word-shift))) + target) + (error "Code size mismatch: target = ~s, proto = ~s" + target-words proto-words)))) + + +(defx86lapfunction %get-kernel-global-from-offset ((offset arg_z)) + (check-nargs 1) + (unbox-fixnum offset imm0) + (movq (@ (target-nil-value) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z)) + (check-nargs 2) + (unbox-fixnum offset imm0) + (movq (% arg_z) (@ (target-nil-value) (% imm0))) + (single-value-return)) + + +(defx86lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y) + (ptr arg_z)) + (check-nargs 2) + (unbox-fixnum offset imm0) + (movq (@ (target-nil-value) (% imm0)) (% imm0)) + (movq (% imm0) (@ x8664::macptr.address (% ptr))) + (single-value-return)) + + + + +(defx86lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z)) + (:arglist (fixnum &optional offset)) + (check-nargs 1 2) + (cmpl ($ x8664::fixnumone) (% nargs)) + (jne @2-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @2-args + (unbox-fixnum offset imm0) + (movq (@ (% fixnum) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (:arglist (fixnum &optional offset)) + (check-nargs 1 2) + (cmpl ($ x8664::fixnumone) (% nargs)) + (jne @2-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @2-args + (unbox-fixnum offset imm0) + (movq (@ (% fixnum) (% imm0)) (% imm0)) + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (:arglist (fixnum offset &optional newval)) + (check-nargs 2 3) + (cmpl ($ '2) (% nargs)) + (jne @3-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @3-args + (unbox-fixnum offset imm0) + (movq (% new-value) (@ (% fixnum) (% imm0))) + (movq (% new-value) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (:arglist (fixnum offset &optional newval)) + (check-nargs 2 3) + (save-simple-frame) + (cmpl ($ '2) (% nargs)) + (jne @3-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @3-args + (call-subprim .SPgetu64) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% fixnum) (% imm1))) + (restore-simple-frame) + (single-value-return)) + + +(defx86lapfunction %current-frame-ptr () + (check-nargs 0) + (movq (% rbp) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %current-tsp () + (check-nargs 0) + (movq (:rcontext x8664::tcr.save-tsp) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %%frame-backlink ((p arg_z)) + (check-nargs 1) + (movq (@ (% arg_z)) (% arg_z)) + (single-value-return)) + +;;; Look for "lea -nnnn(%rip),%fn" AT the tra; if that's present, use +;;; the dispacement -nnnn to find the function. The end of the +;;; encoded displacement is +;;; x8664::recover-fn-from-rip-disp-offset (= 7) bytes from the tra. +(defx86lapfunction %return-address-function ((r arg_z)) + (extract-lisptag r imm0) + (cmpb ($ x8664::tag-tra) (% imm0.b)) + (jne @fail) + (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r))) + (jne @fail) + (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r))) + (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0)) + (jne @fail) + (lea (@ x8664::recover-fn-from-rip-length (% imm0) (% r)) (% arg_z)) + (single-value-return) + @fail + (movl ($ (target-nil-value)) (% arg_z.l)) + (single-value-return)) + +(defx86lapfunction %return-address-offset ((r arg_z)) + (extract-lisptag r imm0) + (cmpb ($ x8664::tag-tra) (% imm0.b)) + (jne @fail) + (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r))) + (jne @fail) + (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r))) + (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0)) + (jne @fail) + (negq (% imm0)) + (leaq (@ (- (ash x8664::recover-fn-from-rip-length x8664::fixnumshift)) (% imm0) 8) (% arg_z)) + (single-value-return) + @fail + (movl ($ (target-nil-value)) (% arg_z.l)) + (single-value-return)) + +;;; It's always been the case that the function associated with a +;;; frame pointer is the caller of the function that "uses" that frame. +(defun %cfp-lfun (p) + (let* ((ra (%fixnum-ref p x8664::lisp-frame.return-address))) + (if (eq ra (%get-kernel-global ret1valaddr)) + (setq ra (%fixnum-ref p x8664::lisp-frame.xtra))) + (values (%return-address-function ra) (%return-address-offset ra)))) + + + +(defx86lapfunction %uvector-data-fixnum ((uv arg_z)) + (check-nargs 1) + (trap-unless-fulltag= arg_z x8664::fulltag-misc) + (addq ($ x8664::misc-data-offset) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %catch-top ((tcr arg_z)) + (check-nargs 1) + (movl ($ (target-nil-value)) (%l arg_y)) + (movq (:rcontext x8664::tcr.catch-top) (% arg_z)) + (testb (%b arg_z) (%b arg_z)) + (cmoveq (% arg_y) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %catch-tsp ((catch arg_z)) + (check-nargs 1) + (lea (@ (- (+ target::fulltag-misc + (ash 1 (1+ target::word-shift)))) (% arg_z)) + (% arg_z)) + (single-value-return)) + + + +;;; Same as %address-of, but doesn't cons any bignums +;;; It also left shift fixnums just like everything else. +(defx86lapfunction %fixnum-address-of ((x arg_z)) + (check-nargs 1) + (box-fixnum x arg_z) + (single-value-return)) + +(defx86lapfunction %save-standard-binding-list ((bindings arg_z)) + (movq (:rcontext x8664::tcr.vs-area) (% imm0)) + (movq (@ x8664::area.high (% imm0)) (% imm1)) + (subq ($ x8664::node-size) (% imm1)) + (movq (% bindings) (@ (% imm1))) + (single-value-return)) + +(defx86lapfunction %saved-bindings-address () + (movq (:rcontext x8664::tcr.vs-area) (% imm0)) + (movq (@ x8664::area.high (% imm0)) (% imm1)) + (lea (@ (- x8664::node-size) (% imm1)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %get-object ((macptr arg_y) (offset arg_z)) + (check-nargs 2) + (trap-unless-typecode= macptr x8664::subtag-macptr) + (macptr-ptr macptr imm0) + (trap-unless-lisptag= offset target::tag-fixnum imm1) + (unbox-fixnum offset imm1) + (movq (@ (% imm0) (% imm1)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z)) + (check-nargs 3) + (trap-unless-typecode= macptr target::subtag-macptr) + (macptr-ptr macptr imm0) + (trap-unless-lisptag= offset target::tag-fixnum imm1) + (unbox-fixnum offset imm1) + (movq (% arg_z) (@ (% imm0) (% imm1))) + (single-value-return)) + +(defx86lapfunction %apply-lexpr-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in x8664::next-method-context (= x8664::temp0). + ;; Put function in x8664::xfn until we're ready to jump to it. + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves x866::xfn/x8664::next-method-context. + ;; Jump to the function in x8664::xfn. + (popq (% ra0)) + (movq (% magic) (% next-method-context)) + (movq (% function) (% xfn)) + (set-nargs 0) + (movq (@ (% args)) (% imm0)) ;lexpr-count + (movl (%l imm0) (% nargs)) + (leaq (@ x8664::node-size (% arg_z) (% imm0)) (% imm1)) + (subl ($ '3) (% imm0)) + (jbe @reg-only) + ;; Some args will be pushed; reserve a frame + (pushq ($ x8664::reserved-frame-marker)) + (pushq ($ x8664::reserved-frame-marker)) + @pushloop + (pushq (@ (- x8664::node-size) (% imm1))) + (subq ($ x8664::node-size) (% imm1)) + (subq ($ x8664::node-size) (% imm0)) + (jne @pushloop) + @three + (movq (@ (* x8664::node-size 3) (% arg_z)) (% arg_x)) + @two + (movq (@ (* x8664::node-size 2) (% arg_z)) (% arg_y)) + @one + (movq (@ (* x8664::node-size 1) (% arg_z)) (% arg_z)) + (jmp @go) + @reg-only + (testl (% nargs) (% nargs)) + (je @go) + (rcmpl (% nargs) ($ '2)) + (je @two) + (jb @one) + (jmp @three) + @go + (push (% ra0)) + (jmp (% xfn))) + +(defx86lapfunction %apply-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in x8664::next-method-context (= x8664::temp0). + ;; Put function in x8664::xfn (= x8664::temp1). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves x8664::xfn/x8664::next-method-context. + ;; Jump to the function in x8664::xfn. + (pop (% ra0)) + (movq (% magic) (% x8664::next-method-context)) + (movq (% function) (% x8664::xfn)) + (movq (% args) (% arg_y)) ; in case of error + (set-nargs 0) + (xorl (% imm0.l) (% imm0.l)) + (push (% imm0)) ; reserve frame (might discard + (push (% imm0)) ; it if nothing is passed on stack.) + (cmp-reg-to-nil arg_z) + (je @done) + @loop + (extract-fulltag arg_z imm1) + (cmpb ($ x8664::fulltag-cons) (%b imm1)) + (jne @bad) + (%car arg_z arg_x) + (%cdr arg_z arg_z) + (lea (@ x8664::node-size (% imm0)) (% imm0)) + (cmp-reg-to-nil arg_z) + (push (% arg_x)) + (jne @loop) + @done + (addl (%l imm0) (% nargs)) + (jne @pop) + @discard-and-go + (discard-reserved-frame) + (jmp @go) + @pop + (cmpl($ '1) (% nargs)) + (pop (% arg_z)) + (je @discard-and-go) + (cmpl ($ '2) (% nargs)) + (pop (% arg_y)) + (je @discard-and-go) + (cmpl ($ '3) (% nargs)) + (pop (% arg_x)) + (je @discard-and-go) + @go + (push (% ra0)) + (jmp (% xfn)) + @bad + (addq (% imm0) (% rsp)) + (movq (% arg_y) (% arg_z)) + (movq ($ (ash $XNOSPREAD x8664::fixnumshift)) (% arg_y)) + (set-nargs 2) + (jmp-subprim .SPksignalerr)) + + +;;; The idea here is to call METHOD in the same stack frame in +;;; which the lexpr was originally called. The lexpr can't +;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE +;;; must have been tail-called, and the frame built on lexpr +;;; entry must be in %rbp. +(defx86lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z)) + (addq ($ x8664::node-size) (% rsp)) ; discard extra return address + (movq (% method) (% xfn)) + (movq (% args) (% rsp)) + (pop (%q nargs)) + (movq (@ x8664::lisp-frame.return-address (% rbp)) (% ra0)) + (movq (@ 0 (% rbp)) (% rbp)) + (rcmpl (% nargs) ($ '3)) + (jbe @pop-regs) + ;; More than 3 args; some must have been pushed by caller, + ;; so retain the reserved frame. + (pop (% arg_z)) + (pop (% arg_y)) + (pop (% arg_x)) + (jmp @popped) + @pop-regs + (je @pop3) + (rcmpl (% nargs) ($ '1)) + (jb @discard) + (ja @pop2) + (pop (% arg_z)) + (jmp @discard) + @pop3 + (pop (% arg_z)) + (pop (% arg_y)) + (pop (% arg_x)) + (jmp @discard) + @pop2 + (pop (% arg_z)) + (pop (% arg_y)) + @discard + (discard-reserved-frame) + @popped + (push (% ra0)) + (jmp (% xfn))) + + + +(defun closure-function (fun) + (while (and (functionp fun) (not (compiled-function-p fun))) + (setq fun (%nth-immediate fun 0)) + (when (vectorp fun) + (setq fun (svref fun 0)))) + fun) + +;;; For use by (setf (apply ...) ...) +;;; (apply+ f butlast last) = (apply f (append butlast (list last))) + +(defun apply+ (&lap function arg1 arg2 &rest other-args) + (x86-lap-function apply+ () + (:arglist (function arg1 arg2 &rest other-args)) + (check-nargs 3 nil) + (cmpl ($ '3) (% nargs)) + (pop (% ra0)) + (ja @no-frame) + (pushq ($ x8664::reserved-frame-marker)) + (pushq ($ x8664::reserved-frame-marker)) +@no-frame + (push (% arg_x)) + (movq (% arg_z) (% temp0)) ; last + (movq (% arg_y) (% arg_z)) ; butlast + (subl ($ '2) (% nargs)) ; remove count for butlast & last + ;; Do .SPspreadargz inline here + (xorl (%l imm0) (%l imm0)) + (movq (% arg_z) (% arg_y)) ; save in case of error + (cmp-reg-to-nil arg_z) + (je @done) + @loop + (extract-fulltag arg_z imm1) + (cmpb ($ x8664::fulltag-cons) (%b imm1)) + (jne @bad) + (%car arg_z arg_x) + (%cdr arg_z arg_z) + (addl ($ '1) (%l imm0)) + (cmp-reg-to-nil arg_z) + (push (% arg_x)) + (jne @loop) + @done + ;; nargs was at least 1 when we started spreading, and can't have gotten + ;; any smaller. + (addl (%l imm0) (% nargs)) + (movq (% temp0) (% arg_z)) + (pop (% arg_y)) + (pop (% arg_x)) + (addl ($ '1) (% nargs)) + (cmpl ($ '3) (% nargs)) + (jne @no-discard) + (discard-reserved-frame) + @no-discard + (load-constant funcall temp0) + (push (% ra0)) + (jmp-subprim .SPfuncall) + @bad ; error spreading list. + (add (% imm0) (% rsp)) ; discard whatever's been pushed + (movq (% arg_y) (% arg_z)) + (movl ($ '#.$XNOSPREAD) (%l arg_y)) + (set-nargs 2) + (jmp-subprim .SPksignalerr) )) + + + +;;; This needs to: +;;; (a) load FP arg regs from the FP-REGS argument +;;; (b) call the .SPffcall subprimitive, which will discard the foreign stack frame +;;; allocated by WITH-VARIABLE-C-FRAME in %FF-CALL +;;; (c) re-establish the same foreign stack frame and store the result regs +;;; (%rax/%xmm0) there +(defx86lapfunction %do-ff-call ((nfp 0) (frame arg_x) (fp-regs arg_y) (entry arg_z)) + (popq (% ra0)) + (popq (% rax)) + (movq (% rbp) (@ (% rsp))) + (movq (% rsp) (% rbp)) + (movq (% ra0) (@ 8 (% rbp))) + (macptr-ptr fp-regs temp0) + (sarq ($ x8664::fixnumshift) (% rax)) + (movq (@ (% temp0)) (% fp0)) + (movq (@ 8 (% temp0)) (% fp1)) + (movq (@ 16 (% temp0)) (% fp2)) + (movq (@ 24 (% temp0)) (% fp3)) + (movq (@ 32 (% temp0)) (% fp4)) + (movq (@ 40 (% temp0)) (% fp5)) + (movq (@ 48 (% temp0)) (% fp6)) + (movq (@ 56 (% temp0)) (% fp7)) + (call-subprim .SPffcall) + (movq (:rcontext x8664::tcr.foreign-sp) (% mm5)) + (movq (% mm5) (@ (% frame))) + (movq (% frame) (:rcontext x8664::tcr.foreign-sp)) + (movq (% rax) (@ 8 (% frame))) + (movq (% fp0) (@ 16 (% frame))) + (movl ($ nil) (%l arg_z)) + (restore-simple-frame) + (single-value-return)) + +(defx86lapfunction %do-ff-call-return-registers ((fp-regs 8)(nfp 0) (frame arg_x) (regbuf arg_y) (entry arg_z)) + (popq (% ra0)) + (popq (% rax)) + (popq (% temp0)) + (movq (% rbp) (@ (% rsp))) + (movq (% rsp) (% rbp)) + (movq (% ra0) (@ 8 (% rbp))) + (macptr-ptr temp0 temp0) + (sarq ($ x8664::fixnumshift) (% rax)) + (movq (@ (% temp0)) (% fp0)) + (movq (@ 8 (% temp0)) (% fp1)) + (movq (@ 16 (% temp0)) (% fp2)) + (movq (@ 24 (% temp0)) (% fp3)) + (movq (@ 32 (% temp0)) (% fp4)) + (movq (@ 40 (% temp0)) (% fp5)) + (movq (@ 48 (% temp0)) (% fp6)) + (movq (@ 56 (% temp0)) (% fp7)) + (call-subprim .SPffcall-return-registers) + (movq (:rcontext x8664::tcr.foreign-sp) (% mm5)) + (movq (% mm5) (@ (% frame))) + (movq (% frame) (:rcontext x8664::tcr.foreign-sp)) + (movl ($ nil) (%l arg_z)) + (restore-simple-frame) + (single-value-return)) + + +(defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0) + (regbuf nil)) + (declare (fixnum len total-words)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (n-fp-args 0)) + (declare (fixnum nargs n-fp-args)) + (ecase result-spec + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :void) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte) + (incf total-words)) + (:registers ) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "unknown arg spec ~s" spec))))) + ;; It's necessary to ensure that the C frame is the youngest thing on + ;; the foreign stack here. + (%stack-block ((fp-args (* 8 8))) + (with-macptrs ((argptr)) + (with-variable-c-frame + total-words frame + (%setf-macptr-to-object argptr frame) + (let* ((gpr-offset 16) + (other-offset (+ gpr-offset (* 6 8)))) + (declare (fixnum gpr-offset other-offset)) + (do* ((i 0 (1+ i)) + (ngpr-args 0) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:address + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (setf (%get-ptr argptr gpr-offset) val) + (incf gpr-offset 8)) + (t + (setf (%get-ptr argptr other-offset) val) + (incf other-offset 8)))) + ((:signed-doubleword :signed-fullword :signed-halfword + :signed-byte) + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (setf (%%get-signed-longlong argptr gpr-offset) val) + (incf gpr-offset 8)) + (t + (setf (%%get-signed-longlong argptr other-offset) val) + (incf other-offset 8)))) + ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword + :unsigned-byte) + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (setf (%%get-unsigned-longlong argptr gpr-offset) val) + (incf gpr-offset 8)) + (t + (setf (%%get-unsigned-longlong argptr other-offset) val) + (incf other-offset 8)))) + (:double-float + (cond ((< n-fp-args 8) + (setf (%get-double-float fp-args (* n-fp-args 8)) val) + (incf n-fp-args)) + (t + (setf (%get-double-float argptr other-offset) val) + (incf other-offset 8)))) + (:single-float + (cond ((< n-fp-args 8) + (setf (%get-single-float fp-args (* n-fp-args 8)) + val) + (incf n-fp-args)) + (t + (setf (%get-single-float argptr other-offset) val) + (incf other-offset 8)))) + (:registers (setq regbuf val)) + (t + (let* ((p 0)) + (declare (fixnum p)) + (dotimes (i (the fixnum spec)) + (setf (%get-ptr argptr other-offset) (%get-ptr val p)) + (incf p 8) + (incf other-offset 8))))))) + (if regbuf + (%do-ff-call-return-registers fp-args (min n-fp-args 8) frame regbuf entry) + (%do-ff-call (min n-fp-args 8) frame fp-args entry)) + (ecase result-spec + (:void nil) + (:address (%get-ptr argptr 8)) + (:unsigned-byte (%get-unsigned-byte argptr 8)) + (:signed-byte (%get-signed-byte argptr 8)) + (:unsigned-halfword (%get-unsigned-word argptr 8)) + (:signed-halfword (%get-signed-word argptr 8)) + (:unsigned-fullword (%get-unsigned-long argptr 8)) + (:signed-fullword (%get-signed-long argptr 8)) + (:unsigned-doubleword (%get-natural argptr 8)) + (:signed-doubleword (%get-signed-natural argptr 8)) + (:single-float (%get-single-float argptr 16)) + (:double-float (%get-double-float argptr 16))))))))))) + + +;;; end of x86-def.lisp +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-float.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-float.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-float.lisp (revision 13564) @@ -0,0 +1,460 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require :number-case-macro)) + + +;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit) +;;; lo - low 28 bits mantissa +;;; exp - take low 11 bits +;;; sign - sign(sign) => result +;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg +;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg +;;; no error checks, no tweaks, no nuthin + +;;; sign is -1, 1, maybe zero + + + +(defx86lapfunction %make-float-from-fixnums ((float 16 )(hi 8) #|(ra 0)|#(lo arg_x) (exp arg_y) (sign arg_z)) + (mov (% sign) (% imm1)) + (sar ($ 63) (% imm1)) + (shl ($ 63) (% imm1)) + (movq (@ hi (% rsp)) (% imm0)) ;hi + (andl ($ (ash (1- (ash 1 24)) x8664::fixnumshift)) (%l imm0)) + (shl ($ (- 28 x8664::fixnumshift)) (% imm0)) + (or (% imm0) (% imm1)) + (unbox-fixnum lo imm0) + (andl ($ (1- (ash 1 28))) (%l imm0)) + (or (% imm0) (% imm1)) + (mov (% exp) (% imm0)) + (shl ($ (- ieee-double-float-exponent-offset x8664::fixnumshift)) (% imm0)) + (or (% imm0) (% imm1)) + (movq (@ float (% rsp)) (% arg_z)) + (mov (% imm1) (@ x8664::double-float.value (% arg_z))) + (single-value-return 4)) + + +;;; Maybe we should trap - or something - on NaNs. +(defx86lapfunction %%double-float-abs! ((n arg_y)(val arg_z)) + (mov (@ x8664::double-float.value (% n)) (% imm0)) + (btr ($ 63) (% imm0)) + (mov (% imm0) (@ x8664::double-float.value (% val))) + (single-value-return)) + + +(defx86lapfunction %short-float-abs ((n arg_z)) + (btr ($ 63) (% n)) + (single-value-return)) + + +(defx86lapfunction %double-float-negate! ((src arg_y) (res arg_z)) + (movq (@ x8664::double-float.value (% src)) (% imm0)) + (btcq ($ 63) (% imm0)) + (movq (% imm0) (@ x8664::double-float.value (% res))) + (single-value-return)) + + +(defx86lapfunction %short-float-negate ((src arg_z)) + (btcq ($ 63) (% arg_z)) + (single-value-return)) + + + +(defx86lapfunction dfloat-significand-zeros ((dfloat arg_z)) + (movq (@ target::double-float.value (% dfloat)) (% imm1)) + (shl ($ (1+ IEEE-double-float-exponent-width)) (% imm1)) + (bsrq (% imm1) (% imm0)) + (xorq ($ (1- target::nbits-in-word)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; This exploits the fact that the single float is already +;;; shifted left 32 bits. We don't want to count the tag +;;; bit as significant, so bash the argument into a fixnum +;;; first. +(defx86lapfunction sfloat-significand-zeros ((sfloat arg_z)) + (xorb (%b sfloat) (%b sfloat)) + (shl ($ (1+ IEEE-single-float-exponent-width)) (% sfloat)) + (bsrq (% sfloat) (% imm0)) + (xorq ($ (1- target::nbits-in-word)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z)) + (unbox-fixnum int imm0) + (get-double-float float fp1) + (shl ($ IEEE-double-float-exponent-offset) (% imm0)) + (movd (% imm0) (% fp2)) + (mulsd (% fp2) (% fp1)) + (put-double-float fp1 result) + (single-value-return)) + +(defx86lapfunction %%scale-sfloat! ((float arg_y)(int arg_z)) + (unbox-fixnum int imm0) + (shl ($ IEEE-double-float-exponent-offset) (% imm0)) + (movd (% imm0) (% fp2)) + (get-single-float float fp1) + (mulss (% fp2) (% fp1)) + (put-single-float fp1 arg_z) + (single-value-return)) + +(defx86lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z)) + (get-double-float f1 fp1) + (put-double-float fp1 f2) + (single-value-return)) + +(defx86lapfunction %short-float->double-float ((src arg_y) (result arg_z)) + (get-single-float src fp1) + (cvtss2sd (% fp1) (% fp1)) + (put-double-float fp1 result) + (single-value-return)) + +(defx86lapfunction %double-float->short-float ((src arg_z)) + (get-double-float src fp1) + (cvtsd2ss (% fp1) (% fp1)) + (put-single-float fp1 arg_z) + (single-value-return)) + +(defx86lapfunction %int-to-sfloat ((int arg_z)) + (int-to-single int imm0 fp1) + (put-single-float fp1 arg_z) + (single-value-return)) + + +(defx86lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z)) + (int-to-double int imm0 fp1) + (put-double-float fp1 arg_z) + (single-value-return)) + + + + +;;; Manipulate the MXCSR. It'll fit in a fixnum, but we have to +;;; load and store it through memory. On x8664, we can hide the +;;; 32-bit MXCSR value in a fixnum on the stack; on a 32-bit x86, +;;; we might need to use a scratch location in the TCR or something. + +;;; Return the MXCSR as a fixnum +(defx86lapfunction %get-mxcsr () + (pushq ($ '0)) + (stmxcsr (@ 4 (% rsp))) + (pop (% arg_z)) + (shr ($ (- 32 x8664::fixnumshift)) (% arg_z)) + (single-value-return)) + +;;; Store the fixnum in arg_z in the MXCSR. Just to be +;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK, +;;; so that only known control and status bits are written to. +(defx86lapfunction %set-mxcsr ((val arg_z)) + (mov (% val) (% temp0)) + (andl ($ '#.x86::mxcsr-write-mask) (%l temp0)) + (shl ($ (- 32 x8664::fixnumshift)) (% temp0)) + (push (% temp0)) + (ldmxcsr (@ 4 (% rsp))) + (add ($ '1) (% rsp)) + (single-value-return)) + + +;;; Get the bits that contain exception masks and rounding mode. + +(defun %get-mxcsr-control () + (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr)))) + +;;; Get the bits that describe current exceptions. +(defun %get-mxcsr-status () + (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr)))) + +;;; Set the bits that describe current exceptions, presumably to clear them. +(defun %set-mxcsr-status (arg) + (%set-mxcsr + (logior (logand x86::mxcsr-status-mask arg) + (logandc2 (%get-mxcsr) x86::mxcsr-status-mask))) + arg) + +;;; Set the bits that mask/unmask exceptions and control rounding. +;;; Clear the bits which describe current exceptions. +(defun %set-mxcsr-control (arg) + (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg))) + +;;; Return the MXCSR value in effect after the last ff-call. +(defx86lapfunction %get-post-ffi-mxcsr () + (xor (% arg_z) (% arg_z)) + (movl (:rcontext x8664::tcr.ffi-exception) (%l imm0)) + (movl (%l arg_z) (:rcontext x8664::tcr.ffi-exception)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; Return the status bits from the last ff-call that represent +;;; unmasked exceptions +(defun %ffi-exception-status () + (logior (%get-mxcsr-control) + (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr))))) + + + + +;;; See if the binary double-float operation OP set any enabled +;;; exception bits in the mxcsr +(defun %df-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + (%copy-double-float op0 (%make-dfloat)) + (%copy-double-float op1 (%make-dfloat))))) + +(defun %sf-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + #+32-bit-target + (%copy-short-float op0 (%make-sfloat)) + #+64-bit-target op0 + #+32-bit-target + (%copy-short-float op1 (%make-sfloat)) + #+64-bit-target op1))) + +(defun %df-check-exception-1 (operation op0 fp-status) + (declare (fixnum fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + (%copy-double-float op0 (%make-dfloat))))) + +(defun %sf-check-exception-1 (operation op0 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + #+32-bit-target + (%copy-short-float op0 (%make-sfloat)) + #+64-bit-target op0))) + + +(defun fp-condition-from-mxcsr (status-bits control-bits) + (declare (fixnum status-bits control-bits)) + (cond + ((and (logbitp x86::mxcsr-ie-bit status-bits) + (not (logbitp x86::mxcsr-im-bit control-bits))) + 'floating-point-invalid-operation) + ((and (logbitp x86::mxcsr-oe-bit status-bits) + (not (logbitp x86::mxcsr-om-bit control-bits))) + 'floating-point-overflow) + ((and (logbitp x86::mxcsr-ue-bit status-bits) + (not (logbitp x86::mxcsr-um-bit control-bits))) + 'floating-point-underflow) + ((and (logbitp x86::mxcsr-ze-bit status-bits) + (not (logbitp x86::mxcsr-zm-bit control-bits))) + 'division-by-zero) + ((and (logbitp x86::mxcsr-pe-bit status-bits) + (not (logbitp x86::mxcsr-pm-bit control-bits))) + 'floating-point-inexact))) + +(defun %fp-error-from-status (status-bits operation op0 &optional op1) + (declare (type (unsigned-byte 6) status-bits)) + (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control)))) + (if condition-class + (let* ((operands (if op1 (list op0 op1) (list op0)))) + (error (make-instance condition-class + :operation operation + :operands operands)))))) + + + +;;; Don't we already have about 20 versions of this ? +(defx86lapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z)) + (macptr-ptr ptr imm0) + (unbox-fixnum byte-offset imm1) + (movsd (@ (% imm0) (% imm1)) (% fp1)) + (put-double-float fp1 dest) + (single-value-return)) + + +(defvar *rounding-mode-alist* + '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3))) + +(defun get-fpu-mode (&optional (mode nil mode-p)) + (let* ((flags (%get-mxcsr-control))) + (declare (fixnum flags)) + (let* ((rounding-mode + (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0) + (if (logbitp x86::mxcsr-rc1-bit flags) 2 0)) + *rounding-mode-alist*))) + (overflow (not (logbitp x86::mxcsr-om-bit flags))) + (underflow (not (logbitp x86::mxcsr-um-bit flags))) + (division-by-zero (not (logbitp x86::mxcsr-zm-bit flags))) + (invalid (not (logbitp x86::mxcsr-im-bit flags))) + (inexact (not (logbitp x86::mxcsr-pm-bit flags)))) + (if mode-p + (ecase mode + (:rounding-mode rounding-mode) + (:overflow overflow) + (:underflow underflow) + (:division-by-zero division-by-zero) + (:invalid invalid) + (:inexact inexact)) + `(:rounding-mode ,rounding-mode + :overflow ,overflow + :underflow ,underflow + :division-by-zero ,division-by-zero + :invalid ,invalid + :inexact ,inexact))))) + +;;; did we document this? +(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p) + (overflow t overflow-p) + (underflow t underflow-p) + (division-by-zero t zero-p) + (invalid t invalid-p) + (inexact t inexact-p)) + (let* ((current (%get-mxcsr-control)) + (new current)) + (declare (fixnum current new)) + (when rounding-p + (let* ((rc-bits (or + (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "Unknown rounding mode: ~s" rounding-mode)))) + (declare (fixnum rc-bits)) + (if (logbitp 0 rc-bits) + (bitsetf x86::mxcsr-rc0-bit new) + (bitclrf x86::mxcsr-rc0-bit new)) + (if (logbitp 1 rc-bits) + (bitsetf x86::mxcsr-rc1-bit new) + (bitclrf x86::mxcsr-rc1-bit new)))) + (when invalid-p + (if invalid + (bitclrf x86::mxcsr-im-bit new) + (bitsetf x86::mxcsr-im-bit new))) + (when overflow-p + (if overflow + (bitclrf x86::mxcsr-om-bit new) + (bitsetf x86::mxcsr-om-bit new))) + (when underflow-p + (if underflow + (bitclrf x86::mxcsr-um-bit new) + (bitsetf x86::mxcsr-um-bit new))) + (when zero-p + (if division-by-zero + (bitclrf x86::mxcsr-zm-bit new) + (bitsetf x86::mxcsr-zm-bit new))) + (when inexact-p + (if inexact + (bitclrf x86::mxcsr-pm-bit new) + (bitsetf x86::mxcsr-pm-bit new))) + (unless (= current new) + (%set-mxcsr-control new)) + (%get-mxcsr))) + + + +;;; Copy a single float pointed at by the macptr in single +;;; to a double float pointed at by the macptr in double + +(defx86lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z)) + (check-nargs 2) + (macptr-ptr single imm0) + (movss (@ (% imm0)) (% fp1)) + (cvtss2sd (% fp1) (% fp1)) + (macptr-ptr double imm0) + (movsd (% fp1) (@ (% imm0))) + (single-value-return)) + +;;; Copy a double float pointed at by the macptr in double +;;; to a single float pointed at by the macptr in single. +(defx86lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z)) + (check-nargs 2) + (macptr-ptr double imm0) + (movsd (@ (% imm0)) (% fp1)) + (cvtsd2ss (% fp1) (% fp1)) + (macptr-ptr single imm0) + (movss (% fp1) (@ (% imm0))) + (single-value-return)) + + +(defx86lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z)) + (check-nargs 2) + (macptr-ptr macptr imm0) + (get-double-float src fp1) + (cvtsd2ss (% fp1) (% fp1)) + (movss (% fp1) (@ (% imm0))) + (single-value-return)) + +(defx86lapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z)) + (shl ($ (- 32 x8664::fixnumshift)) (% arg_z)) + (movb ($ x8664::subtag-single-float) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction single-float-bits ((f arg_z)) + (shr ($ (- 32 x8664::fixnumshift)) (% f)) + (single-value-return)) + +(defun double-float-bits (f) + (values (uvref f target::double-float.val-high-cell) + (uvref f target::double-float.val-low-cell))) + +(defun double-float-from-bits (high low) + (let* ((f (%make-dfloat))) + (setf (uvref f target::double-float.val-high-cell) high + (uvref f target::double-float.val-low-cell) low) + f)) + +;;; Return T if n is negative, else NIL. +(defx86lapfunction %double-float-sign ((n arg_z)) + (movl (@ x8664::double-float.val-high (% n)) (% imm0.l)) + (testl (% imm0.l) (% imm0.l)) + (movl ($ (target-t-value)) (% imm0.l)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (cmovlq (% imm0) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %short-float-sign ((n arg_z)) + (testq (% n) (% n)) + (movl ($ (target-t-value)) (% imm0.l)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (cmovlq (% imm0) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %double-float-sqrt! ((n arg_y) (result arg_z)) + (get-double-float n fp0) + (sqrtsd (% fp0) (% fp0)) + (put-double-float fp0 result) + (single-value-return)) + +(defx86lapfunction %single-float-sqrt ((n arg_z)) + (get-single-float n fp0) + (sqrtss (% fp0) (% fp0)) + (put-single-float fp0 arg_z) + (single-value-return)) + +;;; end of x86-float.lisp +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-hash.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-hash.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-hash.lisp (revision 13564) @@ -0,0 +1,131 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; level-0;ppc;ppc-hash.lisp + + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + + + + +;;; This should stay in LAP so that it's fast +;;; Equivalent to cl:mod when both args are positive fixnums + + +(defx86lapfunction fast-mod ((number arg_y) (divisor arg_z)) + (xorq (% imm1) (% imm1)) + (mov (% number) (% imm0)) + (div (% divisor)) + (mov (% imm1) (% arg_z)) + (single-value-return)) + + +;; Faster mod based on Bruce Hoult's Dylan version, modified to use a branch-free max. +(defx86lapfunction fast-mod-3 ((number arg_x) (divisor arg_y) (recip arg_z)) + (mov (% number) (% imm0)) + (shrq ($ target::fixnumshift) (% imm0)) + (mov (% recip) (% imm1)) + (mul (% imm1)) ;; -> hi word in imm1 (unboxed) + (mov (% divisor) (% imm0)) + (mul (% imm1)) ;; -> lo word in imm0 (boxed) + (subq (% imm0) (% number)) + (subq (% divisor) (% number)) + (mov (% number) (% arg_z)) + (mov (% number) (% imm0)) + (sar ($ (1- target::nbits-in-word)) (% imm0)) + (andq (% imm0) (% divisor)) + (addq (% divisor) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %dfloat-hash ((key arg_z)) + (movq (@ x8664::double-float.value (% key)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %sfloat-hash ((key arg_z)) + (mov (% key) (% imm1)) + (movl ($ #x-80000000) (%l imm0)) + (shr ($ 32) (% imm1)) + (xorq (% arg_y) (% arg_y)) + (shr ($ (- 32 x8664::fixnumshift)) (% key)) + (rcmp (%l imm0) (%l imm1)) + (cmoveq (% arg_y) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %macptr-hash ((key arg_z)) + (movq (@ target::macptr.address (% key)) (% imm0)) + (movq (% imm0) (% imm1)) + (shlq ($ 24) (% imm1)) + (addq (% imm1) (% imm0)) + (movq ($ (lognot target::fixnummask)) (% arg_z)) + (andq (% imm0) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %bignum-hash ((key arg_z)) + (let ((header imm0) + (offset imm1) + (ndigits temp0)) + (getvheader key header) + (header-length header ndigits) + (xorq (% offset) (% offset)) + (let ((immhash header)) + @loop + (rolq ($ 13) (% immhash)) + (addl (@ x8664::misc-data-offset (% key) (% offset)) (%l immhash)) + (addq ($ 4) (% offset)) + (subq ($ '1) (% ndigits)) + (jne @loop) + (box-fixnum immhash arg_z)) + (single-value-return))) + + +(defx86lapfunction %get-fwdnum () + (ref-global target::fwdnum arg_z) + (single-value-return)) + + +(defx86lapfunction %get-gc-count () + (ref-global target::gc-count arg_z) + (single-value-return)) + + +;;; Setting a key in a hash-table vector needs to +;;; ensure that the vector header gets memoized as well +(defx86lapfunction %set-hash-table-vector-key ((vector arg_x) (index arg_y) (value arg_z)) + (jmp-subprim .SPset-hash-key)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defx86lapfunction %set-hash-table-vector-key-conditional ((offset 8) #|(ra 0)|# (vector arg_x) (old arg_y) (new arg_z)) + (movq (@ offset (% rsp)) (% temp0)) + (save-simple-frame) + (call-subprim .SPset-hash-key-conditional) + (restore-simple-frame) + (single-value-return 3)) + +;;; Strip the tag bits to turn x into a fixnum +(defx86lapfunction strip-tag-to-fixnum ((x arg_z)) + (andb ($ (lognot x8664::fixnummask)) (%b x)) + (single-value-return)) + +;;; end of x86-hash.lisp +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-io.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-io.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-io.lisp (revision 13564) @@ -0,0 +1,42 @@ +;;; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") + +;;; not very smart yet + +#+x8664-target +(defx86lapfunction %get-errno () + (movq (:rcontext x8664::tcr.errno-loc) (% imm1)) + (movslq (@ (% imm1)) (% imm0)) + (movss (% fpzero) (@ (% imm1))) + (negq (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +#+x8632-target +(defx8632lapfunction %get-errno () + (movl (:rcontext x8632::tcr.errno-loc) (% imm0)) + (movl (@ (% imm0)) (% imm0)) + (neg (% imm0)) + (box-fixnum imm0 arg_z) + (movl (:rcontext x8632::tcr.errno-loc) (% imm0)) + (movss (% fpzero) (@ (% imm0))) + (single-value-return)) + Index: /branches/qres/ccl/level-0/X86/x86-misc.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-misc.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-misc.lisp (revision 13564) @@ -0,0 +1,926 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; level-0;x86;x86-misc.lisp + + +(in-package "CCL") +#+x8664-target +(progn + +;;; Copy N bytes from pointer src, starting at byte offset src-offset, +;;; to ivector dest, starting at offset dest-offset. +;;; It's fine to leave this in lap. +;;; Depending on alignment, it might make sense to move more than +;;; a byte at a time. +;;; Does no arg checking of any kind. Really. + +(defx86lapfunction %copy-ptr-to-ivector ((src (* 2 x8664::node-size) ) + (src-byte-offset (* 1 x8664::node-size)) + #|(ra 0)|# + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (rsrc-byte-offset temp1)) + (testq (% nbytes) (% nbytes)) + (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset)) ; boxed src-byte-offset + (movq (@ src (% rsp)) (% rsrc)) ; src macptr + (jmp @test) + @loop + (unbox-fixnum rsrc-byte-offset imm0) + (addq ($ '1) (% rsrc-byte-offset)) + (addq (@ x8664::macptr.address (% rsrc)) (% imm0)) + (movb (@ (% imm0)) (%b imm0)) + (unbox-fixnum dest-byte-offset imm1) + (addq ($ '1) (% dest-byte-offset)) + (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1))) + (subq ($ '1) (% nbytes)) + @test + (jne @loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + +(defx86lapfunction %copy-ivector-to-ptr ((src (* 2 x8664::node-size)) + (src-byte-offset (* 1 x8664::node-size)) + #|(ra 0)|# + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (rsrc-byte-offset temp1)) + (testq (% nbytes) (% nbytes)) + (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset)) + (movq (@ src (% rsp)) (% rsrc)) + (jmp @test) + @loop + (unbox-fixnum rsrc-byte-offset imm0) + (addq ($ '1) (% rsrc-byte-offset)) + (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0)) + (unbox-fixnum dest-byte-offset imm1) + (addq ($ '1) (% dest-byte-offset)) + (addq (@ x8664::macptr.address (%q dest)) (% imm1)) + (movb (%b imm0) (@ (% imm1))) + (subq ($ '1) (% nbytes)) + @test + (jne @loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + + +(defun %copy-ivector-to-ivector (src src-byte-offset dest dest-byte-offset nbytes) + (declare (fixnum src-byte-offset dest-byte-offset nbytes)) + (if (or (eq src dest) + (not (eql 0 src-byte-offset)) + (not (eql 0 dest-byte-offset)) + (< nbytes 8)) + (%copy-ivector-to-ivector-bytes src src-byte-offset dest dest-byte-offset nbytes) + (%copy-ivector-to-ivector-words src dest (ash nbytes -3) (logand nbytes 7)))) + +(defx86lapfunction %copy-ivector-to-ivector-words ((src 8) + #|(ra 0)|# + (dest arg_x) + (nwords arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (ridx imm1) + (rval imm0)) + (xorl (%l ridx) (%l ridx)) + (movq (@ src (% rsp)) (% rsrc)) + (jmp @word-test) + @word-loop + (movq (@ x8664::misc-data-offset (% rsrc) (% ridx)) (% rval)) + (movq (% rval) (@ x8664::misc-data-offset (% dest) (% ridx))) + (addq ($ 8) (% ridx)) + @word-test + (cmpq (% ridx) (% nwords)) + (jne @word-loop) + (jmp @byte-test) + @byte-loop + (movb (@ x8664::misc-data-offset (% rsrc) (% ridx)) (%b rval)) + (movb (%b rval) (@ x8664::misc-data-offset (% dest) (% ridx))) + (addq ($ 1) (% ridx)) + @byte-test + (subq ($ '1) (% nbytes)) + (jns @byte-loop) + (movq (% dest) (% arg_z)) + (single-value-return 3))) + + + + +(defx86lapfunction %copy-ivector-to-ivector-bytes ((src-offset 16) + (src-byte-offset 8) + #|(ra 0)|# + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (rsrc-byte-offset temp1)) + (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset)) + (movq (@ src-offset (% rsp)) (% rsrc)) + (cmpq (% dest) (% rsrc)) + (jne @front) + (cmpq (% rsrc-byte-offset) (% dest-byte-offset)) + (jg @back) + @front + (testq (% nbytes) (% nbytes)) + (jmp @front-test) + @front-loop + (unbox-fixnum rsrc-byte-offset imm0) + (addq ($ '1) (% rsrc-byte-offset)) + (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0)) + (unbox-fixnum dest-byte-offset imm1) + (addq ($ '1) (% dest-byte-offset)) + (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1))) + (subq ($ '1) (% nbytes)) + @front-test + (jne @front-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4) + @back + (addq (% nbytes) (% rsrc-byte-offset)) + (addq (% nbytes) (% dest-byte-offset)) + (testq (% nbytes) (% nbytes)) + (jmp @back-test) + @back-loop + (subq ($ '1) (% rsrc-byte-offset)) + (unbox-fixnum rsrc-byte-offset imm0) + (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0)) + (subq ($ '1) (% dest-byte-offset)) + (unbox-fixnum dest-byte-offset imm1) + (subq ($ '1) (% nbytes)) + (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1))) + @back-test + (jne @back-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + + +(defx86lapfunction %copy-gvector-to-gvector ((src (* 2 x8664::node-size)) + (src-element (* 1 x8664::node-size)) + #|(ra 0)|# + (dest arg_x) + (dest-element arg_y) + (nelements arg_z)) + (let ((rsrc temp0) + (rsrc-element imm1) + (val temp1)) + (movq (@ src-element (% rsp)) (% rsrc-element)) + (movq (@ src (% rsp)) (% rsrc)) + (cmpq (% rsrc) (% dest)) + (jne @front) + (rcmp (% rsrc-element) (% dest-element)) + (jl @back) + @front + (testq (% nelements) (% nelements)) + (jmp @front-test) + @front-loop + (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val)) + (addq ($ '1) (% rsrc-element)) + (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element))) + (addq ($ '1) (% dest-element)) + (subq ($ '1) (% nelements)) + @front-test + (jne @front-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4) + @back + (addq (% nelements) (% rsrc-element)) + (addq (% nelements) (% dest-element)) + (testq (% nelements) (% nelements)) + (jmp @back-test) + @back-loop + (subq ($ '1) (% rsrc-element)) + (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val)) + (subq ($ '1) (% dest-element)) + (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element))) + (subq ($ '1) (% nelements)) + @back-test + (jne @back-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + +(defx86lapfunction %heap-bytes-allocated () + (movq (:rcontext x8664::tcr.save-allocptr) (% temp1)) + (movq (:rcontext x8664::tcr.last-allocptr) (% temp0)) + (cmpq ($ -16) (% temp1)) + (movq (:rcontext x8664::tcr.total-bytes-allocated) (% imm0)) + (jz @go) + (movq (% temp0) (% temp2)) + (subq (% temp1) (% temp0)) + (testq (% temp2) (% temp2)) + (jz @go) + (add (% temp0) (% imm0)) + @go + (jmp-subprim .SPmakeu64)) + + +(defx86lapfunction values () + (:arglist (&rest values)) + (save-frame-variable-arg-count) + (push-argregs) + (jmp-subprim .SPnvalret)) + +(defx86lapfunction rdtsc () + (:byte #x0f) ;two-byte rdtsc opcode + (:byte #x31) ;is #x0f #x31 + (shlq ($ 32) (% rdx)) + (orq (% rdx) (% rax)) + (imul ($ (* 2 target::node-size)) (% rax) (% arg_z)) + (shrq ($ 1) (% arg_z)) + (single-value-return)) + +;;; Return all 64 bits of the time-stamp counter as an unsigned integer. +(defx86lapfunction rdtsc64 () + (:byte #x0f) ;two-byte rdtsc opcode + (:byte #x31) ;is #x0f #x31 + (shlq ($ 32) (% rdx)) + (orq (% rdx) (% rax)) + (jmp-subprim .SPmakeu64)) + +;;; It would be nice if (%setf-macptr macptr (ash (the fixnum value) +;;; ash::fixnumshift)) would do this inline. + +(defx86lapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z)) + (check-nargs 2) + (trap-unless-typecode= macptr x8664::subtag-macptr) + (movq (% object) (@ x8664::macptr.address (% macptr))) + (single-value-return)) + +(defx86lapfunction %fixnum-from-macptr ((macptr arg_z)) + (check-nargs 1) + (trap-unless-typecode= arg_z x8664::subtag-macptr) + (movq (@ x8664::macptr.address (% arg_z)) (% imm0)) + (trap-unless-lisptag= imm0 x8664::tag-fixnum imm1) + (movq (% imm0) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (macptr-ptr ptr imm1) + (unbox-fixnum offset imm0) + (movq (@ (% imm1) (% imm0)) (% imm0)) + (jmp-subprim .SPmakeu64)) + + +(defx86lapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (macptr-ptr ptr imm1) + (unbox-fixnum offset imm0) + (movq (@ (% imm1) (% imm0)) (% imm0)) + (jmp-subprim .SPmakes64)) + + + + +(defx86lapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-simple-frame) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (call-subprim .SPgetu64) + (macptr-ptr ptr imm2) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% imm2) (% imm1))) + (restore-simple-frame) + (single-value-return)) + + +(defx86lapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-simple-frame) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (call-subprim .SPgets64) + (macptr-ptr ptr imm2) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% imm2) (% imm1))) + (restore-simple-frame) + (single-value-return)) + +(defx86lapfunction interrupt-level () + (movq (:rcontext x8664::tcr.tlb-pointer) (% imm1)) + (movq (@ x8664::interrupt-level-binding-index (% imm1)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction set-interrupt-level ((new arg_z)) + (movq (:rcontext x8664::tcr.tlb-pointer) (% imm1)) + (trap-unless-fixnum new) + (movq (% new) (@ x8664::interrupt-level-binding-index (% imm1))) + (single-value-return)) + +(defx86lapfunction %current-tcr () + (movq (:rcontext x8664::tcr.linear) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %tcr-toplevel-function ((tcr arg_z)) + (check-nargs 1) + (cmpq (% tcr) (:rcontext x8664::tcr.linear)) + (movq (% rsp) (% imm0)) + (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0)) + (movq (@ x8664::area.high (% temp0)) (% imm1)) + (jz @room) + (movq (@ x8664::area.active (% temp0)) (% imm0)) + @room + (cmpq (% imm1) (% imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovneq (@ (- x8664::node-size) (% imm1)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z)) + (check-nargs 2) + (cmpq (% tcr) (:rcontext x8664::tcr.linear)) + (movq (% rsp) (% imm0)) + (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0)) + (movq (@ x8664::area.high (% temp0)) (% imm1)) + (jz @room) + (movq (@ x8664::area.active (% temp0)) (% imm0)) + @room + (cmpq (% imm1) (% imm0)) + (leaq (@ (- x8664::node-size) (% imm1)) (% imm1)) + (movq ($ 0) (@ (% imm1))) + (jne @have-room) + (movq (% imm1) (@ x8664::area.active (% temp0))) + (movq (% imm1) (@ x8664::tcr.save-vsp (% tcr))) + @have-room + (movq (% fun) (@ (% imm1))) + (single-value-return)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defx86lapfunction %store-node-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z)) + (movq (@ offset (% rsp)) (% temp0)) + (save-simple-frame) + (call-subprim .SPstore-node-conditional) + (restore-simple-frame) + (single-value-return 3)) + +(defx86lapfunction %store-immediate-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z)) + (movq (@ offset (% rsp)) (% temp0)) + (unbox-fixnum temp0 imm1) + @again + (movq (@ (% object) (% imm1)) (% rax)) + (cmpq (% rax) (% old)) + (jne @lose) + (lock) + (cmpxchgq (% new) (@ (% object) (% imm1))) + (jne @again) + (movl ($ (target-t-value)) (%l arg_z)) + (single-value-return 3) + @lose + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return 3)) + +(defx86lapfunction set-%gcable-macptrs% ((ptr x8664::arg_z)) + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers))) + (% rax)) + (movq (% rax) (@ x8664::xmacptr.link (% ptr))) + (lock) + (cmpxchgq (% ptr) (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers)))) + (jne @again) + (single-value-return)) + +;;; Atomically increment or decrement the gc-inhibit-count kernel-global +;;; (It's decremented if it's currently negative, incremented otherwise.) +(defx86lapfunction %lock-gc-lock () + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count))) (% rax)) + (lea (@ '-1 (% rax)) (% temp0)) + (lea (@ '1 (% rax)) (% arg_z)) + (testq (% rax) (% rax)) + (cmovsq (% temp0) (% arg_z)) + (lock) + (cmpxchgq (% arg_z) (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count)))) + (jnz @again) + (single-value-return)) + +;;; Atomically decrement or increment the gc-inhibit-count kernel-global +;;; (It's incremented if it's currently negative, incremented otherwise.) +;;; If it's incremented from -1 to 0, try to GC (maybe just a little.) +(defx86lapfunction %unlock-gc-lock () + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count))) + (% rax)) + (lea (@ '1 (% rax)) (% arg_x)) + (cmpq ($ -1) (% rax)) + (lea (@ '-1 (% rax)) (% arg_z)) + (cmovleq (% arg_x) (% arg_z)) + (lock) + (cmpxchgq (% arg_z) (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count)))) + (jne @again) + (cmpq ($ '-1) (% rax)) + (jne @done) + ;; The GC tried to run while it was inhibited. Unless something else + ;; has just inhibited it, it should be possible to GC now. + (mov ($ arch::gc-trap-function-immediate-gc) (% imm0)) + (uuo-gc-trap) + @done + (single-value-return)) + +;;; Return true iff we were able to increment a non-negative +;;; lock._value + + + + +(defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) + (check-nargs 3) + (unbox-fixnum disp imm1) + @again + (movq (@ (% node) (% imm1)) (% rax)) + (lea (@ (% rax) (% by)) (% arg_z)) + (lock) + (cmpxchgq (% arg_z) (@ (% node) (% imm1))) + (jne @again) + (single-value-return)) + +(defx86lapfunction %atomic-incf-ptr ((ptr arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (lea (@ 1 (% rax)) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jne @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + +(defx86lapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (unbox-fixnum by imm1) + (add (% rax) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jnz @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + + +(defx86lapfunction %atomic-decf-ptr ((ptr arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (lea (@ -1 (% rax)) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jnz @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + +(defx86lapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (testq (% rax) (% rax)) + (lea (@ -1 (% rax)) (% imm1)) + (jz @done) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jnz @again) + @done + (box-fixnum imm1 arg_z) + (single-value-return)) + + +(defx86lapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z)) + (macptr-ptr arg_y imm1) + (unbox-fixnum newval imm0) + (lock) + (xchgq (% imm0) (@ (% imm1))) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value +;;; was equal to OLDVAL. Return the old value +(defx86lapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% imm0)) + (box-fixnum imm0 temp0) + (cmpq (% temp0) (% expected-oldval)) + (jne @done) + (unbox-fixnum newval imm1) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jne @again) + @done + (movq (% temp0) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (let ((address imm1)) + (macptr-ptr ptr address) + @again + (movq (@ (% address)) (% imm0)) + (cmpq (% imm0) (% expected-oldval)) + (jne @done) + (lock) + (cmpxchgq (% newval) (@ (% address))) + (jne @again) + @done + (movq (% imm0) (% arg_z)) + (single-value-return))) + +(defx86lapfunction xchgl ((newval arg_y) (ptr arg_z)) + (unbox-fixnum newval imm0) + (macptr-ptr ptr imm1) + (lock) ; implicit ? + (xchgl (% imm0.l) (@ (% imm1))) + (box-fixnum imm0 arg_z) + (single-value-return)) + + + + +(defx86lapfunction %macptr->dead-macptr ((macptr arg_z)) + (check-nargs 1) + (movb ($ x8664::subtag-dead-macptr) (@ x8664::misc-subtag-offset (% macptr))) + (single-value-return)) + + + + + +(defx86lapfunction %%save-application ((flags arg_y) (fd arg_z)) + (unbox-fixnum flags imm0) + (orq ($ arch::gc-trap-function-save-application) (% imm0)) + (unbox-fixnum fd imm1) + (uuo-gc-trap) + (single-value-return)) + + + +(defx86lapfunction %misc-address-fixnum ((misc-object arg_z)) + (check-nargs 1) + (lea (@ x8664::misc-data-offset (% misc-object)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z)) + (check-nargs 3) + (macptr-ptr ptr imm1) ; address in macptr + (lea (@ 17 (% imm1)) (% imm0)) ; 2 for delta + 15 for alignment + (andb ($ -16) (%b imm0)) ; Clear low four bits to align + (subq (% imm0) (% imm1)) ; imm1 = -delta + (negw (%w imm1)) + (movw (%w imm1) (@ -2 (% imm0))) ; save delta halfword + (unbox-fixnum subtype imm1) ; subtype at low end of imm1 + (shlq ($ (- x8664::num-subtag-bits x8664::fixnum-shift)) (% len )) + (orq (% len) (% imm1)) + (movq (% imm1) (@ (% imm0))) ; store subtype & length + (lea (@ x8664::fulltag-misc (% imm0)) (% arg_z)) ; tag it, return it + (single-value-return)) + +(defx86lapfunction %%make-disposable ((ptr arg_y) (vector arg_z)) + (check-nargs 2) + (lea (@ (- x8664::fulltag-misc) (% vector)) (% imm0)) ; imm0 is addr = vect less tag + (movzwq (@ -2 (% imm0)) (% imm1)) ; get delta + (subq (% imm1) (% imm0)) ; vector addr (less tag) - delta is orig addr + (movq (% imm0) (@ x8664::macptr.address (% ptr))) + (single-value-return)) + + +(defx86lapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + (lea (@ x8664::misc-data-offset (% vect)) (% imm0)) + (movq (% imm0) (@ x8664::macptr.address (% ptr))) + (single-value-return)) + +(defx86lapfunction get-saved-register-values () + (movq (% rsp) (% temp0)) + (push (% save0)) + (push (% save1)) + (push (% save2)) + (push (% save3)) ; this'd be the TCR on Win64. + (set-nargs 4) + (jmp-subprim .SPvalues)) + + +(defx86lapfunction %current-db-link () + (movq (:rcontext x8664::tcr.db-link) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %no-thread-local-binding-marker () + (movq ($ x8664::subtag-no-thread-local-binding) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction pending-user-interrupt () + (xorq (% imm0) (% imm0)) + (ref-global x8664::intflag arg_z) + ;; If another signal happens now, it will get ignored, same as if it happened + ;; before whatever signal is in arg_z. But then these are async signals, so + ;; who can be sure it didn't actually happen just before... + (set-global imm0 x8664::intflag) + (single-value-return)) + + +(defx86lapfunction debug-trap-with-string ((arg arg_z)) + (check-nargs 1) + (uuo-error-debug-trap-with-string) + (single-value-return)) + +(defx86lapfunction %safe-get-ptr ((src arg_y) (dest arg_z)) + (check-nargs 2) + (save-simple-frame) + (macptr-ptr src imm0) + (leaq (@ (:^ done) (% fn)) (% ra0)) + (movq (% imm0) (:rcontext x8664::tcr.safe-ref-address)) + (movq (@ (% imm0)) (% imm0)) + (jmp done) + (:tra done) + (recover-fn-from-rip) + (movq ($ 0) (:rcontext x8664::tcr.safe-ref-address)) + (movq (% imm0) (@ x8664::macptr.address (% dest))) + (restore-simple-frame) + (single-value-return)) + +;;; This was intentded to work around a bug in #_nanosleep in early +;;; Leopard test releases. It's probably not necessary any more; is +;;; it still called ? + +(defx86lapfunction %check-deferred-gc () + (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (:rcontext x8664::tcr.flags)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (jae @done) + (ud2a) + (:byte 3) + (movl ($ (target-t-value)) (% arg_z.l)) + @done + (single-value-return)) + +(defx86lapfunction %%tcr-interrupt ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 4) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %suspend-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 5) + (movzbl (%b imm0) (%l imm0)) + (testl (%l imm0) (%l imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %suspend-other-threads () + (check-nargs 0) + (ud2a) + (:byte 6) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %resume-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 7) + (movzbl (%b imm0) (%l imm0)) + (testl (%l imm0) (%l imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %resume-other-threads () + (check-nargs 0) + (ud2a) + (:byte 8) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %kill-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 9) + (testb (%b imm0) (%b imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + + +(defx86lapfunction %get-spin-lock ((p arg_z)) + (check-nargs 1) + (save-simple-frame) + @again + (macptr-ptr arg_z imm1) + (movq (@ '*spin-lock-tries* (% fn)) (% temp0)) + (movq (@ '*spin-lock-timeouts* (% fn)) (% temp1)) + (movq (@ target::symbol.vcell (% temp0)) (% temp0)) + (movq (:rcontext x8664::tcr.linear) (% arg_y)) + @try-swap + (xorq (% rax) (% rax)) + (lock) + (cmpxchgq (% arg_y) (@ (% imm1))) + (je @done) + @spin + (pause) + (cmpq ($ 0) (@ (% imm1))) + (je @try-swap) + (subq ($ '1) (% temp0)) + (jne @spin) + @wait + (addq ($ x8664::fixnumone) (@ x8664::symbol.vcell (% temp1))) + (pushq (% arg_z)) + (call-symbol yield 0) + (popq (% arg_z)) + (jmp @again) + @done + (restore-simple-frame) + (single-value-return)) + +;;; This is a prototype; it can't easily keep its arguments on the stack, +;;; or in registers, because its job involves unwinding the stack and +;;; restoring registers. Its parameters are thus kept in constants, +;;; and this protoype is cloned (with the right parameters). + +;;; For win64 (which doesn't really have a "save3" register), the code +;;; which instantiates this should always set save3-offset to 0. +(defx86lapfunction %%apply-in-frame-proto () + (:fixed-constants (target-frame target-catch target-db-link target-xcf target-tsp target-foreign-sp save0-offset save1-offset save2-offset save3-offset function args)) + (check-nargs 0) + ;;(uuo-error-debug-trap) + (movq (@ 'target-catch (% fn)) (% temp0)) + (xorl (%l imm0) (%l imm0)) + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (movq (:rcontext target::tcr.catch-top) (% arg_z)) + (jz @did-catch) + @find-catch + (testq (% arg_z) (% arg_z)) + (jz @did-catch) ; never found target catch + (addq ($ '1) (% imm0)) + (cmpq (% temp0) (% arg_z)) + (je @found-catch) + (movq (@ target::catch-frame.link (% arg_z)) (% arg_z)) + (jmp @find-catch) + @found-catch + (set-nargs 0) ; redundant, but ... + (lea (@ (:^ @back-from-nthrow) (% fn)) (% ra0)) + (:talign 4) + (jmp-subprim .SPnthrowvalues) + @back-from-nthrow + (recover-fn-from-rip) + @did-catch + ;; Restore special bindings + (movq (@ 'target-db-link (% fn)) (% imm0)) + (cmpb ($ x8664::fulltag-nil) (%b imm0)) + (jz @no-unbind) + (call-subprim .SPunbind-to) + @no-unbind + ;; If there's at least one exception frame between the target + ;; frame and the last catch (or the point of departure), restore + ;; the NVRs and foreign sp from the oldest such frame + (movq (@ 'target-xcf (% fn)) (% arg_z)) + (cmpb ($ x8664::fulltag-nil) (%b arg_z)) + (jz @no-xcf) + (movq (@ target::xcf.xp (% arg_z)) (% arg_y)) + ;; arg_y points to a "portable" ucontext. Find the platform-specifc + ;; "gpr vector" in the uc_mcontext, load the NVRs and stack/frame + ;; pointer from there. + #+linuxx8664-target + (progn + (addq ($ gp-regs-offset) (% arg_y)) + (movq (@ (* #$REG_R15 8) (% arg_y)) (% r15)) + (movq (@ (* #$REG_R14 8) (% arg_y)) (% r14)) + (movq (@ (* #$REG_R12 8) (% arg_y)) (% r12)) + (movq (@ (* #$REG_R11 8) (% arg_y)) (% r11)) + (movq (@ (* #$REG_RBP 8) (% arg_y)) (% rbp)) + (movq (@ (* #$REG_RSP 8) (% arg_y)) (% rsp))) + #+freebsdx8664-target + (progn + ;; If you think that this is ugly, just wait until you see the Darwin + ;; version. + (addq ($ gp-regs-offset) (% arg_y)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r15)) -3) (% arg_y)) (% r15)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r14)) -3) (% arg_y)) (% r14)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r12)) -3) (% arg_y)) (% r12)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r11)) -3) (% arg_y)) (% r11)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rbp)) -3) (% arg_y)) (% rbp)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rsp)) -3) (% arg_y)) (% rsp))) + #+darwinx8664-target + (progn + ;; Yes, this is ugly. + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_ucontext)) :uc_mcontext)) -3) (% arg_y)) (% arg_y)) + (addq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_mcontext64)) :__ss)) -3)) (% arg_y)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r15)) -3) (% arg_y)) (% r15)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r14)) -3) (% arg_y)) (% r14)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r12)) -3) (% arg_y)) (% r12)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r11)) -3) (% arg_y)) (% r11)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rbp)) -3) (% arg_y)) (% rbp)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rsp)) -3) (% arg_y)) (% rsp))) + ;; This is our best (possibly only) chance to get + ;; the foreign sp right. + (movq (@ target::xcf.prev-xframe (% arg_z)) (% temp0)) + (movq (@ target::xcf.foreign-sp (% arg_z)) (% imm0)) + (movq (% temp0) (:rcontext target::tcr.xframe)) + (movq (% imm0) (:rcontext target::tcr.foreign-sp)) + ;; All done processing the xcf. NVRs may have been + ;; saved between the last catch/last xcf and the + ;; target frame. The save-n-offset parameter/constants + ;; are either 0 or negative offsets from the target frame + ;; of the stack location where the corresponding GPR + ;; was saved. + @no-xcf + (movq (@ 'target-tsp (% fn)) (% imm0)) + (cmpb ($ x8664::fulltag-nil) (%b imm0)) + (movq (@ 'target-foreign-sp (% fn)) (% temp0)) + (je @no-tsp) + (movq (% imm0) (:rcontext target::tcr.save-tsp)) + (movq (% imm0) (:rcontext target::tcr.next-tsp)) + @no-tsp + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (je @no-sp) + (movq (% temp0) (:rcontext target::tcr.foreign-sp)) + @no-sp + (movq (@ 'target-frame (% fn)) (% rbp)) + (movq (@ 'save0-offset (% fn)) (% arg_x)) + (movq (@ 'save1-offset (% fn)) (% arg_y)) + (movq (@ 'save2-offset (% fn)) (% arg_z)) + (movq (@ 'save3-offset (% fn)) (% temp0)) + (testq (% arg_x) (% arg_x)) + (cmovneq (@ (% rbp) (% arg_x)) (% save0)) + (testq (% arg_y) (% arg_y)) + (cmovneq (@ (% rbp) (% arg_x)) (% save1)) + (testq (% arg_z) (% arg_z)) + (cmovneq (@ (% rbp) (% arg_x)) (% save2)) + (testq (% temp0) (% temp0)) + (cmovneq (@ (% rbp) (% arg_x)) (% save3)) + (leave) + (pop (% temp0)) ; return address, not used by subprim + (set-nargs 0) + (movq (@ 'args (% fn)) (% arg_z)) + (lea (@ (:^ @back-from-spread) (% fn)) (% ra0)) + (:talign 4) + (jmp-subprim .SPspreadargz) + @back-from-spread + (recover-fn-from-rip) ; .SPspreadargz preserves %fn, but ... + (push (% temp0)) ; return address + (jmp (@ 'function (% fn)))) + + +(defx86lapfunction %atomic-pop-static-cons () + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global static-conses))) (% rax)) + (cmpq ($ (target-nil-value)) (% rax)) + (jz @lose) + (%cdr rax temp0) + (lock) + (cmpxchgq (% temp0) (@ (+ (target-nil-value) (x8664::kernel-global static-conses)))) + (jnz @again) + @lose + (movq (% rax) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %augment-static-conses ((head arg_y) (tail arg_z)) + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global static-conses))) (% rax)) + (movq (% rax) (@ target::cons.cdr (% tail))) + (lock) + (cmpxchgq (% head) (@ (+ (target-nil-value) (x8664::kernel-global static-conses)))) + (jnz @again) + @lose + (movl ($ (target-nil-value)) (% arg_z.l)) + (single-value-return)) + +(defx86lapfunction %staticp ((x arg_z)) + (check-nargs 1) + (ref-global tenured-area temp0) + (movq (% x) (% imm0)) + (subq (@ target::area.low (% temp0)) (% imm0)) + (shrq ($ target::dnode-shift) (% imm0)) + (cmpq (@ target::area.static-dnodes (% temp0)) (% imm0)) + (leaq (@ (% imm0) target::fixnumone) (% arg_z)) + (movl ($ (target-nil-value)) (%l imm0)) + (cmovaeq (% imm0) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %static-inverse-cons ((n arg_z)) + (check-nargs 1) + (ref-global tenured-area temp0) + (movq (@ target::area.low (% temp0)) (% imm0)) + (leaq (@ target::fulltag-cons (% imm0) (% n) 2) (% arg_z)) + (single-value-return)) + + + + +;;; end of x86-misc.lisp +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-numbers.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-numbers.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-numbers.lisp (revision 13564) @@ -0,0 +1,303 @@ +;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") +#+x8664-target +(progn + + + +(defx86lapfunction %fixnum-signum ((number arg_z)) + (movq ($ '-1) (% arg_x)) + (movq ($ '1) (% arg_y)) + (testq (% number) (% number)) + (cmovsq (% arg_x) (% arg_z)) + (cmovnsq (% arg_y) (% arg_z)) + (single-value-return)) + +;;; see %logcount. +(defx86lapfunction %ilogcount ((number arg_z)) + (let ((rshift imm0) + (temp imm1)) + (unbox-fixnum number rshift) + (xorq (% arg_z) (% arg_z)) + (testq (% rshift) (% rshift)) + (jmp @test) + @next + (lea (@ -1 (% rshift)) (% temp)) + (and (% temp) (% rshift)) ; sets flags + (lea (@ '1 (% arg_z)) (% arg_z)) ; doesn't set flags + @test + (jne @next) + (single-value-return))) + +(defx86lapfunction %iash ((number arg_y) (count arg_z)) + (unbox-fixnum count imm1) + (unbox-fixnum number imm0) + (xorq (% rcx) (% rcx)) ;rcx = imm2 + (testq (% count) (% count)) + (jge @left) + (subb (% imm1.b) (% cl)) + (sar (% cl) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return) + @left + (movb (% imm1.b) (% cl)) + (shl (% cl) (% number)) + (movq (% number) (% arg_z)) + (single-value-return)) + +(defparameter *double-float-zero* 0.0d0) +(defparameter *short-float-zero* 0.0s0) + + +(defx86lapfunction %fixnum-intlen ((number arg_z)) + (unbox-fixnum arg_z imm0) + (movq (% imm0) (% imm1)) + (notq (% imm1)) + (testq (% imm0) (% imm0)) + (cmovsq (% imm1) (% imm0)) + (bsrq (% imm0) (% imm0)) + (setne (% imm1.b)) + (addb (% imm1.b) (% imm0.b)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +;;; Caller guarantees that result fits in a fixnum. + +(defx86lapfunction %truncate-double-float->fixnum ((arg arg_z)) + (get-double-float arg fp1) + (cvttsd2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +(defx86lapfunction %truncate-short-float->fixnum ((arg arg_z)) + (get-single-float arg fp1) + (cvttss2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; DOES round to even + +(defx86lapfunction %round-nearest-double-float->fixnum ((arg arg_z)) + (get-double-float arg fp1) + (cvtsd2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +(defx86lapfunction %round-nearest-short-float->fixnum ((arg arg_z)) + (get-single-float arg fp1) + (cvtss2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + + +;;; We'll get a SIGFPE if divisor is 0. +;;; Don't use %rbp. Trust callback_for_interrupt() to preserve +;;; the word below the stack pointer +(defx86lapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (save-simple-frame) + (cmpq ($ '-1) (% divisor)) + (je @neg) + (unbox-fixnum divisor imm0) + (movq (% imm0) (% imm2)) + (unbox-fixnum dividend imm0) + (cqto) ; imm1 := sign_extend(imm0) + (idivq (% imm2)) + (pop (% rbp)) + (movq (% rsp) (% temp0)) + (box-fixnum imm1 arg_y) + (box-fixnum imm0 arg_z) + (pushq (% arg_z)) + (pushq (% arg_y)) + (set-nargs 2) + (jmp-subprim .SPvalues) + @neg + (negq (% dividend)) + (load-constant *least-positive-bignum* arg_z) + (cmovoq (@ x8664::symbol.vcell (% arg_z)) (% dividend)) + (pop (% rbp)) + (movq (% rsp) (% temp0)) + (pushq (% dividend)) + (pushq ($ 0)) + (set-nargs 2) + (jmp-subprim .SPvalues)) + + +(defx86lapfunction called-for-mv-p () + (ref-global ret1valaddr imm0) + (movq (@ x8664::lisp-frame.return-address (% rbp)) (% imm1)) + (cmpq (% imm0) (% imm1)) + (movq ($ t) (% imm0)) + (movq ($ nil) (% arg_z)) + (cmoveq (% imm0) (% arg_z)) + (single-value-return)) + + +;;; n1 and n2 must be positive (esp non zero) +(defx86lapfunction %fixnum-gcd ((boxed-u arg_y) (boxed-v arg_z)) + (let ((u imm0) + (v imm1) + (k imm2)) + (xorl (% imm2.l) (% imm2.l)) + (bsfq (% boxed-u) (% u)) + (bsfq (% boxed-v) (% v)) + (rcmp (% u) (% v)) + (cmovlel (%l u) (%l k)) + (cmovgl (%l v) (%l k)) + (unbox-fixnum boxed-u u) + (unbox-fixnum boxed-v v) + (subb ($ x8664::fixnumshift) (%b k)) + (jz @start) + (shrq (% cl) (% u)) + (shrq (% cl) (% v)) + @start + ;; At least one of u or v is odd at this point + @loop + ;; if u is even, shift it right one bit + (testb ($ 1) (%b u)) + (jne @u-odd) + (shrq ($ 1) (% u)) + (jmp @test) + @u-odd + ;; if v is even, shift it right one bit + (testb ($ 1) (%b v)) + (jne @both-odd) + (shrq ($ 1) (% v)) + (jmp @test-u) + @both-odd + (cmpq (% v) (% u)) + (jb @v>u) + (subq (% v) (% u)) + (shrq ($ 1) (% u)) + (jmp @test) + @v>u + (subq (% u) (% v)) + (shrq ($ 1) (% v)) + @test-u + (testq (% u) (% u)) + @test + (ja @loop) + (shlq (% cl) (% v)) + (movb ($ 0) (% cl)) + (box-fixnum v arg_z) + (single-value-return))) + +(defx86lapfunction %mrg31k3p ((state arg_z)) + (let ((seed temp0) + (m1 #x7fffffff) + (m2 #x7fffadb3) + (negative-m1 #x80000001) + (negative-m2 #x8000524d)) + (svref state 1 seed) + (movl (@ (+ x8664::misc-data-offset (* 4 1)) (% seed)) (% imm0.l)) + (andl ($ #x1ff) (% imm0.l)) + (shll ($ 22) (% imm0.l)) + (movl (@ (+ x8664::misc-data-offset (* 4 1)) (% seed)) (% imm1.l)) + (shrl ($ 9) (% imm1.l)) + (addl (% imm1.l) (% imm0.l)) + + (movl (@ (+ x8664::misc-data-offset (* 4 2)) (% seed)) (% imm1.l)) + (andl ($ #xffffff) (% imm1.l)) + (shll ($ 7) (% imm1.l)) + (addl (% imm1.l) (% imm0.l)) + (movl (@ (+ x8664::misc-data-offset (* 4 2)) (% seed)) (% imm1.l)) + (shrl ($ 24) (% imm1.l)) + + (addl (% imm1.l) (% imm0.l)) + (leal (@ negative-m1 (% imm0.l)) (% imm1.l)) + (cmpl ($ m1) (% imm0.l)) + (cmovael (% imm1.l) (% imm0.l)) + + (addl (@ (+ x8664::misc-data-offset (* 4 2)) (% seed)) (% imm0.l)) + (leal (@ negative-m1 (% imm0.l)) (% imm1.l)) + (cmpl ($ m1) (% imm0.l)) + (cmovael (% imm1.l) (% imm0.l)) + + ;; update state + (movl (@ (+ x8664::misc-data-offset (* 4 1)) (% seed)) (% imm1.l)) + (movl (% imm1.l) (@ (+ x8664::misc-data-offset (* 4 2)) (% seed))) + (movl (@ (+ x8664::misc-data-offset (* 4 0)) (% seed)) (% imm1.l)) + (movl (% imm1.l) (@ (+ x8664::misc-data-offset (* 4 1)) (% seed))) + (movl (% imm0.l) (@ (+ x8664::misc-data-offset (* 4 0)) (% seed))) + + ;; second component + (movl (@ (+ x8664::misc-data-offset (* 4 3)) (% seed)) (% imm0.l)) + (andl ($ #xffff) (% imm0.l)) + (shll ($ 15) (% imm0.l)) + (movl (@ (+ x8664::misc-data-offset (* 4 3)) (% seed)) (% imm1.l)) + (shrl ($ 16) (% imm1.l)) + (imull ($ 21069) (% imm1.l) (% imm1.l)) + + (addl (% imm1.l) (% imm0.l)) + (leal (@ negative-m2 (% imm0.l)) (% imm1.l)) + (cmpl ($ m2) (% imm0.l)) + (cmovael (% imm1.l) (% imm0.l)) + + (movl (% imm0.l) (% imm2.l)) ;stash t1 + + (movl (@ (+ x8664::misc-data-offset (* 4 5)) (% seed)) (% imm0.l)) + (andl ($ #xffff) (% imm0.l)) + (shll ($ 15) (% imm0.l)) + (movl (@ (+ x8664::misc-data-offset (* 4 5)) (% seed)) (% imm1.l)) + (shrl ($ 16) (% imm1.l)) + (imull ($ 21069) (% imm1.l) (% imm1.l)) + + (addl (% imm1.l) (% imm0.l)) + (leal (@ negative-m2 (% imm0.l)) (% imm1.l)) + (cmpl ($ m2) (% imm0.l)) + (cmovael (% imm1.l) (% imm0.l)) + + (addl (@ (+ x8664::misc-data-offset (* 4 5)) (% seed)) (% imm0.l)) + (leal (@ negative-m2 (% imm0.l)) (% imm1.l)) + (cmpl ($ m2) (% imm0.l)) + (cmovael (% imm1.l) (% imm0.l)) + + (addl (% imm2.l) (% imm0.l)) ;add in t1 + (leal (@ negative-m2 (% imm0.l)) (% imm1.l)) + (cmpl ($ m2) (% imm0.l)) + (cmovael (% imm1.l) (% imm0.l)) + + ;; update state + (movl (@ (+ x8664::misc-data-offset (* 4 4)) (% seed)) (% imm1.l)) + (movl (% imm1.l) (@ (+ x8664::misc-data-offset (* 4 5)) (% seed))) + (movl (@ (+ x8664::misc-data-offset (* 4 3)) (% seed)) (% imm1.l)) + (movl (% imm1.l) (@ (+ x8664::misc-data-offset (* 4 4)) (% seed))) + (movl (% imm0.l) (@ (+ x8664::misc-data-offset (* 4 3)) (% seed))) + + ;; combination + (movl (@ (+ x8664::misc-data-offset (* 4 0)) (% seed)) (% imm1.l)) + (xchgl (% imm1.l) (% imm0.l)) ;for sanity + (rcmpl (% imm0.l) (% imm1.l)) + (ja @ok) + (subl (% imm1.l) (% imm0.l)) + (addl ($ m1) (% imm0.l)) + (box-fixnum imm0 arg_z) + (single-value-return) + @ok + (subl (% imm1.l) (% imm0.l)) + (box-fixnum imm0 arg_z) + (single-value-return))) + +;;; End of x86-numbers.lisp +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-pred.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-pred.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-pred.lisp (revision 13564) @@ -0,0 +1,191 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "X86-LAPMACROS")) + + +(defx86lapfunction eql ((x arg_y) (y arg_z)) + "Return T if OBJ1 and OBJ2 represent either the same object or +numbers with the same type and value." + (check-nargs 2) + @top + @tail + (cmpq (% x) (% y)) + (je @win) + (extract-fulltag x imm0) + (extract-fulltag y imm1) + (cmpb (% imm0.b) (% imm1.b)) + (jnz @lose) + (cmpb ($ x8664::fulltag-misc) (% imm0.b)) + (jnz @lose) + (getvheader x imm0) + (getvheader y imm1) + (cmpb ($ x8664::subtag-macptr) (% imm0.b)) + (je @macptr) ; will need to check %imm1.b + (cmpq (% imm0) (% imm1)) + (jne @lose) + (cmpb ($ x8664::subtag-bignum) (% imm0.b)) + (je @bignum) + (cmpb ($ x8664::subtag-double-float) (% imm0.b)) + (je @double-float) + (cmpb ($ x8664::subtag-complex) (% imm0.b)) + (je @complex) + (cmpb ($ x8664::subtag-ratio) (% imm0.b)) + (je @ratio) + @lose + (movq ($ nil) (% arg_z)) + (single-value-return) + @macptr + (cmpb ($ x8664::subtag-macptr) (% imm1.b)) + (jne @lose) + @double-float + (movq (@ x8664::misc-data-offset (% x)) (% imm0)) + (movq (@ x8664::misc-data-offset (% y)) (% imm1)) + @test + (cmpq (% imm0) (% imm1)) + (movl ($ (target-t-value)) (%l imm0)) + (lea (@ (- x8664::t-offset) (% imm0)) (% arg_z)) + (cmovel (%l imm0) (%l arg_z)) + (single-value-return) + @win + (movq ($ t) (% arg_z)) + (single-value-return) + @ratio + @complex + (save-simple-frame) + (pushq (@ x8664::ratio.denom (% x))) ; aka complex.imagpart + (pushq (@ x8664::ratio.denom (% y))) + (movq (@ x8664::ratio.numer (% x)) (% x)) ; aka complex.realpart + (movq (@ x8664::ratio.numer (% y)) (% y)) ; aka complex.realpart + (:talign 3) + (call @top) + (recover-fn-from-rip) + (cmp-reg-to-nil arg_z) + (pop (% y)) + (pop (% x)) + (restore-simple-frame) + (jnz @tail) + ;; lose, again + (movq ($ nil) (% arg_z)) + (single-value-return) + @bignum + ;; Way back when, we got x's header into imm0. We know that y's + ;; header is identical. Use the element-count from imm0 to control + ;; the loop. There's no such thing as a 0-element bignum, so the + ;; loop must always execute at least once. + (header-length imm0 temp0) + (xorq (% imm1) (% imm1)) + @bignum-next + (movl (@ x8664::misc-data-offset (% x) (% imm1)) (% imm0.l)) + (cmpl (@ x8664::misc-data-offset (% y) (% imm1)) (% imm0.l)) + (jne @lose) + (addq ($ 4) (% imm1)) + (sub ($ '1) (% temp0)) + (jnz @bignum-next) + (movq ($ t) (% arg_z)) + (single-value-return)) + + + +(defx86lapfunction equal ((x arg_y) (y arg_z)) + "Return T if X and Y are EQL or if they are structured components + whose elements are EQUAL. Strings and bit-vectors are EQUAL if they + are the same length and have identical components. Other arrays must be + EQ to be EQUAL. Pathnames are EQUAL if their components are." + (check-nargs 2) + @top + @tail + (cmpq (% x) (% y)) + (je @win) + (extract-fulltag x imm0) + (extract-fulltag y imm1) + (cmpb (% imm0.b) (% imm1.b)) + (jne @lose) + (cmpb ($ x8664::fulltag-cons) (% imm0.b)) + (je @cons) + (cmpb ($ x8664::fulltag-misc) (% imm0.b)) + (je @misc) + @lose + (movq ($ nil) (% arg_z)) + (single-value-return) + @win + (movq ($ t) (% arg_z)) + (single-value-return) + @cons + ;; Check to see if the CARs are EQ. If so, we can avoid saving + ;; context, and can just tail call ourselves on the CDRs. + (%car x temp0) + (%car y temp1) + (cmpq (% temp0) (% temp1)) + (jne @recurse) + (%cdr x x) + (%cdr y y) + (jmp @tail) + @recurse + (save-simple-frame) + (pushq (@ x8664::cons.cdr (% x))) + (pushq (@ x8664::cons.cdr (% y))) + (movq (% temp0) (% x)) + (movq (% temp1) (% y)) + (:talign 4) + (call @top) + (recover-fn-from-rip) + (cmp-reg-to-nil arg_z) + (pop (% y)) + (pop (% x)) + (restore-simple-frame) + (jnz @top) + (movl ($ nil) (% arg_z.l)) + (single-value-return) + @misc + ;; Both objects are uvectors of some sort. Try EQL; if that fails, + ;; call HAIRY-EQUAL. + (save-simple-frame) + (pushq (% x)) + (pushq (% y)) + (call-symbol eql 2) + (cmp-reg-to-nil arg_z) + (jne @won-with-eql) + (popq (% y)) + (popq (% x)) + (restore-simple-frame) + (jump-symbol hairy-equal 2) + @won-with-eql + (restore-simple-frame) ; discards pushed args + (movl ($ t) (% arg_z.l)) + (single-value-return)) + +(defx86lapfunction %lisp-lowbyte-ref ((thing arg_z)) + (box-fixnum thing arg_z) + (andl ($ '#xff) (%l arg_z)) + (single-value-return)) + + + + + + + + + + +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-symbol.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-symbol.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-symbol.lisp (revision 13564) @@ -0,0 +1,166 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "X8664-ARCH") + (require "X86-LAPMACROS")) + +;;; This assumes that macros & special-operators +;;; have something that's not FUNCTIONP in their +;;; function-cells. It also assumes that NIL +;;; isn't a true symbol, but that NILSYM is. +(defx86lapfunction %function ((sym arg_z)) + (check-nargs 1) + (let ((symaddr temp0)) + (movq ($ (+ (target-nil-value) x8664::nilsym-offset)) (% symaddr)) + (cmp-reg-to-nil sym) + (cmovneq (% sym) (% symaddr)) + (trap-unless-fulltag= symaddr x8664::fulltag-symbol) + (movq (% sym) (% arg_y)) + (movq (@ x8664::symbol.fcell (% symaddr)) (% arg_z)) + (extract-fulltag arg_z imm0) + (cmpb ($ x8664::fulltag-function) (%b imm0)) + (je.pt @ok) + (uuo-error-udf (% arg_y)) + @ok + (single-value-return))) + +;;; Traps unless sym is NIL or some other symbol. If NIL, return +;;; nilsym +(defx86lapfunction %symbol->symptr ((sym arg_z)) + (let ((tag imm0)) + (movq ($ (+ (target-nil-value) x8664::nilsym-offset)) (% tag)) + (cmp-reg-to-nil sym) + (cmoveq (% tag) (% sym)) + (je :done) + (trap-unless-fulltag= sym x8664::fulltag-symbol) + :done + (single-value-return))) + +;;; If symptr is NILSYM, return NIL; else typecheck and return symptr +(defx86lapfunction %symptr->symbol ((symptr arg_z)) + (movw ($ (ash 1 x8664::fulltag-symbol)) (% imm0.w)) + (btw (%w symptr) (% imm0.w)) + (jb.pt @ok) + (uuo-error-reg-not-tag (% symptr) ($ x8664::fulltag-symbol)) + @ok + (cmpq ($ (+ (target-nil-value) x8664::nilsym-offset)) (% symptr)) + (sete (% imm0.b)) + (negb (% imm0.b)) + (andl ($ x8664::nilsym-offset) (% imm0.l)) + (subq (% imm0) (% symptr)) + (single-value-return)) + + +;;; Given something whose fulltag is FULLTAG-SYMBOL, return the +;;; underlying uvector. This function and its inverse would +;;; be good candidates for inlining. +(defx86lapfunction %symptr->symvector ((symptr arg_z)) + (subb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %symvector->symptr ((symbol-vector arg_z)) + (addb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %symptr-value ((symptr arg_z)) + (jmp-subprim .SPspecref)) + +(defx86lapfunction %set-symptr-value ((symptr arg_y) (val arg_z)) + (jmp-subprim .SPspecset)) + +;;; This gets a tagged symbol as an argument. +;;; If there's no thread-local binding, it should return +;;; the underlying symbol vector as a first return value. +(defx86lapfunction %symptr-binding-address ((symptr arg_z)) + (movq (@ x8664::symbol.binding-index (% symptr)) (% arg_y)) + (rcmp (% arg_y) (:rcontext x8664::tcr.tlb-limit)) + (movq (:rcontext x8664::tcr.tlb-pointer) (% arg_x)) + (jae @sym) + (cmpb ($ x8664::no-thread-local-binding-marker) (@ (% arg_x) (% arg_y))) + (je @sym) + (shl ($ x8664::word-shift) (% arg_y)) + (push (% arg_x)) + (push (% arg_y)) + (set-nargs 2) + (lea (@ '2 (% rsp)) (% temp0)) + (jmp-subprim .SPvalues) + @sym + (subb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b)) + (push (% arg_z)) + (pushq ($ '#.x8664::symptr.vcell)) + (set-nargs 2) + (lea (@ '2 (% rsp)) (% temp0)) + (jmp-subprim .SPvalues)) + +(defx86lapfunction %tcr-binding-location ((tcr arg_y) (sym arg_z)) + (movq (@ x8664::symbol.binding-index (% sym)) (% arg_x)) + (movl ($ nil) (% arg_z.l)) + (rcmp (% arg_x) (@ x8664::tcr.tlb-limit (% tcr))) + (movq (@ x8664::tcr.tlb-pointer (% tcr)) (% arg_y)) + (jae @done) + (lea (@ (% arg_y) (% arg_x)) (% arg_y)) + ;; We're little-endian, so the tag is at the EA with no + ;; displacement + (cmpb ($ x8664::subtag-no-thread-local-binding) (@ (% arg_y))) + (cmovneq (% arg_y) (% arg_z)) + @done + (single-value-return)) + + +(defx86lapfunction %pname-hash ((str arg_y) (len arg_z)) + (let ((accum imm0) + (offset imm1)) + (xorq (% offset) (% offset)) + (xorq (% accum) (% accum)) + (testq (% len) (% len)) + (jz @done) + @loop8 + (roll ($ 5) (%l accum)) + (xorl (@ x8664::misc-data-offset (% str) (% offset) 4) (%l accum)) + (addq ($ 1) (% offset)) + (subq ($ '1) (% len)) + (jnz @loop8) + (shlq ($ 5) (% accum)) + (shrq ($ (- 5 x8664::fixnumshift)) (% accum)) + (movq (% accum) (% arg_z)) + @done + (single-value-return))) + +(defx86lapfunction %string-hash ((start arg_x) (str arg_y) (len arg_z)) + (let ((accum imm0) + (offset imm1)) + (unbox-fixnum start offset) + (xorq (% accum) (% accum)) + (testq (% len) (% len)) + (jz @done) + @loop8 + (roll ($ 5) (%l accum)) + (xorl (@ x8664::misc-data-offset (% str) (% offset) 4) (%l accum)) + (addq ($ 1) (% offset)) + (subq ($ '1) (% len)) + (jnz @loop8) + (shlq ($ 5) (% accum)) + (shrq ($ (- 5 x8664::fixnumshift)) (% accum)) + (movq (% accum) (% arg_z)) + @done + (single-value-return))) +) ; #+x8664-target Index: /branches/qres/ccl/level-0/X86/x86-utils.lisp =================================================================== --- /branches/qres/ccl/level-0/X86/x86-utils.lisp (revision 13564) +++ /branches/qres/ccl/level-0/X86/x86-utils.lisp (revision 13564) @@ -0,0 +1,541 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") +#+x8664-target +(progn + +(defx86lapfunction %address-of ((arg arg_z)) + ;; %address-of a fixnum is a fixnum, just for spite. + ;; %address-of anything else is the address of that thing as an integer. + (testb ($ x8664::fixnummask) (%b arg)) + (je @done) + (movq (% arg) (% imm0)) + (jmp-subprim .SPmakeu64) + @done + (single-value-return)) + +;;; "areas" are fixnum-tagged and, for the most part, so are their +;;; contents. + +;;; The nilreg-relative global all-areas is a doubly-linked-list header +;;; that describes nothing. Its successor describes the current/active +;;; dynamic heap. Return a fixnum which "points to" that area, after +;;; ensuring that the "active" pointers associated with the current thread's +;;; stacks are correct. + + + +(defx86lapfunction %normalize-areas () + (let ((address temp0) + (temp temp1)) + + ; update active pointer for tsp area. + (movq (:rcontext x8664::tcr.ts-area) (% address)) + (movq (:rcontext x8664::tcr.save-tsp) (% temp)) + (movq (% temp) (@ x8664::area.active (% address))) + + ;; Update active pointer for vsp area. + (movq (:rcontext x8664::tcr.vs-area) (% address)) + (movq (% rsp) (@ x8664::area.active (% address))) + + (ref-global all-areas arg_z) + (movq (@ x8664::area.succ (% arg_z)) (% arg_z)) + + (single-value-return))) + +(defx86lapfunction %active-dynamic-area () + (ref-global all-areas arg_z) + (movq (@ x8664::area.succ (% arg_z)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %object-in-stack-area-p ((object arg_y) (area arg_z)) + (movq (@ x8664::area.active (% area)) (% imm0)) + (movq (@ x8664::area.high (% area)) (% imm1)) + (rcmp (% object) (% imm0)) + (movq ($ nil) (% arg_z)) + (movq ($ t) (% imm0)) + (jb @done) + (rcmp (% object) (% imm1)) + (cmovbq (% imm0) (% arg_z)) + @done + (single-value-return)) + +(defx86lapfunction %object-in-heap-area-p ((object arg_y) (area arg_z)) + (rcmp (% object) (@ x8664::area.low (% area))) + (setae (%b imm0)) + (rcmp (% object) (@ x8664::area.low (% area))) + (setb (%b imm1)) + (andb (% imm1.b) (% imm0.b)) + (andl ($ x8664::t-offset) (%l imm0)) + (lea (@ (target-nil-value) (% imm0)) (% arg_z)) + (single-value-return)) + + + + +(defx86lapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2)) + (save-simple-frame) + (push (% fun)) + (push (% obj)) + (push (% limit)) + (movq (% f) (% fun)) + (movq (@ x8664::area.active (% a)) (% limit)) + (movq (@ x8664::area.low (% a)) (% obj)) + (jmp @test) + @loop + (movb (@ (% obj)) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b)) + (jne @cons) + @misc + (lea (@ x8664::fulltag-misc (% obj)) (% obj)) + (movq (% obj) (% arg_z)) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (getvheader obj imm1) + (movb (% imm1.b) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @64) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @64) + (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b)) + (jne @not64) + @64 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ x8664::word-shift) (% imm1)) + (jmp @uvector-next) + @not64 + (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b)) + (jne @not32) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 2) (% imm1)) + (jmp @uvector-next) + @not32 + (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b)) + (jne @not-bit) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (addq ($ 7) (% imm1)) + (shrq ($ 3) (% imm1)) + (jmp @uvector-next) + @not-bit + (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256))) + (jb @16) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (jmp @uvector-next) + @16 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 1) (% imm1)) + (jmp @uvector-next) + @cons + (addq ($ x8664::fulltag-cons) (% obj)) + (movq (% obj) (% arg_z)) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj)) + (jmp @test) + ;; size of OBJ in bytes (without header or alignment padding) + ;; in imm1. + @uvector-next + (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1)) + (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b)) + (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj)) + @test + (cmpq (% limit) (% obj)) + (jb @loop) + (pop (% limit)) + (pop (% obj)) + (pop (% fun)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (restore-simple-frame) + (single-value-return))) + + + +;;; This walks the active "dynamic" area. Objects might be moving around +;;; while we're doing this, so we have to be a lot more careful than we +;;; are when walking a static area. +;;; There are a couple of approaches to termination: +;;; a) Allocate a "sentinel" cons, and terminate when we run into it. +;;; b) Check the area limit (which is changing if we're consing) and +;;; terminate when we hit it. +;;; (b) loses if the function conses. (a) conses. I can't think of anything +;;; better than (a). +;;; This, of course, assumes that any GC we're doing does in-place compaction +;;; (or at least preserves the relative order of objects in the heap.) + +(defx86lapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2)) + (save-simple-frame) + (push (% fun)) + (push (% obj)) + (push (% limit)) + (movq (% f) (% fun)) + (ref-global tenured-area a) + (movq (@ x8664::area.low (% a)) (% obj)) + (subq ($ (- x8664::cons.size x8664::fulltag-cons)) + (:rcontext x8664::tcr.save-allocptr)) + (movq (:rcontext x8664::tcr.save-allocptr) (% allocptr)) + (cmpq (:rcontext x8664::tcr.save-allocbase) (% allocptr)) + (ja @ok) + (uuo-alloc) + @ok + (andb ($ (lognot x8664::fulltagmask)) + (:rcontext x8664::tcr.save-allocptr)) + (movq (% allocptr) (% limit)) + (jmp @test) + @loop + (movb (@ (% obj)) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b)) + (jne @cons) + @misc + (lea (@ x8664::fulltag-misc (% obj)) (% obj)) + (movq (% obj) (% arg_z)) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (getvheader obj imm1) + (movb (% imm1.b) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @64) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @64) + (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b)) + (jne @not64) + @64 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ x8664::word-shift) (% imm1)) + (jmp @uvector-next) + @not64 + (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b)) + (jne @not32) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 2) (% imm1)) + (jmp @uvector-next) + @not32 + (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b)) + (jne @not-bit) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (addq ($ 7) (% imm1)) + (shrq ($ 3) (% imm1)) + (jmp @uvector-next) + @not-bit + (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256))) + (jb @16) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (jmp @uvector-next) + @16 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 1) (% imm1)) + (jmp @uvector-next) + @cons + (addq ($ x8664::fulltag-cons) (% obj)) + (cmpq (% obj) (% limit)) + (movq (% obj) (% arg_z)) + (je @done) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj)) + (jmp @test) + ;; size of OBJ in bytes (without header or alignment padding) + ;; in imm1. + @uvector-next + (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1)) + (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b)) + (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj)) + @test + (cmpq (% limit) (% obj)) + (jb @loop) + @done + (pop (% limit)) + (pop (% obj)) + (pop (% fun)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (restore-simple-frame) + (single-value-return))) + +(defun walk-dynamic-area (area func) + (with-other-threads-suspended + (%walk-dynamic-area area func))) + + + +(defx86lapfunction %class-of-instance ((i arg_z)) + (svref i instance.class-wrapper arg_z) + (svref arg_z %wrapper-class arg_z) + (single-value-return)) + +(defx86lapfunction class-of ((x arg_z)) + (check-nargs 1) + (movw ($ (logior (ash 1 x8664::tag-list) + (ash 1 x8664::tag-imm-1))) + (%w imm1)) + (extract-lisptag x imm0) + (btw (% imm0.w) (% imm1.w)) + (cmovbl (% arg_z.l) (% imm0.l)) + (movq (@ '*class-table* (% fn)) (% temp1)) + (cmpb ($ x8664::tag-misc) (% imm0.b)) + (jne @have-tag) + (extract-subtag x imm0) + @have-tag + (movq (@ x8664::symbol.vcell (% temp1)) (% temp1)) + (movzbl (% imm0.b) (% imm0.l)) + (movq (@ x8664::misc-data-offset (% temp1) (% imm0) 8) (% temp0)) + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (je @bad) + (extract-fulltag temp0 imm0) + (cmpb ($ x8664::fulltag-function) (%b imm0)) + (jne @ret) + (set-nargs 1) + (jmp (% temp0)) + @bad + (load-constant no-class-error fname) + (set-nargs 1) + (jmp (@ x8664::symbol.fcell (% fname))) + @ret + (movq (% temp0) (% arg_z)) ; return frob from table + (single-value-return)) + +(defx86lapfunction full-gccount () + (ref-global tenured-area arg_z) + (testq (% arg_z) (% arg_z)) + (cmoveq (@ (+ (target-nil-value) (x8664::%kernel-global 'gc-count))) (% arg_z)) + (cmovneq (@ x8664::area.gc-count (% arg_z)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction gc () + (check-nargs 0) + (movq ($ arch::gc-trap-function-gc) (% imm0)) + (uuo-gc-trap) + (movq ($ nil) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction egc ((arg arg_z)) + "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return +the previous enabled status. Although this function is thread-safe (in +the sense that calls to it are serialized), it doesn't make a whole lot +of sense to be turning the EGC on and off from multiple threads ..." + (check-nargs 1) + (clrq imm1) + (cmp-reg-to-nil arg) + (setne (% imm1.b)) + (movq ($ arch::gc-trap-function-egc-control) (% imm0)) + (uuo-gc-trap) + (single-value-return)) + + + + +(defx86lapfunction %configure-egc ((e0size arg_x) + (e1size arg_y) + (e2size arg_z)) + (check-nargs 3) + (movq ($ arch::gc-trap-function-configure-egc) (% imm0)) + (uuo-gc-trap) + (single-value-return)) + +(defx86lapfunction purify () + (check-nargs 0) + (movq ($ arch::gc-trap-function-purify) (% imm0)) + (uuo-gc-trap) + (movq ($ nil) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction impurify () + (check-nargs 0) + (movq ($ arch::gc-trap-function-impurify) (% imm0)) + (uuo-gc-trap) + (movq ($ nil) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction lisp-heap-gc-threshold () + "Return the value of the kernel variable that specifies the amount +of free space to leave in the heap after full GC." + (check-nargs 0) + (movq ($ arch::gc-trap-function-get-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + #+x8632-target + (jmp-subprim .SPmakeu32) + #+x8664-target + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction set-lisp-heap-gc-threshold ((new arg_z)) + "Set the value of the kernel variable that specifies the amount of free +space to leave in the heap after full GC to new-value, which should be a +non-negative fixnum. Returns the value of that kernel variable (which may +be somewhat larger than what was specified)." + (check-nargs 1) + (save-simple-frame) + (call-subprim .SPgetu64) + (movq (% imm0) (% imm1)) + (movq ($ arch::gc-trap-function-set-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + (restore-simple-frame) + (jmp-subprim .SPmakeu64)) + + +(defx86lapfunction use-lisp-heap-gc-threshold () + "Try to grow or shrink lisp's heap space, so that the free space is (approximately) equal to the current heap threshold. Return NIL" + (check-nargs 0) + (movq ($ arch::gc-trap-function-use-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction freeze () + "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." + (movl ($ arch::gc-trap-function-freeze) (% imm0.l)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction flash-freeze () + "Like FREEZE, without the GC." + (movl ($ arch::gc-trap-function-flash-freeze) (% imm0.l)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction %watch ((thing arg_z)) + (check-nargs 1) + (movl ($ arch::watch-trap-function-watch) (%l imm0)) + (uuo-watch-trap) + (single-value-return)) + +(defx86lapfunction %unwatch ((watched arg_y) (new arg_z)) + (check-nargs 2) + (movl ($ arch::watch-trap-function-unwatch) (%l imm0)) + (uuo-watch-trap) + (single-value-return)) + +(defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z)) + (check-nargs 2) + (save-simple-frame) + (ud2a) + (:byte 10) + (push (% arg_z)) + (push (% allocptr)) + (set-nargs 2) + (jmp-subprim .SPnvalret)) + + + + +;;; offset is a fixnum, one of the x8664::kernel-import-xxx constants. +;;; Returns that kernel import, a fixnum. +(defx86lapfunction %kernel-import ((offset arg_z)) + (ref-global kernel-imports imm0) + (unbox-fixnum arg_z imm1) + (movq (@ (% imm0) (% imm1)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %get-unboxed-ptr ((macptr arg_z)) + (macptr-ptr arg_z imm0) + (movq (@ (% imm0)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %revive-macptr ((p arg_z)) + (movb ($ x8664::subtag-macptr) (@ x8664::misc-subtag-offset (% p))) + (single-value-return)) + +(defx86lapfunction %macptr-type ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svref p x8664::macptr.type-cell imm0) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %macptr-domain ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svref p x8664::macptr.domain-cell imm0) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %set-macptr-type ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum new imm1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svset p x8664::macptr.type-cell imm1) + (single-value-return)) + +(defx86lapfunction %set-macptr-domain ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum new imm1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svset p x8664::macptr.domain-cell imm1) + (single-value-return)) + +(defx86lapfunction true () + (pop (% ra0)) + (subq ($ '3) (% nargs.q)) + (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0)) + (cmovaq (% imm0) (% rsp)) + (movl ($ (target-t-value)) (%l arg_z)) + (push (% ra0)) + (single-value-return)) + +(defx86lapfunction false () + (pop (% ra0)) + (subq ($ '3) (% nargs.q)) + (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0)) + (cmovaq (% imm0) (% rsp)) + (movl ($ (target-nil-value)) (%l arg_z)) + (push (% ra0)) + (single-value-return)) + + + +;;; end +) ; #+x8664-target Index: /branches/qres/ccl/level-0/l0-aprims.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-aprims.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-aprims.lisp (revision 13564) @@ -0,0 +1,223 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +; l0-aprims.lisp + +;;; This weak list is used to track semaphores as well as locks. +(defvar %system-locks% nil) + + +(defun record-system-lock (l) + (atomic-push-uvector-cell %system-locks% population.data l) + l) + +;;; This has to run very early in the initial thread. +(defun %revive-system-locks () + (dolist (s (population-data %system-locks%)) + (%revive-macptr s) + (%setf-macptr s + (case (uvref s target::xmacptr.flags-cell) + (#.$flags_DisposeRecursiveLock + (ff-call + (%kernel-import target::kernel-import-new-recursive-lock) + :address)) + (#.$flags_DisposeRwlock + (ff-call + (%kernel-import target::kernel-import-rwlock-new) + :address)) + (#.$flags_DisposeSemaphore + (ff-call + (%kernel-import target::kernel-import-new-semaphore) + :signed-fullword 0 + :address)))) + (set-%gcable-macptrs% s))) + +(dolist (p %all-packages%) + (setf (pkg.lock p) (make-read-write-lock))) + +(defparameter %all-packages-lock% nil) + + + +(defun %cstr-pointer (string pointer &optional (nul-terminated t)) + (if (typep string 'simple-base-string) + (locally (declare (simple-base-string string) + (optimize (speed 3) (safety 0))) + (let* ((n (length string))) + (declare (fixnum n)) + (dotimes (i n) + (setf (%get-unsigned-byte pointer i) + (let* ((code (%scharcode string i))) + (declare (type (mod #x110000) code)) + (if (< code 256) + code + (char-code #\Sub))))) + (when nul-terminated + (setf (%get-byte pointer n) 0))) + nil) + (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))) + +(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t)) + (declare (fixnum start end)) + (let* ((n (- end start))) + (multiple-value-bind (s o) (dereference-base-string string) + (declare (fixnum o)) + (do* ((i 0 (1+ i)) + (o (the fixnum (+ o start)) (1+ o))) + ((= i n)) + (declare (fixnum i o)) + (setf (%get-unsigned-byte pointer i) + (let* ((code (char-code (schar s o)))) + (declare (type (mod #x110000) code)) + (if (< code 256) + code + (char-code #\Sub)))))) + (when nul-terminated + (setf (%get-byte pointer n) 0)) + nil)) + +(defun string (thing) + "Coerces X into a string. If X is a string, X is returned. If X is a + symbol, X's pname is returned. If X is a character then a one element + string containing that character is returned. If X cannot be coerced + into a string, an error occurs." + (etypecase thing + (string thing) + (symbol (symbol-name thing)) + (character (make-string 1 :initial-element thing)))) + + +(defun dereference-base-string (s) + (multiple-value-bind (vector offset) (array-data-and-offset s) + (unless (typep vector 'simple-base-string) (report-bad-arg s 'base-string)) + (values vector offset (length s)))) + +(defun make-gcable-macptr (flags) + (let ((v (%alloc-misc target::xmacptr.element-count target::subtag-macptr))) + (setf (uvref v target::xmacptr.address-cell) 0) ; ?? yup. + (setf (uvref v target::xmacptr.flags-cell) flags) + (set-%gcable-macptrs% v) + v)) + +(defun %make-recursive-lock-ptr () + (record-system-lock + (%setf-macptr + (make-gcable-macptr $flags_DisposeRecursiveLock) + (ff-call (%kernel-import target::kernel-import-new-recursive-lock) + :address)))) + +(defun %make-rwlock-ptr () + (record-system-lock + (%setf-macptr + (make-gcable-macptr $flags_DisposeRwLock) + (ff-call (%kernel-import target::kernel-import-rwlock-new) + :address)))) + +(defun make-recursive-lock () + (make-lock nil)) + +(defun %make-lock (pointer name) + (gvector :lock pointer 'recursive-lock 0 name nil nil)) + +(defun make-lock (&optional name) + "Create and return a lock object, which can be used for synchronization +between threads." + (%make-lock (%make-recursive-lock-ptr) name)) + +(defun lock-name (lock) + (uvref (require-type lock 'lock) target::lock.name-cell)) + +(defun recursive-lock-ptr (r) + (if (and (eq target::subtag-lock (typecode r)) + (eq (%svref r target::lock.kind-cell) 'recursive-lock)) + (%svref r target::lock._value-cell) + (report-bad-arg r 'recursive-lock))) + +(defun recursive-lock-whostate (r) + (if (and (eq target::subtag-lock (typecode r)) + (eq (%svref r target::lock.kind-cell) 'recursive-lock)) + (or (%svref r target::lock.whostate-cell) + (setf (%svref r target::lock.whostate-cell) + (%lock-whostate-string "Lock wait" r))) + (report-bad-arg r 'recursive-lock))) + + +(defun read-write-lock-ptr (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (%svref rw target::lock._value-cell) + (report-bad-arg rw 'read-write-lock))) + +(defun make-read-write-lock () + "Create and return a read-write lock, which can be used for +synchronization between threads." + (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil nil nil)) + +(defun rwlock-read-whostate (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (or (%svref rw target::lock.whostate-cell) + (setf (%svref rw target::lock.whostate-cell) + (%lock-whostate-string "Read lock wait" rw))) + (report-bad-arg rw 'read-write-lock))) + +(defun rwlock-write-whostate (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (or (%svref rw target::lock.whostate-2-cell) + (setf (%svref rw target::lock.whostate-2-cell) + (%lock-whostate-string "Write lock wait" rw))) + (report-bad-arg rw 'read-write-lock))) + + +(defun %make-semaphore-ptr () + (let* ((p (ff-call (%kernel-import target::kernel-import-new-semaphore) + :signed-fullword 0 + :address))) + (if (%null-ptr-p p) + (error "Can't create semaphore.") + (record-system-lock + (%setf-macptr + (make-gcable-macptr $flags_DisposeSemaphore) + p))))) + +(defun make-semaphore () + "Create and return a semaphore, which can be used for synchronization +between threads." + (%istruct 'semaphore (%make-semaphore-ptr))) + +(defun semaphorep (x) + (istruct-typep x 'semaphore)) + +(setf (type-predicate 'semaphore) 'semaphorep) + +(defun make-list (size &key initial-element) + "Constructs a list with size elements each set to value" + (unless (and (typep size 'fixnum) + (>= (the fixnum size) 0)) + (report-bad-arg size '(and fixnum unsigned-byte))) + (locally (declare (fixnum size)) + (if (>= size (ash 1 16)) + (values (%allocate-list initial-element size)) + (do* ((result '() (cons initial-element result))) + ((zerop size) result) + (decf size))))) + +; end Index: /branches/qres/ccl/level-0/l0-array.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-array.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-array.lisp (revision 13564) @@ -0,0 +1,852 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + + +; Return T if array or vector header, NIL if (simple-array * *), else +; error. + +(defun %array-is-header (array) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH))))) + +(defun %set-fill-pointer (vectorh new) + (setf (%svref vectorh target::vectorh.logsize-cell) new)) + +(defun %array-header-subtype (header) + (the fixnum + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref header target::arrayH.flags-cell))))) + +(defun array-element-subtype (array) + (if (%array-is-header array) + (%array-header-subtype array) + (typecode array))) + +#+ppc32-target +(defconstant ppc32::*immheader-array-types* + '#(short-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + character + (unsigned-byte 8) + (signed-byte 8) + unused + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + +#+ppc64-target +(defconstant ppc64::*immheader-array-types* + '#(unused + unused + unused + unused + (signed-byte 8) + (signed-byte 16) + (signed-byte 32) + (signed-byte 64) + (unsigned-byte 8) + (unsigned-byte 16) + (unsigned-byte 32) + (unsigned-byte 64) + unused + unused + short-float + fixnum + unused + unused + unused + double-float + unused + unused + character + unused + unused + unused + unused + unused + unused + bit + unused + unused)) + +#+x8632-target +(defconstant x8632::*immheader-array-types* + '#(short-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + character + (unsigned-byte 8) + (signed-byte 8) + unused + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + +#+x8664-target +(progn +(defconstant x8664::*immheader-0-array-types* + ;; ivector-class-other-bit + #(unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + (signed-byte 16) + (unsigned-byte 16) + character + (signed-byte 8) + (unsigned-byte 8) + bit + )) + +(defconstant x8664::*immheader-1-array-types* + ;; ivector-class-32-bit + #( + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + character + (signed-byte 32) + (unsigned-byte 32) + single-float)) + +(defconstant x8664::*immheader-2-array-types* + ;; ivector-class-64-bit + #( + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + fixnum + (signed-byte 64) + (unsigned-byte 64) + double-float)) + +) + + +(defun array-element-type (array) + "Return the type of the elements of the array" + (let* ((subtag (if (%array-is-header array) + (%array-header-subtype array) + (typecode array)))) + (declare (fixnum subtag)) + (if (= subtag target::subtag-simple-vector) + t ; only node CL array type + #+ppc-target + (svref target::*immheader-array-types* + #+ppc32-target + (ash (the fixnum (- subtag ppc32::min-cl-ivector-subtag)) -3) + #+ppc64-target + (ash (the fixnum (logand subtag #x7f)) (- ppc64::nlowtagbits))) + #+x8632-target + (svref x8632::*immheader-array-types* + (ash (the fixnum (- subtag x8632::min-cl-ivector-subtag)) + (- x8632::ntagbits))) + #+x8664-target + (let* ((class (logand subtag x8664::fulltagmask)) + (idx (ash subtag (- x8664::ntagbits)))) + (declare (fixnum class idx)) + (cond ((= class x8664::ivector-class-64-bit) + (%svref x8664::*immheader-2-array-types* idx)) + ((= class x8664::ivector-class-32-bit) + (%svref x8664::*immheader-1-array-types* idx)) + (t + (%svref x8664::*immheader-0-array-types* idx)))) + ))) + + + +(defun adjustable-array-p (array) + "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical + to the argument, this happens for complex arrays." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (logbitp $arh_adjp_bit (the fixnum (%svref array target::arrayH.flags-cell))))))) + +(defun array-displacement (array) + "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset + options to MAKE-ARRAY, or NIL and 0 if not a displaced array." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (and (<= typecode target::subtag-vectorH) + (logbitp $arh_exp_disp_bit + (the fixnum (%svref array target::arrayH.flags-cell)))) + (values (%svref array target::arrayH.data-vector-cell) + (%svref array target::arrayH.displacement-cell)) + (values nil 0))))) + +(defun array-data-and-offset (array) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (<= typecode target::subtag-vectorH) + (%array-header-data-and-offset array) + (values array 0))))) + +(defun array-data-offset-subtype (array) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (<= typecode target::subtag-vectorH) + (do* ((header array data) + (offset (%svref header target::arrayH.displacement-cell) + (+ offset + (the fixnum + (%svref header target::arrayH.displacement-cell)))) + (data (%svref header target::arrayH.data-vector-cell) + (%svref header target::arrayH.data-vector-cell))) + ((> (the fixnum (typecode data)) target::subtag-vectorH) + (values data offset (typecode data))) + (declare (fixnum offset))) + (values array 0 typecode))))) + + +(defun array-has-fill-pointer-p (array) + "Return T if the given ARRAY has a fill pointer, or NIL otherwise." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (>= typecode target::min-array-subtag) + (and (= typecode target::subtag-vectorH) + (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell)))) + (report-bad-arg array 'array)))) + + +(defun fill-pointer (array) + "Return the FILL-POINTER of the given VECTOR." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (and (= typecode target::subtag-vectorH) + (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell)))) + (%svref array target::vectorH.logsize-cell) + (report-bad-arg array '(and array (satisfies array-has-fill-pointer-p)))))) + +(defun set-fill-pointer (array value) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (and (= typecode target::subtag-vectorH) + (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell)))) + (let* ((vlen (%svref array target::vectorH.physsize-cell))) + (declare (fixnum vlen)) + (if (eq value t) + (setq value vlen) + (unless (and (fixnump value) + (>= (the fixnum value) 0) + (<= (the fixnum value) vlen)) + (%err-disp $XARROOB value array))) + (setf (%svref array target::vectorH.logsize-cell) value)) + (%err-disp $XNOFILLPTR array)))) + +(eval-when (:compile-toplevel) + (assert (eql target::vectorH.physsize-cell target::arrayH.physsize-cell))) + +(defun array-total-size (array) + "Return the total number of elements in the Array." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (%svref array target::vectorH.physsize-cell) + (uvsize array))))) + + + +(defun array-dimension (array axis-number) + "Return the length of dimension AXIS-NUMBER of ARRAY." + (unless (typep axis-number 'fixnum) (report-bad-arg axis-number 'fixnum)) + (locally + (declare (fixnum axis-number)) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (= typecode target::subtag-arrayH) + (let* ((rank (%svref array target::arrayH.rank-cell))) + (declare (fixnum rank)) + (unless (and (>= axis-number 0) + (< axis-number rank)) + (%err-disp $XNDIMS array axis-number)) + (%svref array (the fixnum (+ target::arrayH.dim0-cell axis-number)))) + (if (neq axis-number 0) + (%err-disp $XNDIMS array axis-number) + (if (= typecode target::subtag-vectorH) + (%svref array target::vectorH.physsize-cell) + (uvsize array)))))))) + +(defun array-dimensions (array) + "Return a list whose elements are the dimensions of the array" + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (= typecode target::subtag-arrayH) + (let* ((rank (%svref array target::arrayH.rank-cell)) + (dims ())) + (declare (fixnum rank)) + (do* ((i (1- rank) (1- i))) + ((< i 0) dims) + (declare (fixnum i)) + (push (%svref array (the fixnum (+ target::arrayH.dim0-cell i))) dims))) + (list (if (= typecode target::subtag-vectorH) + (%svref array target::vectorH.physsize-cell) + (uvsize array))))))) + + +(defun array-rank (array) + "Return the number of dimensions of ARRAY." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (= typecode target::subtag-arrayH) + (%svref array target::arrayH.rank-cell) + 1)))) + +(defun vector-push (elt vector) + "Attempt to set the element of ARRAY designated by its fill pointer + to NEW-EL, and increment the fill pointer by one. If the fill pointer is + too large, NIL is returned, otherwise the index of the pushed element is + returned." + (let* ((fill (fill-pointer vector)) + (len (%svref vector target::vectorH.physsize-cell))) + (declare (fixnum fill len)) + (when (< fill len) + (multiple-value-bind (data offset) (%array-header-data-and-offset vector) + (declare (fixnum offset)) + (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill)) + (uvref data (the fixnum (+ fill offset))) elt) + fill)))) + +;;; Implement some of the guts of REPLACE, where the source and target +;;; sequence have the same type (and we might be able to BLT things +;;; around more quickly because of that.) +;;; Both TARGET and SOURCE are (SIMPLE-ARRAY (*) *), and all of the +;;; indices are fixnums and in bounds. +(defun %uvector-replace (target target-start source source-start n typecode) + (declare (fixnum target-start n source-start n typecode) + (optimize (speed 3) (safety 0))) + (ecase typecode + (#.target::subtag-simple-vector + (if (and (eq source target) + (> target-start source-start)) + (do* ((i 0 (1+ i)) + (source-pos (1- (the fixnum (+ source-start n))) + (1- source-pos)) + (target-pos (1- (the fixnum (+ target-start n))) + (1- target-pos))) + ((= i n)) + (declare (fixnum i source-pos target-pos)) + (setf (svref target target-pos) (svref source source-pos))) + (dotimes (i n) + (setf (svref target target-start) (svref source source-start)) + (incf target-start) + (incf source-start)))) + (#.target::subtag-bit-vector + (if (and (eq source target) + (> target-start source-start)) + (do* ((i 0 (1+ i)) + (source-pos (1- (the fixnum (+ source-start n))) + (1- source-pos)) + (target-pos (1- (the fixnum (+ target-start n))) + (1- target-pos))) + ((= i n)) + (declare (fixnum i source-pos target-pos)) + (setf (sbit target target-pos) (sbit source source-pos))) + (dotimes (i n) + (setf (sbit target target-start) (sbit source source-start)) + (incf target-start) + (incf source-start)))) + ;; All other cases can be handled with %COPY-IVECTOR-TO-IVECTOR, + ;; which knows how to handle overlap + ((#.target::subtag-s8-vector + #.target::subtag-u8-vector) + (%copy-ivector-to-ivector source + source-start + target + target-start + n)) + ((#.target::subtag-s16-vector + #.target::subtag-u16-vector) + (%copy-ivector-to-ivector source + (the fixnum (* source-start 2)) + target + (the fixnum (* target-start 2)) + (the fixnum (* n 2)))) + ((#.target::subtag-s32-vector + #.target::subtag-u32-vector + #.target::subtag-single-float-vector + #.target::subtag-simple-base-string + #+32-bit-target #.target::subtag-fixnum-vector) + (%copy-ivector-to-ivector source + (the fixnum (* source-start 4)) + target + (the fixnum (* target-start 4)) + (the fixnum (* n 4)))) + ((#.target::subtag-double-float-vector + #+64-bit-target #.target::subtag-s64-vector + #+64-bit-target #.target::subtag-u64-vector + #+64-bit-target #.target::subtag-fixnum-vector) + (%copy-ivector-to-ivector source + (the fixnum + (+ (the fixnum (- target::misc-dfloat-offset + target::misc-data-offset)) + (the fixnum (* source-start 8)))) + target + (the fixnum + (+ (the fixnum (- target::misc-dfloat-offset + target::misc-data-offset)) + (the fixnum (* target-start 8)))) + (the fixnum (* n 8))))) + target) + +(defun vector-push-extend (elt vector &optional (extension nil extp)) + "Attempt to set the element of VECTOR designated by its fill pointer +to ELT, and increment the fill pointer by one. If the fill pointer is +too large, VECTOR is extended using adjust-array. EXTENSION is the +minimum number of elements to add if it must be extended." + (when extp + (unless (and (typep extension 'fixnum) + (> (the fixnum extension) 0)) + (setq extension (require-type extension 'unsigned-byte)))) + (let* ((fill (fill-pointer vector)) + (len (%svref vector target::vectorH.physsize-cell))) + (declare (fixnum fill len)) + (multiple-value-bind (data offset) (%array-header-data-and-offset vector) + (declare (fixnum offset)) + (if (= fill len) + (let* ((flags (%svref vector target::arrayH.flags-cell))) + (declare (fixnum flags)) + (unless (logbitp $arh_adjp_bit flags) + (%err-disp $XMALADJUST vector)) + (let* ((new-size (max + (+ len (the fixnum (or extension + len))) + 4)) + (typecode (typecode data)) + (new-vector (%alloc-misc new-size typecode))) + (%uvector-replace new-vector 0 data offset fill typecode) + (setf (%svref vector target::vectorH.data-vector-cell) new-vector + (%svref vector target::vectorH.displacement-cell) 0 + (%svref vector target::vectorH.physsize-cell) new-size + (%svref vector target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags) + (uvref new-vector fill) elt))) + (setf (uvref data (the fixnum (+ offset fill))) elt)) + (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill)))) + fill)) + +;;; Could avoid potential memoization somehow +(defun vector (&lexpr vals) + "Construct a SIMPLE-VECTOR from the given objects." + (let* ((n (%lexpr-count vals)) + (v (allocate-typed-vector :simple-vector n))) + (declare (fixnum n)) + (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i))))) + +;;; CALL-ARGUMENTS-LIMIT. +(defun list-to-vector (elts) + (let* ((n (length elts))) + (declare (fixnum n)) + (if (< n (floor #x8000 target::node-size)) + (apply #'vector elts) + (make-array n :initial-contents elts)))) + + + +(defun %gvector (subtag &lexpr vals) + (let* ((n (%lexpr-count vals)) + (v (%alloc-misc n subtag))) + (declare (fixnum n)) + (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i))))) + +(defun %aref1 (v i) + (let* ((typecode (typecode v))) + (declare (fixnum typecode)) + (if (> typecode target::subtag-vectorH) + (uvref v i) + (if (= typecode target::subtag-vectorH) + (multiple-value-bind (data offset) + (%array-header-data-and-offset v) + (unless (typep i 'fixnum) + (report-bad-arg i 'fixnum)) + (unless (and (typep i 'fixnum) + (>= (the fixnum i) 0) + (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell)))) + (if (not (typep i 'fixnum)) + (report-bad-arg i 'fixnum) + (%err-disp $XARROOB i v))) + (uvref data (+ offset i))) + (if (= typecode target::subtag-arrayH) + (%err-disp $XNDIMS v 1) + (report-bad-arg v 'array)))))) + +(defun %aset1 (v i new) + (let* ((typecode (typecode v))) + (declare (fixnum typecode)) + (if (> typecode target::subtag-vectorH) + (setf (uvref v i) new) + (if (= typecode target::subtag-vectorH) + (multiple-value-bind (data offset) + (%array-header-data-and-offset v) + (unless (and (typep i 'fixnum) + (>= (the fixnum i) 0) + (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell)))) + (if (not (typep i 'fixnum)) + (report-bad-arg i 'fixnum) + (%err-disp $XARROOB i v))) + (setf (uvref data (+ offset i)) new)) + (if (= typecode target::subtag-arrayH) + (%err-disp $XNDIMS v 1) + (report-bad-arg v 'array)))))) + +;;; Validate the N indices in the lexpr L against the +;;; array-dimensions of L. If anything's out-of-bounds, +;;; error out (unless NO-ERROR is true, in which case +;;; return NIL.) +;;; If everything's OK, return the "row-major-index" of the array. +;;; We know that A's an array-header of rank N. + +(defun %array-index (a l n &optional no-error) + (declare (fixnum n)) + (let* ((count (%lexpr-count l))) + (declare (fixnum count)) + (do* ((axis (1- n) (1- axis)) + (chunk-size 1) + (result 0)) + ((< axis 0) result) + (declare (fixnum result axis chunk-size)) + (let* ((index (%lexpr-ref l count axis)) + (dim (%svref a (the fixnum (+ target::arrayH.dim0-cell axis))))) + (declare (fixnum dim)) + (unless (and (typep index 'fixnum) + (>= (the fixnum index) 0) + (< (the fixnum index) dim)) + (if no-error + (return-from %array-index nil) + (%err-disp $XARROOB index a))) + (incf result (the fixnum (* chunk-size (the fixnum index)))) + (setq chunk-size (* chunk-size dim)))))) + +(defun aref (a &lexpr subs) + "Return the element of the ARRAY specified by the SUBSCRIPTS." + (let* ((n (%lexpr-count subs))) + (declare (fixnum n)) + (if (= n 1) + (%aref1 a (%lexpr-ref subs n 0)) + (if (= n 2) + (%aref2 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1)) + (if (= n 3) + (%aref3 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1) (%lexpr-ref subs n 2)) + (let* ((typecode (typecode a))) + (declare (fixnum typecode)) + (if (>= typecode target::min-vector-subtag) + (%err-disp $XNDIMS a n) + (if (< typecode target::min-array-subtag) + (report-bad-arg a 'array) + ;; This typecode is Just Right ... + (progn + (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) n) + (%err-disp $XNDIMS a n)) + (let* ((rmi (%array-index a subs n))) + (declare (fixnum rmi)) + (multiple-value-bind (data offset) (%array-header-data-and-offset a) + (declare (fixnum offset)) + (uvref data (the fixnum (+ offset rmi)))))))))))))) + + + + + +(defun aset (a &lexpr subs&val) + (let* ((count (%lexpr-count subs&val)) + (nsubs (1- count))) + (declare (fixnum nsubs count)) + (if (eql count 0) + (%err-disp $xneinps) + (let* ((val (%lexpr-ref subs&val count nsubs))) + (if (= nsubs 1) + (%aset1 a (%lexpr-ref subs&val count 0) val) + (if (= nsubs 2) + (%aset2 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) val) + (if (= nsubs 3) + (%aset3 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) (%lexpr-ref subs&val count 2) val) + (let* ((typecode (typecode a))) + (declare (fixnum typecode)) + (if (>= typecode target::min-vector-subtag) + (%err-disp $XNDIMS a nsubs) + (if (< typecode target::min-array-subtag) + (report-bad-arg a 'array) + ; This typecode is Just Right ... + (progn + (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) nsubs) + (%err-disp $XNDIMS a nsubs)) + (let* ((rmi (%array-index a subs&val nsubs))) + (declare (fixnum rmi)) + (multiple-value-bind (data offset) (%array-header-data-and-offset a) + (setf (uvref data (the fixnum (+ offset rmi))) val)))))))))))))) + + + +(defun schar (s i) + "SCHAR returns the character object at an indexed position in a string + just as CHAR does, except the string must be a simple-string." + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (aref (the simple-string s) i) + (report-bad-arg s 'simple-string)))) + + +(defun %scharcode (s i) + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (locally + (declare (optimize (speed 3) (safety 0))) + (aref (the (simple-array (unsigned-byte 32) (*)) s) i)) + (report-bad-arg s 'simple-string)))) + + +(defun set-schar (s i v) + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (setf (aref (the simple-string s) i) v) + (report-bad-arg s 'simple-string)))) + + +(defun %set-scharcode (s i v) + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (locally + (declare (optimize (speed 3) (safety 0))) + (setf (aref (the simple-string s) i) v)) + (report-bad-arg s 'simple-string)))) + + +; Strings are simple-strings, start & end values are sane. +(defun %simple-string= (str1 str2 start1 start2 end1 end2) + (declare (fixnum start1 start2 end1 end2)) + (when (= (the fixnum (- end1 start1)) + (the fixnum (- end2 start2))) + (locally (declare (type simple-base-string str1 str2)) + (do* ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((= i1 end1) t) + (declare (fixnum i1 i2)) + (unless (eq (schar str1 i1) (schar str2 i2)) + (return)))))) + +(defun copy-uvector (src) + (%extend-vector 0 src (uvsize src))) + +#+ppc32-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (= #.ppc32::fulltag-immheader (logand subtag #.ppc32::fulltagmask)) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((element-bit-shift + (if (<= subtag ppc32::max-32-bit-ivector-subtag) + 5 + (if (<= subtag ppc32::max-8-bit-ivector-subtag) + 3 + (if (<= subtag ppc32::max-16-bit-ivector-subtag) + 4 + (if (= subtag ppc32::subtag-double-float-vector) + 6 + 0))))) + (total-bits (ash element-count element-bit-shift))) + (ash (+ 7 total-bits) -3))) + +#+ppc64-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (= ppc64::lowtag-immheader (logand subtag ppc64::lowtagmask)) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((ivector-class (logand subtag ppc64::fulltagmask)) + (element-bit-shift + (if (= ivector-class ppc64::ivector-class-32-bit) + 5 + (if (= ivector-class ppc64::ivector-class-8-bit) + 3 + (if (= ivector-class ppc64::ivector-class-64-bit) + 6 + (if (= subtag ppc64::subtag-bit-vector) + 0 + 4))))) + (total-bits (ash element-count element-bit-shift))) + (declare (fixnum ivector-class element-bit-shift total-bits)) + (ash (the fixnum (+ 7 total-bits)) -3))) + +#+x8632-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (= #.x8632::fulltag-immheader (logand subtag #.x8632::fulltagmask)) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((element-bit-shift + (if (<= subtag x8632::max-32-bit-ivector-subtag) + 5 + (if (<= subtag x8632::max-8-bit-ivector-subtag) + 3 + (if (<= subtag x8632::max-16-bit-ivector-subtag) + 4 + (if (= subtag x8632::subtag-double-float-vector) + 6 + 0))))) + (total-bits (ash element-count element-bit-shift))) + (ash (+ 7 total-bits) -3))) + +#+x8664-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (logbitp (the (mod 16) (logand subtag x8664::fulltagmask)) + (logior (ash 1 x8664::fulltag-immheader-0) + (ash 1 x8664::fulltag-immheader-1) + (ash 1 x8664::fulltag-immheader-2))) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((ivector-class (logand subtag x8664::fulltagmask)) + (element-bit-shift + (if (= ivector-class x8664::ivector-class-32-bit) + 5 + (if (= ivector-class x8664::ivector-class-64-bit) + 6 + (if (= subtag x8664::subtag-bit-vector) + 0 + (if (>= subtag x8664::min-8-bit-ivector-subtag) + 3 + 4))))) + (total-bits (ash element-count element-bit-shift))) + (declare (fixnum ivector-class element-bit-shift total-bits)) + (ash (the fixnum (+ 7 total-bits)) -3))) + +(defun element-type-subtype (type) + "Convert element type specifier to internal array subtype code" + (ctype-subtype (specifier-type type))) + +(defun ctype-subtype (ctype) + (typecase ctype + (class-ctype + (if (or (eq (class-ctype-class ctype) *character-class*) + (eq (class-ctype-class ctype) *base-char-class*) + (eq (class-ctype-class ctype) *standard-char-class*)) + target::subtag-simple-base-string + target::subtag-simple-vector)) + (numeric-ctype + (if (eq (numeric-ctype-complexp ctype) :complex) + target::subtag-simple-vector + (case (numeric-ctype-class ctype) + (integer + (let* ((low (numeric-ctype-low ctype)) + (high (numeric-ctype-high ctype))) + (cond ((or (null low) (null high)) target::subtag-simple-vector) + ((and (>= low 0) (<= high 1)) target::subtag-bit-vector) + ((and (>= low 0) (<= high 255)) + target::subtag-u8-vector) + ((and (>= low 0) (<= high 65535)) + target::subtag-u16-vector) + ((and (>= low 0) (<= high #xffffffff)) + target::subtag-u32-vector) + #+64-bit-target + ((and (>= low 0) (<= high (1- (ash 1 64)))) + target::subtag-u64-vector) + ((and (>= low -128) (<= high 127)) target::subtag-s8-vector) + ((and (>= low -32768) (<= high 32767)) target::subtag-s16-vector) + #+32-bit-target + ((and (>= low target::target-most-negative-fixnum) + (<= high target::target-most-positive-fixnum)) + target::subtag-fixnum-vector) + ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31)))) + target::subtag-s32-vector) + #+64-bit-target + ((and (>= low target::target-most-negative-fixnum) + (<= high target::target-most-positive-fixnum)) + target::subtag-fixnum-vector) + #+64-bit-target + ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63)))) + target::subtag-s64-vector) + (t target::subtag-simple-vector)))) + (float + (case (numeric-ctype-format ctype) + ((double-float long-float) target::subtag-double-float-vector) + ((single-float short-float) target::subtag-single-float-vector) + (t target::subtag-simple-vector))) + (t target::subtag-simple-vector)))) + (named-ctype ; *, T, etc. + target::subtag-simple-vector) + (t + (harder-ctype-subtype ctype)))) + +(defun %set-simple-array-p (array) + (setf (%svref array target::arrayh.flags-cell) + (bitset $arh_simple_bit (%svref array target::arrayh.flags-cell)))) + +(defun %array-header-simple-p (array) + (logbitp $arh_simple_bit (%svref array target::arrayh.flags-cell))) + +(defun %misc-ref (v i) + (%misc-ref v i)) + +(defun %misc-set (v i new) + (%misc-set v i new)) + + + +; end of l0-array.lisp Index: /branches/qres/ccl/level-0/l0-bignum32.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-bignum32.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-bignum32.lisp (revision 13564) @@ -0,0 +1,2141 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +#+32-bit-target ; the whole shebang +(eval-when (:compile-toplevel :execute) + (require "ARCH") + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") + + (defconstant digit-size 32) + (defconstant half-digit-size (/ digit-size 2)) + + (defconstant maximum-bignum-length (1- (ash 1 24))) + + (deftype bignum-index () `(integer 0 (,maximum-bignum-length))) + (deftype bignum-element-type () `(unsigned-byte ,digit-size)) + (deftype bignum-half-element-type () `(unsigned-byte ,half-digit-size)) + (deftype bignum-type () 'bignum) + (defmacro %bignum-digits (bignum)`(uvsize ,bignum)) + + (defmacro digit-bind ((&rest digits) form &body body) + `(multiple-value-bind ,digits + ,form + (declare (type bignum-half-element-type ,@digits)) + ,@body)) + + (defmacro digit-set ((&rest digits) form) + `(multiple-value-setq ,digits + ,form)) + + (defmacro digit-zerop (h l) + `(and (zerop ,h) (zerop ,l))) + + + + ;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS. + + ;;; BIGNUM-REPLACE -- Internal. + ;;; + (defmacro bignum-replace (dest src &key (start1 '0) end1 (start2 '0) end2 + from-end) + (once-only ((n-dest dest) + (n-src src)) + (if (and (eq start1 0)(eq start2 0)(null end1)(null end2)(null from-end)) + ; this is all true for some uses today << + `(%copy-ivector-to-ivector ,n-src 0 ,n-dest 0 (%ilsl 2 (min (the fixnum (%bignum-length ,n-src)) + (the fixnum (%bignum-length ,n-dest))))) + (let* ((n-start1 (gensym)) + (n-end1 (gensym)) + (n-start2 (gensym)) + (n-end2 (gensym))) + `(let ((,n-start1 ,start1) + (,n-start2 ,start2) + (,n-end1 ,(or end1 `(%bignum-length ,n-dest))) + (,n-end2 ,(or end2 `(%bignum-length ,n-src)))) + ,(if (null from-end) + `(%copy-ivector-to-ivector + ,n-src (%i* 4 ,n-start2) + ,n-dest (%i* 4 ,n-start1) + (%i* 4 (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + `(let ((nwds (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + (%copy-ivector-to-ivector + ,n-src (%ilsl 2 (%i- ,n-end2 nwds)) + ,n-dest (%ilsl 2 (%i- ,n-end1 nwds)) + (%i* 4 nwds))))))))) + + + ;;;; Shifting. + + (defconstant all-ones-half-digit #xFFFF) + + + + + + (defmacro %logxor (h1 l1 h2 l2) + (once-only ((h1v h1)(l1v l1)(h2v h2)(l2v l2)) + `(values (%ilogxor ,h1v ,h2v)(%ilogxor ,l1v ,l2v)))) + + + (defmacro %lognot (h l) + (once-only ((h1v h)(l1v l)) + `(values (%ilognot ,h1v)(%ilognot ,l1v)))) + + (defmacro %allocate-bignum (ndigits) + `(%alloc-misc ,ndigits target::subtag-bignum)) + + (defmacro %normalize-bignum-macro (big) + `(%normalize-bignum-2 t ,big)) + + (defmacro %mostly-normalize-bignum-macro (big) + `(%normalize-bignum-2 nil ,big)) + + +;;; %ALLOCATE-BIGNUM must zero all elements. +;;; + (declaim (inline %bignum-length)) + +;;; Temp space needed to (Karatsuba)-square N-digit argument + (defmacro mpn-kara-mul-n-tsize (n) + `(* 8 (+ ,n 32))) +;;; Need the same amount of space to do Karatsuba multiply. + (defmacro mpn-kara-sqr-n-tsize (n) + `(mpn-kara-mul-n-tsize ,n)) + +) + + + + +#+32-bit-target +(progn +;;; Extract the length of the bignum. +;;; +(defun %bignum-length (bignum) + (uvsize bignum)) + + + + + + +;;;; Addition. +(defun add-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (bignum-index len-a len-b)) + (when (> len-b len-a) + (rotatef a b) + (rotatef len-a len-b)) + (let* ((len-res (1+ len-a)) + (res (%allocate-bignum len-res)) + (carry 0) + (sign-b (%bignum-sign b))) + (dotimes (i len-b) + (setq carry (%add-with-carry res i carry a i b i))) + (if (/= len-a len-b) + (finish-bignum-add res carry a sign-b len-b len-a) + (%add-with-carry res len-a carry (%bignum-sign a) nil sign-b nil)) + (%normalize-bignum-macro res)))) + +;;; Could do better than this, surely. +(defun add-bignum-and-fixnum (bignum fixnum) + (with-small-bignum-buffers ((bigfix fixnum)) + (add-bignums bignum bigfix))) + + + +;;; B was shorter than A; keep adding B's sign digit to each remaining +;;; digit of A, propagating the carry. +(defun finish-bignum-add (result carry a sign-b start end) + (declare (type bignum-index start end)) + (do* ((i start (1+ i))) + ((= i end) + (%add-with-carry result end carry (%bignum-sign a) nil sign-b nil)) + (setq carry (%add-with-carry result i carry a i sign-b nil)))) + + + + + + + +;;;; Subtraction. +(defun subtract-bignum (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (1+ (max len-a len-b))) + (res (%allocate-bignum len-res))) + (declare (bignum-index len-a len-b len-res)) + (bignum-subtract-loop a len-a b len-b res) + (%normalize-bignum-macro res))) + +(defun bignum-subtract-loop (a len-a b len-b res) + (declare (bignum-index len-a len-b )) + (let* ((len-res (%bignum-length res))) + (declare (bignum-index len-res)) + (let* ((borrow 1) + (sign-a (%bignum-sign a)) + (sign-b (%bignum-sign b))) + (dotimes (i (the bignum-index (min len-a len-b))) + (setq borrow (%subtract-with-borrow res i borrow a i b i))) + (if (< len-a len-b) + (do* ((i len-a (1+ i))) + ((= i len-b) + (if (< i len-res) + (%subtract-with-borrow res i borrow sign-a nil sign-b nil))) + (setq borrow (%subtract-with-borrow res i borrow sign-a nil b i))) + (do* ((i len-b (1+ i))) + ((= i len-a) + (if (< i len-res) + (%subtract-with-borrow res i borrow sign-a nil sign-b nil))) + (setq borrow (%subtract-with-borrow res i borrow a i sign-b nil))))))) + + + +;;;; Multiplication. + +;;; These parameters match GMP's. +(defvar *sqr-basecase-threshold* 5) +(defvar *sqr-karatsuba-threshold* 22) +(defvar *mul-karatsuba-threshold* 10) + +;;; Squaring is often simpler than multiplication. This should never +;;; be called with (>= N *sqr-karatsuba-threshold*). +(defun mpn-sqr-basecase (prodp up n) + (declare (fixnum prodp up n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (umulppm up up prodp) + (when (> n 1) + (%stack-block ((tarr (* 4 (* 2 *sqr-karatsuba-threshold*)))) + (let* ((tp (macptr->fixnum tarr))) + (mpn-mul-1 tp + (the fixnum (1+ up)) + (the fixnum (1- n)) + up + (the fixnum (+ tp (the fixnum (1- n))))) + (do* ((i 2 (1+ i))) + ((= i n)) + (declare (fixnum i)) + (mpn-addmul-1 (the fixnum (- (the fixnum (+ tp (the fixnum (+ i i)))) + 2)) + (the fixnum (+ up i)) + (the fixnum (- n i)) + (the fixnum (+ up (the fixnum (1- i)))) + (the fixnum (+ tp (the fixnum (+ n (the fixnum (- i 2)))))))) + (do* ((i 1 (1+ i)) + (ul (1+ up) (1+ ul))) + ((= i n)) + (declare (fixnum i ul)) + (umulppm ul ul (the fixnum (+ prodp (the fixnum (+ i i)))))) + (let* ((2n-2 (- (the fixnum (+ n n)) 2)) + (carry (mpn-lshift-1 tp tp 2n-2))) + (declare (fixnum 2n-2 carry)) + (setq carry + (+ carry + (the fixnum (mpn-add-n (the fixnum (1+ prodp)) + (the fixnum (1+ prodp)) + tp + 2n-2)))) + (add-fixnum-to-limb carry (the fixnum (+ prodp + (the fixnum (1- + (the fixnum + (+ n n)))))))))))) + +;;; For large enough values of N, squaring via Karatsuba-style +;;; divide&conquer is faster than in the base case. +(defun mpn-kara-sqr-n (p a n ws) + (declare (fixnum p a n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (n2 (ash n -1)) + (x 0) + (y 0) + (i 0)) + (declare (fixnum w w0 w1 xx n2 x y i)) + (cond ((logbitp 0 n) + ;; Odd length + (let* ((n3 (- n n2)) + (n1 0) + (nm1 0)) + (declare (fixnum n3 n1 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum + (- (the fixnum (mpn-sub-n p a (the fixnum (+ a n3)) n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a) + (setq y (+ a n3) + x a)) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (setq n1 (1+ n)) + (cond ((< n3 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n3 p n3) + (mpn-mul-basecase p a n3 a n3)) + ((< n3 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n3) + (mpn-sqr-basecase p a n3)) + (t + (mpn-kara-sqr-n ws p n3 (the fixnum (+ ws n1))) + (mpn-kara-sqr-n p a n3 (the fixnum (+ ws n1))))) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ a n3)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2)) + (t + (mpn-kara-sqr-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ ws n1))))) + (mpn-sub-n ws p ws n1) + (setq nm1 (1- n)) + (unless (zerop (the fixnum + (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop + (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n1 n3)))) + 1)))) + (t ; N is even + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a) + (setq y (+ a n2) + x a)) + (mpn-sub-n p x y n2) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n2 p n2) + (mpn-mul-basecase p a n2 a n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ a n2)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n2) + (mpn-sqr-basecase p a n2) + (mpn-sqr-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2)) + (t + (mpn-kara-sqr-n ws p n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n p a n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (- (the fixnum (mpn-sub-n ws p ws n))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Karatsuba subroutine: multiply A and B, store result at P, use WS +;;; as scrach space. Treats A and B as if they were both of size N; +;;; if that's not true, caller must fuss around the edges. +(defun mpn-kara-mul-n (p a b n ws) + (declare (fixnum p a b n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (x 0) + (y 0) + (i 0) + (n2 (ash n -1)) + (sign 0)) + (declare (fixnum w w0 w1 xx x y i n2 sign)) + (cond ((logbitp 0 n) + (let* ((n1 0) + (n3 (- n n2)) + (nm1 0)) + (declare (fixnum n1 n3 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (mpn-sub-n p a (the fixnum (+ a n3)) n2))) w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a + sign -1) + (setq x a + y (+ a n3))) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (copy-limb (the fixnum (+ b n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (the fixnum (mpn-sub-n (the fixnum (+ p n3)) + b + (the fixnum (+ b n3)) + n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n3) + y b + sign (lognot sign)) + (setq x b + y (+ b n3))) + (mpn-sub-n (the fixnum (+ p n3)) x y n2))) + (copy-limb w (the fixnum (+ p n))) + (setq n1 (1+ n)) + (cond + ((< n2 *mul-karatsuba-threshold*) + (cond + ((< n3 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n3 (the fixnum (+ p n3)) n3) + (mpn-mul-basecase p a n3 b n3)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))))) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ b n3)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + (the fixnum (+ b n3)) + n2 + (the fixnum (+ ws n1))))) + (if (not (zerop sign)) + (mpn-add-n ws p ws n1) + (mpn-sub-n ws p ws n1)) + (setq nm1 (1- n)) + (unless (zerop (the fixnum (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum + (+ p (the fixnum (+ n1 n3)))) 1)))) + (t ; even length + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (setq sign 0) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a + sign -1) + (setq x a + y (+ a n2))) + (mpn-sub-n p x y n2) + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n2) + y b + sign (lognot sign)) + (setq x b + y (+ b n2))) + (mpn-sub-n (the fixnum (+ p n2)) x y n2) + (cond + ((< n2 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n2 (the fixnum (+ p n2)) n2) + (mpn-mul-basecase p a n2 b n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ b n2)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n2)) n2 + (the fixnum (+ ws n))) + (mpn-kara-mul-n p a b n2 (the fixnum (+ ws n))) + (mpn-kara-mul-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + (the fixnum (+ b n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (if (not (zerop sign)) + (mpn-add-n ws p ws n) + (- (the fixnum (mpn-sub-n ws p ws n)))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Square UP, of length UN. I wonder if a Karatsuba multiply might be +;;; faster than a basecase square. +(defun mpn-sqr-n (prodp up un) + (declare (fixnum prodp up un)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< un *sqr-basecase-threshold*) + (mpn-mul-basecase prodp up un up un) + (if (< un *sqr-karatsuba-threshold*) + (mpn-sqr-basecase prodp up un) + (%stack-block ((wsptr (mpn-kara-sqr-n-tsize un))) + (mpn-kara-sqr-n prodp up un (macptr->fixnum wsptr)))))) + +;;; Subroutine: store AxB at P. Assumes A & B to be of length N +(defun mpn-mul-n (p a b n) + (declare (fixnum p a b n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< n *mul-karatsuba-threshold*) + (mpn-mul-basecase p a n b n) + (%stack-block ((wsptr (mpn-kara-mul-n-tsize n))) + (mpn-kara-mul-n p a b n (macptr->fixnum wsptr))))) + + +;;; Multiply [UP,UN] by [VP,VN]. UN must not be less than VN. +;;; This does Karatsuba if operands are big enough; if they are +;;; and they differ in size, this computes the product of the +;;; smaller-size slices, then fixes up the resut. +(defun mpn-mul (prodp up un vp vn) + (declare (fixnum prodp up un vp vn)) + (declare (optimize (speed 3) (safety 0) (space 0))) + ;(assert (>= un vn 1)) + (if (and (= up vp) (= un vn)) + (mpn-sqr-n prodp up un) + (if (< vn *mul-karatsuba-threshold*) + (mpn-mul-basecase prodp up un vp vn) + (let* ((l vn)) + (declare (fixnum l)) + (mpn-mul-n prodp up vp vn) + (unless (= un vn) + (incf prodp vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq un vn vn un up vp vp up)) + (%stack-block ((wsptr + (the fixnum + (+ 8 + (the fixnum + (* 4 + (the fixnum + (+ vn + (if (>= vn *mul-karatsuba-threshold*) + vn + un))))))))) + (setf (%get-unsigned-long wsptr 0) 0 + (%get-unsigned-long wsptr 4) 0) + (let* ((tt (macptr->fixnum wsptr)) + (c (1+ tt)) + (ws (1+ c))) + (declare (fixnum tt c ws )) + (do* () + ((< vn *mul-karatsuba-threshold*)) + (mpn-mul-n ws up vp vn) + (cond ((<= l (the fixnum (+ vn vn))) + (add-fixnum-to-limb (mpn-add-n prodp prodp ws l) tt) + (unless (= l (the fixnum (+ vn vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ vn vn)) l)) + tt) + tt) + (setq l (the fixnum (+ vn vn))))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ vn vn))) c) + (add-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (- l (the fixnum (+ vn vn)))) + c) + tt))) + (incf prodp vn) + (decf l vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq up vp vp up un vn vn un))) + (unless (zerop vn) + (mpn-mul-basecase ws up un vp vn) + (cond ((<= l (the fixnum (+ un vn))) + (add-fixnum-to-limb + (mpn-add-n prodp prodp ws l) + tt) + (unless (= l (the fixnum (+ un vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ un vn)) l)) + tt) + tt))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ un vn))) + c) + (add-fixnum-to-limb + (mpn-add-1 + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (- (the fixnum (- l un)) vn)) + c) + tt))))))))))) + +(defun multiply-bignums (a b) + (let* ((signs-differ (not (eq (bignum-minusp a) (bignum-minusp b))))) + (flet ((multiply-unsigned-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (+ len-a len-b)) + (res (%allocate-bignum len-res)) ) + (declare (bignum-index len-a len-b len-res)) + (if (and (>= len-a 16) + (>= len-b 16) + #+x8632-target + nil) + (let* ((ubytes (* len-a 4)) + (vbytes (* len-b 4)) + (rbytes (* len-res 4))) + (declare (fixnum ubytes vbytes rbytes)) + (%stack-block ((uptr ubytes) + (vptr vbytes) + (rptr rbytes)) + (let* ((up (macptr->fixnum uptr)) + (vp (macptr->fixnum vptr)) + (rp (macptr->fixnum rptr))) + (declare (fixnum up vp rp)) + (%copy-ivector-to-ptr a 0 uptr 0 ubytes) + (if (eq a b) ; maybe try eql .. + (mpn-mul rp up len-a up len-a) + (progn + (%copy-ivector-to-ptr b 0 vptr 0 vbytes) + (if (< len-a len-b) + (mpn-mul rp vp len-b up len-a) + (mpn-mul rp up len-a vp len-b))))) + (%copy-ptr-to-ivector rptr 0 res 0 rbytes))) + (dotimes (i len-a) + (declare (type bignum-index i)) + (%multiply-and-add-harder-loop-2 a b res i len-b))) + res))) + (let* ((res (with-negated-bignum-buffers a b multiply-unsigned-bignums))) + (if signs-differ (negate-bignum-in-place res)) + (%normalize-bignum-macro res))))) + + +(defun multiply-bignum-and-fixnum (bignum fixnum) + (declare (type bignum-type bignum) (fixnum fixnum)) + (let* ((bignum-len (%bignum-length bignum)) + (bignum-plus-p (bignum-plusp bignum)) + (fixnum-plus-p (not (minusp fixnum))) + (negate-res (neq bignum-plus-p fixnum-plus-p))) + (declare (type bignum-type bignum) + (type bignum-index bignum-len)) + (flet ((do-it (bignum fixnum negate-res) + (let* ((bignum-len (%bignum-length bignum)) + (result (%allocate-bignum (the fixnum (1+ bignum-len))))) + (declare (type bignum-type bignum) + (type bignum-index bignum-len)) + (with-small-bignum-buffers ((carry-digit) + (result-digit)) + (dotimes (i bignum-len (%set-digit result bignum-len carry-digit)) + (%set-digit result i + (%multiply-and-add result-digit carry-digit bignum i fixnum)))) + (when negate-res + (negate-bignum-in-place result)) + (%normalize-bignum-macro result )))) + (declare (dynamic-extent #'do-it)) + (if bignum-plus-p + (do-it bignum (if fixnum-plus-p fixnum (- fixnum)) negate-res) + (with-bignum-buffers ((b1 (the fixnum (1+ bignum-len)))) + (negate-bignum bignum nil b1) + (do-it b1 (if fixnum-plus-p fixnum (- fixnum)) negate-res)))))) + +;; assume we already know result won't fit in a fixnum +;; only caller is fixnum-*-2 +;; + +(defun multiply-fixnums (a b) + (declare (fixnum a b)) + (* a b)) + + +;;;; GCD. + + +;;; Both args are > 0. +(defun bignum-fixnum-gcd (bignum fixnum) + (let* ((rem (bignum-truncate-by-fixnum-no-quo bignum fixnum))) + (declare (fixnum rem)) + (if (zerop rem) + fixnum + (%fixnum-gcd rem fixnum)))) + + + + +;;; NEGATE-BIGNUM -- Public. +;;; +;;; Fully-normalize is an internal optional. It cause this to always return +;;; a bignum, without any extraneous digits, and it never returns a fixnum. +;;; +(defun negate-bignum (x &optional (fully-normalize t) res) + (declare (type bignum-type x)) + (let* ((len-x (%bignum-length x)) + (len-res (1+ len-x)) + (minusp (bignum-minusp x))) + (declare (type bignum-index len-x len-res)) + (if (not res) (setq res (%allocate-bignum len-res))) ;Test len-res for range? + (let ((carry (bignum-negate-loop-really x len-x res))) ; i think carry is always 0 + (if (eq carry 0) + (if minusp (%bignum-set res len-x 0 0)(%bignum-set res len-x #xffff #xffff)) + (digit-bind (h l) + (if minusp + (%add-the-carry 0 0 carry) + (%add-the-carry #xffff #xffff carry)) + + (%bignum-set res len-x h l)))) + (if fully-normalize + (%normalize-bignum-macro res) + (%mostly-normalize-bignum-macro res)))) + +;;; NEGATE-BIGNUM-IN-PLACE -- Internal. +;;; +;;; This assumes bignum is positive; that is, the result of negating it will +;;; stay in the provided allocated bignum. +;;; +(defun negate-bignum-in-place (bignum) + (bignum-negate-loop-really bignum (%bignum-length bignum) bignum) + bignum) + + + + +(defun copy-bignum (bignum) + (let ((res (%allocate-bignum (%bignum-length bignum)))) + (bignum-replace res bignum) + res)) + + + + +;;; BIGNUM-ASHIFT-RIGHT -- Public. +;;; +;;; First compute the number of whole digits to shift, shifting them by +;;; skipping them when we start to pick up bits, and the number of bits to +;;; shift the remaining digits into place. If the number of digits is greater +;;; than the length of the bignum, then the result is either 0 or -1. If we +;;; shift on a digit boundary (that is, n-bits is zero), then we just copy +;;; digits. The last branch handles the general case which uses a macro that a +;;; couple other routines use. The fifth argument to the macro references +;;; locals established by the macro. +;;; + + +(defun bignum-ashift-right (bignum x) + (declare (type bignum-type bignum) + (fixnum x)) + (let ((bignum-len (%bignum-length bignum))) + (declare (type bignum-index bignum-len)) + (multiple-value-bind (digits n-bits) (truncate x digit-size) + (declare (type bignum-index digits)(fixnum n-bits)) + (cond + ((>= digits bignum-len) + (if (bignum-plusp bignum) 0 -1)) + ((eql 0 n-bits) + (bignum-ashift-right-digits bignum digits)) + (t + (let* ((res-len (- bignum-len digits)) + (res (%allocate-bignum res-len)) + (len-1 (1- res-len))) + (declare (fixnum res-len len-1)) + (bignum-shift-right-loop-1 n-bits res bignum len-1 digits) + (%normalize-bignum-macro res ))))))) + + + + + +;;; BIGNUM-ASHIFT-RIGHT-DIGITS -- Internal. +;;; +(defun bignum-ashift-right-digits (bignum digits) + (declare (type bignum-type bignum) + (type bignum-index digits)) + (let* ((res-len (- (%bignum-length bignum) digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len) + (type bignum-type res)) + (bignum-replace res bignum :start2 digits) + (%normalize-bignum-macro res))) + + +;;; BIGNUM-BUFFER-ASHIFT-RIGHT -- Internal. +;;; +;;; GCD uses this for an in-place shifting operation. This is different enough +;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a +;;; macro, but they share the basic algorithm. This routine foregoes a first +;;; test for digits being greater than or equal to bignum-len since that will +;;; never happen for its uses in GCD. We did fold the last branch into a macro +;;; since it was duplicated a few times, and the fifth argument to it +;;; references locals established by the macro. +;;; +#| +(defun bignum-buffer-ashift-right (bignum bignum-len x) + (declare (type bignum-index bignum-len) (fixnum x)) + (multiple-value-bind (digits n-bits) + (truncate x digit-size) + (declare (type bignum-index digits)) + (cond + ((zerop n-bits) + (let ((new-end (- bignum-len digits))) + (bignum-replace bignum bignum :end1 new-end :start2 digits + :end2 bignum-len) + (%normalize-bignum-buffer bignum new-end))) + (t + (shift-right-unaligned bignum digits n-bits (- bignum-len digits) + ((= j res-len-1) + (digit-bind (h l) (%bignum-ref bignum i) + (digit-set (h l) (%ashr h l n-bits)) + (%bignum-set bignum j h l)) + (%normalize-bignum-buffer bignum res-len))))))) +|# +#| +(defun bignum-buffer-ashift-right (bignum bignum-len x) + (declare (type bignum-index bignum-len) (fixnum x)) + (multiple-value-bind (digits n-bits) (truncate x digit-size) + (declare (type bignum-index digits)(fixnum n-bits)) + (macrolet ((clear-high-digits () + `(do* ((i (1- (the fixnum (%bignum-length bignum))) (1- i)) + (j digits (1- j))) + ((= 0 j)) + (declare (fixnum i j)) + (%bignum-set bignum i 0 0)))) + (cond + ((zerop n-bits) + (let* ((new-end (- bignum-len digits))) + (declare (fixnum new-end)) + (bignum-replace bignum bignum :end1 new-end :start2 digits + :end2 bignum-len) + (clear-high-digits) + (%normalize-bignum-buffer bignum new-end))) + (t + (let* ((res-len (- bignum-len digits)) + (len-1 (1- res-len))) + (declare (fixnum res-len len-1)) + (bignum-shift-right-loop-1 n-bits bignum bignum len-1 digits) + ; clear the old high order digits - assume always positive + ; (when (neq 0 digits)(push digits poof)) + (clear-high-digits) + (%normalize-bignum-buffer bignum res-len))))))) +|# + + + +;;; BIGNUM-ASHIFT-LEFT -- Public. +;;; +;;; This handles shifting a bignum buffer to provide fresh bignum data for some +;;; internal routines. We know bignum is safe when called with bignum-len. +;;; First we compute the number of whole digits to shift, shifting them +;;; starting to store farther along the result bignum. If we shift on a digit +;;; boundary (that is, n-bits is zero), then we just copy digits. The last +;;; branch handles the general case. +;;; +(defun bignum-ashift-left (bignum x &optional bignum-len) + (declare (type bignum-type bignum) + (fixnum x) + (type (or null bignum-index) bignum-len)) + (multiple-value-bind (digits n-bits) + (truncate x digit-size) + (declare (fixnum digits n-bits)) + (let* ((bignum-len (or bignum-len (%bignum-length bignum))) + (res-len (+ digits bignum-len 1))) + (declare (fixnum bignum-len res-len)) + (when (> res-len maximum-bignum-length) + (error "Can't represent result of left shift.")) + (if (zerop n-bits) + (bignum-ashift-left-digits bignum bignum-len digits) + (bignum-ashift-left-unaligned bignum digits n-bits res-len))))) + +;;; BIGNUM-ASHIFT-LEFT-DIGITS -- Internal. +;;; +(defun bignum-ashift-left-digits (bignum bignum-len digits) + (declare (type bignum-index bignum-len digits)) + (let* ((res-len (+ bignum-len digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len)) + (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len + :from-end t) + res)) + +;;; BIGNUM-ASHIFT-LEFT-UNALIGNED -- Internal. +;;; +;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. +;;; When res comes in non-nil, then this foregoes allocating a result, and it +;;; normalizes the buffer instead of the would-be allocated result. +;;; +;;; We start storing into one digit higher than digits, storing a whole result +;;; digit from parts of two contiguous digits from bignum. When the loop +;;; finishes, we store the remaining bits from bignum's first digit in the +;;; first non-zero result digit, digits. We also grab some left over high +;;; bits from the last digit of bignum. +;;; + +(defun bignum-ashift-left-unaligned (bignum digits n-bits res-len + &optional (res nil resp)) + (declare (type bignum-index digits res-len) + (type (mod #.digit-size) n-bits)) + (let* (;(remaining-bits (- digit-size n-bits)) + (res-len-1 (1- res-len)) + (res (or res (%allocate-bignum res-len)))) + (declare (type bignum-index res-len res-len-1)) + (bignum-shift-left-loop n-bits res bignum res-len-1 (the fixnum (1+ digits))) + ; if resp provided we don't care about returned value + (if (not resp) (%normalize-bignum-macro res)))) + + + + + +;;;; Relational operators. + + + +;;; BIGNUM-COMPARE -- Public. +;;; +;;; This compares two bignums returning -1, 0, or 1, depending on whether a +;;; is less than, equal to, or greater than b. +;;; +;(proclaim '(function bignum-compare (bignum bignum) (integer -1 1))) +(defun bignum-compare (a b) + (declare (type bignum-type a b)) + (let* ((a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (if (eq a-plusp b-plusp) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (cond ((= len-a len-b) + (do* ((i (1- len-a) (1- i))) + ((zerop i) (%compare-digits a b 0)) + (declare (fixnum i)) + (let* ((signum (%compare-digits a b i))) + (declare (fixnum signum)) + (unless (zerop signum) + (return signum))))) + ((> len-a len-b) + (if a-plusp 1 -1)) + (t (if a-plusp -1 1)))) + (if a-plusp 1 -1)))) + + + + + + + +;;;; Integer length and logcount + + +(defun bignum-integer-length (big) + (the fixnum (- (the fixnum (ash (the fixnum (%bignum-length big)) 5)) + (the fixnum (%bignum-sign-bits big))))) + +; (not (zerop (logand integer1 integer2) + +(defun bignum-logtest (num1 num2) + (let* ((length1 (%bignum-length num1)) + (length2 (%bignum-length num2)) + (n1-minusp (bignum-minusp num1)) + (n2-minusp (bignum-minusp num2))) + (declare (fixnum length1 length2)) + (if (and n1-minusp n2-minusp) ; both neg, get out quick + T + (let ((val (bignum-logtest-loop (min length1 length2) num1 num2))) + #|(do* ((index 0 (1+ index))) + ((= index (min length1 length2)) nil) + ; maybe better to start from high end of shorter? + (multiple-value-bind (hi1 lo1)(%bignum-ref num1 index) + (multiple-value-bind (hi2 lo2)(%bignum-ref num2 index) + (when (or (not (zerop (%ilogand hi1 hi2))) + (not (zerop (%ilogand lo1 lo2)))) + (return t)))))))|# + (or val + (when (not (eql length1 length2)) ; lengths same => value nil + (if (< length1 length2) + n1-minusp + n2-minusp))))))) + + + +(defun logtest-fix-big (fix big) + (declare (fixnum fix)) + (if (eql 0 (the fixnum fix)) + nil + (if (> (the fixnum fix) 0) + (let () + (multiple-value-bind (hi lo)(%bignum-ref big 0) + (declare (fixnum hi lo)) + (or (not (zerop (logand fix lo))) + (not (zerop (logand (ash fix (- 16)) hi)))))) + t))) + + +(defun bignum-logcount (bignum) + (declare (type bignum-type bignum)) + (let* ((length (%bignum-length bignum)) + (plusp (bignum-plusp bignum)) + (result 0)) + (declare (type bignum-index length) + (fixnum result)) + (if plusp + (dotimes (index length result) + (incf result (the fixnum (%logcount bignum index)))) + (dotimes (index length result) + (incf result (the fixnum (%logcount-complement bignum index))))))) + + + +;;;; Logical operations. + +;;; NOT. +;;; + +;;; BIGNUM-LOGICAL-NOT -- Public. +;;; +(defun bignum-logical-not (a) + (declare (type bignum-type a)) + (let* ((len (%bignum-length a)) + (res (%allocate-bignum len))) + (declare (type bignum-index len)) + (dotimes (i len res) + (%bignum-lognot i a res)))) + + + + +;;; AND. +;;; + +;;; BIGNUM-LOGICAL-AND -- Public. +;;; +(defun bignum-logical-and (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (if a-plusp + (logand-shorter-positive a len-a b (%allocate-bignum len-a)) + (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + ((< len-b len-a) + (if b-plusp + (logand-shorter-positive b len-b a (%allocate-bignum len-b)) + (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (t (logand-shorter-positive a len-a b (%allocate-bignum len-a)))))) + +;;; LOGAND-SHORTER-POSITIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is positive. Because this +;;; is AND, we don't care about any bits longer than a's since its infinite 0 +;;; sign bits will mask the other bits out of b. The result is len-a big. +;;; +(defun logand-shorter-positive (a len-a b res) + (declare (type bignum-type a b res) + (type bignum-index len-a)) + (dotimes (i len-a) + (%bignum-logand i a b res)) + (%normalize-bignum-macro res)) + +;;; LOGAND-SHORTER-NEGATIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is negative. Because this +;;; is AND, we just copy any bits longer than a's since its infinite 1 sign +;;; bits will include any bits from b. The result is len-b big. +;;; +(defun logand-shorter-negative (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logand i a b res)) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + + + +;;; +;;; +;;; bignum-logandc2 + +(defun bignum-logandc2 (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (logandc2-shorter-any a len-a b len-b (if a-plusp (%allocate-bignum len-a) (%allocate-bignum len-b)))) + ((< len-b len-a) ; b shorter + (logandc1-shorter-any b len-b a len-a (if b-plusp (%allocate-bignum len-a)(%allocate-bignum len-b)))) + (t (logandc2-shorter-any a len-a b len-b (%allocate-bignum len-a)))))) + +(defun logandc2-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logandc2 i a b res)) + (if (bignum-minusp a) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (digit-bind (h l) (%bignum-ref b i) + (%bignum-set res i (%ilognot h) (%ilognot l))))) + (%normalize-bignum-macro res)) + + + +(defun logandc1-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logandc1 i a b res)) + (if (bignum-plusp a) + (if (neq len-a len-b) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b))) + (%normalize-bignum-macro res)) + + + +(defun fix-big-logand (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logand fix big res))) + (if res + (progn + (bignum-replace res big :start1 1 :start2 1 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + +(defun fix-big-logandc2 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc2 fix big res))) + (if res + (progn + (do ((i 1 (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (digit-lognot-move i big res)) + (%normalize-bignum-macro res)) + val)))) + +(defun fix-big-logandc1 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (>= fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc1 fix big res))) + (if res + (progn + (bignum-replace res big :start1 1 :start2 1 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + + + + + + +;;; IOR. +;;; + +;;; BIGNUM-LOGICAL-IOR -- Public. +;;; +(defun bignum-logical-ior (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (if a-plusp + (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b)) + (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + ((< len-b len-a) + (if b-plusp + (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a)) + (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a)))))) + +;;; LOGIOR-SHORTER-POSITIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is positive. Because this +;;; is IOR, we don't care about any bits longer than a's since its infinite +;;; 0 sign bits will mask the other bits out of b out to len-b. The result +;;; is len-b long. +;;; +(defun logior-shorter-positive (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logior i a b res)) + (if (not (eql len-a len-b)) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b)) + (%normalize-bignum-macro res)) + +;;; LOGIOR-SHORTER-NEGATIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is negative. Because this +;;; is IOR, we just copy any bits longer than a's since its infinite 1 sign +;;; bits will include any bits from b. The result is len-b long. +;;; +(defun logior-shorter-negative (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logior i a b res)) + ; silly to propagate sign and then normalize it away + ; but may need to do at least once - but we are only normalizing from len-a? + ; ah but the sign needs to be correct + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (%bignum-set res i #xffff #xffff)) + (%normalize-bignum-macro res)) + + + + +;;; XOR. +;;; + +;;; BIGNUM-LOGICAL-XOR -- Public. +;;; +(defun bignum-logical-xor (a b) + (declare (type bignum-type a b)) + (let ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (if (< len-a len-b) + (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) + (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) + +;;; BIGNUM-LOGICAL-XOR-AUX -- Internal. +;;; +;;; This takes the the shorter of two bignums in a and len-a. Res is len-b +;;; long. Do the XOR. +;;; +(defun bignum-logical-xor-aux (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logxor i a b res)) + (unless (= len-a len-b) + (let ((sign (if (bignum-minusp a) #xffff 0))) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (digit-bind (h l) (%bignum-ref b i) + (%bignum-set res i (%ilogxor sign h)(%ilogxor sign l)))))) + (%normalize-bignum-macro res)) + + + + + + +;;;; LDB (load byte) + +; [slh] 'twas all commented out - thank gawd + + + +;;;; TRUNCATE. + +;;; This is the original sketch of the algorithm from which I implemented this +;;; TRUNCATE, assuming both operands are bignums. I should modify this to work +;;; with the documentation on my functions, as a general introduction. I've +;;; left this here just in case someone needs it in the future. Don't look +;;; at this unless reading the functions' comments leaves you at a loss. +;;; Remember this comes from Knuth, so the book might give you the right general +;;; overview. +;;; +;;; +;;; (truncate x y): +;;; +;;; If X's magnitude is less than Y's, then result is 0 with remainder X. +;;; +;;; Make x and y positive, copying x if it is already positive. +;;; +;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign +;;; digit) +;;; Just do most sig digit to determine how much to shift whole number. +;;; Shift x this much too. +;;; Remember this initial shift count. +;;; +;;; Allocate q to be len-x minus len-y quantity plus 1. +;;; +;;; i = last digit of x. +;;; k = last digit of q. +;;; +;;; LOOP +;;; +;;; j = last digit of y. +;;; +;;; compute guess. +;;; if x[i] = y[j] then g = #xFFFFFFFF +;;; else g = x[i]x[i-1]/y[j]. +;;; +;;; check guess. +;;; %UNSIGNED-MULTIPLY returns b and c defined below. +;;; a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF). +;;; Use %UNSIGNED-MULTIPLY taking low-order result. +;;; b = (logand (ash (* g y[j-1]) -32) #xFFFFFFFF). +;;; c = (logand (* g y[j-1]) #xFFFFFFFF). +;;; if a < b, okay. +;;; if a > b, guess is too high +;;; g = g - 1; go back to "check guess". +;;; if a = b and c > x[i-2], guess is too high +;;; g = g - 1; go back to "check guess". +;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER +;;; SAME FOR A, B, AND C. +;;; +;;; Subtract g * y from x[i - len-y+1]..x[i]. See paper for doing this in step. +;;; If x[i] < 0, guess is fucked. +;;; negative g, then add 1 +;;; zero or positive g, then subtract 1 +;;; AND add y back into x[len-y+1..i]. +;;; +;;; q[k] = g. +;;; i = i - 1. +;;; k = k - 1. +;;; +;;; If k>=0, goto LOOP. +;;; +;;; +;;; Now quotient is good, but remainder is not. +;;; Shift x right by saved initial left shifting count. +;;; +;;; Check quotient and remainder signs. +;;; x pos y pos --> q pos r pos +;;; x pos y neg --> q neg r pos +;;; x neg y pos --> q neg r neg +;;; x neg y neg --> q pos r neg +;;; +;;; Normalize quotient and remainder. Cons result if necessary. +;;; + + + +;;; These are used by BIGNUM-TRUNCATE and friends in the general case. +;;; +(defvar *truncate-x* nil) +(defvar *truncate-y* nil) + +;;; BIGNUM-TRUNCATE -- Public. +;;; +;;; This divides x by y returning the quotient and remainder. In the general +;;; case, we shift y to setup for the algorithm, and we use two buffers to save +;;; consing intermediate values. X gets destructively modified to become the +;;; remainder, and we have to shift it to account for the initial Y shift. +;;; After we multiple bind q and r, we first fix up the signs and then return +;;; the normalized results. +;;; + + +(defun bignum-truncate (x1 y1 &optional no-rem) + (declare (type bignum-type x1 y1)) + (let* ((x-plusp (bignum-plusp x1)) + (y-plusp (bignum-plusp y1))) + (flet + ((do-it (x y) + (let* ((len-x (%bignum-length x)) + (len-y (%bignum-length y))) + (declare (fixnum len-x len-y)) + + (let ((c (bignum-compare y x))) + (cond + ((eql c 1) ; > + (return-from bignum-truncate (values 0 x1))) + ((eql c 0)(values 1 0)) ; = might as well since did compare anyway + ((< len-y 2) + (multiple-value-bind (q r) + (bignum-truncate-single-digit x len-x y no-rem) + (values q + (unless no-rem + (cond (x-plusp r) + ((typep r 'fixnum) (the fixnum (- (the fixnum r)))) + (t (negate-bignum-in-place r) + (%normalize-bignum-macro r ))))))) + (t + (let* ((len-x+1 (1+ len-x))) + (declare (fixnum len-x+1)) + (with-bignum-buffers ((*truncate-x* len-x+1) + (*truncate-y* (the fixnum (1+ len-y)))) + (let ((y-shift (shift-y-for-truncate y))) + (shift-and-store-truncate-buffers x len-x y len-y y-shift) + (values (do-truncate len-x+1 len-y) + ;; DO-TRUNCATE must execute first. + (when (not no-rem) + (when (not (eql 0 y-shift)) + (let* ((res-len-1 (1- len-y))) + (declare (fixnum res-len-1)) + (bignum-shift-right-loop-1 y-shift *truncate-x* *truncate-x* res-len-1 0))) + (let ((the-res (%normalize-bignum-macro *truncate-x* ))) + (if (not (fixnump the-res)) + (if x-plusp (copy-bignum the-res) (negate-bignum the-res)) + (if x-plusp the-res (the fixnum (- (the fixnum the-res))))) + )))))))))))) + (multiple-value-bind (q r)(with-negated-bignum-buffers x1 y1 do-it) + (let ((quotient (cond ((eq x-plusp y-plusp) q) + ((typep q 'fixnum) (the fixnum (- (the fixnum q)))) + (t (negate-bignum-in-place q) + (%normalize-bignum-macro q ))))) + (if no-rem + quotient + (values quotient r))))))) + +(defun bignum-rem (x1 y1) + (declare (type bignum-type x1 y1)) + (let* ((x-plusp (bignum-plusp x1))) + (flet + ((do-it (x y) + (let* ((len-x (%bignum-length x)) + (len-y (%bignum-length y))) + (declare (fixnum len-x len-y)) + (let ((c (bignum-compare y x))) + (cond + ((eql c 1) (return-from bignum-rem x1)) + ((eql c 0) 0) ; = might as well since did compare anyway + ((< len-y 2) + (let ((r (bignum-truncate-single-digit-no-quo x len-x y))) ; phooey + (cond (x-plusp r) + ((typep r 'fixnum) (the fixnum (- (the fixnum r)))) + (t (negate-bignum-in-place r) + (%normalize-bignum-macro r ))))) + (t + (let* ((len-x+1 (1+ len-x))) + (declare (fixnum len-x+1)) + (with-bignum-buffers ((*truncate-x* len-x+1) + (*truncate-y* (the fixnum (1+ len-y)))) + (let ((y-shift (shift-y-for-truncate y))) + (shift-and-store-truncate-buffers x len-x y len-y y-shift) + (do-truncate-no-quo len-x+1 len-y) + (when (not (eql 0 y-shift)) + (let* ((res-len-1 (1- len-y))) + (declare (fixnum res-len-1)) + (bignum-shift-right-loop-1 y-shift *truncate-x* *truncate-x* res-len-1 0))) + (let ((the-res (%normalize-bignum-macro *truncate-x*))) + (if (not (fixnump the-res)) + (if x-plusp (copy-bignum the-res) (negate-bignum the-res)) + (if x-plusp the-res (the fixnum (- (the fixnum the-res))))))))))))))) + (declare (dynamic-extent #'do-it)) + (with-negated-bignum-buffers x1 y1 do-it)))) + + + +;;; BIGNUM-TRUNCATE-SINGLE-DIGIT -- Internal. +;;; +;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes +;;; up the quotient and remainder with respect to sign and normalization. +;;; +;;; We don't have to worry about shifting y to make its most significant digit +;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit +;;; and r-digit. If y is a single digit bignum, it is already large enough +;;; for %FLOOR. That is, it has some bits on pretty high in the digit. +;;; +;;; x is positive +(defun bignum-truncate-single-digit (x len-x y &optional no-rem) + (declare (type bignum-index len-x)) + (let* ((maybe-q (%allocate-bignum 2)) + (q (if (<= len-x 2) maybe-q (%allocate-bignum len-x))) + (r-h 0) + (r-l 0)) + (declare (dynamic-extent maybe-q)) + (digit-bind (y-h y-l) (%bignum-ref y 0) + (multiple-value-setq (r-h r-l)(%floor-loop-quo x q y-h y-l)) + (if (eq q maybe-q) + (progn + (setq q (%normalize-bignum-macro q)) + (if (not (fixnump q)) (setq q (copy-bignum q)))) + (setq q (%normalize-bignum-macro q ))) + ;; might as well make a fixnum if possible + (if no-rem + q + (if (> (%digits-sign-bits r-h r-l) target::fixnumshift) + (values q (%ilogior (%ilsl 16 r-h) r-l)) + (let ((rem (%allocate-bignum 1))) + (%bignum-set rem 0 r-h r-l) + (values q rem))))))) + +;;; aka rem +(defun bignum-truncate-single-digit-no-quo (x len-x y) + (declare (type bignum-index len-x)) + (declare (ignore len-x)) + (let (;(q (%allocate-bignum len-x)) + (r-h 0) + (r-l 0)) + (progn + (digit-bind (y-h y-l) (%bignum-ref y 0) + (multiple-value-setq (r-h r-l)(%floor-loop-no-quo x y-h y-l)) + ; might as well make a fixnum if possible + (if (> (%digits-sign-bits r-h r-l) target::fixnumshift) + (%ilogior (%ilsl 16 r-h) r-l) + (let ((rem (%allocate-bignum 1))) + (%bignum-set rem 0 r-h r-l) + rem)))))) + +;; so big deal - we save a one digit bignum for y +;; and bigger deal if x is negative - we copy or negate x, computing result destructively +;; - thus avoiding making a negated x in addition to result +;; +(defun bignum-truncate-by-fixnum (x y) + (declare (fixnum y)) + (when (eql y 0)(error (make-condition 'division-by-zero :operation 'truncate :operands (list x y)))) + (let* ((len-x (%bignum-length x)) + (x-minus (bignum-minusp x)) + (maybe-q (%allocate-bignum 3)) + (q (if x-minus + (if (<= len-x 2) + (dotimes (i 3 (negate-bignum-in-place maybe-q)) + (if (< i len-x) + (multiple-value-bind (hi lo) (%bignum-ref x i) + (%bignum-set maybe-q i hi lo)) + (%bignum-set maybe-q i 65535 65535))) + (negate-bignum x)) + (if (<= len-x 2) ; this was broken if negative because bignum-replace just copies min len-a len-b digits + (progn + (bignum-replace maybe-q x) + maybe-q) + (%allocate-bignum len-x)))) ; q is new big or -x + ;(len-q (%bignum-length q)) + (y-minus (minusp y)) + (y (if y-minus (- y) y))) + (declare (fixnum y)) + (declare (type bignum-index len-x)) + (declare (dynamic-extent maybe-q)) + (let* ((r-h 0) + (r-l 0) + (y-h (%ilogand #xffff (%iasr 16 y))) + (y-l (%ilogand #xffff y))) + (multiple-value-setq (r-h r-l)(%floor-loop-quo (if x-minus q x) q y-h y-l)) + (let* ((r (%ilogior (%ilsl 16 r-h) r-l))) + (declare (fixnum r)) + (when (neq x-minus y-minus)(negate-bignum-in-place q)) + (setq q (%normalize-bignum-macro q )) + (values (if (eq q maybe-q) (copy-bignum q) q) + (if x-minus (the fixnum (- r)) r)))))) + +(defun bignum-truncate-by-fixnum-no-quo (x y) + (declare (fixnum y)) + (when (eql y 0)(error (make-condition 'division-by-zero :operation 'truncate :operands (list x Y)))) + (let* ((len-x (%bignum-length x)) + (x-minus (bignum-minusp x)) + (y-minus (minusp y)) + (y (if y-minus (- y) y))) + (declare (fixnum y)) + (declare (type bignum-index len-x)) + (let* (;(LEN-Q (%BIGNUM-LENGTH Q)) + (r-h 0) + (r-l 0) + (y-h (%ilogand #xffff (%iasr 16 y))) + (y-l (%ilogand #xffff y))) + (if x-minus + (with-bignum-buffers ((q (the fixnum (1+ len-x)))) + (negate-bignum x nil q) + (multiple-value-setq (r-h r-l)(%floor-loop-no-quo q y-h y-l))) + (multiple-value-setq (r-h r-l)(%floor-loop-no-quo x y-h y-l))) + (let* ((r (%ilogior (%ilsl 16 r-h) r-l))) + (declare (fixnum r)) + (if x-minus (the fixnum (- r)) r))))) + + +;;; DO-TRUNCATE -- Internal. +;;; +;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how +;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies +;;; *truncate-x* on each interation, and this buffer becomes our remainder. +;;; +;;; *truncate-x* definitely has at least three digits, and it has one more than +;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to +;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. +;;; + + +(defun do-truncate (len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + ;; Add one for extra sign digit in case high bit is on. + (len-res (1+ len-q)) + (maybe-q (%allocate-bignum 2)) + (q (if (<= len-res 2) maybe-q (%allocate-bignum len-res))) + (k (1- len-q)) + (i (1- len-x)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q len-res k i low-x-digit)) + (declare (dynamic-extent maybe-q)) + (loop + (digit-bind (h l) + (digit-bind (guess-h guess-l) + (bignum-truncate-guess-2 *truncate-x* i *truncate-y* (the fixnum (1- len-y))) + (try-bignum-truncate-guess guess-h guess-l len-y low-x-digit)) + (%bignum-set q k h l)) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (setq i (1- i))))) + (if (eq q maybe-q) + (progn + (setq q (%normalize-bignum-macro q)) + (if (fixnump q) q (copy-bignum q))) + (%normalize-bignum-macro q)))) + +(defun do-truncate-no-quo (len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + (k (1- len-q)) + (i (1- len-x)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q k i low-x-digit)) + (loop + (digit-bind (guess-h guess-l) (bignum-truncate-guess-2 *truncate-x* i *truncate-y* (the fixnum (1- len-y))) + (try-bignum-truncate-guess guess-h guess-l len-y low-x-digit) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (setq i (1- i)))))) + nil)) + +;;; TRY-BIGNUM-TRUNCATE-GUESS -- Internal. +;;; +;;; This takes a digit guess, multiplies it by *truncate-y* for a result one +;;; greater in length than len-y, and subtracts this result from *truncate-x*. +;;; Low-x-digit is the first digit of x to start the subtraction, and we know x +;;; is long enough to subtract a len-y plus one length bignum from it. Next we +;;; check the result of the subtraction, and if the high digit in x became +;;; negative, then our guess was one too big. In this case, return one less +;;; than guess passed in, and add one value of y back into x to account for +;;; subtracting one too many. Knuth shows that the guess is wrong on the order +;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely. +;;; + +(defun try-bignum-truncate-guess (guess-h guess-l len-y low-x-digit) + (declare (type bignum-index low-x-digit len-y)) + + (let ((carry-digit-h 0) + (carry-digit-l 0) + (borrow 1) + (i low-x-digit)) + (declare (type bignum-index i) + (fixnum borrow carry-digit-h carry-digit-l)) + ;; Multiply guess and divisor, subtracting from dividend simultaneously. + (dotimes (j len-y) + (multiple-value-bind (y-h y-l) (%bignum-ref *truncate-y* j) + (multiple-value-bind (high-h high-l low-h low-l) + (%multiply-and-add-1 guess-h + guess-l + y-h + y-l + carry-digit-h + carry-digit-l) + (setq carry-digit-h high-h + carry-digit-l high-l) + (multiple-value-bind (tx-h tx-l) (%bignum-ref *truncate-x* i) + (multiple-value-bind (x-h x-l temp-borrow) + (%subtract-with-borrow-1 tx-h tx-l low-h low-l borrow) + (%bignum-set *truncate-x* i x-h x-l) + (setq borrow temp-borrow))))) + (incf i)) + (multiple-value-bind (tx-h tx-l) (%bignum-ref *truncate-x* i) + (multiple-value-bind (x-h x-l) + (%subtract-with-borrow-1 tx-h tx-l carry-digit-h carry-digit-l borrow) + (%bignum-set *truncate-x* i x-h x-l))) + ;; See if guess is off by one, adding one Y back in if necessary. + + + (cond ((%digit-0-or-plusp *truncate-x* i) + (values guess-h guess-l)) + (t + ;; If subtraction has negative result, add one divisor value back + ;; in. The guess was one too large in magnitude. + ;; hmm - happens about 1.6% of the time + (bignum-add-loop-+ low-x-digit *truncate-x* *truncate-y* len-y) + (%subtract-one guess-h guess-l) + ;(%subtract-with-borrow guess-h guess-l 0 1 1) + )))) + + + +;;; BIGNUM-TRUNCATE-GUESS -- Internal. +;;; +;;; This returns a guess for the next division step. Y1 is the highest y +;;; digit, and y2 is the second to highest y digit. The x... variables are +;;; the three highest x digits for the next division step. +;;; +;;; From Knuth, our guess is either all ones or x-i and x-i-1 divided by y1, +;;; depending on whether x-i and y1 are the same. We test this guess by +;;; determining whether guess*y2 is greater than the three high digits of x +;;; minus guess*y1 shifted left one digit: +;;; ------------------------------ +;;; | x-i | x-i-1 | x-i-2 | +;;; ------------------------------ +;;; ------------------------------ +;;; - | g*y1 high | g*y1 low | 0 | +;;; ------------------------------ +;;; ... < guess*y2 ??? +;;; If guess*y2 is greater, then we decrement our guess by one and try again. +;;; This returns a guess that is either correct or one too large. +;;; +;;; the y's come from *truncate-y*, x's from *truncate-x* +;;; doing this in lap is not screamingly difficult - x's at i, i-1, i-2 + + + + + +(defun bignum-truncate-guess-2 (x xidx y yidx) + (digit-bind (guess-h guess-l) + (%floor-99 x xidx y yidx) + (truncate-guess-loop guess-h guess-l x xidx y yidx))) + + + + + +;;; SHIFT-Y-FOR-TRUNCATE -- Internal. +;;; +;;; This returns the amount to shift y to place a one in the second highest +;;; bit. Y must be positive. If the last digit of y is zero, then y has a +;;; one in the previous digit's sign bit, so we know it will take one less +;;; than digit-size to get a one where we want. Otherwise, we count how many +;;; right shifts it takes to get zero; subtracting this value from digit-size +;;; tells us how many high zeros there are which is one more than the shift +;;; amount sought. +;;; +;;; Note: This is exactly the same as one less than the integer-length of the +;;; last digit subtracted from the digit-size. +;;; +;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit +;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits. +;;; +(defun shift-y-for-truncate (y) + (the fixnum (1- (the fixnum (%bignum-sign-bits y))))) + +;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS -- Internal. +;;; +;;; Stores two bignums into the truncation bignum buffers, shifting them on the +;;; way in. This assumes x and y are positive and at least two in length, and +;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y. +;;; +(defun shift-and-store-truncate-buffers (x len-x y len-y shift) + (declare (type bignum-index len-x len-y) + (type (integer 0 (#.digit-size)) shift)) + (cond ((eql 0 shift) + (bignum-replace *truncate-x* x :end1 len-x) + (bignum-replace *truncate-y* y :end1 len-y)) + (t + (bignum-ashift-left-unaligned x 0 shift (the fixnum (1+ len-x)) *truncate-x*) + (bignum-ashift-left-unaligned y 0 shift (the fixnum (1+ len-y)) *truncate-y*)))) + + + + + +;;;; General utilities. + + +;;; %NORMALIZE-BIGNUM-BUFFER -- Internal. +;;; +;;; Internal in-place operations use this to fixup remaining digits in the +;;; incoming data, such as in-place shifting. This is basically the same as +;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer +;;; instead of shrinking the bignum. +;;; + + + + + + + + +;;; %NORMALIZE-BIGNUM -- Internal. +;;; +;;; This drops the last digit if it is unnecessary sign information. It +;;; repeats this as needed, possibly ending with a fixnum. If the resulting +;;; length from shrinking is one, see if our one word is a fixnum. Shift the +;;; possible fixnum bits completely out of the word, and compare this with +;;; shifting the sign bit all the way through. If the bits are all 1's or 0's +;;; in both words, then there are just sign bits between the fixnum bits and +;;; the sign bit. If we do have a fixnum, shift it over for the two low-tag +;;; bits. +;;; + +(defun %normalize-bignum (res) + ;(declare (optimize (speed 3)(safety 0))) + (%normalize-bignum-2 t res)) + +;;; %MOSTLY-NORMALIZE-BIGNUM -- Internal. +;;; +;;; This drops the last digit if it is unnecessary sign information. It +;;; repeats this as needed, possibly ending with a fixnum magnitude but never +;;; returning a fixnum. +;;; + +(defun %mostly-normalize-bignum (res &optional len) + (declare (ignore len)) + (%normalize-bignum-2 nil res)) + + + + +; think its ok +(defun ldb32 (hi-data lo-data size pos) + (declare (fixnum hi-data lo-data size pos)) + (let* ((hi-bit (+ pos size)) + (mask (%i- (%ilsl size 1) 1))) + (declare (fixnum hi-bit mask)) + (%ilogand mask (if (< hi-bit 16) + (%iasr pos lo-data) + (if (>= pos 16) + (%ilsr (the fixnum (- pos 16)) hi-data) + (%ilogior + (%iasr pos lo-data) + (%ilsl (the fixnum (- 16 pos)) hi-data))))))) + + + + + +; this was wrong for negative bigs when byte includes or exceeds sign +(defun %ldb-fixnum-from-bignum (bignum size position) + (declare (fixnum size position)) + (let* ((low-idx (ash position -5)) + (low-bit (logand position 31)) + (hi-bit (+ low-bit size)) + (len (%bignum-length bignum)) + (minusp (bignum-minusp bignum))) + (declare (fixnum size position low-bit hi-bit low-idx len)) + (if (>= low-idx len) + (if minusp (1- (ash 1 size)) 0) + (multiple-value-bind (hi lo)(%bignum-ref bignum low-idx) + (let ((chunk-lo (ldb32 hi lo (min size (%i- 32 low-bit)) low-bit))) + (let ((val + (if (< hi-bit 32) + chunk-lo + (progn + (setq low-idx (1+ low-idx)) + (multiple-value-setq (hi lo) + (if (>= low-idx len) + (if minusp (values #xffff #xffff)(values 0 0)) + (%bignum-ref bignum low-idx))) + (let ((chunk-hi (ldb32 hi lo (%i- size (%i- 32 low-bit)) 0))) + (%ilogior (ash chunk-hi (%i- 32 low-bit)) chunk-lo)))))) + val)))))) + +(defun load-byte (size position integer) + (if (and (bignump integer) + (<= size (- 31 target::fixnumshift)) + (fixnump position)) + (%ldb-fixnum-from-bignum integer size position) + (let ((mask (byte-mask size))) + (if (and (fixnump mask) (fixnump integer)(fixnump position)) + (%ilogand mask (%iasr position integer)) + (logand mask (ash integer (- position))))))) + + +#+safe-but-slow +(defun %bignum-bignum-gcd (u v) + (setq u (abs u) v (abs v)) + (do* ((g 1 (ash g 1))) + ((or (oddp u) (oddp v)) + (do* () + ((zerop u) (* g v)) + (cond ((evenp u) (setq u (ash u -1))) + ((evenp v) (setq v (ash v -1))) + (t (let* ((temp (ash (abs (- u v)) -1))) + (if (< u v) + (setq v temp) + (setq u temp))))))) + (setq u (ash u -1) v (ash v -1)))) + + +(defun %positive-bignum-bignum-gcd (u0 v0) + (let* ((u-len (%bignum-length u0)) + (v-len (%bignum-length v0))) + (declare (fixnum u-len v-len)) + (if (or (< u-len v-len) + (and (= u-len v-len) + (< (bignum-compare u0 v0) 0))) + (psetq u0 v0 v0 u0 u-len v-len v-len u-len)) + (with-bignum-buffers ((u u-len) + (u2 u-len) + (v v-len) + (v2 v-len)) + (bignum-replace u u0) + (bignum-replace v v0) + (let* ((u-trailing-0-bits (%bignum-count-trailing-zero-bits u)) + (u-trailing-0-digits (ash u-trailing-0-bits -5)) + (v-trailing-0-bits (%bignum-count-trailing-zero-bits v)) + (v-trailing-0-digits (ash v-trailing-0-bits -5))) + (declare (fixnum u-trailing-0-bits v-trailing-0-bits)) + (unless (zerop u-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len u-trailing-0-digits )))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u))) + (unless (zerop v-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v))) + (let* ((shift (min u-trailing-0-bits + v-trailing-0-bits))) + (loop + (let* ((fix-u (and (= u-len 1) + (let* ((hi-u (%bignum-ref-hi u 0))) + (declare (fixnum hi-u)) + (= hi-u (the fixnum + (logand hi-u (ash target::target-most-positive-fixnum -16))))) + (uvref u 0))) + (fix-v (and (= v-len 1) + (let* ((hi-v (%bignum-ref-hi v 0))) + (declare (fixnum hi-v)) + (= hi-v (the fixnum + (logand hi-v (ash target::target-most-positive-fixnum -16))))) + (uvref v 0)))) + (if fix-v + (if fix-u + (return (ash (%fixnum-gcd fix-u fix-v) shift)) + (return (ash (bignum-fixnum-gcd u fix-v) shift))) + (if fix-u + (return (ash (bignum-fixnum-gcd v fix-u) shift))))) + + (let* ((signum (if (> u-len v-len) + 1 + (if (< u-len v-len) + -1 + (bignum-compare u v))))) + (declare (fixnum signum)) + (case signum + (0 ; (= u v) + (if (zerop shift) + (let* ((copy (%allocate-bignum u-len))) + (bignum-replace copy u) + (return copy)) + (return (ash u shift)))) + (1 ; (> u v) + (bignum-subtract-loop u u-len v v-len u) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)) + (setq u-trailing-0-bits + (%bignum-count-trailing-zero-bits u) + u-trailing-0-digits + (ash u-trailing-0-bits -5)) + (unless (zerop u-trailing-0-bits) + (%init-misc 0 u2) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len + u-trailing-0-digits)))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)))) + (t ; (> v u) + (bignum-subtract-loop v v-len u u-len v) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)) + (setq v-trailing-0-bits + (%bignum-count-trailing-zero-bits v) + v-trailing-0-digits + (ash v-trailing-0-bits -5)) + (unless (zerop v-trailing-0-bits) + (%init-misc 0 v2) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)))))))))))) + +(defun %bignum-bignum-gcd (u v) + (with-negated-bignum-buffers u v %positive-bignum-bignum-gcd)) + +(defun unsignedwide->integer (uwidep) + (with-bignum-buffers ((b 3)) + (setf (uvref b 0) (%get-unsigned-long uwidep 4) + (uvref b 1) (%get-unsigned-long uwidep 0)) + (let* ((n (%normalize-bignum b))) + (if (typep n 'bignum) + (copy-bignum n) + n)))) + +(defun one-bignum-factor-of-two (a) + (declare (type bignum-type a)) + (let ((len (%bignum-length a))) + (declare (fixnum len)) + (dotimes (i len) + (multiple-value-bind (a-h a-l) (%bignum-ref a i) + (declare (fixnum a-h a-l)) + (unless (and (= a-h 0)(= a-l 0)) + (return (+ (%ilsl 5 i) + (let* ((j 0) + (a a-l)) + (declare (fixnum a j)) + (if (= a-l 0) (setq j 16 a a-h)) + (dotimes (i 16) + (if (oddp a) + (return (%i+ j i)) + (setq a (%iasr 1 a)))))))))))) + +(defun logbitp (index integer) + "Predicate returns T if bit index of integer is a 1." + (number-case index + (fixnum + (if (minusp (the fixnum index))(report-bad-arg index '(integer 0)))) + (bignum + ;; assuming bignum cant have more than most-positive-fixnum bits + ;; (2 expt 24 longs) + (if (bignum-minusp index)(report-bad-arg index '(integer 0))) + ;; should error if integer isn't + (return-from logbitp (minusp (require-type integer 'integer))))) + (number-case integer + (fixnum + (if (%i< index (- target::nbits-in-word target::fixnumshift)) + (%ilogbitp index integer) + (minusp (the fixnum integer)))) + (bignum + (let ((bidx (%iasr 5 index)) + (bbit (%ilogand index 31))) + (declare (fixnum bidx bbit)) + (if (>= bidx (%bignum-length integer)) + (bignum-minusp integer) + (multiple-value-bind (hi lo) (%bignum-ref integer bidx) + (declare (fixnum hi lo)) + (if (> bbit 15) + (%ilogbitp (%i- bbit 16) hi) + (%ilogbitp bbit lo)))))))) + +) ; #+32-bit-target Index: /branches/qres/ccl/level-0/l0-bignum64.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-bignum64.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-bignum64.lisp (revision 13564) @@ -0,0 +1,2207 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +#+64-bit-target +(eval-when (:compile-toplevel :execute) + (require "ARCH") + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") + + (defsetf bignum-ref bignum-set) + + (defconstant digit-size 32) + (defconstant half-digit-size (/ digit-size 2)) + + (defconstant maximum-bignum-length (1- (ash 1 56))) + (defconstant all-ones-digit #xffffffff) + (deftype bignum-index () `(integer 0 (,maximum-bignum-length))) + (deftype bignum-element-type () `(unsigned-byte ,digit-size)) + (deftype bignum-half-element-type () `(unsigned-byte ,half-digit-size)) + (deftype bignum-type () 'bignum) + (defmacro %normalize-bignum-macro (big) + `(%normalize-bignum-2 t ,big)) + + (defmacro %mostly-normalize-bignum-macro (big) + `(%normalize-bignum-2 nil ,big)) + (defmacro %lognot (x) + `(logand #xffffffff (lognot (the fixnum ,x)))) + (defmacro %logior (x y) + `(logior (the fixnum ,x) (the fixnum ,y))) + (defmacro %logxor (x y) + `(logand #xffffffff (logxor (the fixnum ,x) (the fixnum ,y)))) + + ;;; BIGNUM-REPLACE -- Internal. + ;;; + (defmacro bignum-replace (dest src &key (start1 '0) end1 (start2 '0) end2 + from-end) + (once-only ((n-dest dest) + (n-src src)) + (if (and (eq start1 0)(eq start2 0)(null end1)(null end2)(null from-end)) + ;; this is all true for some uses today << + `(%copy-ivector-to-ivector ,n-src 0 ,n-dest 0 (%ilsl 2 (min (the fixnum (%bignum-length ,n-src)) + (the fixnum (%bignum-length ,n-dest))))) + (let* ((n-start1 (gensym)) + (n-end1 (gensym)) + (n-start2 (gensym)) + (n-end2 (gensym))) + `(let ((,n-start1 ,start1) + (,n-start2 ,start2) + (,n-end1 ,(or end1 `(%bignum-length ,n-dest))) + (,n-end2 ,(or end2 `(%bignum-length ,n-src)))) + ,(if (null from-end) + `(%copy-ivector-to-ivector + ,n-src (%i* 4 ,n-start2) + ,n-dest (%i* 4 ,n-start1) + (%i* 4 (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + `(let ((nwds (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + (%copy-ivector-to-ivector + ,n-src (%ilsl 2 (%i- ,n-end2 nwds)) + ,n-dest (%ilsl 2 (%i- ,n-end1 nwds)) + (%i* 4 nwds))))))))) + + + ;;;; Shifting. + + (defconstant all-ones-half-digit #xFFFF) + + +;;; %ALLOCATE-BIGNUM must zero all elements. +;;; + (defmacro %allocate-bignum (ndigits) + `(%alloc-misc ,ndigits target::subtag-bignum)) + + (declaim (inline %bignum-length)) + +;;; This macro is used by BIGNUM-ASHIFT-RIGHT, +;;; BIGNUM-BUFFER-ASHIFT-RIGHT, and BIGNUM-LDB-BIGNUM-RES. They supply +;;; a termination form that references locals established by this +;;; form. Source is the source bignum. Start-digit is the first digit +;;; in source from which we pull bits. Start-pos is the first bit we +;;; want. Res-len-form is the form that computes the length of the +;;; resulting bignum. Termination is a DO termination form with a test +;;; and body. When result is supplied, it is the variable to which +;;; this binds a newly allocated bignum. +;;; +;;; Given start-pos, 1-31 inclusively, of shift, we form the j'th resulting +;;; digit from high bits of the i'th source digit and the start-pos number of +;;; bits from the i+1'th source digit. + (defmacro shift-right-unaligned (source + start-digit + start-pos + res-len-form + termination + &optional result) + `(let* ((high-bits-in-first-digit (- digit-size ,start-pos)) + (res-len ,res-len-form) + (res-len-1 (1- res-len)) + ,@(if result `((,result (%allocate-bignum res-len))))) + (declare (type bignum-index res-len res-len-1)) + (do ((i ,start-digit i+1) + (i+1 (1+ ,start-digit) (1+ i+1)) + (j 0 (1+ j))) + ,termination + (declare (type bignum-index i i+1 j)) + (setf (bignum-ref ,(if result result source) j) + (%logior (%digit-logical-shift-right (bignum-ref ,source i) + ,start-pos) + (%ashl (bignum-ref ,source i+1) + high-bits-in-first-digit)))))) + + + ) + + +#+64-bit-target +(progn + +;;; Extract the length of the bignum. +;;; +(defun %bignum-length (bignum) + (uvsize bignum)) + + + +;;; We can probably do better than UVREF here, but +;;; a) it's not -that- bad +;;; b) it does some bounds/sanity checking, which isn't a bad idea. + +(defmacro bignum-ref (b i) + `(%typed-miscref :bignum ,b ,i)) + +(defmacro bignum-set (b i val) + `(%typed-miscset :bignum ,b ,i ,val)) + + +(defun bignum-plusp (b) + (not (logbitp (1- digit-size) (the bignum-element-type (bignum-ref b (1- (%bignum-length b))))))) + +;;; Return T if digit is positive, or NIL if negative. +(defun %digit-0-or-plusp (digit) + (declare (type bignum-element-type digit)) + (not (logbitp (1- digit-size) digit))) + +(defun %bignum-0-or-plusp (bignum len) + (declare (type bignum-type bignum) + (type bignum-index len)) + (%digit-0-or-plusp (bignum-ref bignum (1- len)))) + +(defun bignum-minusp (b) + (logbitp 31 (the fixnum (bignum-ref b (1- (%bignum-length b)))))) + +(defun %sign-digit (b i) + (%ashr (bignum-ref b (1- i)) (1- digit-size))) + +;;; Return the sign of bignum (0 or -1) as a fixnum +(defun %bignum-sign (b) + (if (logbitp 31 (the fixnum (bignum-ref b (1- (%bignum-length b))))) + -1 + 0)) + + +(defun %add-with-carry (a-digit b-digit carry-in) + (declare (fixnum a-digit b-digit carry-in)) + (setq a-digit (logand all-ones-digit a-digit) + b-digit (logand all-ones-digit b-digit)) + (let* ((sum (+ carry-in (the fixnum (+ a-digit b-digit))))) + (declare (fixnum sum)) + (values (logand all-ones-digit sum) (logand 1 (the fixnum (ash sum -32)))))) + +(defun %subtract-with-borrow (a-digit b-digit borrow-in) + (declare (fixnum a-digit b-digit borrow-in)) + (setq a-digit (logand all-ones-digit a-digit) + b-digit (logand all-ones-digit b-digit)) + (let* ((diff (- (the fixnum (- a-digit b-digit)) + (the fixnum (- 1 borrow-in))))) + (declare (fixnum diff)) + (values (logand all-ones-digit diff) + (- 1 (logand (the fixnum (ash diff -32)) 1))))) + + + +(defun %compare-digits (bignum-a bignum-b idx) + (let* ((a (bignum-ref bignum-a idx)) + (b (bignum-ref bignum-b idx))) + (declare (fixnum a b)) + (if (= a b) + 0 + (if (> a b) + 1 + -1)))) + + + +;;;; Addition. +(defun add-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (bignum-index len-a len-b) + (optimize (speed 3) (safety 0))) + (when (> len-b len-a) + (rotatef a b) + (rotatef len-a len-b)) + (let* ((len-res (1+ len-a)) + (res (%allocate-bignum len-res)) + (carry 0) + (sign-b (%bignum-sign b))) + (dotimes (i len-b) + (let* ((sum (+ + (the fixnum (+ (the bignum-element-type (bignum-ref a i)) + (the bignum-element-type (bignum-ref b i)))) + carry))) + (declare (fixnum sum)) + (setf (bignum-ref res i) sum) + (setq carry (logand 1 (the fixnum (ash sum -32)))))) + (if (/= len-a len-b) + (finish-bignum-add res carry a sign-b len-b len-a) + (setf (bignum-ref res len-a) + (+ (the fixnum carry) + (the fixnum (+ (the bignum-element-type (%bignum-sign a)) + sign-b))))) + (%normalize-bignum-macro res)))) + +(defun add-bignum-and-fixnum (bignum fixnum) + (declare (bignum-type bignum) + (fixnum fixnum) + (optimize (speed 3) (safety 0))) + (let* ((len-bignum (%bignum-length bignum)) + (len-res (1+ len-bignum)) + (res (%allocate-bignum len-res)) + (low (logand all-ones-digit fixnum)) + (high (logand all-ones-digit (the fixnum (ash fixnum -32))))) + (declare (bignum-index len-bignum) + (bignum-type res) + (bignum-element-type low high)) + (let* ((sum0 (+ (the bignum-element-type (bignum-ref bignum 0)) low)) + (sum1 (+ (the fixnum (+ (the bignum-element-type (bignum-ref bignum 1)) + high)) + (the fixnum (logand 1 (ash sum0 -32))))) + (carry (logand 1 (ash sum1 -32)))) + (declare (fixnum sum0 sum1) (bignum-element-type carry)) + (setf (bignum-ref res 0) sum0 + (bignum-ref res 1) sum1) + (if (> len-bignum 2) + (finish-bignum-add res carry bignum (ash fixnum (- (- target::nbits-in-word target::fixnumshift))) 2 len-bignum) + (setf (bignum-ref res 2) + (+ (the fixnum carry) + (the fixnum (+ (the bignum-element-type (%bignum-sign bignum)) + (the fixnum (ash fixnum (- (- target::nbits-in-word target::fixnumshift))))))))) + (%normalize-bignum-macro res)))) + + + + + +;;; B was shorter than A; keep adding B's sign digit to each remaining +;;; digit of A, propagating the carry. +(defun finish-bignum-add (result carry a sign-b start end) + (declare (type bignum-index start end) + (bignum-element-type sign-b carry) + (optimize (speed 3) (safety 0))) + (do* ((i start (1+ i)) + (sign-b (logand all-ones-digit sign-b))) + ((= i end) + (setf (bignum-ref result end) + (the fixnum (+ + (the fixnum (+ (the fixnum + (logand all-ones-digit + (the fixnum + (%sign-digit a end)))) + sign-b)) + carry)))) + (declare (fixnum i) (bignum-element-type sign-b)) + (let* ((sum (the fixnum (+ (the fixnum (+ (bignum-ref a i) + sign-b)) + carry)))) + (declare (fixnum sum)) + (setf (bignum-ref result i) sum) + (setq carry (logand 1 (the fixnum (ash sum -32))))))) + + + + + +;;;; Subtraction. +(defun subtract-bignum (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (1+ (max len-a len-b))) + (res (%allocate-bignum len-res))) + (declare (bignum-index len-a len-b len-res)) + (bignum-subtract-loop a len-a b len-b res) + (%normalize-bignum-macro res))) + +(defun bignum-subtract-loop (a len-a b len-b res) + (declare (bignum-index len-a len-b ) + (optimize (speed 3) (safety 0))) + (let* ((len-res (%bignum-length res))) + (declare (bignum-index len-res)) + (let* ((borrow 1) + (sign-a (%bignum-sign a)) + (sign-b (%bignum-sign b))) + (declare (bignum-element-type borrow sign-a sign-b)) + (dotimes (i (the bignum-index len-res)) + (multiple-value-bind (result-digit borrow-out) + (%subtract-with-borrow + (if (< i len-a) + (bignum-ref a i) + sign-a) + (if (< i len-b) + (bignum-ref b i) + sign-b) + borrow) + (setf (bignum-ref res i) result-digit + borrow borrow-out)))))) + + + +;;;; Multiplication. + +#|| +;;; These parameters match GMP's. +(defvar *sqr-basecase-threshold* 5) +(defvar *sqr-karatsuba-threshold* 22) +(defvar *mul-karatsuba-threshold* 10) + +;;; Squaring is often simpler than multiplication. This should never +;;; be called with (>= N *sqr-karatsuba-threshold*). +(defun mpn-sqr-basecase (prodp up n) + (declare (fixnum prodp up n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (umulppm up up prodp) + (when (> n 1) + (%stack-block ((tarr (* 4 (* 2 *sqr-karatsuba-threshold*)))) + (let* ((tp (macptr->fixnum tarr))) + (mpn-mul-1 tp + (the fixnum (1+ up)) + (the fixnum (1- n)) + up + (the fixnum (+ tp (the fixnum (1- n))))) + (do* ((i 2 (1+ i))) + ((= i n)) + (declare (fixnum i)) + (mpn-addmul-1 (the fixnum (- (the fixnum (+ tp (the fixnum (+ i i)))) + 2)) + (the fixnum (+ up i)) + (the fixnum (- n i)) + (the fixnum (+ up (the fixnum (1- i)))) + (the fixnum (+ tp (the fixnum (+ n (the fixnum (- i 2)))))))) + (do* ((i 1 (1+ i)) + (ul (1+ up) (1+ ul))) + ((= i n)) + (declare (fixnum i ul)) + (umulppm ul ul (the fixnum (+ prodp (the fixnum (+ i i)))))) + (let* ((2n-2 (- (the fixnum (+ n n)) 2)) + (carry (mpn-lshift-1 tp tp 2n-2))) + (declare (fixnum 2n-2 carry)) + (incf carry (the fixnum (mpn-add-n (the fixnum (1+ prodp)) + (the fixnum (1+ prodp)) + tp + 2n-2))) + (add-fixnum-to-limb carry (the fixnum (+ prodp + (the fixnum (1- + (the fixnum + (+ n n)))))))))))) + +;;; For large enough values of N, squaring via Karatsuba-style +;;; divide&conquer is faster than in the base case. +(defun mpn-kara-sqr-n (p a n ws) + (declare (fixnum p a n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (n2 (ash n -1)) + (x 0) + (y 0) + (i 0)) + (declare (fixnum w w0 w1 xx n2 x y i)) + (cond ((logbitp 0 n) + ;; Odd length + (let* ((n3 (- n n2)) + (n1 0) + (nm1 0)) + (declare (fixnum n3 n1 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum + (- (the fixnum (mpn-sub-n p a (the fixnum (+ a n3)) n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a) + (setq y (+ a n3) + x a)) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (setq n1 (1+ n)) + (cond ((< n3 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n3 p n3) + (mpn-mul-basecase p a n3 a n3)) + ((< n3 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n3) + (mpn-sqr-basecase p a n3)) + (t + (mpn-kara-sqr-n ws p n3 (the fixnum (+ ws n1))) + (mpn-kara-sqr-n p a n3 (the fixnum (+ ws n1))))) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ a n3)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2)) + (t + (mpn-kara-sqr-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ ws n1))))) + (mpn-sub-n ws p ws n1) + (setq nm1 (1- n)) + (unless (zerop (the fixnum + (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop + (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n1 n3)))) + 1)))) + (t ; N is even + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a) + (setq y (+ a n2) + x a)) + (mpn-sub-n p x y n2) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n2 p n2) + (mpn-mul-basecase p a n2 a n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ a n2)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n2) + (mpn-sqr-basecase p a n2) + (mpn-sqr-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2)) + (t + (mpn-kara-sqr-n ws p n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n p a n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (- (the fixnum (mpn-sub-n ws p ws n))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Karatsuba subroutine: multiply A and B, store result at P, use WS +;;; as scrach space. Treats A and B as if they were both of size N; +;;; if that's not true, caller must fuss around the edges. +(defun mpn-kara-mul-n (p a b n ws) + (declare (fixnum p a b n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (x 0) + (y 0) + (i 0) + (n2 (ash n -1)) + (sign 0)) + (declare (fixnum w w0 w1 xx x y i n2 sign)) + (cond ((logbitp 0 n) + (let* ((n1 0) + (n3 (- n n2)) + (nm1 0)) + (declare (fixnum n1 n3 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (mpn-sub-n p a (the fixnum (+ a n3)) n2))) w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a + sign -1) + (setq x a + y (+ a n3))) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (copy-limb (the fixnum (+ b n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (the fixnum (mpn-sub-n (the fixnum (+ p n3)) + b + (the fixnum (+ b n3)) + n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n3) + y b + sign (lognot sign)) + (setq x b + y (+ b n3))) + (mpn-sub-n (the fixnum (+ p n3)) x y n2))) + (copy-limb w (the fixnum (+ p n))) + (setq n1 (1+ n)) + (cond + ((< n2 *mul-karatsuba-threshold*) + (cond + ((< n3 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n3 (the fixnum (+ p n3)) n3) + (mpn-mul-basecase p a n3 b n3)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))))) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ b n3)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + (the fixnum (+ b n3)) + n2 + (the fixnum (+ ws n1))))) + (if (not (zerop sign)) + (mpn-add-n ws p ws n1) + (mpn-sub-n ws p ws n1)) + (setq nm1 (1- n)) + (unless (zerop (the fixnum (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum + (+ p (the fixnum (+ n1 n3)))) 1)))) + (t ; even length + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (setq sign 0) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a + sign -1) + (setq x a + y (+ a n2))) + (mpn-sub-n p x y n2) + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n2) + y b + sign (lognot sign)) + (setq x b + y (+ b n2))) + (mpn-sub-n (the fixnum (+ p n2)) x y n2) + (cond + ((< n2 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n2 (the fixnum (+ p n2)) n2) + (mpn-mul-basecase p a n2 b n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ b n2)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n2)) n2 + (the fixnum (+ ws n))) + (mpn-kara-mul-n p a b n2 (the fixnum (+ ws n))) + (mpn-kara-mul-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + (the fixnum (+ b n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (if (not (zerop sign)) + (mpn-add-n ws p ws n) + (- (the fixnum (mpn-sub-n ws p ws n)))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Square UP, of length UN. I wonder if a Karatsuba multiply might be +;;; faster than a basecase square. +(defun mpn-sqr-n (prodp up un) + (declare (fixnum prodp up un)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< un *sqr-basecase-threshold*) + (mpn-mul-basecase prodp up un up un) + (if (< un *sqr-karatsuba-threshold*) + (mpn-sqr-basecase prodp up un) + (%stack-block ((wsptr (mpn-kara-sqr-n-tsize un))) + (mpn-kara-sqr-n prodp up un (macptr->fixnum wsptr)))))) + +;;; Subroutine: store AxB at P. Assumes A & B to be of length N +(defun mpn-mul-n (p a b n) + (declare (fixnum p a b n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< n *mul-karatsuba-threshold*) + (mpn-mul-basecase p a n b n) + (%stack-block ((wsptr (mpn-kara-mul-n-tsize n))) + (mpn-kara-mul-n p a b n (macptr->fixnum wsptr))))) + + +;;; Multiply [UP,UN] by [VP,VN]. UN must not be less than VN. +;;; This does Karatsuba if operands are big enough; if they are +;;; and they differ in size, this computes the product of the +;;; smaller-size slices, then fixes up the resut. +(defun mpn-mul (prodp up un vp vn) + (declare (fixnum prodp up un vp vn)) + (declare (optimize (speed 3) (safety 0) (space 0))) + ;(assert (>= un vn 1)) + (if (and (= up vp) (= un vn)) + (mpn-sqr-n prodp up un) + (if (< vn *mul-karatsuba-threshold*) + (mpn-mul-basecase prodp up un vp vn) + (let* ((l vn)) + (declare (fixnum l)) + (mpn-mul-n prodp up vp vn) + (unless (= un vn) + (incf prodp vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq un vn vn un up vp vp up)) + (%stack-block ((wsptr + (the fixnum + (+ 8 + (the fixnum + (* 4 + (the fixnum + (+ vn + (if (>= vn *mul-karatsuba-threshold*) + vn + un))))))))) + (setf (%get-unsigned-long wsptr 0) 0 + (%get-unsigned-long wsptr 4) 0) + (let* ((tt (macptr->fixnum wsptr)) + (c (1+ tt)) + (ws (1+ c))) + (declare (fixnum tt c ws )) + (do* () + ((< vn *mul-karatsuba-threshold*)) + (mpn-mul-n ws up vp vn) + (cond ((<= l (the fixnum (+ vn vn))) + (add-fixnum-to-limb (mpn-add-n prodp prodp ws l) tt) + (unless (= l (the fixnum (+ vn vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ vn vn)) l)) + tt) + tt) + (setq l (the fixnum (+ vn vn))))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ vn vn))) c) + (add-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (- l (the fixnum (+ vn vn)))) + c) + tt))) + (incf prodp vn) + (decf l vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq up vp vp up un vn vn un))) + (unless (zerop vn) + (mpn-mul-basecase ws up un vp vn) + (cond ((<= l (the fixnum (+ un vn))) + (add-fixnum-to-limb + (mpn-add-n prodp prodp ws l) + tt) + (unless (= l (the fixnum (+ un vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ un vn)) l)) + tt) + tt))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ un vn))) + c) + (add-fixnum-to-limb + (mpn-add-1 + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (- (the fixnum (- l un)) vn)) + c) + tt))))))))))) +||# + +(defun multiply-bignums (a b) + (let* ((signs-differ (not (eq (bignum-minusp a) (bignum-minusp b))))) + (flet ((multiply-unsigned-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (+ len-a len-b)) + (res (%allocate-bignum len-res))) + (declare (bignum-index len-a len-b len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (%multiply-and-add-loop a b res i len-b)) + res)) + (multiply-unsigned-bignums64 (a b) + (let* ((len-a (ceiling (%bignum-length a) 2)) + (len-b (ceiling (%bignum-length b) 2)) + (len-res (+ len-a len-b)) + (res (%allocate-bignum (+ len-res len-res)))) + (declare (bignum-index len-a len-b len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (%multiply-and-add-loop64 a b res i len-b)) + res))) + (let* ((res (with-negated-bignum-buffers a b + multiply-unsigned-bignums64))) + (if signs-differ (negate-bignum-in-place res)) + (%normalize-bignum-macro res))))) + +(defun multiply-bignum-and-fixnum (bignum fixnum) + (declare (type bignum-type bignum) (fixnum fixnum)) + (if (eql fixnum 1) + bignum + (with-small-bignum-buffers ((big-fix fixnum)) + (multiply-bignums bignum big-fix)))) + +#+slower +(defun multiply-bignum-and-fixnum (bignum fixnum) + (declare (type bignum-type bignum) (fixnum fixnum)) + (if (eql fixnum 1) + bignum + (if (eql fixnum target::target-most-negative-fixnum) + (with-small-bignum-buffers ((big-fix fixnum)) + (multiply-bignums bignum big-fix)) + (let* ((big-len (%bignum-length bignum)) + (big-neg (bignum-minusp bignum)) + (signs-differ (not (eq big-neg (minusp fixnum))))) + (flet ((multiply-unsigned-bignum-and-2-digit-fixnum (a len-a high low) + (declare (bignum-type a) + (bignum-element-type high low) + (bignum-index len-a) + (optimize (speed 3) (safety 0))) + (let* ((len-res (+ len-a 2)) + (res (%allocate-bignum len-res)) ) + (declare (bignum-index len-a len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (let* ((carry-digit 0) + (x (bignum-ref a i)) + (k i)) + (declare (fixnum k)) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add4 x + low + (bignum-ref res k) + carry-digit) + (setf (bignum-ref res k) res-digit + carry-digit big-carry + k (1+ k))) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add4 x + high + (bignum-ref res k) + carry-digit) + (setf (bignum-ref res k) res-digit + carry-digit big-carry + k (1+ k))) + (setf (bignum-ref res k) carry-digit))) + res)) + (multiply-unsigned-bignum-and-1-digit-fixnum (a len-a fix) + (declare (bignum-type a) + (bignum-element-type fix) + (bignum-index len-a) + (optimize (speed 3) (safety 0))) + (let* ((len-res (+ len-a 1)) + (res (%allocate-bignum len-res)) ) + (declare (bignum-index len-a len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (let* ((carry-digit 0) + (x (bignum-ref a i)) + (k i)) + (declare (fixnum k)) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add4 x + fix + (bignum-ref res k) + carry-digit) + (setf (bignum-ref res k) res-digit + carry-digit big-carry + k (1+ k))) + (setf (bignum-ref res k) carry-digit))) + res))) + (let* ((fixnum (if (< fixnum 0) (- fixnum) fixnum)) + (low (logand (1- (ash 1 32)) fixnum)) + (high (unless (<= (%fixnum-intlen fixnum) 32) + (ldb (byte 32 32) fixnum))) + (res (if big-neg + (let* ((neg-len (1+ big-len))) + (declare (type bignum-index neg-len)) + (with-bignum-buffers ((neg neg-len)) + (negate-bignum bignum nil neg) + (setq neg-len (%bignum-length bignum)) + (if high + (multiply-unsigned-bignum-and-2-digit-fixnum + neg + neg-len + high + low) + (multiply-unsigned-bignum-and-1-digit-fixnum + neg + neg-len + low)))) + (if high + (multiply-unsigned-bignum-and-2-digit-fixnum + bignum + big-len + high + low) + (multiply-unsigned-bignum-and-1-digit-fixnum + bignum + big-len + low))))) + (if signs-differ (negate-bignum-in-place res)) + (%normalize-bignum-macro res))))))) + + +;; assume we already know result won't fit in a fixnum +;; only caller is fixnum-*-2 +;; + +(defun multiply-fixnums (a b) + (declare (fixnum a b)) + (* a b)) + + +;;;; GCD. + + +;;; Both args are > 0. +(defun bignum-fixnum-gcd (bignum fixnum) + (let* ((rem (bignum-truncate-by-fixnum-no-quo bignum fixnum))) + (declare (fixnum rem)) + (if (zerop rem) + fixnum + (%fixnum-gcd rem fixnum)))) + + + + +;;; NEGATE-BIGNUM -- Public. +;;; +;;; Fully-normalize is an internal optional. It cause this to always return +;;; a bignum, without any extraneous digits, and it never returns a fixnum. +;;; +(defun negate-bignum (x &optional (fully-normalize t) res) + (declare (type bignum-type x)) + (let* ((len-x (%bignum-length x)) + (len-res (1+ len-x)) + (minusp (bignum-minusp x)) + (res (or res (%allocate-bignum len-res)))) + (declare (type bignum-index len-x len-res)) ;Test len-res for range? + (let ((carry (bignum-negate-loop-really x len-x res))) + (declare (fixnum carry)) + (if (zerop carry) + (setf (bignum-ref res len-x) (if minusp 0 all-ones-digit)) + (setf (bignum-ref res len-x) (if minusp 1 0)))) + (if fully-normalize + (%normalize-bignum-macro res) + (%mostly-normalize-bignum-macro res)))) + +;;; NEGATE-BIGNUM-IN-PLACE -- Internal. +;;; +;;; This assumes bignum is positive; that is, the result of negating it will +;;; stay in the provided allocated bignum. +;;; +(defun negate-bignum-in-place (bignum) + (bignum-negate-loop-really bignum (%bignum-length bignum) bignum) + bignum) + + + + +(defun copy-bignum (bignum) + (let ((res (%allocate-bignum (%bignum-length bignum)))) + (bignum-replace res bignum) + res)) + + + + +;;; BIGNUM-ASHIFT-RIGHT -- Public. +;;; +;;; First compute the number of whole digits to shift, shifting them by +;;; skipping them when we start to pick up bits, and the number of bits to +;;; shift the remaining digits into place. If the number of digits is greater +;;; than the length of the bignum, then the result is either 0 or -1. If we +;;; shift on a digit boundary (that is, n-bits is zero), then we just copy +;;; digits. The last branch handles the general case which uses a macro that a +;;; couple other routines use. The fifth argument to the macro references +;;; locals established by the macro. +;;; + + +(defun bignum-ashift-right (bignum x) + (declare (type bignum-type bignum) + (fixnum x) + (optimize (speed 3) (safety 0))) + (let ((bignum-len (%bignum-length bignum))) + (declare (type bignum-index bignum-len)) + (multiple-value-bind (digits n-bits) (truncate x digit-size) + (declare (type bignum-index digits)(fixnum n-bits)) + (cond + ((>= digits bignum-len) + (if (bignum-plusp bignum) 0 -1)) + ((eql 0 n-bits) + (bignum-ashift-right-digits bignum digits)) + (t + (shift-right-unaligned bignum digits n-bits (- bignum-len digits) + ((= j res-len-1) + (setf (bignum-ref res j) + (%ashr (bignum-ref bignum i) n-bits)) + (%normalize-bignum-macro res)) + res)))))) + + + + + +;;; BIGNUM-ASHIFT-RIGHT-DIGITS -- Internal. +;;; +(defun bignum-ashift-right-digits (bignum digits) + (declare (type bignum-type bignum) + (type bignum-index digits)) + (let* ((res-len (- (%bignum-length bignum) digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len) + (type bignum-type res)) + (bignum-replace res bignum :start2 digits) + (%normalize-bignum-macro res))) + + +;;; BIGNUM-BUFFER-ASHIFT-RIGHT -- Internal. +;;; +;;; GCD uses this for an in-place shifting operation. This is different enough +;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a +;;; macro, but they share the basic algorithm. This routine foregoes a first +;;; test for digits being greater than or equal to bignum-len since that will +;;; never happen for its uses in GCD. We did fold the last branch into a macro +;;; since it was duplicated a few times, and the fifth argument to it +;;; references locals established by the macro. +;;; + + +;;; BIGNUM-ASHIFT-LEFT -- Public. +;;; +;;; This handles shifting a bignum buffer to provide fresh bignum data for some +;;; internal routines. We know bignum is safe when called with bignum-len. +;;; First we compute the number of whole digits to shift, shifting them +;;; starting to store farther along the result bignum. If we shift on a digit +;;; boundary (that is, n-bits is zero), then we just copy digits. The last +;;; branch handles the general case. +;;; +(defun bignum-ashift-left (bignum x &optional bignum-len) + (declare (type bignum-type bignum) + (fixnum x) + (type (or null bignum-index) bignum-len)) + (multiple-value-bind (digits n-bits) + (truncate x digit-size) + (declare (fixnum digits n-bits)) + (let* ((bignum-len (or bignum-len (%bignum-length bignum))) + (res-len (+ digits bignum-len 1))) + (declare (fixnum bignum-len res-len)) + (when (> res-len maximum-bignum-length) + (error "Can't represent result of left shift.")) + (if (zerop n-bits) + (bignum-ashift-left-digits bignum bignum-len digits) + (bignum-ashift-left-unaligned bignum digits n-bits res-len))))) + +;;; BIGNUM-ASHIFT-LEFT-DIGITS -- Internal. +;;; +(defun bignum-ashift-left-digits (bignum bignum-len digits) + (declare (type bignum-index bignum-len digits)) + (let* ((res-len (+ bignum-len digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len)) + (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len + :from-end t) + res)) + + + +;;; BIGNUM-ASHIFT-LEFT-UNALIGNED -- Internal. +;;; +;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. +;;; When res comes in non-nil, then this foregoes allocating a result, and it +;;; normalizes the buffer instead of the would-be allocated result. +;;; +;;; We start storing into one digit higher than digits, storing a whole result +;;; digit from parts of two contiguous digits from bignum. When the loop +;;; finishes, we store the remaining bits from bignum's first digit in the +;;; first non-zero result digit, digits. We also grab some left over high +;;; bits from the last digit of bignum. +;;; + +(defun bignum-ashift-left-unaligned (bignum digits n-bits res-len + &optional (res nil resp)) + (declare (type bignum-index digits res-len) + (type (mod #.digit-size) n-bits)) + (let* ((remaining-bits (- digit-size n-bits)) + (res-len-1 (1- res-len)) + (res (or res (%allocate-bignum res-len)))) + (declare (type bignum-index res-len res-len-1) + (optimize (speed 3) (safety 0))) + (do ((i 0 i+1) + (i+1 1 (1+ i+1)) + (j (1+ digits) (1+ j))) + ((= j res-len-1) + (setf (bignum-ref res digits) + (%ashl (bignum-ref bignum 0) n-bits)) + (setf (bignum-ref res j) + (%ashr (bignum-ref bignum i) remaining-bits)) + (if resp + (%zero-trailing-sign-digits res res-len) + (%mostly-normalize-bignum-macro res))) + (declare (type bignum-index i i+1 j)) + (setf (bignum-ref res j) + (%logior (%digit-logical-shift-right (bignum-ref bignum i) + remaining-bits) + (%ashl (bignum-ref bignum i+1) n-bits)))))) + + + + + + + + +;;;; Relational operators. + + + +;;; BIGNUM-COMPARE -- Public. +;;; +;;; This compares two bignums returning -1, 0, or 1, depending on whether a +;;; is less than, equal to, or greater than b. +;;; +;(proclaim '(function bignum-compare (bignum bignum) (integer -1 1))) +(defun bignum-compare (a b) + (declare (type bignum-type a b)) + (let* ((a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (if (eq a-plusp b-plusp) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (cond ((= len-a len-b) + (do* ((i (1- len-a) (1- i))) + ((zerop i) (%compare-digits a b 0)) + (declare (fixnum i)) + (let* ((signum (%compare-digits a b i))) + (declare (fixnum signum)) + (unless (zerop signum) + (return signum))))) + ((> len-a len-b) + (if a-plusp 1 -1)) + (t (if a-plusp -1 1)))) + (if a-plusp 1 -1)))) + + + + + + + +;;;; Integer length and logcount + + +(defun bignum-integer-length (big) + (the fixnum (- (the fixnum (ash (the fixnum (%bignum-length big)) 5)) + (the fixnum (%bignum-sign-bits big))))) + +; (not (zerop (logand integer1 integer2) + +(defun bignum-logtest (num1 num2) + (let* ((length1 (%bignum-length num1)) + (length2 (%bignum-length num2)) + (n1-minusp (bignum-minusp num1)) + (n2-minusp (bignum-minusp num2))) + (declare (fixnum length1 length2)) + (if (and n1-minusp n2-minusp) ; both neg, get out quick + T + (or (dotimes (i (min length1 length2)) + (unless (zerop (the fixnum + (logand (the fixnum (bignum-ref num1 i)) + (the fixnum (bignum-ref num2 i))))) + (return t))) + (if (< length1 length2) + n1-minusp + (if (< length1 length2) + n2-minusp)))))) + +(defun logtest-fix-big (fix big) + (declare (fixnum fix)) + (unless (zerop fix) + (if (plusp fix) + (or + (not (eql 0 (the fixnum (logand (the fixnum (bignum-ref big 0)) fix)))) + (and (> (%bignum-length big) 1) + (not (eql 0 (the fixnum (logand (the fixnum (bignum-ref big 1)) + (the fixnum (ash fix -32)))))))) + t))) + + +(defun bignum-logcount (bignum) + (declare (type bignum-type bignum)) + (let* ((length (%bignum-length bignum)) + (plusp (bignum-plusp bignum)) + (result 0)) + (declare (type bignum-index length) + (fixnum result)) + (if plusp + (dotimes (index length result) + (incf result (the fixnum (%logcount bignum index)))) + (dotimes (index length result) + (incf result (the fixnum (%logcount-complement bignum index))))))) + + + +;;;; Logical operations. + +;;; NOT. +;;; + +;;; BIGNUM-LOGICAL-NOT -- Public. +;;; +(defun bignum-logical-not (a) + (declare (type bignum-type a)) + (let* ((len (%bignum-length a)) + (res (%allocate-bignum len))) + (declare (type bignum-index len)) + (dotimes (i len res) + (bignum-set res i (%lognot (the fixnum (bignum-ref a i))))))) + + + + +;;; AND. +;;; + +;;; BIGNUM-LOGICAL-AND -- Public. +;;; +(defun bignum-logical-and (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (shorter a) + (longer b) + (shorter-len len-a) + (longer-len len-b) + (shorter-positive (bignum-plusp a))) + (declare (type bignum-index len-a len-b shorter-len longer-len)) + (when (< len-b len-a) + (setq shorter b + longer a + shorter-len len-b + longer-len len-a + shorter-positive (bignum-plusp b))) + (let* ((result (%allocate-bignum longer-len))) + (%bignum-logand shorter-len shorter longer result) + (unless shorter-positive + (bignum-replace result longer :start1 shorter-len :start2 shorter-len :end1 longer-len :end2 longer-len)) + (%normalize-bignum-macro result)))) + + +;;; +;;; +;;; bignum-logandc2 + +(defun bignum-logandc2 (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (logandc2-shorter-any a len-a b len-b (if a-plusp (%allocate-bignum len-a) (%allocate-bignum len-b)))) + ((< len-b len-a) ; b shorter + (logandc1-shorter-any b len-b a len-a (if b-plusp (%allocate-bignum len-a)(%allocate-bignum len-b)))) + (t (logandc2-shorter-any a len-a b len-b (%allocate-bignum len-a)))))) + +(defun logandc2-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logand (the fixnum (bignum-ref a i)) + (the fixnum (%lognot (the fixnum (bignum-ref b i))))))) + (if (bignum-minusp a) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) + (%lognot (the fixnum (bignum-ref b i)))))) + (%normalize-bignum-macro res)) + + + +(defun logandc1-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logand + (the fixnum (%lognot (the fixnum (bignum-ref a i)))) + (the fixnum (bignum-ref b i))))) + (when (bignum-plusp a) + (unless (= len-a len-b) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b))) + (%normalize-bignum-macro res)) + + + +(defun fix-big-logand (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logand fix big res))) + (if res + (progn + (bignum-replace res big :start1 2 :start2 2 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + +(defun fix-big-logandc2 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc2 fix big res))) + (if res + (progn + (do ((i 2 (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) + (%lognot (bignum-ref big i)))) + (%normalize-bignum-macro res)) + val)))) + +(defun fix-big-logandc1 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (>= fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc1 fix big res))) + (if res + (progn + (bignum-replace res big :start1 2 :start2 2 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + +;;; IOR. +;;; + +;;; BIGNUM-LOGICAL-IOR -- Public. +;;; +(defun bignum-logical-ior (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (longer-len len-b) + (shorter-len len-a) + (shorter a) + (longer b) + (shorter-positive (bignum-plusp a))) + (declare (type bignum-index len-a len-b longer-len shorter-len)) + (when (< len-b len-a) + (setq shorter b + longer a + shorter-len len-b + longer-len len-a + shorter-positive (bignum-plusp b))) + (let* ((result (%allocate-bignum longer-len))) + (%bignum-logior shorter-len shorter longer result) + (unless (= shorter-len longer-len) + (if shorter-positive + (bignum-replace result longer :start1 shorter-len :start2 shorter-len :end1 longer-len :end2 longer-len) + (do* ((i shorter-len (1+ i))) + ((= i longer-len)) + (declare (type bignum-index i)) + (setf (bignum-ref result i) #xffffffff)))) + (%normalize-bignum-macro result)))) + + + +;;; XOR. +;;; + +;;; BIGNUM-LOGICAL-XOR -- Public. +;;; +(defun bignum-logical-xor (a b) + (declare (type bignum-type a b)) + (let ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (if (< len-a len-b) + (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) + (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) + +;;; BIGNUM-LOGICAL-XOR-AUX -- Internal. +;;; +;;; This takes the the shorter of two bignums in a and len-a. Res is len-b +;;; long. Do the XOR. +;;; +(defun bignum-logical-xor-aux (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (%logxor (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (unless (= len-a len-b) + (let ((sign (if (bignum-minusp a) all-ones-digit 0))) + (declare (fixnum sign)) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) + (%logxor (bignum-ref b i) sign))))) + (%normalize-bignum-macro res)) + + + +;;;; TRUNCATE + +;;; Divide X by Y when Y is a single bignum digit. BIGNUM-TRUNCATE +;;; fixes up the quotient and remainder with respect to sign and +;;; normalization. +;;; +;;; We don't have to worry about shifting Y to make its most +;;; significant digit sufficiently large for %FLOOR to return +;;; digit-size quantities for the q-digit and r-digit. If Y is +;;; a single digit bignum, it is already large enough for +;;; %FLOOR. That is, it has some bits on pretty high in the +;;; digit. + +(defun bignum-truncate-single-digit (x len-x y) + (declare (type bignum-index len-x)) + (let ((q (%allocate-bignum len-x)) + (r 0) + (y (bignum-ref y 0))) + (declare (type bignum-element-type r y)) + (do ((i (1- len-x) (1- i))) + ((minusp i)) + (multiple-value-bind (q-digit r-digit) + (%floor r (bignum-ref x i) y) + (declare (type bignum-element-type q-digit r-digit)) + (setf (bignum-ref q i) q-digit) + (setf r r-digit))) + (let ((rem (%allocate-bignum 1))) + (setf (bignum-ref rem 0) r) + (values q rem)))) + +;;; This returns a guess for the next division step. Y1 is the +;;; highest y digit, and y2 is the second to highest y +;;; digit. The x... variables are the three highest x digits +;;; for the next division step. +;;; +;;; From Knuth, our guess is either all ones or x-i and x-i-1 +;;; divided by y1, depending on whether x-i and y1 are the +;;; same. We test this guess by determining whether guess*y2 +;;; is greater than the three high digits of x minus guess*y1 +;;; shifted left one digit: +;;; ------------------------------ +;;; | x-i | x-i-1 | x-i-2 | +;;; ------------------------------ +;;; ------------------------------ +;;; - | g*y1 high | g*y1 low | 0 | +;;; ------------------------------ +;;; ... < guess*y2 ??? +;;; If guess*y2 is greater, then we decrement our guess by one +;;; and try again. This returns a guess that is either +;;; correct or one too large. +(defun bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2) + (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2)) + (let ((guess (if (= x-i y1) + all-ones-digit + (%floor x-i x-i-1 y1)))) + (declare (type bignum-element-type guess)) + (loop + (multiple-value-bind (high-guess*y1 low-guess*y1) + (%multiply guess y1) + (declare (type bignum-element-type low-guess*y1 + high-guess*y1)) + (multiple-value-bind (high-guess*y2 low-guess*y2) + (%multiply guess y2) + (declare (type bignum-element-type high-guess*y2 + low-guess*y2)) + (multiple-value-bind (middle-digit borrow) + (%subtract-with-borrow x-i-1 low-guess*y1 1) + (declare (type bignum-element-type middle-digit) + (fixnum borrow)) + ;; Supplying borrow of 1 means there was no + ;; borrow, and we know x-i-2 minus 0 requires + ;; no borrow. + (let ((high-digit (%subtract-with-borrow x-i + high-guess*y1 + borrow))) + (declare (type bignum-element-type high-digit)) + (if (and (= high-digit 0) + (or (> high-guess*y2 + middle-digit) + (and (= middle-digit + high-guess*y2) + (> low-guess*y2 + x-i-2)))) + (setf guess (%subtract-with-borrow guess 1 1)) + (return guess))))))))) + + +;;; This returns the amount to shift y to place a one in the +;;; second highest bit. Y must be positive. If the last digit +;;; of y is zero, then y has a one in the previous digit's +;;; sign bit, so we know it will take one less than digit-size +;;; to get a one where we want. Otherwise, we count how many +;;; right shifts it takes to get zero; subtracting this value +;;; from digit-size tells us how many high zeros there are +;;; which is one more than the shift amount sought. +;;; +;;; Note: This is exactly the same as one less than the +;;; integer-length of the last digit subtracted from the +;;; digit-size. +;;; +;;; We shift y to make it sufficiently large that doing the +;;; 2*digit-size by digit-size %FLOOR calls ensures the quotient and +;;; remainder fit in digit-size. +(defun shift-y-for-truncate (y) + (the fixnum (1- (the fixnum (%bignum-sign-bits y))))) + +;;; Stores two bignums into the truncation bignum buffers, +;;; shifting them on the way in. This assumes x and y are +;;; positive and at least two in length, and it assumes +;;; truncate-x and truncate-y are one digit longer than x and +;;; y. +(defun shift-and-store-truncate-buffers (truncate-x truncate-y x len-x y len-y shift) + (declare (type bignum-index len-x len-y) + (type (integer 0 (#.digit-size)) shift)) + (cond ((zerop shift) + (bignum-replace truncate-x x :end1 len-x) + (bignum-replace truncate-y y :end1 len-y)) + (t + (bignum-ashift-left-unaligned x 0 shift (1+ len-x) + truncate-x) + (bignum-ashift-left-unaligned y 0 shift (1+ len-y) + truncate-y)))) + +;;; Divide TRUNCATE-X by TRUNCATE-Y, returning the quotient +;;; and destructively modifying TRUNCATE-X so that it holds +;;; the remainder. +;;; +;;; LEN-X and LEN-Y tell us how much of the buffers we care about. +;;; +;;; TRUNCATE-X definitely has at least three digits, and it has one +;;; more than TRUNCATE-Y. This keeps i, i-1, i-2, and low-x-digit +;;; happy. Thanks to SHIFT-AND-STORE-TRUNCATE-BUFFERS. + +(defun do-truncate (truncate-x truncate-y len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + ;; Add one for extra sign digit in case high bit is on. + (q (%allocate-bignum (1+ len-q))) + (k (1- len-q)) + (y1 (bignum-ref truncate-y (1- len-y))) + (y2 (bignum-ref truncate-y (- len-y 2))) + (i (1- len-x)) + (i-1 (1- i)) + (i-2 (1- i-1)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) + (type bignum-element-type y1 y2)) + (loop + (setf (bignum-ref q k) + (try-bignum-truncate-guess + truncate-x truncate-y + ;; This modifies TRUNCATE-X. Must access + ;; elements each pass. + (bignum-truncate-guess y1 y2 + (bignum-ref truncate-x i) + (bignum-ref truncate-x i-1) + (bignum-ref truncate-x i-2)) + len-y low-x-digit)) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (shiftf i i-1 i-2 (1- i-2))))) + q)) + +#+notyet +(defun do-truncate-no-quo (truncate-x truncate-y len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + (k (1- len-q)) + (i (1- len-x)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q k i low-x-digit)) + (loop + (let* ((guess (bignum-truncate-guess truncate-x i truncate-y (the fixnum (1- len-y))) + (try-bignum-truncate-guess guess len-y low-x-digit) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (setq i (1- i)))))) + nil)))) + +;;; This takes a digit guess, multiplies it by TRUNCATE-Y for a +;;; result one greater in length than LEN-Y, and subtracts this result +;;; from TRUNCATE-X. LOW-X-DIGIT is the first digit of X to start +;;; the subtraction, and we know X is long enough to subtract a LEN-Y +;;; plus one length bignum from it. Next we check the result of the +;;; subtraction, and if the high digit in X became negative, then our +;;; guess was one too big. In this case, return one less than GUESS +;;; passed in, and add one value of Y back into X to account for +;;; subtracting one too many. Knuth shows that the guess is wrong on +;;; the order of 3/b, where b is the base (2 to the digit-size power) +;;; -- pretty rarely. + +(defun try-bignum-truncate-guess (truncate-x truncate-y guess len-y low-x-digit) + (declare (type bignum-index low-x-digit len-y) + (type bignum-element-type guess)) + (let ((carry-digit 0) + (borrow 1) + (i low-x-digit)) + (declare (type bignum-element-type carry-digit) + (type bignum-index i) + (fixnum borrow)) + ;; Multiply guess and divisor, subtracting from dividend + ;; simultaneously. + (dotimes (j len-y) + (multiple-value-bind (high-digit low-digit) + (%multiply-and-add3 guess + (bignum-ref truncate-y j) + carry-digit) + (declare (type bignum-element-type high-digit low-digit)) + (setf carry-digit high-digit) + (multiple-value-bind (x temp-borrow) + (%subtract-with-borrow (bignum-ref truncate-x i) + low-digit + borrow) + (declare (type bignum-element-type x) + (fixnum temp-borrow)) + (setf (bignum-ref truncate-x i) x) + (setf borrow temp-borrow))) + (incf i)) + (setf (bignum-ref truncate-x i) + (%subtract-with-borrow (bignum-ref truncate-x i) + carry-digit borrow)) + ;; See whether guess is off by one, adding one + ;; Y back in if necessary. + (cond ((%digit-0-or-plusp (bignum-ref truncate-x i)) + guess) + (t + ;; If subtraction has negative result, add one + ;; divisor value back in. The guess was one too + ;; large in magnitude. + (let ((i low-x-digit) + (carry 0)) + (dotimes (j len-y) + (multiple-value-bind (v k) + (%add-with-carry (bignum-ref truncate-y j) + (bignum-ref truncate-x i) + carry) + (declare (type bignum-element-type v)) + (setf (bignum-ref truncate-x i) v) + (setf carry k)) + (incf i)) + (setf (bignum-ref truncate-x i) + (%add-with-carry (bignum-ref truncate-x i) + 0 carry))) + (%subtract-with-borrow guess 1 1))))) + +;;; Someone (from the original CMUCL or SPICE Lisp project, perhaps) +;;; is the "I" who implemented the original version of this. + +;;; This is the original sketch of the algorithm from which I implemented this +;;; TRUNCATE, assuming both operands are bignums. I should modify this to work +;;; with the documentation on my functions, as a general introduction. I've +;;; left this here just in case someone needs it in the future. Don't look at +;;; this unless reading the functions' comments leaves you at a loss. Remember +;;; this comes from Knuth, so the book might give you the right general +;;; overview. +;;; +;;; (truncate x y): +;;; +;;; If X's magnitude is less than Y's, then result is 0 with remainder X. +;;; +;;; Make x and y positive, copying x if it is already positive. +;;; +;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign +;;; digit) +;;; Just do most sig digit to determine how much to shift whole number. +;;; Shift x this much too. +;;; Remember this initial shift count. +;;; +;;; Allocate q to be len-x minus len-y quantity plus 1. +;;; +;;; i = last digit of x. +;;; k = last digit of q. +;;; +;;; LOOP +;;; +;;; j = last digit of y. +;;; +;;; compute guess. +;;; if x[i] = y[j] then g = (1- (ash 1 digit-size)) +;;; else g = x[i]x[i-1]/y[j]. +;;; +;;; check guess. +;;; %UNSIGNED-MULTIPLY returns b and c defined below. +;;; a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF). +;;; Use %UNSIGNED-MULTIPLY taking low-order result. +;;; b = (logand (ash (* g y[j-1]) (- digit-size)) (1- (ash 1 digit-size))). +;;; c = (logand (* g y[j-1]) (1- (ash 1 digit-size))). +;;; if a < b, okay. +;;; if a > b, guess is too high +;;; g = g - 1; go back to "check guess". +;;; if a = b and c > x[i-2], guess is too high +;;; g = g - 1; go back to "check guess". +;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER +;;; SAME FOR A, B, AND C. +;;; +;;; Subtract g * y from x[i - len-y+1]..x[i]. See paper for doing this in step. +;;; If x[i] < 0, guess is screwed up. +;;; negative g, then add 1 +;;; zero or positive g, then subtract 1 +;;; AND add y back into x[len-y+1..i]. +;;; +;;; q[k] = g. +;;; i = i - 1. +;;; k = k - 1. +;;; +;;; If k>=0, goto LOOP. +;;; +;;; Now quotient is good, but remainder is not. +;;; Shift x right by saved initial left shifting count. +;;; +;;; Check quotient and remainder signs. +;;; x pos y pos --> q pos r pos +;;; x pos y neg --> q neg r pos +;;; x neg y pos --> q neg r neg +;;; x neg y neg --> q pos r neg +;;; +;;; Normalize quotient and remainder. Cons result if necessary. + + +(defun bignum-truncate (x y &optional no-rem) + (declare (type bignum-type x y)) + (DECLARE (IGNORE NO-REM)) + ;; Divide X by Y returning the quotient and remainder. In the + ;; general case, we shift Y to set up for the algorithm, and we + ;; use two buffers to save consing intermediate values. X gets + ;; destructively modified to become the remainder, and we have + ;; to shift it to account for the initial Y shift. After we + ;; multiple bind q and r, we first fix up the signs and then + ;; return the normalized results. + (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) + (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) + (x (if x-plusp x (negate-bignum x nil))) + (y (if y-plusp y (negate-bignum y nil))) + (len-x (%bignum-length x)) + (len-y (%bignum-length y))) + (multiple-value-bind (q r) + (cond ((< len-y 2) + (bignum-truncate-single-digit x len-x y)) + ((plusp (bignum-compare y x)) + (let ((res (%allocate-bignum len-x))) + (dotimes (i len-x) + (setf (bignum-ref res i) (bignum-ref x i))) + (values 0 res))) + (t + (let ((len-x+1 (1+ len-x))) + (with-bignum-buffers ((truncate-x len-x+1) + (truncate-y (1+ len-y))) + (let ((y-shift (shift-y-for-truncate y))) + (shift-and-store-truncate-buffers truncate-x + truncate-y + x len-x + y len-y + y-shift) + (values + (do-truncate truncate-x + truncate-y + len-x+1 + len-y) + ;; Now DO-TRUNCATE has executed, we just + ;; tidy up the remainder (in TRUNCATE-X) + ;; and return it. + (cond + ((zerop y-shift) + (let ((res (%allocate-bignum len-y))) + (declare (type bignum-type res)) + (bignum-replace res truncate-x :end2 len-y) + (%normalize-bignum-macro res))) + (t + (shift-right-unaligned + truncate-x 0 y-shift len-y + ((= j res-len-1) + (setf (bignum-ref res j) + (%ashr (bignum-ref truncate-x i) + y-shift)) + (%normalize-bignum-macro res)) + res))))))))) + (let ((quotient (cond ((eq x-plusp y-plusp) q) + ((typep q 'fixnum) (the fixnum (- q))) + (t (negate-bignum-in-place q)))) + (rem (cond (x-plusp r) + ((typep r 'fixnum) (the fixnum (- r))) + (t (negate-bignum-in-place r))))) + (values (if (typep quotient 'fixnum) + quotient + (%normalize-bignum-macro quotient)) + (if (typep rem 'fixnum) + rem + (%normalize-bignum-macro rem))))))) + +(defun bignum-truncate-by-fixnum (bignum fixnum) + (with-small-bignum-buffers ((y fixnum)) + (bignum-truncate bignum y))) + +(defun bignum-truncate-by-fixnum-no-quo (bignum fixnum) + (nth-value 1 (bignum-truncate-by-fixnum bignum fixnum))) + +;;; This may do unnecessary computation in some cases. +(defun bignum-rem (x y) + (nth-value 1 (bignum-truncate x y))) + + + + +;;;; General utilities. + +(defun %zero-trailing-sign-digits (bignum len) + (declare (fixnum len)) + (unless (<= len 1) + (do ((next (bignum-ref bignum (the fixnum (- len 2))) + (bignum-ref bignum (the fixnum (- len 2)))) + (sign (bignum-ref bignum (the fixnum (- len 1))) + next)) + ((not (zerop (the fixnum (%logxor sign (%ashr next 31)))))) + (decf len) + (setf (bignum-ref bignum len) 0) + ;; Return, unless we've already done so (having found significant + ;; digits earlier.) + (when (= len 1) + (return)))) + len) + + +(defun %normalize-bignum-2 (return-fixnum-p bignum) + (let* ((len (%bignum-length bignum)) + (newlen (%zero-trailing-sign-digits bignum len))) + (declare (fixnum len newlen)) + (unless (= len newlen) + (%set-bignum-length newlen bignum)) + (or (and return-fixnum-p + (%maybe-fixnum-from-one-or-two-digit-bignum bignum)) + bignum))) + + +;;; %MOSTLY-NORMALIZE-BIGNUM -- Internal. +;;; +;;; This drops the last digit if it is unnecessary sign information. It +;;; repeats this as needed, possibly ending with a fixnum magnitude but never +;;; returning a fixnum. +;;; + +(defun %mostly-normalize-bignum (res &optional len) + (declare (ignore len)) + (%normalize-bignum-2 nil res)) + + + + + +(defun load-byte (size position integer) + (if (and (bignump integer) + (<= size (- 63 target::fixnumshift)) + (fixnump position)) + (%ldb-fixnum-from-bignum integer size position) + (let ((mask (byte-mask size))) + (if (and (fixnump mask) (fixnump integer)(fixnump position)) + (%ilogand mask (%iasr position integer)) + (logand mask (ash integer (- position))))))) + + +#+safe-but-slow +;;; This is basically the same algorithm as the "destructive" +;;; version below; while it may be more readable, it's often +;;; slower and conses too much to be at all viable. +(defun %bignum-bignum-gcd (u v) + (setq u (abs u) v (abs v)) + (do* ((g 1 (ash g 1))) + ((or (oddp u) (oddp v)) + (do* () + ((zerop u) (* g v)) + (cond ((evenp u) (setq u (ash u -1))) + ((evenp v) (setq v (ash v -1))) + (t (let* ((temp (ash (abs (- u v)) -1))) + (if (< u v) + (setq v temp) + (setq u temp))))))) + (setq u (ash u -1) v (ash v -1)))) + + + + +#-safe-but-slow +(progn +(defun %positive-bignum-bignum-gcd (u0 v0) + (let* ((u-len (%bignum-length u0)) + (v-len (%bignum-length v0))) + (declare (fixnum u-len v-len)) + (if (or (< u-len v-len) + (and (= u-len v-len) + (< (bignum-compare u0 v0) 0))) + (psetq u0 v0 v0 u0 u-len v-len v-len u-len)) + (with-bignum-buffers ((u u-len) + (u2 u-len) + (v v-len) + (v2 v-len)) + (bignum-replace u u0) + (bignum-replace v v0) + (let* ((u-trailing-0-bits (%bignum-count-trailing-zero-bits u)) + (u-trailing-0-digits (ash u-trailing-0-bits -5)) + (v-trailing-0-bits (%bignum-count-trailing-zero-bits v)) + (v-trailing-0-digits (ash v-trailing-0-bits -5))) + (declare (fixnum u-trailing-0-bits v-trailing-0-bits)) + (unless (zerop u-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len u-trailing-0-digits )))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u))) + (unless (zerop v-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v))) + (let* ((shift (min u-trailing-0-bits + v-trailing-0-bits))) + (loop + (let* ((fix-u (and (<= u-len 2) + (%maybe-fixnum-from-one-or-two-digit-bignum u))) + (fix-v (and (<= v-len 2) + (%maybe-fixnum-from-one-or-two-digit-bignum v)))) + (if fix-v + (if fix-u + (return (ash (%fixnum-gcd fix-u fix-v) shift)) + (return (ash (bignum-fixnum-gcd u fix-v) shift))) + (if fix-u + (return (ash (bignum-fixnum-gcd v fix-u) shift))))) + (let* ((signum (if (> u-len v-len) + 1 + (if (< u-len v-len) + -1 + (bignum-compare u v))))) + (declare (fixnum signum)) + (case signum + (0 ; (= u v) + (if (zerop shift) + (let* ((copy (%allocate-bignum u-len))) + (bignum-replace copy u) + (return copy)) + (return (ash u shift)))) + (1 ; (> u v) + (bignum-subtract-loop u u-len v v-len u) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)) + (setq u-trailing-0-bits + (%bignum-count-trailing-zero-bits u) + u-trailing-0-digits + (ash u-trailing-0-bits -5)) + (unless (zerop u-trailing-0-bits) + (%init-misc 0 u2) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len + u-trailing-0-digits)))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)))) + (t ; (> v u) + (bignum-subtract-loop v v-len u u-len v) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)) + (setq v-trailing-0-bits + (%bignum-count-trailing-zero-bits v) + v-trailing-0-digits + (ash v-trailing-0-bits -5)) + (unless (zerop v-trailing-0-bits) + (%init-misc 0 v2) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)))))))))))) + +(defun %bignum-bignum-gcd (u v) + (with-negated-bignum-buffers u v %positive-bignum-bignum-gcd)) +) + + +(defun bignum-shift-right-loop-1 (nbits result source len idx) + (declare (type bignum-type result source) + (type (mod 32) nbits) + (type bignum-index idx len)) + (let* ((rbits (- 32 nbits))) + (declare (type (mod 33) rbits)) + (dotimes (j len) + (let* ((x (bignum-ref source idx))) + (declare (type bignum-element-type x)) + (setq x (%ilsr nbits x)) + (incf idx) + (let* ((y (bignum-ref source idx))) + (declare (type bignum-element-type y)) + (setq y (%ashl y rbits)) + (setf (bignum-ref result j) + (%logior x y))))) + (setf (bignum-ref result len) + (%ilsr nbits (bignum-ref source idx))) + idx)) + + +(defun %logcount (bignum idx) + (%ilogcount (bignum-ref bignum idx))) + +(defun %logcount-complement (bignum idx) + (- 32 (the fixnum (%ilogcount (bignum-ref bignum idx))))) + +(defun %bignum-evenp (bignum) + (not (logbitp 0 (the fixnum (bignum-ref bignum 0))))) + +(defun %bignum-oddp (bignum) + (logbitp 0 (the fixnum (bignum-ref bignum 0)))) + +(defun %ldb-fixnum-from-bignum (bignum size position) + (declare (fixnum size position)) + (let* ((low-idx (ash position -5)) + (low-bit (logand position 31)) + (hi-bit (+ low-bit size)) + (len (%bignum-length bignum)) + (minusp (bignum-minusp bignum))) + (declare (fixnum size position low-bit hi-bit low-idx len)) + (if (>= low-idx len) + (if minusp (1- (ash 1 size)) 0) + (flet ((ldb32 (digit size pos) + (declare (fixnum digit size pos)) + (logand (the fixnum (1- (ash 1 size))) + (the fixnum (ash digit (the fixnum (- pos))))))) + (let* ((low-digit (bignum-ref bignum low-idx)) + (chunk-lo (ldb32 low-digit (min size (%i- 32 low-bit)) low-bit))) + (if (< hi-bit 32) + chunk-lo + (let* ((have (- 32 low-bit)) + (remain (- size have))) + (declare (fixnum have remain)) + (setq low-idx (1+ low-idx)) + (when (> remain 32) + (setq chunk-lo + (logior (ash (if (< low-idx len) + (bignum-ref bignum low-idx) + (if minusp all-ones-digit 0)) + have) + chunk-lo)) + (incf have 32) + (decf remain 32) + (incf low-idx)) + (let* ((high-digit + (if (>= low-idx len) + (if minusp all-ones-digit 0) + (bignum-ref bignum low-idx))) + (chunk-hi (ldb32 high-digit remain 0))) + (%ilogior (ash chunk-hi have) chunk-lo))))))))) + + + +(defun bignum-negate-loop-really (big len res) + (declare (fixnum len)) + (let* ((carry 1)) + (dotimes (i len carry) + (multiple-value-bind (result-digit carry-out) + (%add-with-carry (%lognot (bignum-ref big i)) 0 carry) + (setf (bignum-ref res i) result-digit + carry carry-out))))) + +(defun bignum-negate-to-pointer (big len res) + (declare (fixnum len)) + (let* ((carry 1)) + (do* ((i 0 (1+ i)) + (j 0 (+ j 4))) + ((= i len) carry) + (declare (fixnum i)) + (multiple-value-bind (result-digit carry-out) + (%add-with-carry (%lognot (bignum-ref big i)) 0 carry) + (setf (%get-unsigned-long res j) result-digit + carry carry-out))))) + + +(defun %bignum-count-trailing-zero-bits (bignum) + (let* ((count 0)) + (dotimes (i (%bignum-length bignum)) + (let* ((digit (bignum-ref bignum i))) + (declare (type bignum-element-type digit)) + (if (zerop digit) + (incf count 32) + (progn + (dotimes (bit 32) + (declare (type (mod 32) bit)) + (if (logbitp bit digit) + (return) + (incf count))) + (return))))) + count)) + + +(defun one-bignum-factor-of-two (a) + (declare (type bignum-type a)) + (let ((len (%bignum-length a))) + (declare (fixnum len)) + (dotimes (i len) + (let* ((x (bignum-ref a i))) + (declare (fixnum x)) + (unless (zerop x) + (return (+ (ash i 5) + (dotimes (j 32) + (if (logbitp j x) + (return j)))))))))) + + +(defun %bignum-random (number state) + (let* ((ndigits (%bignum-length number)) + (sign-index (1- ndigits))) + (declare (fixnum ndigits sign-index)) + (with-bignum-buffers ((bignum ndigits)) + (dotimes (i sign-index) + (setf (bignum-ref bignum i) (random (expt 2 digit-size) state))) + (setf (bignum-ref bignum sign-index) + (logand #x7fffffff (the (unsigned-byte 32) + (random (expt 2 (1- digit-size)) state)))) + (let* ((result (mod bignum number))) + (if (eq result bignum) + (copy-uvector bignum) + result))))) + + + +(defun logbitp (index integer) + "Predicate returns T if bit index of integer is a 1." + (number-case index + (fixnum + (if (minusp (the fixnum index))(report-bad-arg index '(integer 0)))) + (bignum + ;; assuming bignum cant have more than most-positive-fixnum bits + ;; (2 expt 24 longs) + (if (bignum-minusp index)(report-bad-arg index '(integer 0))) + ;; should error if integer isn't + (return-from logbitp (minusp (require-type integer 'integer))))) + (number-case integer + (fixnum + (if (%i< index (- target::nbits-in-word target::fixnumshift)) + (%ilogbitp index integer) + (minusp (the fixnum integer)))) + (bignum + (let ((bidx (%iasr 5 index)) + (bbit (%ilogand index 31))) + (declare (fixnum bidx bbit)) + (if (>= bidx (%bignum-length integer)) + (bignum-minusp integer) + (logbitp bbit (bignum-ref integer bidx))))))) + +) ; #+64-bit-target Index: /branches/qres/ccl/level-0/l0-cfm-support.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-cfm-support.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-cfm-support.lisp (revision 13564) @@ -0,0 +1,992 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +; l0-cfm-support.lisp + +(in-package "CCL") + +#+windows-target +(progn + (defvar *windows-invalid-handle* nil) + (setq *windows-invalid-handle* (%int-to-ptr #+64-bit-target #xffffffffffffffff #+32-bit-target #xffffffff))) + + +;;; We have several different conventions for representing an +;;; "entry" (a foreign symbol address, possibly represented as +;;; something cheaper than a MACPTR.) Destructively modify +;;; ADDR so that it points to where ENTRY points. +(defun entry->addr (entry addr) + #+ppc32-target + ;; On PPC32, all function addresses have their low 2 bits clear; + ;; so do fixnums. + (%setf-macptr-to-object addr entry) + #+ppc64-target + ;; On PPC64, some addresses can use the fixnum trick. In other + ;; cases, an "entry" is just a MACPTR. + (if (typep entry 'fixnum) + (%setf-macptr-to-object addr entry) + (%setf-macptr addr entry)) + ;; On x86, an "entry" is just an integer. There might elswehere be + ;; some advantage in treating those integers as signed (they might + ;; be more likely to be fixnums, for instance), so ensure that they + ;; aren't. + #+x86-target + (%setf-macptr addr (%int-to-ptr + (if (< entry 0) + (logand entry (1- (ash 1 target::nbits-in-word))) + entry))) + #-(or ppc-target x86-target) (dbg "Fix entry->addr")) + + + + +;;; Bootstrapping. Real version is in l1-aprims. +;;; Called by expansion of with-pstrs + +(defun byte-length (string &optional script start end) + (declare (ignore script)) + (when (or start end) + (error "Don't support start or end args yet")) + (if (base-string-p string) + (length string) + (error "Don't support non base-string yet."))) + + + + +(defun external-entry-point-p (x) + (istruct-typep x 'external-entry-point)) + +;;; On both Linux and FreeBSD, RTLD_NEXT and RTLD_DEFAULT behave +;;; the same way wrt symbols defined somewhere other than the lisp +;;; kernel. On Solaris, RTLD_DEFAULT will return the address of +;;; an imported symbol's procedure linkage table entry if the symbol +;;; has a plt entry (e.g., if it happens to be referenced by the +;;; lisp kernel.) *RTLD-NEXT* is therefore a slightly better +;;; default; we've traditionaly used *RTLD-DEFAULT*. +(defvar *rtld-next*) +(defvar *rtld-default*) +(defvar *rtld-use*) +(setq *rtld-next* (%incf-ptr (%null-ptr) -1) + *rtld-default* (%int-to-ptr #+(or linux-target darwin-target windows-target) 0 + #-(or linux-target darwin-target windows-target) -2) + *rtld-use* #+solaris-target *rtld-next* #-solaris-target *rtld-default*) + +#+(or linux-target freebsd-target solaris-target) +(progn + +(defvar *dladdr-entry*) + +;;; I can't think of a reason to change this. +(defvar *dlopen-flags* nil) +(setq *dlopen-flags* (logior #$RTLD_GLOBAL #$RTLD_NOW)) +) + +(defvar *eeps* nil) + +(defvar *fvs* nil) + +(defun eeps () + (or *eeps* + (setq *eeps* (make-hash-table :test #'equal)))) + +(defun fvs () + (or *fvs* + (setq *fvs* (make-hash-table :test #'equal)))) + +(defun unload-foreign-variables (lib) + (let* ((fvs (fvs))) + (when fvs + (maphash #'(lambda (k fv) + (declare (ignore k)) + (when (eq (fv.container fv) lib) + (setf (fv.addr fv) nil))) + fvs)))) + +(defun generate-external-functions (path) + (let* ((names ())) + (maphash #'(lambda (k ignore) + (declare (ignore ignore)) + (push k names)) (eeps)) + (with-open-file (stream path + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (dolist (k names) (format stream "~&extern void * ~a();" k)) + + (format stream "~&external_function external_functions[] = {") + (dolist (k names) (format stream "~&~t{~s,~a}," k k)) + (format stream "~&~t{0,0}~&};")))) + + +(defvar *shared-libraries* nil) + +#+(or linux-target freebsd-target solaris-target) +(progn + +(defun soname-ptr-from-link-map (map) + (let* ((path (pref map :link_map.l_name))) + (if (%null-ptr-p path) + (let* ((p (malloc 1))) + (setf (%get-unsigned-byte p 0) 0) + p) + (if (eql (%get-unsigned-byte path 0) 0) + path + (with-macptrs ((dyn-strings) + (dynamic-entries (pref map :link_map.l_ld))) + (let* ((soname-offset nil)) + ;; Walk over the entries in the file's dynamic segment; the + ;; last such entry will have a tag of #$DT_NULL. Note the + ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD) + ;; address of the dynamic string table and the offset of the + ;; #$DT_SONAME string in that string table. + ;; Actually, the above isn't quite right; there seem to + ;; be cases (involving vDSO) where the address of a library's + ;; dynamic string table is expressed as an offset relative + ;; to link_map.l_addr as well. + (loop + (case #+32-bit-target (pref dynamic-entries :lf32_yn.d_tag) + #+64-bit-target (pref dynamic-entries :lf64_yn.d_tag) + (#. #$DT_NULL (return)) + (#. #$DT_SONAME + (setq soname-offset + #+32-bit-target (pref dynamic-entries + :lf32_yn.d_un.d_val) + #+64-bit-target (pref dynamic-entries + :lf64_yn.d_un.d_val))) + (#. #$DT_STRTAB + (%setf-macptr dyn-strings + ;; Try to guess whether we're dealing + ;; with a displacement or with an + ;; absolute address. There may be + ;; a better way to determine this, + ;; but for now we assume that absolute + ;; addresses aren't negative and that + ;; displacements are. + (let* ((disp (%get-signed-natural + dynamic-entries + target::node-size))) + #+(or freebsd-target solaris-target) + (%inc-ptr (pref map :link_map.l_addr) disp) + #-(or freebsd-target solaris-target) + (let* ((udisp #+32-bit-target (pref dynamic-entries + :lf32_yn.d_un.d_val) + #+64-bit-target (pref dynamic-entries + :lf64_yn.d_un.d_val))) + (if (and (> udisp (pref map :link_map.l_addr)) + (< udisp (%ptr-to-int dynamic-entries))) + (%int-to-ptr udisp) + (%int-to-ptr + (if (< disp 0) + (+ disp (pref map :link_map.l_addr)) + disp)))))))) + (%setf-macptr dynamic-entries + (%inc-ptr dynamic-entries + #+32-bit-target + (record-length :lf32_yn) + #+64-bit-target + (record-length :lf64_yn)))) + (if (and soname-offset + (not (%null-ptr-p dyn-strings))) + (%inc-ptr dyn-strings soname-offset) + ;; Use the full pathname of the library. + (pref map :link_map.l_name)))))))) + +(defun shared-library-at (base) + (dolist (lib *shared-libraries*) + (when (eql (shlib.base lib) base) + (return lib)))) + +(defun shared-library-with-name (name) + (let* ((namelen (length name))) + (dolist (lib *shared-libraries*) + (let* ((libname (shlib.soname lib))) + (when (%simple-string= name libname 0 0 namelen (length libname)) + (return lib)))))) + +(defun shlib-from-map-entry (m) + (let* ((base (%int-to-ptr (pref m :link_map.l_addr)))) + ;; On relatively modern Linux systems, this is often NULL. + ;; I'm not sure what (SELinux ? Pre-binding ? Something else ?) + ;; counts as being "relatively modern" in this case. + ;; The link-map's l_ld field is a pointer to the .so's dynamic + ;; section, and #_dladdr seems to recognize that as being an + ;; address within the library and returns a reasonable "base address". + (when (%null-ptr-p base) + (let* ((addr (%library-base-containing-address (pref m :link_map.l_ld)))) + (if addr (setq base addr)))) + (or (let* ((existing-lib (shared-library-at base))) + (when (and existing-lib (null (shlib.map existing-lib))) + (setf (shlib.map existing-lib) m + (shlib.pathname existing-lib) + (%get-cstring (pref m :link_map.l_name)) + (shlib.base existing-lib) base)) + existing-lib) + (let* ((soname-ptr (soname-ptr-from-link-map m)) + (soname (unless (%null-ptr-p soname-ptr) (%get-cstring soname-ptr))) + (pathname (%get-cstring (pref m :link_map.l_name))) + (shlib (shared-library-with-name soname))) + (if shlib + (setf (shlib.map shlib) m + (shlib.base shlib) base + (shlib.pathname shlib) pathname) + (push (setq shlib (%cons-shlib soname pathname m base)) + *shared-libraries*)) + shlib)))) + + +(defun %get-r-debug () + (let* ((addr (ff-call (%kernel-import target::kernel-import-get-r-debug) + address))) + (unless (%null-ptr-p addr) + addr))) + +(defun %link-map-address () + (let* ((r_debug (%get-r-debug))) + (if r_debug + (pref r_debug :r_debug.r_map) + (let* ((p (or (foreign-symbol-address "_dl_loaded") + (foreign-symbol-address "_rtld_global")))) + (if p + (%get-ptr p)))))) + +(defun %walk-shared-libraries (f) + (let* ((loaded (%link-map-address))) + (do* ((map (pref loaded :link_map.l_next) (pref map :link_map.l_next))) + ((%null-ptr-p map)) + (funcall f map)))) + + +(defun %dlopen-shlib (l) + (with-cstrs ((n (shlib.soname l))) + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address n + :unsigned-fullword *dlopen-flags* + :void))) + +(defun init-shared-libraries () + (setq *dladdr-entry* (foreign-symbol-entry "dladdr")) + (when (null *shared-libraries*) + (%walk-shared-libraries #'shlib-from-map-entry) + ;;; On Linux, it seems to be necessary to open each of these + ;;; libraries yet again, specifying the RTLD_GLOBAL flag. + ;;; On FreeBSD, it seems desirable -not- to do that. + #+linux-target + (dolist (l *shared-libraries*) + (%dlopen-shlib l)))) + +(init-shared-libraries) + +;;; Walk over all registered entrypoints, invalidating any whose container +;;; is the specified library. Return true if any such entrypoints were +;;; found. +(defun unload-library-entrypoints (lib) + (let* ((count 0)) + (declare (fixnum count)) + (maphash #'(lambda (k eep) + (declare (ignore k)) + (when (eq (eep.container eep) lib) + (setf (eep.address eep) nil) + (incf count))) + (eeps)) + (not (zerop count)))) + + + + + +(defun open-shared-library (name) + "If the library denoted by name can be loaded by the operating system, +return an object of type SHLIB that describes the library; if the library +is already open, increment a reference count. If the library can't be +loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from +the operating system." + (let* ((handle (with-cstrs ((name name)) + (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address name + :unsigned-fullword *dlopen-flags* + :address))) + (link-map #-(or freebsd-target solaris-target) handle + #+(or freebsd-target solaris-target) + (if (%null-ptr-p handle) + handle + (rlet ((p :address)) + (if (eql 0 (ff-call + (foreign-symbol-entry "dlinfo") + :address handle + :int #$RTLD_DI_LINKMAP + :address p + :int)) + (pref p :address) + (%null-ptr)))))) + (if (%null-ptr-p link-map) + (error "Error opening shared library ~s: ~a" name (dlerror)) + (prog1 (let* ((lib (shlib-from-map-entry link-map))) + (incf (shlib.opencount lib)) + (setf (shlib.handle lib) handle) + lib) + (%walk-shared-libraries + #'(lambda (map) + (unless (shared-library-at + (%int-to-ptr (pref map :link_map.l_addr))) + (let* ((new (shlib-from-map-entry map))) + (%dlopen-shlib new))))))))) + +) + + +#+darwin-target +(progn + +(defun shared-library-with-header (header) + (dolist (lib *shared-libraries*) + (when (eql (shlib.map lib) header) + (return lib)))) + +(defun shared-library-with-module (module) + (dolist (lib *shared-libraries*) + (when (eql (shlib.base lib) module) + (return lib)))) + +(defun shared-library-with-name (name &optional (is-unloaded nil)) + (let* ((namelen (length name))) + (dolist (lib *shared-libraries*) + (let* ((libname (shlib.soname lib))) + (when (and (%simple-string= name libname 0 0 namelen (length libname)) + (or (not is-unloaded) (and (null (shlib.map lib)) + (null (shlib.base lib))))) + (return lib)))))) + +;;; +;;; maybe we could fix this up name to get the "real name" +;;; this is might be possible for dylibs but probably not for modules +;;; for now soname and pathname are just the name that the user passed in +;;; if the library is "discovered" later, it is the name the system gave +;;; to it -- usually a full pathname +;;; +;;; header and module are ptr types +;;; +(defun shared-library-from-header-module-or-name (header module name) + ;; first try to find the library based on its address + (let ((found-lib (if (%null-ptr-p module) + (shared-library-with-header header) + (shared-library-with-module module)))) + + (unless found-lib + ;; check if the library name is still on our list but has been unloaded + (setq found-lib (shared-library-with-name name t)) + (if found-lib + (setf (shlib.map found-lib) header + (shlib.base found-lib) module) + ;; otherwise add it to the list + (push (setq found-lib (%cons-shlib name name header module)) + *shared-libraries*))) + found-lib)) + + +(defun open-shared-library (name) + "If the library denoted by name can be loaded by the operating system, +return an object of type SHLIB that describes the library; if the library +is already open, increment a reference count. If the library can't be +loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from +the operating system." + (rlet ((type :signed)) + (let ((result (with-cstrs ((cname name)) + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address cname + :address type + :address)))) + (cond + ((= 1 (pref type :signed)) + ;; dylib + (shared-library-from-header-module-or-name result (%null-ptr) name)) + ((= 2 (pref type :signed)) + ;; bundle + (shared-library-from-header-module-or-name (%null-ptr) result name)) + ((= 0 (pref type :signed)) + ;; neither a dylib nor bundle was found + (error "Error opening shared library ~s: ~a" name + (%get-cstring result))) + (t (error "Unknown error opening shared library ~s." name)))))) + +;;; Walk over all registered entrypoints, invalidating any whose container +;;; is the specified library. Return true if any such entrypoints were +;;; found. +;;; +;;; SAME AS LINUX VERSION +;;; +(defun unload-library-entrypoints (lib) + (let* ((count 0)) + (declare (fixnum count)) + (maphash #'(lambda (k eep) + (declare (ignore k)) + (when (eq (eep.container eep) lib) + (setf (eep.address eep) nil) + (incf count))) + (eeps)) + (not (zerop count)))) + +;;; +;;; When restarting from a saved image +;;; +(defun reopen-user-libraries () + (dolist (lib *shared-libraries*) + (setf (shlib.map lib) nil + (shlib.base lib) nil)) + (loop + (let* ((win nil) + (lose nil)) + (dolist (lib *shared-libraries*) + (let* ((header (shlib.map lib)) + (module (shlib.base lib))) + (unless (and header module) + (rlet ((type :signed)) + (let ((result (with-cstrs ((cname (shlib.soname lib))) + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address cname + :address type + :address)))) + (cond + ((= 1 (pref type :signed)) + ;; dylib + (setf (shlib.map lib) result + (shlib.base lib) (%null-ptr) + win t)) + ((= 2 (pref type :signed)) + ;; bundle + (setf (shlib.map lib) (%null-ptr) + (shlib.base lib) result + win t)) + (t + ;; neither a dylib nor bundle was found + (setq lose t)))))))) + (when (or (not lose) (not win)) (return))))) + +;;; end darwin-target + ) + +#+windows-target +(progn + (defvar *current-process-handle*) + (defvar *enum-process-modules-addr*) + (defvar *get-module-file-name-addr*) + (defvar *get-module-base-name-addr*) + (defvar *get-module-handle-ex-addr*) + + + (defun init-windows-ffi () + (%revive-macptr *windows-invalid-handle*) + (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address)) + (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules")) + (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA")) + (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA")) + (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA"))) + + (init-windows-ffi) + + (defun hmodule-pathname (hmodule) + (do* ((bufsize 64)) + () + (%stack-block ((name bufsize)) + (let* ((needed (ff-call *get-module-file-name-addr* + :address *current-process-handle* + :address hmodule + :address name + :signed-fullword bufsize + :signed-fullword))) + (if (eql 0 needed) + (return nil) + (if (< bufsize needed) + (setq bufsize needed) + (return (%str-from-ptr name needed)))))))) + + (defun hmodule-basename (hmodule) + (do* ((bufsize 64)) + () + (%stack-block ((name bufsize)) + (let* ((needed (ff-call *get-module-base-name-addr* + :address *current-process-handle* + :address hmodule + :address name + :signed-fullword bufsize + :signed-fullword))) + (if (eql 0 needed) + (return nil) + (if (< bufsize needed) + (setq bufsize needed) + (return (%str-from-ptr name needed)))))))) + + (defun existing-shlib-for-hmodule (hmodule) + (dolist (shlib *shared-libraries*) + (when (eql hmodule (shlib.map shlib)) (return shlib)))) + + + (defun shared-library-from-hmodule (hmodule) + (or (existing-shlib-for-hmodule hmodule) + (let* ((shlib (%cons-shlib (hmodule-basename hmodule) + (hmodule-pathname hmodule) + hmodule + hmodule))) + (push shlib *shared-libraries*) + shlib))) + + (defun for-each-loaded-module (f) + (let* ((have (* 16 (record-length #>HMODULE)))) + (rlet ((pneed #>DWORD)) + (loop + (%stack-block ((modules have)) + (ff-call *enum-process-modules-addr* + :address *current-process-handle* + :address modules + #>DWORD have + :address pneed) + (let* ((need (pref pneed #>DWORD))) + (if (> need have) + (setq have need) + (return + (do* ((i 0 (+ i (record-length #>HMODULE)))) + ((= i need)) + (funcall f (%get-ptr modules i))))))))))) + + (defun init-shared-libraries () + (for-each-loaded-module #'shared-library-from-hmodule)) + + (defun shlib-containing-entry (addr &optional name) + (with-macptrs ((p (%int-to-ptr addr))) + (shlib-containing-address p name))) + + (defun shlib-containing-address (addr &optional name) + (declare (ignore name)) + (rlet ((phmodule :address (%null-ptr))) + (let* ((found (ff-call *get-module-handle-ex-addr* + #>DWORD (logior + #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS + #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT) + :address addr + :address phmodule + #>BOOL))) + (unless (eql 0 found) + (let* ((hmodule (pref phmodule :address))) + (dolist (lib *shared-libraries*) + (when (eql (shlib.map lib) hmodule) + (return lib)))))))) + + + (defun open-shared-library (name) + "If the library denoted by name can be loaded by the operating system, +return an object of type SHLIB that describes the library; if the library +is already open, increment a reference count. If the library can't be +loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from +the operating system." + (let* ((hmodule (with-cstrs ((name name)) + (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address name + :unsigned-fullword 0 + :address))) + (shlib (unless (%null-ptr-p hmodule) + (shared-library-from-hmodule hmodule)))) + (if shlib + (progn + (incf (shlib.opencount shlib)) + (setf (shlib.handle shlib) hmodule) + shlib) + (error "Can't open shared library ~s" name)))) + +(init-shared-libraries) + +;;; end windows-target +) + + +(defun ensure-open-shlib (c force) + (if (or (shlib.map c) (not force)) + *rtld-use* + (error "Shared library not open: ~s" (shlib.soname c)))) + +(defun resolve-container (c force) + (if c + (ensure-open-shlib c force) + *rtld-use* + )) + + + + +;;; An "entry" can be fixnum (the low 2 bits are clear) which represents +;;; a (32-bit word)-aligned address. That convention covers all +;;; function addresses on ppc32 and works for addresses that are +;;; 0 mod 8 on PPC64, but can't work for things that're byte-aligned +;;; (x8664 and other non-RISC platforms.) +;;; For PPC64, we may have to cons up a macptr if people use broken +;;; linkers. (There are usually cache advantages to aligning ppc +;;; function addresses on at least a 16-byte boundary, but some +;;; linkers don't quite get the concept ...) + +(defun foreign-symbol-entry (name &optional (handle *rtld-use*)) + "Try to resolve the address of the foreign symbol name. If successful, +return a fixnum representation of that address, else return NIL." + (with-cstrs ((n name)) + #+ppc-target + (with-macptrs (addr) + (%setf-macptr addr + (ff-call (%kernel-import target::kernel-import-FindSymbol) + :address handle + :address n + :address)) + (unless (%null-ptr-p addr) ; No function can have address 0 + (or (macptr->fixnum addr) (%inc-ptr addr 0)))) + #+x8632-target + (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) + :address handle + :address n + :unsigned-fullword))) + (unless (eql 0 addr) addr)) + #+x8664-target + (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) + :address handle + :address n + :unsigned-doubleword))) + (unless (eql 0 addr) addr)))) + +(defvar *statically-linked* nil) + +#+(or linux-target freebsd-target solaris-target) +(progn + +(defun %library-base-containing-address (address) + (rletZ ((info :l_info)) + (let* ((status (ff-call *dladdr-entry* + :address address + :address info :signed-fullword))) + (declare (integer status)) + (unless (zerop status) + (pref info :l_info.dli_fbase))))) + +(defun shlib-containing-address (address &optional name) + (declare (ignore name)) + (let* ((base (%library-base-containing-address address))) + (if base + (shared-library-at base)))) + + +(defun shlib-containing-entry (entry &optional name) + (unless *statically-linked* + (with-macptrs (p) + (entry->addr entry p) + (shlib-containing-address p name)))) +) + +#+darwin-target +(progn +(defvar *dyld-image-count*) +(defvar *dyld-get-image-header*) +(defvar *dyld-get-image-name*) +(defvar *nslookup-symbol-in-image*) +(defvar *nsaddress-of-symbol*) +(defvar *nsmodule-for-symbol*) +(defvar *ns-is-symbol-name-defined-in-image*) +(defvar *dladdr-entry* 0) + +(defun setup-lookup-calls () + #+notyet + (setq *dladdr-entry* (foreign-symbol-entry "_dladdr")) + (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count")) + (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header")) + (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name")) + (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage")) + (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol")) + (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol")) + (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage"))) + +(setup-lookup-calls) + +;;; +;;; given an entry address (a number) and a symbol name (lisp string) +;;; find the associated dylib or module +;;; if the dylib or module is not found in *shared-libraries* list it is added +;;; if not found in the OS list it returns nil +;;; +;;; got this error before putting in the call to +;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead +;;; lock (dyld operation attempted in a thread already doing a dyld +;;; operation) +;;; + +(defun legacy-shlib-containing-address (addr name) + (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword)) + (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address))) + (when (and (not (%null-ptr-p header)) + (or (eql (pref header :mach_header.filetype) #$MH_DYLIB) + (eql (pref header :mach_header.filetype) #$MH_BUNDLE))) + ;; make sure the image is either a bundle or a dylib + ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5) + (with-cstrs ((cname name)) + ;; also we must check is symbol name is defined in the + ;; image otherwise in certain cases there is a crash, + ;; another likely OS bug happens in the case where a + ;; bundle imports a dylib and then we call + ;; nslookupsymbolinimage on the bundle image + (when (/= 0 + (ff-call *ns-is-symbol-name-defined-in-image* :address header + :address cname :unsigned)) + (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname + :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR + :address))) + (unless (%null-ptr-p symbol) + ;; compare the found address to the address we are looking for + (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address))) + ;; (format t "Foundaddr ~s~%" foundaddr) + ;; (format t "Compare to addr ~s~%" addr) + (when (eql foundaddr addr) + (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address)) + (libname (unless (%null-ptr-p imgname) (%get-cstring imgname))) + (libmodule (%int-to-ptr 0)) + (libheader (%int-to-ptr 0))) + (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE) + (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address)) + (setf libheader header)) + ;; make sure that this shared library is on *shared-libraries* + (return (shared-library-from-header-module-or-name libheader libmodule libname))))))))))))) + +(defun shlib-containing-address (address name) + (if (zerop *dladdr-entry*) + (legacy-shlib-containing-address address name) + ;; Bootstrapping. RLET might be clearer here. + (%stack-block ((info (record-length #>Dl_info) :clear t)) + (unless (zerop (ff-call *dladdr-entry* + :address address + :address info + :signed-fullword)) + (let* ((addr (pref info #>Dl_info.dli_fbase))) + (format t "~&name = ~s" (pref info #>Dl_info.dli_fname)) + + (dolist (lib *shared-libraries*) + (when (eql (shlib.base lib) addr) + (return lib)))))))) + +(defun shlib-containing-entry (entry &optional name) + (unless name + (error "foreign name must be non-NIL.")) + (with-macptrs (addr) + (entry->addr entry addr) + (shlib-containing-address addr name))) + +;; end Darwin progn +) + +#-(or linux-target darwin-target freebsd-target solaris-target windows-target) +(defun shlib-containing-entry (entry &optional name) + (declare (ignore entry name)) + *rtld-default*) + + +(defun resolve-eep (e &optional (require-resolution t)) + (or (eep.address e) + (let* ((name (eep.name e)) + (container (eep.container e)) + (handle (resolve-container container require-resolution)) + (addr (foreign-symbol-entry name handle))) + (if addr + (progn + (unless container + (setf (eep.container e) (shlib-containing-entry addr name))) + (setf (eep.address e) addr)) + (if require-resolution + (error "Can't resolve foreign symbol ~s" name)))))) + + + +(defun foreign-symbol-address (name &optional (map *rtld-use*)) + "Try to resolve the address of the foreign symbol name. If successful, +return that address encapsulated in a MACPTR, else returns NIL." + (with-cstrs ((n name)) + (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address))) + (unless (%null-ptr-p addr) + addr)))) + +(defun resolve-foreign-variable (fv &optional (require-resolution t)) + (or (fv.addr fv) + (let* ((name (fv.name fv)) + (container (fv.container fv)) + (handle (resolve-container container require-resolution)) + (addr (foreign-symbol-address name handle))) + (if addr + (progn + (unless container + (setf (fv.container fv) (shlib-containing-address addr name))) + (setf (fv.addr fv) addr)) + (if require-resolution + (error "Can't resolve foreign symbol ~s" name)))))) + +(defun load-eep (name) + (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name))))) + (resolve-eep eep nil) + eep)) + +(defun load-fv (name type) + (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type))))) + (resolve-foreign-variable fv nil) + fv)) + + + + + + +#+(or linux-target freebsd-target solaris-target) +(progn + +;;; Return the position of the last dot character in name, if that +;;; character is followed by one or more decimal digits (e.g., the +;;; start of a numeric suffix on a library name.) Return NIL if +;;; there's no such suffix. +(defun last-dot-pos (name) + (do* ((i (1- (length name)) (1- i)) + (default i) + (trailing-digits nil)) + ((<= i 0) default) + (declare (fixnum i)) + (let* ((code (%scharcode name i))) + (declare (type (mod #x110000) code)) + (if (and (>= code (char-code #\0)) + (<= code (char-code #\9))) + (setq trailing-digits t) + (if (= code (char-code #\.)) + (return (if trailing-digits i)) + (return default)))))) + +;;; It's assumed that the set of libraries that the OS has open +;;; (accessible via the _dl_loaded global variable) is a subset of +;;; the libraries on *shared-libraries*. + +(defun revive-shared-libraries () + (dolist (lib *shared-libraries*) + (setf (shlib.map lib) nil + (shlib.pathname lib) nil + (shlib.base lib) nil) + (let* ((soname (shlib.soname lib)) + (last-dot (if soname (last-dot-pos soname)))) + (when soname + (with-cstrs ((soname soname)) + (let* ((map (block found + (%walk-shared-libraries + #'(lambda (m) + (with-macptrs (libname) + (%setf-macptr libname + (soname-ptr-from-link-map m)) + (unless (%null-ptr-p libname) + (when (or (%cstrcmp soname libname) + (and last-dot + (%cnstrcmp soname libname (1+ last-dot)))) + (return-from found m))))))))) + (when map + ;;; Sigh. We can't reliably lookup symbols in the library + ;;; unless we open the library (which is, of course, + ;;; already open ...) ourselves, passing in the + ;;; #$RTLD_GLOBAL flag. + #+linux-target + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address soname + :unsigned-fullword *dlopen-flags* + :void) + (setf (shlib.base lib) (%int-to-ptr (pref map :link_map.l_addr)) + (shlib.pathname lib) (%get-cstring + (pref map :link_map.l_name)) + (shlib.soname lib) (%get-cstring (soname-ptr-from-link-map map)) + (shlib.map lib) map)))))))) + +;;; Repeatedly iterate over shared libraries, trying to open those +;;; that weren't already opened by the kernel. Keep doing this until +;;; we reach stasis (no failures or no successes.) + +(defun %reopen-user-libraries () + (loop + (let* ((win nil) + (lose nil)) + (dolist (lib *shared-libraries*) + (let* ((map (shlib.map lib)) + (handle (shlib.handle lib))) + (unless map + (with-cstrs ((soname (shlib.soname lib))) + (setq handle + (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address soname + :unsigned-fullword *dlopen-flags* + :address)) + #-(or freebsd-target solaris-target) (setq map handle) + #+(or freebsd-target solaris-target) + (setq map + (if (%null-ptr-p handle) + handle + (rlet ((p :address)) + (if (eql 0 (ff-call + (foreign-symbol-entry "dlinfo") + :address handle + :int #$RTLD_DI_LINKMAP + :address p + :int)) + (pref p :address) + (%null-ptr))))) + (if (%null-ptr-p map) + (setq lose t) + (setf (shlib.pathname lib) + (%get-cstring (pref map :link_map.l_name)) + (shlib.base lib) + (%int-to-ptr (pref map :link_map.l_addr)) + (shlib.map lib) map + (shlib.handle lib) handle + win t)))))) + (when (or (not lose) (not win)) (return))))) +) + + +(defun refresh-external-entrypoints () + #+linux-target + (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked)))) + (%revive-macptr *rtld-next*) + (%revive-macptr *rtld-default*) + #+(or linux-target freebsd-target solaris-target) + (unless *statically-linked* + (setq *dladdr-entry* (foreign-symbol-entry "dladdr")) + (revive-shared-libraries) + (%reopen-user-libraries)) + #+darwin-target + (progn + (setup-lookup-calls) + (reopen-user-libraries)) + #+windows-target + (init-windows-ffi) + (when *eeps* + (without-interrupts + (maphash #'(lambda (k v) + (declare (ignore k)) + (setf (eep.address v) nil) + (resolve-eep v nil)) + *eeps*))) + (when *fvs* + (without-interrupts + (maphash #'(lambda (k v) + (declare (ignore k)) + (setf (fv.addr v) nil) + (resolve-foreign-variable v nil)) + *fvs*)))) + + Index: /branches/qres/ccl/level-0/l0-complex.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-complex.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-complex.lisp (revision 13564) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel) + (require "NUMBER-MACROS")) + +(defun coerce-to-complex-type (num type) + (cond ((complexp num) + (let ((real (%realpart num)) + (imag (%imagpart num))) + (if (and (typep real type) + (typep imag type)) + num + (complex (coerce real type) + (coerce imag type))))) + (t (complex (coerce num type))))) + +;;; end of l0-complex.lisp Index: /branches/qres/ccl/level-0/l0-def.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-def.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-def.lisp (revision 13564) @@ -0,0 +1,251 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; primitives that manipulate function & variable definitions. + + + + + +(defun functionp (arg) + "Return true if OBJECT is a FUNCTION, and NIL otherwise." + (functionp arg)) + +(defun lfunp (arg) + (functionp arg)) + +(defun %proclaim-special (sym &optional initp) + (let* ((oldbits (%symbol-bits sym))) + (declare (fixnum oldbits)) + (%symbol-bits sym (bitset $sym_vbit_special oldbits)) + initp)) + +(setq *lfun-names* (make-hash-table :test 'eq :weak t)) + +(defun lookup-lfun-name (lfun) + (gethash lfun *lfun-names*)) + + +(defun function-name (fun) + (or (and (functionp fun) (lfun-name fun)) + (if (compiled-function-p (setq fun (closure-function fun))) + (lfun-name fun)))) + + +(defun bootstrapping-fmakunbound (name) + (when (consp name) + (unless (eq (%car name) 'setf) + (error "Function spec handler not loaded yet")) + (setq name (setf-function-name (cadr name)))) + (%unfhave name) + name) + +;;; redefined in sysutils. +(%fhave 'fmakunbound #'bootstrapping-fmakunbound) + +(defun bootstrapping-fset (name fn) + (fmakunbound name) + (%fhave name fn) + fn) + +;Redefined in sysutils. +(%fhave 'fset #'bootstrapping-fset) + +(defun bootstrapping-record-source-file (fn &optional type) + (declare (ignore fn type)) + nil) + +;Redefined in l1-utils. +(%fhave 'record-source-file #'bootstrapping-record-source-file) + + +(setq *fasload-print* nil) +(setq *save-doc-strings* t) + + + +(%fhave '%defun-encapsulated-maybe ;Redefined in encapsulate + (qlfun bootstrapping-defun-encapsulated (name fn) + (declare (ignore name fn)) + nil)) + +(%fhave 'encapsulated-function-name ;Redefined in encapsulate - used in l1-io + (qlfun bootstrapping-encapsulated-function-name (fn) + (declare (ignore fn)) + nil)) + +(%fhave 'set-function-info (qlfun set-function-info (name info) + (if (typep info 'string) + (set-documentation name 'function info)) + name)) + +(defun %defun (named-fn &optional info) + (unless (typep named-fn 'function) + (dbg named-fn)) + (let* ((name (function-name named-fn))) + (unless (and name + (or (symbolp name) + (setf-function-name-p name))) + (dbg named-fn)) + (record-source-file name 'function) + (if (not (%defun-encapsulated-maybe name named-fn)) + (fset name named-fn)) + (set-function-info name info) + (when *fasload-print* (format t "~&~S~%" name)) + name)) + +(defun validate-function-name (name) + (if (symbolp name) + name + (if (setf-function-name-p name) + (setf-function-name (cadr name)) + (report-bad-arg name 'function-name)))) + +;;; There are three kinds of things which can go in the function +;;; cell of a symbol: 1) A function. 2) The thing which is the +;;; value of %unbound-function%: a 1-element vector whose 0th +;;; element is a code vector which causes an "undefined function" +;;; error to be signalled. 3) A macro or special-form definition, +;;; which is a 2-element vector whose 0th element is a code vector +;;; which signals a "can't apply macro or special form" error when +;;; executed and whose 1st element is a macro or special-operator +;;; name. It doesn't matter what type of gvector cases 2 and 3 +;;; are. Once that's decided, it wouldn't hurt if %FHAVE +;;; typechecked its second arg. + +(defun %fhave (name def) + (let* ((fname (validate-function-name name))) + (setf (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell) def))) + +;;; FBOUNDP is true of any symbol whose function-cell contains something other +;;; than %unbound-function%; we expect FBOUNDP to return that something. +(defun fboundp (name) + "Return true if name has a global function definition." + (let* ((fname (validate-function-name name)) + (def (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell))) + (unless (eq def %unbound-function%) + def))) + +;;; %UNFHAVE doesn't seem to want to deal with SETF names or function specs. +;;; Who does ? + +(defun %unfhave (sym) + (let* ((symvec (symptr->symvector (%symbol->symptr sym))) + (old (%svref symvec target::symbol.fcell-cell)) + (unbound %unbound-function%)) + (setf (%svref symvec target::symbol.fcell-cell) unbound) + (not (eq old unbound)))) + +;;; It's guaranteed that lfun-bits is a fixnum. Might be a 30-bit fixnum ... + + + + + +(defun lfun-vector-name (fun &optional (new-name nil set-name-p)) + (let* ((bits (lfun-bits fun))) + (declare (fixnum bits)) + (if (and (logbitp $lfbits-gfn-bit bits) + (not (logbitp $lfbits-method-bit bits))) + (progn + (if set-name-p + (%gf-name fun new-name) + (%gf-name fun))) + (let* ((has-name-cell (not (logbitp $lfbits-noname-bit bits)))) + (if has-name-cell + (let* ((lfv (lfun-vector fun)) + (name-idx (- (the fixnum (uvsize lfv)) 2)) + (old-name (%svref lfv name-idx))) + (declare (fixnum name-idx)) + (if (and set-name-p (not (eq old-name new-name))) + (setf (%svref lfv name-idx) new-name)) + old-name)))))) + +(defun lfun-name (fun &optional (new-name nil set-name-p)) + (multiple-value-bind (stored-name stored?) (lookup-lfun-name fun) + (unless stored? + (setq stored-name (lfun-vector-name fun))) + (when (and set-name-p (neq new-name stored-name)) + (if (and stored? (eq new-name (lfun-vector-name fun))) + (remhash fun *lfun-names*) + (if (logbitp $lfbits-noname-bit (the fixnum (lfun-bits fun))) ; no name-cell in function vector. + (puthash fun *lfun-names* new-name) + (lfun-vector-name fun new-name)))) + stored-name)) + +(defun lfun-bits (function &optional new) + (unless (functionp function) + (setq function (require-type function 'function))) + (let* ((lfv (lfun-vector function)) + (idx (1- (the fixnum (uvsize lfv)))) + (old (%svref lfv idx))) + (declare (fixnum idx)) + (if new + (setf (%svref lfv idx) new)) + old)) + +(defun %macro-have (symbol macro-function) + (declare (special %macro-code%)) ; magically set by xloader. + (%fhave symbol (vector %macro-code% macro-function))) + + +(defun special-operator-p (symbol) + "If the symbol globally names a special form, return T, otherwise NIL." + (let ((def (fboundp symbol))) + (and (typep def 'simple-vector) + (not (lfunp (svref def 1)))))) + +(defun special-form-p (x) (special-operator-p x)) + +(defun setf-function-name-p (thing) + (and (consp thing) + (consp (%cdr thing)) + (null (%cddr thing)) + (eq (%car thing) 'setf) + (symbolp (%cadr thing)))) + +(defun macro-function (form &optional env) + "If SYMBOL names a macro in ENV, returns the expansion function, + else returns NIL. If ENV is unspecified or NIL, use the global + environment only." + (setq form (require-type form 'symbol)) + (when env + ; A definition-environment isn't a lexical environment, but it can + ; be an ancestor of one. + (unless (istruct-typep env 'lexical-environment) + (report-bad-arg env 'lexical-environment)) + (let ((cell nil)) + (tagbody + top + (if (setq cell (%cdr (assq form (lexenv.functions env)))) + (return-from macro-function + (if (eq (car cell) 'macro) (%cdr cell)))) + (unless (listp (setq env (lexenv.parent-env env))) + (go top))))) + ; Not found in env, look in function cell. + (%global-macro-function form)) + +(defun %fixnum-ref-macptr (fixnum &optional (offset 0)) + (%int-to-ptr (%fixnum-ref-natural fixnum offset))) + +(defun %fixnum-set-macptr (fixnum offset &optional (newval offset newval-p)) + (%fixnum-set-natural fixnum (if newval-p offset 0) (%ptr-to-int newval)) + newval) + +;;; end of l0-def.lisp Index: /branches/qres/ccl/level-0/l0-error.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-error.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-error.lisp (revision 13564) @@ -0,0 +1,141 @@ +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defparameter *error-format-strings* + '((1 . "Unbound variable: ~S .") + (2 . "Invalid reference to ~s at index ~s.") + (3 . "Too many arguments.") + (4 . "Too few arguments.") + (5 . "Argument ~S is not of the required type.") + (6 . "Undefined function: ~S .") + (7 . "Invalid assignnnt of ~s at index ~s, to ~s.") + (8 . "Can't coerce ~S to ~S") + (9 . "Funcallable instance ~S was called with args ~s, but has no FUNCALLABLE-INSTANCE-FUNCTION") + (10 . "Out of memory.") + (11 . "Default image file not found.") + (12 . "No translation for ~S") + (13 . "~S can't be FUNCALLed or APPLYed.") + (14 . "~S is not a symbol or lambda expression") + (15 . "Declaration ~S in unexpected position") + (16 . "Can't setq constant ~S") + (17 . "Odd number of forms to setq in ~S") + (18 . "Illegal arg to setq ~S") + (19 . "~S is not a symbol.") + (20 . "~S is a constant.") + (21 . "Bad initialization form: ~S") + (22 . "Symbol macro ~S is declared or proclaimed special") + (23 . "Too many arguments in ~S") + (24 . "Local macro cannot reference lexically defined variable ~S") + (25 . "Local macro cannot reference lexically defined function ~S") + (26 . "Local macro cannot reference lexically defined tag ~S") + (27 . "Local macro cannot reference lexically defined block ~S") + (28 . "Can't find tag ~S") + (29 . "Duplicate tag ~S") + (30 . "Can't find block ~S") + (31 . "Bad lambda list ~S.") + (32 . "~S is not a valid lambda expression.") + (33 . "Can't throw to tag ~S .") + (34 . "Object ~S is not of type ~S.") + (35 . "FUNCTION can't reference lexically defined macro ~S") + (36 . "Unimplemented FPU instruction ~^~S.") + (41 . "Unmatched ')'.") + (42 . "~S and ~S must be on the same volume.") + (43 . "Filename ~S contains illegal character ~S") + (44 . "Illegal use of wildcarded filename ~S") + (45 . "~S is not a FASL or TEXT file.") + (46 . "Cannot rename directory to file ~S") + (47 . "Found a directory instead of a file or vice versa ~S") + (48 . "Cannot copy directories: ~S") + (49 . "String too long for pascal record") + (50 . "Cannot create ~S") + (64 . "Floating point overflow") + (66 . "Can't divide by zero.") + (75 . "Stack overflow. Bytes requested: ~d") + (76 . "Memory allocation request failed.") + (77 . "~S exceeds array size limit of ~S bytes.") + (94. "Printer error.") + (95. "Can't load printer.") + (96. "Can't get printer parameters.") + (97. "Can't start up printer job.") + (98. "Floating point exception.") + (111 . "Unexpected end of file encountered.") + (112 . "Array index ~S out of bounds for ~S .") + (113 . "Reader error: ~S encountered.") + (114 . "Reader error: Unknown reader macro character ~S .") + (115 . "Can't redefine constant ~S .") + (116 . "Reader error: Illegal character ~S .") + (117 . "Reader error: Illegal symbol syntax.") + (118 . "Reader error: Dot context error.") + (119 . "Reader error: Bad value ~S for *READ-BASE*.") + (120 . "Can't construct argument list from ~S.") + (121 . "Wrong FASL version.") + (122 . "Not a FASL file.") + (123 . "Undefined function ~s called with arguments ~s.") + (124 . "Image file incompatible with current version of Lisp.") + (127 . "Using ~S in ~S ~%would cause name conflicts with symbols inherited by that package: ~%~:{~S ~S~%~}") + (128 . "Importing ~S to ~S would conflict with inherited symbol ~S ." ) + (129 . "Reader error: Malformed number in a #b/#o/#x/#r macro." ) + (130 . "There is no package named ~S ." ) + (131 . "Reader error: No external symbol named ~S in package ~S ." ) + (132 . "Bad FASL file: internal inconsistency detected." ) + (133 . "Importing ~S to ~S would conflict with symbol ~S ." ) + (134 . "Uninterning ~S from ~S would cause conflicts among ~S ." ) + (135 . "~S is not accessible in ~S ." ) + (136 . "Exporting ~S in ~S would cause a name conflict with ~S in ~S ." ) + (137 . "Using ~S in ~S ~%would cause name conflicts with symbols already present in that package: ~%~:{~S ~S~%~}") + (139 . "Reader macro function ~S called outside of reader." ) + (140 . "Reader error: undefined character ~S in a ~S dispatch macro." ) + (141 . "Reader dispatch macro character ~S doesn't take an argument." ) + (142 . "Reader dispatch macro character ~S requires an argument." ) + (143 . "Reader error: Bad radix in #R macro." ) + (144 . "Reader error: Duplicate #~S= label." ) + (145 . "Reader error: Missing #~S# label." ) + (146 . "Reader error: Illegal font number in #\\ macro." ) + (147 . "Unknown character name ~S in #\\ macro." ) + (148 . "~S cannot be accessed with ~S subscripts." ) + (149 . "Requested size is too large to displace to ~S ." ) + (150 . "Too many elements in argument list ~S ." ) + (151 . "Arrays are not of the same size" ) + (152 . "Conflicting keyword arguments : ~S ~S, ~S ~S .") + (153 . "Incorrect keyword arguments in ~S .") + (154 . "Two few arguments in form ~S .") + (155 . "Too many arguments in form ~S .") + (157 . "value ~S is not of the expected type ~S.") + (158 . "~S is not a structure.") + (159 . "Access to slot ~S of structure ~S is out of bounds.") + (160 . "Form ~S does not match lambda list ~A .") + (161 . "Temporary number space exhausted.") + (163 . "Illegal #+/- expression ~S.") + (164 . "File ~S does not exist.") + (165 . "~S argument ~S is not of the required type.") + (166 . "~S argument ~S is not of type ~S.") + (167 . "Too many arguments in ~S.") + (168 . "Too few arguments in ~S.") + (169 . "Arguments don't match lambda list in ~S.") + (170 . "~S is not a proper list.") + (171 . "~S is not an array with a fill pointer.") + (172 . "~S is not an adjustable array.") + (173 . "Can't access component ~D of ~S.") + (174 . "~S doesn't match array element type of ~S.") + (175 . "Stack group ~S is exhausted.") + (176 . "Stack group ~S called with arguments ~:S; exactly 1 argument accepted.") + (177 . "Attempt to return too many values.") + (178 . "Can't dynamically bind ~S. ") + (200 . "Foreign exception: ~S. "))) + + Index: /branches/qres/ccl/level-0/l0-float.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-float.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-float.lisp (revision 13564) @@ -0,0 +1,1062 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;;; +;;; level-0;l0-float.lisp + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require :number-case-macro) +) + +;;; used by float reader +(defun make-float-from-fixnums (hi lo exp sign &optional result) + ;;(require-null-or-double-float-sym result) + ;; maybe nuke all these require-types? + ;;(setq hi (require-type hi 'fixnum)) + ;;(setq lo (require-type lo 'fixnum)) + ;;(setq exp (require-type exp 'fixnum)) + ;;(setq sign (require-type sign 'fixnum)) + (let ((the-float (or result (%make-dfloat)))) + (%make-float-from-fixnums the-float hi lo exp sign) + the-float)) + + +#+32-bit-target +(defun make-short-float-from-fixnums (significand biased-exp sign &optional result) + (%make-short-float-from-fixnums (or result (%make-sfloat)) significand biased-exp sign)) + +#+64-bit-target +(defun make-short-float-from-fixnums (significand biased-exp sign) + (declare (fixnum significand biased-exp sign)) + (host-single-float-from-unsigned-byte-32 + (logior + (the fixnum (if (< sign 0) (ash 1 31) 0)) + (the fixnum (ash biased-exp IEEE-single-float-exponent-offset)) + (the fixnum (logand significand + (1- (ash 1 IEEE-single-float-hidden-bit))))))) + + +(defun float-sign (n1 &optional n2) ; second arg silly + "Return a floating-point number that has the same sign as + FLOAT1 and, if FLOAT2 is given, has the same absolute value + as FLOAT2." + (if (and n2 (not (typep n2 'float))) + (setq n2 (require-type n2 'float))) + (number-case n1 + (double-float + (if (%double-float-sign n1) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) n2 (- n2)) + -1.0d0) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) (- n2) n2) + 1.0d0))) + (short-float + (if (%short-float-sign n1) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) n2 (- n2)) + -1.0s0) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) (- n2) n2) + 1.0s0))))) + + + +(defun %double-float-minusp (n) + (and (%double-float-sign n)(not (%double-float-zerop n)))) + +(defun %short-float-minusp (n) + (and (%short-float-sign n) (not (%short-float-zerop n)))) + +(defun %double-float-abs (n) + (if (not (%double-float-sign n)) + n + (%%double-float-abs! n (%make-dfloat)))) + +#+32-bit-target +(defun %short-float-abs (n) + (if (not (%short-float-sign n)) + n + (%%short-float-abs! n (%make-sfloat)))) + +(defun fixnum-decode-float (n) + (etypecase n + (double-float (%integer-decode-double-float n)))) + +(defun nan-or-infinity-p (n) + (etypecase n + (double-float (eq 2047 (%double-float-exp n))) + (short-float (eq 255 (%short-float-exp n))))) + +; not sure this is right +(defun infinity-p (n) + (etypecase n + (double-float (multiple-value-bind (hi lo exp)(fixnum-decode-float n) + (and (eq 2047 exp) + (eq #x1000000 hi) + (eq 0 lo)))) + (short-float + #+32-bit-target + (multiple-value-bind (high low)(%sfloat-hwords n) + (let* ((mantissa (%ilogior2 low (%ilsl 16 (%ilogand2 high #x007F)))) + (exp (%ilsr 7 (%ilogand2 high #x7F80)))) + (and (eq exp 255) + (eq 0 mantissa)))) + #+64-bit-target + (let* ((bits (single-float-bits n)) + (exp (ldb (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + bits)) + (mantissa (ldb (byte IEEE-single-float-mantissa-width + IEEE-single-float-mantissa-offset) + bits))) + (declare (fixnum bits exp mantissa)) + (and (= exp 255) + (zerop mantissa)))))) + +#+32-bit-target +(defun fixnum-decode-short-float (float) + (multiple-value-bind (high low)(%sfloat-hwords float) + (let* ((mantissa (%ilogior2 low (%ilsl 16 (%ilogand2 high #x007F)))) + (exp (%ilsr 7 (%ilogand2 high #x7F80)))) + (if (and (neq exp 0)(neq exp 255))(setq mantissa (%ilogior mantissa #x800000))) + (values mantissa exp (%ilsr 15 high))))) + +#+64-bit-target +(defun fixnum-decode-short-float (float) + (let* ((bits (single-float-bits float))) + (declare (fixnum bits)) + (let* ((mantissa (ldb (byte IEEE-single-float-mantissa-width + IEEE-single-float-mantissa-offset) + bits)) + (exp (ldb (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + bits)) + (sign (lsh bits -31))) + (declare (fixnum mantissa exp sign)) + (unless (or (= exp 0) (= exp 255)) + (setq mantissa (logior mantissa (ash 1 IEEE-single-float-hidden-bit)))) + (values mantissa exp sign)))) + + + +#+32-bit-target +(defun integer-decode-double-float (n) + (multiple-value-bind (hi lo exp sign)(%integer-decode-double-float n) + ; is only 53 bits and positive so should be easy + ;(values (logior (ash hi 28) lo) exp sign))) + ; if denormalized, may fit in a fixnum + (setq exp (- exp (if (< hi #x1000000) + (+ IEEE-double-float-mantissa-width IEEE-double-float-bias) + (+ IEEE-double-float-mantissa-width (1+ IEEE-double-float-bias))))) + (if (< hi (ash 1 (1- target::fixnumshift))) ; aka 2 + (values (logior (ash hi 28) lo) exp sign) + ; might fit in 1 word? + (let ((big (%alloc-misc 2 target::subtag-bignum))) + (make-big-53 hi lo big) + (if (< hi #x1000000) (%normalize-bignum big)) + (values big exp sign))))) + +#+64-bit-target +(defun integer-decode-double-float (n) + (multiple-value-bind (hi lo exp sign)(%integer-decode-double-float n) + (setq exp (- exp (if (< hi #x1000000) + (+ IEEE-double-float-mantissa-width IEEE-double-float-bias) + (+ IEEE-double-float-mantissa-width (1+ IEEE-double-float-bias))))) + (values (logior (ash hi 28) lo) exp sign))) + + +;;; actually only called when magnitude bigger than a fixnum +#+32-bit-target +(defun %truncate-double-float (n) + (multiple-value-bind (hi lo exp sign)(%integer-decode-double-float n) + (if (< exp (1+ IEEE-double-float-bias)) ; this is false in practice + 0 + (progn + (setq exp (- exp (+ IEEE-double-float-mantissa-width (1+ IEEE-double-float-bias)))) + (if (eq sign 1) ; positive + (logior (ash hi (+ 28 exp))(ash lo exp)) + (if (<= exp 0) ; exp positive - negate before shift - else after + (let ((poo (logior (ash hi (+ 28 exp))(ash lo exp)))) + (- poo)) + (let ((poo (logior (ash hi 28) lo))) + (ash (- poo) exp)))))))) + +#+64-bit-target +(defun %truncate-double-float (n) + (multiple-value-bind (mantissa exp sign) (integer-decode-float n) + (* sign (ash mantissa exp)))) + + + +; actually only called when bigger than a fixnum +(defun %truncate-short-float (n) + (multiple-value-bind (mantissa exp sign)(fixnum-decode-short-float n) + (if (< exp (1+ IEEE-single-float-bias)) ; is magnitude less than 1 - false in practice + 0 + (progn + (setq exp (- exp (+ IEEE-single-float-mantissa-width (1+ IEEE-single-float-bias)))) + (ash (if (eq sign 0) mantissa (- mantissa)) exp))))) + +(defun decode-float (n) + "Return three values: + 1) a floating-point number representing the significand. This is always + between 0.5 (inclusive) and 1.0 (exclusive). + 2) an integer representing the exponent. + 3) -1.0 or 1.0 (i.e. the sign of the argument.)" + (number-case n + (double-float + (let* ((old-exp (%double-float-exp n)) + (sign (if (%double-float-sign n) -1.0d0 1.0d0))) + (if (eq 0 old-exp) + (if (%double-float-zerop n) + (values 0.0d0 0 sign) + (let* ((val (%make-dfloat)) + (zeros (dfloat-significand-zeros n))) + (%%double-float-abs! n val) + (%%scale-dfloat! val (+ 2 IEEE-double-float-bias zeros) val) ; get it normalized + (set-%double-float-exp val IEEE-double-float-bias) ; then bash exponent + (values val (- old-exp zeros IEEE-double-float-bias) sign))) + (if (> old-exp IEEE-double-float-normal-exponent-max) + (error "Can't decode NAN or infinity ~s" n) + (let ((val (%make-dfloat))) + (%%double-float-abs! n val) + (set-%double-float-exp val IEEE-double-float-bias) + (values val (- old-exp IEEE-double-float-bias) sign)))))) + (short-float + (let* ((old-exp (%short-float-exp n)) + (sign (if (%short-float-sign n) -1.0s0 1.0s0))) + (if (eq 0 old-exp) + (if (%short-float-zerop n) + (values 0.0s0 0 sign) + #+32-bit-target + (let* ((val (%make-sfloat)) + (zeros (sfloat-significand-zeros n))) + (%%short-float-abs! n val) + (%%scale-sfloat! val (+ 2 IEEE-single-float-bias zeros) val) ; get it normalized + (set-%short-float-exp val IEEE-single-float-bias) ; then bash exponent + (values val (- old-exp zeros IEEE-single-float-bias) sign)) + #+64-bit-target + (let* ((zeros (sfloat-significand-zeros n)) + (val (%%scale-sfloat (%short-float-abs n) + (+ 2 IEEE-single-float-bias zeros)))) + (values (set-%short-float-exp val IEEE-single-float-bias) + (- old-exp zeros IEEE-single-float-bias) sign))) + (if (> old-exp IEEE-single-float-normal-exponent-max) + (error "Can't decode NAN or infinity ~s" n) + #+32-bit-target + (let ((val (%make-sfloat))) + (%%short-float-abs! n val) + (set-%short-float-exp val IEEE-single-float-bias) + (values val (- old-exp IEEE-single-float-bias) sign)) + #+64-bit-target + (values (set-%short-float-exp (%short-float-abs n) + IEEE-single-float-bias) + (- old-exp IEEE-single-float-bias) sign))))))) + +; (* float (expt 2 int)) +(defun scale-float (float int) + "Return the value (* f (expt (float 2 f) ex)), but with no unnecessary loss + of precision or overflow." + (unless (fixnump int)(setq int (require-type int 'fixnum))) + (number-case float + (double-float + (let* ((float-exp (%double-float-exp float)) + (new-exp (+ float-exp int))) + (if (eq 0 float-exp) ; already denormalized? + (if (%double-float-zerop float) + float + (let ((result (%make-dfloat))) + (%%scale-dfloat! float (+ (1+ IEEE-double-float-bias) int) result))) + (if (<= new-exp 0) ; maybe going denormalized + (if (<= new-exp (- IEEE-double-float-digits)) + 0.0d0 ; should this be underflow? - should just be normal and result is fn of current fpu-mode + ;(error "Can't scale ~s by ~s." float int) ; should signal something + (let ((result (%make-dfloat))) + (%copy-double-float float result) + (set-%double-float-exp result 1) ; scale by float-exp -1 + (%%scale-dfloat! result (+ IEEE-double-float-bias (+ float-exp int)) result) + result)) + (if (> new-exp IEEE-double-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'scale-float + :operands (list float int))) + (let ((new-float (%make-dfloat))) + (%copy-double-float float new-float) + (set-%double-float-exp new-float new-exp) + new-float)))))) + (short-float + (let* ((float-exp (%short-float-exp float)) + (new-exp (+ float-exp int))) + (if (eq 0 float-exp) ; already denormalized? + (if (%short-float-zerop float) + float + #+32-bit-target + (let ((result (%make-sfloat))) + (%%scale-sfloat! float (+ (1+ IEEE-single-float-bias) int) result)) + #+64-bit-target + (%%scale-sfloat float (+ (1+ IEEE-single-float-bias) int))) + (if (<= new-exp 0) ; maybe going denormalized + (if (<= new-exp (- IEEE-single-float-digits)) + ;; should this be underflow? - should just be normal and + ;; result is fn of current fpu-mode (error "Can't scale + ;; ~s by ~s." float int) ; should signal something + 0.0s0 + #+32-bit-target + (let ((result (%make-sfloat))) + (%copy-short-float float result) + (set-%short-float-exp result 1) ; scale by float-exp -1 + (%%scale-sfloat! result (+ IEEE-single-float-bias (+ float-exp int)) result) + result) + #+64-bit-target + (%%scale-sfloat (set-%short-float-exp float 1) + (+ IEEE-single-float-bias (+ float-exp int)))) + (if (> new-exp IEEE-single-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'scale-float + :operands (list float int))) + #+32-bit-target + (let ((new-float (%make-sfloat))) + (%copy-short-float float new-float) + (set-%short-float-exp new-float new-exp) + new-float) + #+64-bit-target + (set-%short-float-exp float new-exp)))))))) + +(defun %copy-float (f) + ;Returns a freshly consed float. float can also be a macptr. + (cond ((double-float-p f) (%copy-double-float f (%make-dfloat))) + ((macptrp f) + (let ((float (%make-dfloat))) + (%copy-ptr-to-ivector f 0 float (* 4 target::double-float.value-cell) 8) + float)) + (t (error "Illegal arg ~s to %copy-float" f)))) + +(defun float-precision (float) ; not used - not in cltl2 index ? + "Return a non-negative number of significant digits in its float argument. + Will be less than FLOAT-DIGITS if denormalized or zero." + (number-case float + (double-float + (if (eq 0 (%double-float-exp float)) + (if (not (%double-float-zerop float)) + ; denormalized + (- IEEE-double-float-mantissa-width (dfloat-significand-zeros float)) + 0) + IEEE-double-float-digits)) + (short-float + (if (eq 0 (%short-float-exp float)) + (if (not (%short-float-zerop float)) + ; denormalized + (- IEEE-single-float-mantissa-width (sfloat-significand-zeros float)) + 0) + IEEE-single-float-digits)))) + + +(defun %double-float (number &optional result) + ;(require-null-or-double-float-sym result) + ; use number-case when macro is common + (number-case number + (double-float + (if result + (%copy-double-float number result) + number)) + (short-float + (%short-float->double-float number (or result (%make-dfloat)))) + (fixnum + (%fixnum-dfloat number (or result (%make-dfloat)))) + (bignum (%bignum-dfloat number result)) + (ratio + (if (not result)(setq result (%make-dfloat))) + (let* ((num (%numerator number)) + (den (%denominator number))) + ; dont error if result is floatable when either top or bottom is not. + ; maybe do usual first, catching error + (if (not (or (bignump num)(bignump den))) + (with-stack-double-floats ((fnum num) + (fden den)) + (%double-float/-2! fnum fden result)) + (let* ((numlen (integer-length num)) + (denlen (integer-length den)) + (exp (- numlen denlen)) + (minusp (minusp num))) + (if (and (<= numlen IEEE-double-float-bias) + (<= denlen IEEE-double-float-bias) + #|(not (minusp exp))|# + (<= (abs exp) IEEE-double-float-mantissa-width)) + (with-stack-double-floats ((fnum num) + (fden den)) + + (%double-float/-2! fnum fden result)) + (if (> exp IEEE-double-float-mantissa-width) + (progn (%double-float (round num den) result)) + (if (>= exp 0) + ; exp between 0 and 53 and nums big + (let* ((shift (- IEEE-double-float-digits exp)) + (num (if minusp (- num) num)) + (int (round (ash num shift) den)) ; gaak + (intlen (integer-length int)) + (new-exp (+ intlen (- IEEE-double-float-bias shift)))) + + (when (> intlen IEEE-double-float-digits) + (setq shift (1- shift)) + (setq int (round (ash num shift) den)) + (setq intlen (integer-length int)) + (setq new-exp (+ intlen (- IEEE-double-float-bias shift)))) + (when (> new-exp 2046) + (error (make-condition 'floating-point-overflow + :operation 'double-float + :operands (list number)))) + (make-float-from-fixnums (ldb (byte 25 (- intlen 25)) int) + (ldb (byte 28 (max (- intlen 53) 0)) int) + new-exp ;(+ intlen (- IEEE-double-float-bias 53)) + (if minusp -1 1) + result)) + ; den > num - exp negative + (progn + (float-rat-neg-exp num den (if minusp -1 1) result))))))))))) + + +#+32-bit-target +(defun %short-float-ratio (number &optional result) + (if (not result)(setq result (%make-sfloat))) + (let* ((num (%numerator number)) + (den (%denominator number))) + ;; dont error if result is floatable when either top or bottom is + ;; not. maybe do usual first, catching error + (if (not (or (bignump num)(bignump den))) + (target::with-stack-short-floats ((fnum num) + (fden den)) + (%short-float/-2! fnum fden result)) + (let* ((numlen (integer-length num)) + (denlen (integer-length den)) + (exp (- numlen denlen)) + (minusp (minusp num))) + (if (and (<= numlen IEEE-single-float-bias) + (<= denlen IEEE-single-float-bias) + #|(not (minusp exp))|# + (<= (abs exp) IEEE-single-float-mantissa-width)) + (target::with-stack-short-floats ((fnum num) + (fden den)) + (%short-float/-2! fnum fden result)) + (if (> exp IEEE-single-float-mantissa-width) + (progn (%short-float (round num den) result)) + (if (>= exp 0) + ; exp between 0 and 23 and nums big + (let* ((shift (- IEEE-single-float-digits exp)) + (num (if minusp (- num) num)) + (int (round (ash num shift) den)) ; gaak + (intlen (integer-length int)) + (new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> intlen IEEE-single-float-digits) + (setq shift (1- shift)) + (setq int (round (ash num shift) den)) + (setq intlen (integer-length int)) + (setq new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> new-exp IEEE-single-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'short-float + :operands (list number)))) + (make-short-float-from-fixnums + (ldb (byte IEEE-single-float-digits (- intlen IEEE-single-float-digits)) int) + new-exp + (if minusp -1 1) + result)) + ; den > num - exp negative + (progn + (float-rat-neg-exp num den (if minusp -1 1) result t))))))))) + +#+64-bit-target +(defun %short-float-ratio (number) + (let* ((num (%numerator number)) + (den (%denominator number))) + ;; dont error if result is floatable when either top or bottom is + ;; not. maybe do usual first, catching error + (if (not (or (bignump num)(bignump den))) + (/ (the short-float (%short-float num)) + (the short-float (%short-float den))) + (let* ((numlen (integer-length num)) + (denlen (integer-length den)) + (exp (- numlen denlen)) + (minusp (minusp num))) + (if (and (<= numlen IEEE-single-float-bias) + (<= denlen IEEE-single-float-bias) + #|(not (minusp exp))|# + (<= (abs exp) IEEE-single-float-mantissa-width)) + (/ (the short-float (%short-float num)) + (the short-float (%short-float den))) + (if (> exp IEEE-single-float-mantissa-width) + (progn (%short-float (round num den))) + (if (>= exp 0) + ; exp between 0 and 23 and nums big + (let* ((shift (- IEEE-single-float-digits exp)) + (num (if minusp (- num) num)) + (int (round (ash num shift) den)) ; gaak + (intlen (integer-length int)) + (new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> intlen IEEE-single-float-digits) + (setq shift (1- shift)) + (setq int (round (ash num shift) den)) + (setq intlen (integer-length int)) + (setq new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> new-exp IEEE-single-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'short-float + :operands (list number)))) + (make-short-float-from-fixnums + (ldb (byte IEEE-single-float-digits (- intlen IEEE-single-float-digits)) int) + new-exp + (if minusp 1 0))) + ; den > num - exp negative + (progn + (float-rat-neg-exp num den (if minusp -1 1) nil t))))))))) + + +#+32-bit-target +(defun %short-float (number &optional result) + (number-case number + (short-float + (if result (%copy-short-float number result) number)) + (double-float + (%double-float->short-float number (or result (%make-sfloat)))) + (fixnum + (%fixnum-sfloat number (or result (%make-sfloat)))) + (bignum + (%bignum-sfloat number (or result (%make-sfloat)))) + (ratio + (%short-float-ratio number result)))) + +#+64-bit-target +(defun %short-float (number) + (number-case number + (short-float number) + (double-float (%double-float->short-float number)) + (fixnum (%fixnum-sfloat number)) + (bignum (%bignum-sfloat number)) + (ratio (%short-float-ratio number)))) + + +(defun float-rat-neg-exp (integer divisor sign &optional result short) + (if (minusp sign)(setq integer (- integer))) + (let* ((integer-length (integer-length integer)) + ;; make sure we will have enough bits in the quotient + ;; (and a couple extra for rounding) + (shift-factor (+ (- (integer-length divisor) integer-length) (if short 28 60))) ; fix + (scaled-integer integer)) + (if (plusp shift-factor) + (setq scaled-integer (ash integer shift-factor)) + (setq divisor (ash divisor (- shift-factor))) ; assume div > num + ) + ;(pprint (list shift-factor scaled-integer divisor)) + (multiple-value-bind (quotient remainder)(floor scaled-integer divisor) + (unless (zerop remainder) ; whats this - tells us there's junk below + (setq quotient (logior quotient 1))) + ;; why do it return 2 values? + (values (float-and-scale-and-round sign quotient (- shift-factor) short result))))) + + + +;;; when is (negate-bignum (bignum-ashift-right big)) ; can't negate +;;; in place cause may get bigger cheaper than (negate-bignum big) - 6 +;;; 0r 8 digits ; 8 longs so win if digits > 7 or negate it on the +;;; stack + +(defun %bignum-dfloat (big &optional result) + (let* ((minusp (bignum-minusp big))) + (flet + ((doit (new-big) + (let* ((int-len (bignum-integer-length new-big))) + (when (>= int-len (- 2047 IEEE-double-float-bias)) ; args? + (error (make-condition 'floating-point-overflow + :operation 'float :operands (list big)))) + (if (> int-len 53) + (let* ((hi (ldb (byte 25 (- int-len 25)) new-big)) + (lo (ldb (byte 28 (- int-len 53)) new-big))) + ;(print (list new-big hi lo)) + (when (and (logbitp (- int-len 54) new-big) ; round bit + (or (%ilogbitp 0 lo) ; oddp + ;; or more bits below round + (%i< (one-bignum-factor-of-two new-big) (- int-len 54)))) + (if (eq lo #xfffffff) + (setq hi (1+ hi) lo 0) + (setq lo (1+ lo))) + (when (%ilogbitp 25 hi) ; got bigger + (setq int-len (1+ int-len)) + (let ((bit (%ilogbitp 0 hi))) + (setq hi (%ilsr 1 hi)) + (setq lo (%ilsr 1 lo)) + (if bit (setq lo (%ilogior #x8000000 lo)))))) + (make-float-from-fixnums hi lo (+ IEEE-double-float-bias int-len)(if minusp -1 1) result)) + (let* ((hi (ldb (byte 25 (- int-len 25)) new-big)) + (lobits (min (- int-len 25) 28)) + (lo (ldb (byte lobits (- int-len (+ lobits 25))) new-big))) + (if (< lobits 28) (setq lo (ash lo (- 28 lobits)))) + (make-float-from-fixnums hi lo (+ IEEE-double-float-bias int-len) (if minusp -1 1) result)))))) + (declare (dynamic-extent #'doit)) + (with-one-negated-bignum-buffer big doit)))) + +#+32-bit-target +(defun %bignum-sfloat (big &optional result) + (let* ((minusp (bignum-minusp big))) + (flet + ((doit (new-big) + (let* ((int-len (bignum-integer-length new-big))) + (when (>= int-len (- 255 IEEE-single-float-bias)) ; args? + (error (make-condition 'floating-point-overflow + :operation 'float :operands (list big 1.0s0)))) + (if t ;(> int-len IEEE-single-float-digits) ; always true + (let* ((lo (ldb (byte IEEE-single-float-digits (- int-len IEEE-single-float-digits)) new-big))) + (when (and (logbitp (- int-len 25) new-big) ; round bit + (or (%ilogbitp 0 lo) ; oddp + ; or more bits below round + (%i< (one-bignum-factor-of-two new-big) (- int-len 25)))) + (setq lo (1+ lo)) + (when (%ilogbitp 24 lo) ; got bigger + (setq int-len (1+ int-len)) + (setq lo (%ilsr 1 lo)))) + (make-short-float-from-fixnums lo (+ IEEE-single-float-bias int-len)(if minusp -1 1) result)) + )))) + (declare (dynamic-extent #'doit)) + (with-one-negated-bignum-buffer big doit)))) + + +#+64-bit-target +(defun %bignum-sfloat (big) + (let* ((minusp (bignum-minusp big))) + (flet + ((doit (new-big) + (let* ((int-len (bignum-integer-length new-big))) + (when (>= int-len (- 255 IEEE-single-float-bias)) ; args? + (error (make-condition 'floating-point-overflow + :operation 'float :operands (list big 1.0s0)))) + (if t ;(> int-len IEEE-single-float-digits) ; always true + (let* ((lo (ldb (byte IEEE-single-float-digits (- int-len IEEE-single-float-digits)) new-big))) + (when (and (logbitp (- int-len 25) new-big) ; round bit + (or (%ilogbitp 0 lo) ; oddp + ; or more bits below round + (%i< (one-bignum-factor-of-two new-big) (- int-len 25)))) + (setq lo (1+ lo)) + (when (%ilogbitp 24 lo) ; got bigger + (setq int-len (1+ int-len)) + (setq lo (%ilsr 1 lo)))) + (make-short-float-from-fixnums lo (+ IEEE-single-float-bias int-len)(if minusp -1 1))) + )))) + (declare (dynamic-extent #'doit)) + (with-one-negated-bignum-buffer big doit)))) + + + + +(defun %fixnum-dfloat (fix &optional result) + (if (eq 0 fix) + (if result (%copy-double-float 0.0d0 result) 0.0d0) + (progn + (when (not result)(setq result (%make-dfloat))) + ; it better return result + (%int-to-dfloat fix result)))) + + +#+32-bit-target +(defun %fixnum-sfloat (fix &optional result) + (if (eq 0 fix) + (if result (%copy-short-float 0.0s0 result) 0.0s0) + (%int-to-sfloat! fix (or result (%make-sfloat))))) + +#+64-bit-target +(defun %fixnum-sfloat (fix) + (if (eq 0 fix) + 0.0s0 + (%int-to-sfloat fix))) + +;;; Transcendental functions. +(defun sin (x) + "Return the sine of NUMBER." + (if (complexp x) + (let* ((r (realpart x)) + (i (imagpart x))) + (complex (* (sin r) (cosh i)) + (* (cos r) (sinh i)))) + (if (typep x 'double-float) + (%double-float-sin! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-sin! sx (%make-sfloat))) + #+64-bit-target + (%single-float-sin (%short-float x))))) + +(defun cos (x) + "Return the cosine of NUMBER." + (if (complexp x) + (let* ((r (realpart x)) + (i (imagpart x))) + (complex (* (cos r) (cosh i)) + (- (* (sin r) (sinh i))))) + (if (typep x 'double-float) + (%double-float-cos! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-cos! sx (%make-sfloat))) + #+64-bit-target + (%single-float-cos (%short-float x))))) + +(defun tan (x) + "Return the tangent of NUMBER." + (if (complexp x) + (/ (sin x) (cos x)) + (if (typep x 'double-float) + (%double-float-tan! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-tan! sx (%make-sfloat))) + #+64-bit-target + (%single-float-tan (%short-float x)) + ))) + + + + +(defun atan (y &optional (x nil x-p)) + "Return the arc tangent of Y if X is omitted or Y/X if X is supplied." + (if x-p + (if (or (typep x 'double-float) + (typep y 'double-float)) + (with-stack-double-floats ((dy y) + (dx x)) + (%df-atan2 dy dx)) + #+32-bit-target + (target::with-stack-short-floats ((sy y) + (sx x)) + (%sf-atan2! sy sx)) + #+64-bit-target + (%sf-atan2 (%short-float y) (%short-float x))) + (if (typep y 'complex) + (let* ((iy (* (sqrt -1) y))) + (/ (- (log (+ 1 iy)) (log (- 1 iy))) + #c(0 2))) + (if (typep y 'double-float) + (%double-float-atan! y (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sy y)) + (%single-float-atan! sy (%make-sfloat))) + #+64-bit-target + (%single-float-atan (%short-float y)) + )))) + + + +(defun log (x &optional (b nil b-p)) + "Return the logarithm of NUMBER in the base BASE, which defaults to e." + (if b-p + (if (zerop b) + (if (zerop x) + (report-bad-arg x '(not (satisfies zerop) )) + (if (floatp x) (float 0.0d0 x) 0)) + (/ (log-e x) (log-e b))) + (log-e x))) + +(defun log-e (x) + (cond + ((bignump x) + (if (minusp x) + (complex (log-e (- x)) pi) + (let* ((base1 3) + (guess (floor (1- (integer-length x)) + (log base1 2))) + (guess1 (* guess (log-e base1)))) + (+ guess1 (log-e (/ x (expt base1 guess))))))) + ((and (ratiop x) + (or (> x most-positive-short-float) + (< x most-negative-short-float))) + (- (log-e (%numerator x)) (log-e (%denominator x)))) + ((typep x 'complex) + (complex (log-e (abs x)) (phase x))) + ((typep x 'double-float) + (with-stack-double-floats ((dx x)) + (if (minusp x) + (complex (%double-float-log! (%%double-float-abs! dx dx) (%make-dfloat)) pi) + (%double-float-log! dx (%make-dfloat))))) + (t + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (if (minusp x) + (complex (%single-float-log! (%%short-float-abs! sx sx) (%make-sfloat)) + #.(coerce pi 'short-float)) + (%single-float-log! sx (%make-sfloat)))) + #+64-bit-target + (if (minusp x) + (complex (%single-float-log (%short-float-abs (%short-float x))) #.(coerce pi 'single-float)) + (%single-float-log (%short-float x))) + ))) + + + +(defun exp (x) + "Return e raised to the power NUMBER." + (typecase x + (complex (* (exp (realpart x)) (cis (imagpart x)))) + (double-float (%double-float-exp! x (%make-dfloat))) + (t + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-exp! sx (%make-sfloat))) + #+64-bit-target + (%single-float-exp (%short-float x))))) + + + +(defun expt (b e) + "Return BASE raised to the POWER." + (cond ((zerop e) (1+ (* b e))) + ((integerp e) + (if (minusp e) (/ 1 (%integer-power b (- e))) (%integer-power b e))) + ((zerop b) + (if (plusp (realpart e)) b (report-bad-arg e '(number (0) *)))) + ((and (realp b) (plusp b) (realp e)) + (if (or (typep b 'double-float) + (typep e 'double-float)) + (with-stack-double-floats ((b1 b) + (e1 e)) + (%double-float-expt! b1 e1 (%make-dfloat))) + #+32-bit-target + (target::with-stack-short-floats ((b1 b) + (e1 e)) + (%single-float-expt! b1 e1 (%make-sfloat))) + #+64-bit-target + (%single-float-expt (%short-float b) (%short-float e)) + )) + (t (exp (* e (log b)))))) + + + +(defun sqrt (x &aux a b) + "Return the square root of NUMBER." + (cond ((zerop x) x) + ((complexp x) (* (sqrt (abs x)) (cis (/ (phase x) 2)))) + ((minusp x) (complex 0 (sqrt (- x)))) + ((floatp x) + (fsqrt x)) + ((and (integerp x) (eql x (* (setq a (isqrt x)) a))) a) + ((and (ratiop x) + (let ((n (numerator x)) + d) + (and (eql n (* (setq a (isqrt n)) a)) + (eql (setq d (denominator x)) + (* (setq b (isqrt d)) b))))) + (/ a b)) + (t + #+32-bit-target + (target::with-stack-short-floats ((f1)) + (fsqrt (%short-float x f1))) + #+64-bit-target + (fsqrt (%short-float x))))) + + + +(defun asin (x) + "Return the arc sine of NUMBER." + (number-case x + (complex + (let ((sqrt-1-x (sqrt (- 1 x))) + (sqrt-1+x (sqrt (+ 1 x)))) + (complex (atan (/ (realpart x) + (realpart (* sqrt-1-x sqrt-1+x)))) + (asinh (imagpart (* (conjugate sqrt-1-x) + sqrt-1+x)))))) + (double-float + (locally (declare (type double-float x)) + (if (and (<= -1.0d0 x) + (<= x 1.0d0)) + (%double-float-asin! x (%make-dfloat)) + (let* ((temp (+ (complex -0.0d0 x) + (sqrt (- 1.0d0 (the double-float (* x x))))))) + (complex (phase temp) (- (log (abs temp)))))))) + ((short-float rational) + #+32-bit-target + (let* ((x1 (%make-sfloat))) + (declare (dynamic-extent x1)) + (if (and (realp x) + (<= -1.0s0 (setq x (%short-float x x1))) + (<= x 1.0s0)) + (%single-float-asin! x1 (%make-sfloat)) + (progn + (setq x (+ (complex (- (imagpart x)) (realpart x)) + (sqrt (- 1 (* x x))))) + (complex (phase x) (- (log (abs x))))))) + #+64-bit-target + (if (and (realp x) + (<= -1.0s0 (setq x (%short-float x))) + (<= x 1.0s0)) + (%single-float-asin x) + (progn + (setq x (+ (complex (- (imagpart x)) (realpart x)) + (sqrt (- 1 (* x x))))) + (complex (phase x) (- (log (abs x)))))) + ))) + + +(eval-when (:execute :compile-toplevel) + (defconstant double-float-half-pi (asin 1.0d0)) + (defconstant single-float-half-pi (asin 1.0f0)) +) + + + +(defun acos (x) + "Return the arc cosine of NUMBER." + (number-case x + (complex + (let ((sqrt-1+x (sqrt (+ 1 x))) + (sqrt-1-x (sqrt (- 1 x)))) + (complex (* 2 (atan (/ (realpart sqrt-1-x) + (realpart sqrt-1+x)))) + (asinh (imagpart (* (conjugate sqrt-1+x) + sqrt-1-x)))))) + + (double-float + (locally (declare (type double-float x)) + (if (and (<= -1.0d0 x) + (<= x 1.0d0)) + (%double-float-acos! x (%make-dfloat)) + (- double-float-half-pi (asin x))))) + ((short-float rational) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (locally + (declare (type short-float sx)) + (if (and (<= -1.0s0 sx) + (<= sx 1.0s0)) + (%single-float-acos! sx (%make-sfloat)) + (- single-float-half-pi (asin sx))))) + #+64-bit-target + (let* ((sx (%short-float x))) + (declare (type short-float sx)) + (if (and (<= -1.0s0 sx) + (<= sx 1.0s0)) + (%single-float-acos sx) + (- single-float-half-pi (asin sx)))) + ))) + + +(defun fsqrt (x) + (etypecase x + (double-float (%double-float-sqrt! x (%make-dfloat))) + (single-float + #+32-bit-target + (%single-float-sqrt! x (%make-sfloat)) + #+64-bit-target + (%single-float-sqrt x)))) + + + +(defun %df-atan2 (y x &optional result) + (if (zerop x) + (if (zerop y) + (if (plusp (float-sign x)) + y + (float-sign y pi)) + (float-sign y double-float-half-pi)) + (%double-float-atan2! y x (or result (%make-dfloat))))) + +#+32-bit-target +(defun %sf-atan2! (y x &optional result) + (if (zerop x) + (if (zerop y) + (if (plusp (float-sign x)) + y + (float-sign y pi)) + (float-sign y single-float-half-pi)) + (%single-float-atan2! y x (or result (%make-sfloat))))) + +#+64-bit-target +(defun %sf-atan2 (y x) + (if (zerop x) + (if (zerop y) + (if (plusp (float-sign x)) + y + (float-sign y pi)) + (float-sign y single-float-half-pi)) + (%single-float-atan2 y x))) + +#+64-bit-target +(defun %short-float-exp (n) + (let* ((bits (single-float-bits n))) + (declare (type (unsigned-byte 32) bits)) + (ldb (byte IEEE-single-float-exponent-width IEEE-single-float-exponent-offset) bits))) + + +#+64-bit-target +(defun set-%short-float-exp (float exp) + (host-single-float-from-unsigned-byte-32 + (dpb exp + (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + (the (unsigned-byte 32) (single-float-bits float))))) + +#+64-bit-target +(defun %%scale-sfloat (float int) + (* (the single-float float) + (the single-float (host-single-float-from-unsigned-byte-32 + (dpb int + (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + 0))))) + +#+64-bit-target +(defun %double-float-exp (n) + (let* ((highword (double-float-bits n))) + (declare (fixnum highword)) + (logand (1- (ash 1 IEEE-double-float-exponent-width)) + (ash highword (- (- IEEE-double-float-exponent-offset 32)))))) + +#+64-bit-target +(defun set-%double-float-exp (float exp) + (let* ((highword (double-float-bits float))) + (declare (fixnum highword)) + (setf (uvref float target::double-float.val-high-cell) + (dpb exp + (byte IEEE-double-float-exponent-width + (- IEEE-double-float-exponent-offset 32)) + highword)) + exp)) + +#+64-bit-target +(defun %integer-decode-double-float (f) + (multiple-value-bind (hiword loword) (double-float-bits f) + (declare (type (unsigned-byte 32) hiword loword)) + (let* ((exp (ldb (byte IEEE-double-float-exponent-width + (- IEEE-double-float-exponent-offset 32)) + hiword)) + (mantissa (logior + (the fixnum + (dpb (ldb (byte (- IEEE-double-float-mantissa-width 32) + IEEE-double-float-mantissa-offset) + hiword) + (byte (- IEEE-double-float-mantissa-width 32) + 32) + loword)) + (if (zerop exp) + 0 + (ash 1 IEEE-double-float-hidden-bit)))) + (sign (if (logbitp 31 hiword) -1 1))) + (declare (fixnum exp mantissa sign)) + (values (ldb (byte 25 28) mantissa) + (ldb (byte 28 0) mantissa) + exp + sign)))) + +;;; end of l0-float.lisp Index: /branches/qres/ccl/level-0/l0-hash.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-hash.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-hash.lisp (revision 13564) @@ -0,0 +1,1998 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;;;;;;;;;;;; +;; +;; See hash.lisp for documentation + + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv") + (require :number-case-macro) + (define-symbol-macro deleted-hash-key-marker (%slot-unbound-marker)) + (define-symbol-macro free-hash-marker (%unbound-marker)) + (define-symbol-macro rehashing-value-marker (%slot-unbound-marker)) + (declaim (inline nhash.vector-size)) + (declaim (inline mixup-hash-code)) + (declaim (inline hash-table-p)) + (declaim (inline %%eqhash)) + (declaim (inline index->vector-index vector-index->index swap)) + (declaim (inline %already-rehashed-p %set-already-rehashed-p)) + (declaim (inline need-use-eql)) + (declaim (inline %needs-rehashing-p)) + (declaim (inline compute-hash-code)) + (declaim (inline eq-hash-find eq-hash-find-for-put)) + (declaim (inline read-lock-hash-table write-lock-hash-table unlock-hash-table)) + (declaim (inline %hash-symbol)) + (declaim (inline hash-mod)) + (declaim (inline set-hash-key-conditional set-hash-value-conditional)) + (declaim (inline hash-lock-free-p lock-free-gethash))) + + + +(defun %cons-hash-table (keytrans-function compare-function vector + threshold rehash-ratio rehash-size find find-new owner &optional lock-free-p) + (%istruct + 'HASH-TABLE ; type + keytrans-function ; nhash.keytransF + compare-function ; nhash.compareF + nil ; nhash.rehash-bits + vector ; nhash.vector + (if lock-free-p $nhash.lock-free 0) ; nhash.lock + owner ; nhash.owner + threshold ; nhash.grow-threshold + rehash-ratio ; nhash.rehash-ratio + rehash-size ; nhash.rehash-size + 0 ; nhash.puthash-count + (if lock-free-p + (make-lock) + (unless owner (make-read-write-lock))) ; nhash.exclusion-lock + find ; nhash.find + find-new ; nhash.find-new + nil ; nhash.read-only + )) + +(defun nhash.vector-size (vector) + (nhash.vector.size vector)) + +(defun hash-mod (hash entries vector) + (fast-mod-3 hash entries (nhash.vector.size-reciprocal vector))) + +;; For lock-free hash tables +(defun set-hash-key-conditional (index vector old new) + (%set-hash-table-vector-key-conditional (%i+ target::misc-data-offset + (ash (the fixnum index) target::word-shift)) + vector + old + new)) + +(defun set-hash-value-conditional (index vector old new) + (store-gvector-conditional (%i+ index 1) vector old new)) + +(defun hash-lock-free-p (hash) + (logtest $nhash.lock-free (the fixnum (nhash.lock hash)))) + +;;; Is KEY something which can be EQL to something it's not EQ to ? +;;; (e.g., is it a number or macptr ?) +;;; This can be more general than necessary but shouldn't be less so. +(defun need-use-eql (key) + (let* ((typecode (typecode key))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-macptr) + #+(or ppc32-target x8632-target) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-numeric-subtag)) + #+64-bit-target + (or (= typecode target::subtag-bignum) + (= typecode target::subtag-double-float) + (= typecode target::subtag-ratio) + (= typecode target::subtag-complex))))) + +;;; Don't rehash at all, unless some key is address-based (directly or +;;; indirectly.) +(defun %needs-rehashing-p (vector) + (let* ((flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (if (logbitp $nhash_track_keys_bit flags) + ;; GC is tracking key movement + (logbitp $nhash_key_moved_bit flags) + ;; GC is not tracking key movement + (if (logbitp $nhash_component_address_bit flags) + (not (eql (the fixnum (%get-gc-count)) (the fixnum (nhash.vector.gc-count vector)))))))) + +(defun %set-does-not-need-rehashing (vector) + (let* ((flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (setf (nhash.vector.gc-count vector) (%get-gc-count)) + (when (logbitp $nhash_track_keys_bit flags) + (setf (nhash.vector.flags vector) + (logand (lognot (ash 1 $nhash_key_moved_bit)) flags))))) + + +;;; Tempting though it may be to remove this, a hash table loaded from +;;; a fasl file likely needs to be rehashed, and the MAKE-LOAD-FORM +;;; for hash tables needs to be able to call this or something similar. +(defun %set-needs-rehashing (hash) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (setf (nhash.vector.gc-count vector) (the fixnum (1- (the fixnum (%get-gc-count))))) + (when (logbitp $nhash_track_keys_bit flags) + (setf (nhash.vector.flags vector) (logior (ash 1 $nhash_key_moved_bit) flags))))) + +#+32-bit-target +(defun mixup-hash-code (fixnum) + (declare (fixnum fixnum)) + (the fixnum + (+ fixnum + (the fixnum (%ilsl (- 32 8) + (logand (1- (ash 1 (- 8 3))) fixnum)))))) + +#+64-bit-target +(defun mixup-hash-code (fixnum) + (declare (fixnum fixnum)) + (the fixnum + (+ fixnum + (the fixnum (%ilsl 50 + (logand (1- (ash 1 (- 8 3))) fixnum)))))) + + +(defun rotate-hash-code (fixnum) + (declare (fixnum fixnum)) + (let* ((low-3 (logand 7 fixnum)) + (but-low-3 (%ilsr 3 fixnum)) + (low-3*64K (%ilsl 13 low-3)) + (low-3-in-high-3 (%ilsl (- 32 3 3) low-3))) + (declare (fixnum low-3 but-low-3 low-3*64K low-3-in-high-3)) + (the fixnum (+ low-3-in-high-3 + (the fixnum (logxor low-3*64K but-low-3)))))) + + + + +(defconstant $nhash-track-keys-mask + #.(- (ash 1 $nhash_track_keys_bit))) + +(defconstant $nhash-clear-key-bits-mask #xfffff) + + +(defun %hash-symbol (sym) + (if sym + (let* ((vector (%symptr->symvector sym)) + (cell (%svref vector target::symbol.plist-cell))) + (or (car cell) + (let* ((pname (%svref vector target::symbol.pname-cell)) + (hash (mixup-hash-code (%pname-hash pname (uvsize pname))))) + (declare (type simple-string pname)) + (if cell + (setf (car cell) hash) + (progn + (setf (%svref vector target::symbol.plist-cell) + (cons hash nil)) + hash))))) + +nil-hash+)) + +;;; Hash on address, or at least on some persistent, immutable +;;; attribute of the key. If all keys are fixnums or immediates (or if +;;; that attribute exists), rehashing won't ever be necessary. +(defun %%eqhash (key) + (let* ((typecode (typecode key))) + (if (eq typecode target::tag-fixnum) + (values (mixup-hash-code key) nil) + (if (eq typecode target::subtag-instance) + (values (mixup-hash-code (instance.hash key)) nil) + (if (symbolp key) + (values (%hash-symbol key) nil) + (let ((hash (mixup-hash-code (strip-tag-to-fixnum key)))) + (if (immediate-p-macro key) + (values hash nil) + (values hash :key )))))))) + + +#+32-bit-target +(defun swap (num) + (declare (fixnum num)) + (the fixnum (+ (the fixnum (%ilsl 16 num))(the fixnum (%ilsr 13 num))))) + +#+64-bit-target +(defun swap (num) + (declare (fixnum num)) + (the fixnum (+ (the fixnum (%ilsl 32 num))(the fixnum (%ilsr 29 num))))) + +;;; teeny bit faster when nothing to do +(defun %%eqlhash-internal (key) + (number-case key + (fixnum (mixup-hash-code key)) ; added this + (double-float (%dfloat-hash key)) + (short-float (%sfloat-hash key)) + (bignum (%bignum-hash key)) + (ratio (logxor (swap (%%eqlhash-internal (numerator key))) + (%%eqlhash-internal (denominator key)))) + (complex + (logxor (swap (%%eqlhash-internal (realpart key))) + (%%eqlhash-internal (imagpart key)))) + (t (cond ((macptrp key) + (%macptr-hash key)) + (t key))))) + + + + +;;; new function + +(defun %%eqlhash (key) + ;; if key is a macptr, float, bignum, ratio, or complex, convert it + ;; to a fixnum + (if (hashed-by-identity key) + (%%eqhash key) + (let ((primary (%%eqlhash-internal key))) + (if (eq primary key) + (%%eqhash key) + (mixup-hash-code (strip-tag-to-fixnum primary)))))) + + +(defun %%equalhash (key) + (let* ((id-p (hashed-by-identity key)) + (hash (if (and key (not id-p)) (%%eqlhash-internal key))) + addressp) + (cond ((null key) (mixup-hash-code 17)) + #+64-bit-target + ((and (typep key 'single-float) + (zerop (the single-float key))) + 0) + ((immediate-p-macro key) (mixup-hash-code (strip-tag-to-fixnum key))) + ((and hash (neq hash key)) hash) ; eql stuff + (t (typecase key + (simple-string (%pname-hash key (length key))) + (string + (let ((length (length key))) + (multiple-value-bind (data offset) (array-data-and-offset key) + (%string-hash offset data length)))) + (bit-vector (bit-vector-hash key)) + (cons + (let ((hash 0)) + (do* ((i 0 (1+ i)) + (list key (cdr list))) + ((or (not (consp list)) (> i 11))) ; who figured 11? + (declare (fixnum i)) + (multiple-value-bind (h1 a1) (%%equalhash (%car list)) + (when a1 (setq addressp t)) + ; fix the case of lists of same stuff in different order + ;(setq hash (%ilogxor (fixnum-rotate h1 i) hash)) + (setq hash (%i+ (rotate-hash-code hash) h1)) + )) + (values hash addressp))) + (pathname (%%equalphash key)) + (t (%%eqlhash key))))))) + +(defun update-hash-flags (hash vector addressp) + (when addressp + (flet ((new-flags (flags addressp) + (declare (fixnum flags)) + (if (eq :key addressp) + ;; hash code depended on key's address + (if (logbitp $nhash_component_address_bit flags) + flags + (logior $nhash-track-keys-mask + (if (logbitp $nhash_track_keys_bit flags) + flags + (bitclr $nhash_key_moved_bit flags)))) + ;; hash code depended on component address + (bitset $nhash_component_address_bit + (logand (lognot $nhash-track-keys-mask) flags))))) + (declare (inline new-flags)) + (if (hash-lock-free-p hash) + (loop + (let* ((flags (nhash.vector.flags vector)) + (new-flags (new-flags flags addressp))) + (when (or (eq flags new-flags) + (store-gvector-conditional nhash.vector.flags vector flags new-flags)) + (return)))) + (setf (nhash.vector.flags vector) + (new-flags (nhash.vector.flags vector) addressp)))))) + +(defun compute-hash-code (hash key update-hash-flags &optional + (vector (nhash.vector hash))) ; vectorp)) + (let ((keytransF (nhash.keytransF hash)) + primary addressp) + (if (not (fixnump keytransF)) + ;; not EQ or EQL hash table + (progn + (multiple-value-setq (primary addressp) (funcall keytransF key)) + (let ((immediate-p (immediate-p-macro primary))) + (setq primary (strip-tag-to-fixnum primary)) + (unless immediate-p + (setq primary (mixup-hash-code primary)) + (setq addressp :key)))) + ;; EQ or EQL hash table + (if (and (not (eql keytransF 0)) + (need-use-eql key)) + ;; EQL hash table + (setq primary (%%eqlhash-internal key)) + ;; EQ hash table - or something eql doesn't do + (multiple-value-setq (primary addressp) (%%eqhash key)))) + (when update-hash-flags + (when addressp + (update-hash-flags hash vector addressp))) + (let* ((entries (nhash.vector-size vector))) + (declare (fixnum entries)) + (values primary + (hash-mod primary entries vector) + entries)))) + +(defun %already-rehashed-p (primary rehash-bits) + (declare (optimize (speed 3)(safety 0))) + (declare (type (simple-array bit (*)) rehash-bits)) + (eql 1 (sbit rehash-bits primary))) + +(defun %set-already-rehashed-p (primary rehash-bits) + (declare (optimize (speed 3)(safety 0))) + (declare (type (simple-array bit (*)) rehash-bits)) + (setf (sbit rehash-bits primary) 1)) + + +(defun hash-table-p (hash) + (istruct-typep hash 'hash-table)) + +(defun %normalize-hash-table-count (hash) + (let* ((vector (nhash.vector hash)) + (weak-deletions-count (nhash.vector.weak-deletions-count vector))) + (declare (fixnum weak-deletions-count)) + (unless (eql 0 weak-deletions-count) + (setf (nhash.vector.weak-deletions-count vector) 0) + ;; lock-free hash tables don't maintain deleted-count, since would need to + ;; lock and it's not worth it. + (unless (hash-lock-free-p hash) + (let ((deleted-count (the fixnum + (+ (the fixnum (nhash.vector.deleted-count vector)) + weak-deletions-count))) + (count (the fixnum (- (the fixnum (nhash.vector.count vector)) weak-deletions-count)))) + (setf (nhash.vector.deleted-count vector) deleted-count + (nhash.vector.count vector) count)))))) + + +(defparameter *shared-hash-table-default* t + "Be sure that you understand the implications of changing this +before doing so.") + +(defparameter *lock-free-hash-table-default* :shared + "If NIL, hash tables default to using the standard algorithms, with locks for shared tables. + If :SHARED, shared hash tables default to using the \"lock-free\" algorithm, + which is faster for typical access but slower for rehashing or growing the table. + Otherwise, all hash tables default to the lock-free algorithm") + +(defun make-hash-table (&key (test 'eql) + (size 60) + (rehash-size 1.5) + (rehash-threshold .85) + (hash-function nil) + (weak nil) + (finalizeable nil) + (address-based t) ;; Ignored + (lock-free *lock-free-hash-table-default*) + (shared *shared-hash-table-default*)) + "Create and return a new hash table. The keywords are as follows: + :TEST -- Indicates what kind of test to use. + :SIZE -- A hint as to how many elements will be put in this hash + table. + :REHASH-SIZE -- Indicates how to expand the table when it fills up. + If an integer, add space for that many elements. If a floating + point number (which must be greater than 1.0), multiply the size + by that amount. + :REHASH-THRESHOLD -- Indicates how dense the table can become before + forcing a rehash. Can be any positive number <=1, with density + approaching zero as the threshold approaches 0. Density 1 means an + average of one entry per bucket." + (declare (ignore address-based)) ;; TODO: could reinterpret as "warn if becomes address-based" + (unless (and test (or (functionp test) (symbolp test))) + (report-bad-arg test '(and (not null) (or symbol function)))) + (unless (or (functionp hash-function) (symbolp hash-function)) + (report-bad-arg hash-function '(or symbol function))) + (unless (and (realp rehash-threshold) (<= 0.0 rehash-threshold) (<= rehash-threshold 1.0)) + (report-bad-arg rehash-threshold '(real 0 1))) + (unless (or (fixnump rehash-size) (and (realp rehash-size) (< 1.0 rehash-size))) + (report-bad-arg rehash-size '(or fixnum (real 1 *)))) + (unless (fixnump size) (report-bad-arg size 'fixnum)) + (setq rehash-threshold (/ 1.0 (max 0.01 rehash-threshold))) + (let* ((default-hash-function + (cond ((or (eq test 'eq) (eq test #'eq)) + (setq test 0)) + ((or (eq test 'eql) (eq test #'eql)) + (setq test -1)) + ((or (eq test 'equal) (eq test #'equal)) + (setq test #'equal) #'%%equalhash) + ((or (eq test 'equalp) (eq test #'equalp)) + (setq test #'equalp) #'%%equalphash) + (t (setq test (require-type test 'symbol)) + (or hash-function + (error "non-standard test specified without hash-function"))))) + (find-function + (case test + (0 #'eq-hash-find) + (-1 #'eql-hash-find) + (t #'general-hash-find))) + (find-put-function + (case test + (0 #'eq-hash-find-for-put) + (-1 #'eql-hash-find-for-put) + (t #'general-hash-find-for-put)))) + (setq hash-function + (if hash-function + (require-type hash-function 'symbol) + default-hash-function)) + (when (and weak (neq weak :value) (neq test 0)) + (error "Only EQ hash tables can be weak.")) + (when (and finalizeable (not weak)) + (error "Only weak hash tables can be finalizeable.")) + (when (and (eq lock-free :shared) (not shared)) + (setq lock-free nil)) + (multiple-value-bind (grow-threshold total-size) + (compute-hash-size (1- size) 1 rehash-threshold) + (let* ((flags (+ (if weak (ash 1 $nhash_weak_bit) 0) + (ecase weak + ((t nil :key) 0) + (:value (ash 1 $nhash_weak_value_bit))) + (if finalizeable (ash 1 $nhash_finalizeable_bit) 0) + (if lock-free (ash 1 $nhash_keys_frozen_bit) 0))) + (hash (%cons-hash-table + hash-function test + (%cons-nhash-vector total-size flags) + grow-threshold rehash-threshold rehash-size + find-function find-put-function + (unless shared *current-process*) + lock-free))) + (setf (nhash.vector.hash (nhash.vector hash)) hash) + hash)))) + +(defun compute-hash-size (size rehash-size rehash-ratio) + (let* ((new-size size)) + (declare (fixnum size new-size)) + (setq new-size (max 30 (if (fixnump rehash-size) + (%i+ size rehash-size) + (ceiling (* size rehash-size))))) + (if (<= new-size size) + (setq new-size (1+ size))) ; God save you if you make this happen + + (let ((vector-size (%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio)))))) + ; TODO: perhaps allow more entries, based on actual size: + ; (values (min (floor vector-size rehash-ratio) (%i- vector-size 2)) vector-size)) + (values new-size vector-size) + ))) + +;;; Suggested size is a fixnum: number of pairs. Return a fixnum >= +;;; that size that is relatively prime to all secondary keys. +(defun %hash-size (suggestion) + (declare (fixnum suggestion)) + (declare (optimize (speed 3)(safety 0))) + (if (<= suggestion #.(aref secondary-keys 7)) + (setq suggestion (+ 2 #.(aref secondary-keys 7))) + (setq suggestion (logior 1 suggestion))) + (loop + (dovector (key secondary-keys (return-from %hash-size suggestion)) + (when (eql 0 (fast-mod suggestion key)) + (return))) + (incf suggestion 2))) + + +(defvar *continue-from-readonly-hashtable-lock-error* t) + +(defun signal-read-only-hash-table-error (hash) + (cond ((hash-lock-free-p hash) + ;; We don't really do anything different if this is set, so no problem + (cerror "Modify it anyway" + "Attempt to modify readonly hash table ~s" hash)) + (*continue-from-readonly-hashtable-lock-error* + (cerror "Make the hash-table writable. DANGEROUS! This could damage your lisp if another thread is acccessing this table. CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!" + "Hash-table ~s is readonly" hash) + (assert-hash-table-writeable hash) + (write-lock-hash-table hash)) + (t (error "Hash-table ~s is readonly" hash)))) + +(defun read-lock-hash-table (hash) + (if (nhash.read-only hash) + :readonly + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (read-lock-rwlock lock) + (unless (eq (nhash.owner hash) *current-process*) + (error "Not owner of hash table ~s" hash)))))) + +(defun write-lock-hash-table (hash) + (if (nhash.read-only hash) + (signal-read-only-hash-table-error hash) + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (write-lock-rwlock lock) + (unless (eq (nhash.owner hash) *current-process*) + (error "Not owner of hash table ~s" hash)))))) + + +(defun unlock-hash-table (hash was-readonly) + (unless was-readonly + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (unlock-rwlock lock))))) + +(defun index->vector-index (index) + (declare (fixnum index)) + (the fixnum (+ $nhash.vector_overhead (the fixnum (+ index index))))) + +(defun vector-index->index (index) + (declare (fixnum index)) + (the fixnum (ash (the fixnum (- index $nhash.vector_overhead)) -1))) + +(defun hash-table-count (hash) + "Return the number of entries in the given HASH-TABLE." + (setq hash (require-type hash 'hash-table)) + (when (hash-lock-free-p hash) + ;; We don't try to maintain a running total, so just count. + (return-from hash-table-count (lock-free-count-entries hash))) + (%normalize-hash-table-count hash) + (the fixnum (nhash.vector.count (nhash.vector hash)))) + +(defun hash-table-rehash-size (hash) + "Return the rehash-size HASH-TABLE was created with." + (nhash.rehash-size (require-type hash 'hash-table))) + +(defun hash-table-rehash-threshold (hash) + "Return the rehash-threshold HASH-TABLE was created with." + (/ 1.0 (nhash.rehash-ratio (require-type hash 'hash-table)))) + +(defun hash-table-size (hash) + "Return a size that can be used with MAKE-HASH-TABLE to create a hash + table that can hold however many entries HASH-TABLE can hold without + having to be grown." + (let* ((hash (require-type hash 'hash-table)) + (vector (nhash.vector hash))) + (values (floor (nhash.vector.size vector) (nhash.rehash-ratio hash))))) + +(defun hash-table-test (hash) + "Return the test HASH-TABLE was created with." + (let ((f (nhash.compareF (require-type hash 'hash-table)))) + (if (fixnump f) + (if (eql 0 f) 'eq 'eql) + (let ((name (if (symbolp f) f (function-name f)))) + (if (memq name '(equal equalp)) name f))))) + +;;; sometimes you'd rather have the function than the symbol. +(defun hash-table-test-function (hash) + (let ((f (nhash.compareF (require-type hash 'hash-table)))) + (if (fixnump f) + (if (eql 0 f) #'eq #'eql) + f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; nearly-lock-free hash tables +;; +;; A modification of the lock-free hash table algorithm described by Cliff Click Jr. in +;; http://blogs.azulsystems.com/cliff/2007/03/a_nonblocking_h.html. +;; +;; The modifications have to do with the fact that our goal is just to minimize the +;; performance impact of thread-safety, by eliminating the need for locking on every +;; read. I don't bother with aspects of his algorithm that aren't relevant to that goal. +;; +;; The main difference from Click's algorithm is that I don't try to do rehashing +;; concurrently. Instead, rehashing grabs a lock, so that only one thread can be +;; rehashing at any given time, and readers/writers will block waiting for the rehashing +;; to finish. +;; +;; In addition, I don't have a separate state for partially inserted key, I reuse the +;; DELETED state for that. So in our implementation the following are the possible states +;; of a hash table entry (where "object" means any object other than the special markers): +;; +;; State Key Value +;; DELETED1 object free-hash-marker +;; DELETED2 deleted-marker free-hash-marker +;; IN-USE object object +;; FREE free-hash-marker free-hash-marker +;; REHASHING object rehashing-value-marker +;; REHASHING free-hash-marker rehashing-value-marker +;; REHASHING deleted-marker rehashing-value-marker +;; +;; No other states are allowed - at no point in time can a hash table entry be in any +;; other state. In addition, the only transitions allowed on the key slot are +;; free-hash-marker -> object/deleted-marker -> deleted-marker. Once a key slot +;; is claimed, it must never change to free or another key value (even after the hash +;; vector has been discarded after rehashing, because there some process might still +;; be looking at it). +;; In particular, rehashing in place is not an option. All rehashing creates a new +;; vector and copies into it. This means it's kinda risky to use lock-free hash +;; tables with address-based keys, because they will thrash in low-memory situations, +;; but we don't disallow it because a particular use might not have this problem. +;; +;; The following operations may take place: +;; +;; * gethash: find matching key - if no match, return not found. Else fetch value, +;; if value is rehashing-value-marker then maybe-rehash and try again; +;; if value is free-hash-marker, return not found, else return found value. +;; +;; * puthash: find matching key or FREE slot. +;; ** If found key, fetch value. +;; if value is rehashing-value-marker then maybe-rehash and try again; +;; else store-conditional the value -> new value, if fails try again. +;; ** Else have FREE slot, store-key-conditional free-hash-marker -> key, +;; and if that succeeds, store-conditional free-hash-marker -> new value, +;; if either fails, maybe-rehash and try again. +;; +;; * remhash: find matching key - if no match, done. Else fetch value, +;; if value is rehashing-value-marker then maybe-rehash and try again; +;; else store-conditional the value -> free-hash-marker, if fails try again. +;; +;; * rehash: grab a lock, estimate number of entries, make a new vector. loop over +;; old vector, at each entry fetch the old value with atomic swap of +;; rehashing-value-marker. This prevents any further state changes involving the +;; value. It doesn't prevent state changes involving the key, but the only ones that +;; can happen is FREE -> DELETED, and DELETED1 <-> DELETED2, all of which are +;; equivalent from the point of view of rehashing. Anyway, if the old value was +;; rehashing-value-marker then bug (because we have a lock). If the old value is +;; free-hash-marker then do nothing, else get the entry key and rehash into the new +;; vector -- if no more room, start over. When done, store the new vector in the +;; hash table and release lock. +;; +;; * gc: for weak tables, gc may convert IN-USE states to DELETED2 states. +;; Even for non-weak tables, gc could convert DELETED1 states to DELETED2. + + +(defun lock-free-rehash (hash) + ;;(break "We think we need to rehash ~s" (nhash.vector hash)) + (with-lock-context + (without-interrupts ;; not re-entrant + (let ((lock (nhash.exclusion-lock hash))) + (%lock-recursive-lock-object lock) + ;; TODO: might also want to rehash if deleted entries are a large percentage + ;; of all entries, more or less. + (when (or (%i<= (nhash.grow-threshold hash) 0) ;; no room + (%needs-rehashing-p (nhash.vector hash))) ;; or keys moved + (%lock-free-rehash hash)) + (%unlock-recursive-lock-object lock))))) + + +;; TODO: This is silly. We're implementing atomic swap using store-conditional, +;; but internally store-conditional is probably implemented using some kind of +;; an atomic swap!! +(defun atomic-swap-gvector (index gvector value) + (loop + (let ((old-value (%svref gvector index))) + (when (store-gvector-conditional index gvector old-value value) + (return old-value))))) + +;; Interrupts are disabled and caller has the hash lock on the table, blocking other +;; threads attempting a rehash. +;; Other threads might be reading/writing/deleting individual entries, but they +;; will block if they see a value = rehashing-value-marker. +;; GC may run, updating the needs-rehashing flags and deleting weak entries in both +;; old and new vectors. +(defun %lock-free-rehash (hash) + (let* ((old-vector (nhash.vector hash)) + (inherited-flags (logand $nhash_weak_flags_mask (nhash.vector.flags old-vector))) + (grow-threshold (nhash.grow-threshold hash)) + count new-vector vector-size) + ;; Prevent puthash from adding new entries. Note this doesn't keep it from undeleting + ;; existing entries, so we might still lose, but this makes the odds much smaller. + (setf (nhash.grow-threshold hash) 0) + (setq count (lock-free-count-entries hash)) + (multiple-value-setq (grow-threshold vector-size) + (if (%i<= grow-threshold 0) ; if ran out of room, grow, else get just enough. + (compute-hash-size count (nhash.rehash-size hash) (nhash.rehash-ratio hash)) + (compute-hash-size count 1 (nhash.rehash-ratio hash)))) + (setq new-vector (%cons-nhash-vector vector-size inherited-flags)) + (loop with full-count = grow-threshold + for i from $nhash.vector_overhead below (uvsize old-vector) by 2 + do (let* ((value (atomic-swap-gvector (%i+ i 1) old-vector rehashing-value-marker)) + (key (%svref old-vector i))) + (when (eq value rehashing-value-marker) (error "Who else is doing this?")) + (unless (or (eq value free-hash-marker) (eq key deleted-hash-key-marker)) + (let* ((new-index (%growhash-probe new-vector hash key)) + (new-vector-index (index->vector-index new-index))) + (%set-hash-table-vector-key new-vector new-vector-index key) + (setf (%svref new-vector (%i+ new-vector-index 1)) value) + (decf grow-threshold) + (when (%i<= grow-threshold 0) + ;; Too many entries got undeleted while we were rehashing (that's the + ;; only way we could end up with more than COUNT entries, as adding + ;; new entries is blocked). Grow the output vector. + (multiple-value-bind (bigger-threshold bigger-vector-size) + (compute-hash-size full-count (nhash.rehash-size hash) (nhash.rehash-ratio hash)) + (assert (> bigger-vector-size vector-size)) + (let ((bigger-vector (%cons-nhash-vector bigger-vector-size 0))) + (%copy-gvector-to-gvector new-vector + $nhash.vector_overhead + bigger-vector + $nhash.vector_overhead + (%i- (uvsize new-vector) $nhash.vector_overhead)) + (setf (nhash.vector.flags bigger-vector) (nhash.vector.flags new-vector)) + (%lock-free-rehash-in-place hash bigger-vector) + (setq grow-threshold (- bigger-threshold full-count)) + (setq full-count bigger-threshold) + (setq new-vector bigger-vector) + (setq vector-size bigger-vector-size)))))))) + (when (%needs-rehashing-p new-vector) ;; keys moved, but at least can use the same new-vector. + (%lock-free-rehash-in-place hash new-vector)) + (setf (nhash.vector.hash new-vector) hash) + (setf (nhash.grow-threshold hash) grow-threshold) + ;; At this point, another thread might decrement the threshold while they're looking at the old + ;; vector. That's ok, just means it will be too small and we'll rehash sooner than planned, + ;; no big deal. + (setf (nhash.vector hash) new-vector))) + +;; This is called on a new vector that hasn't been installed yet, so no other thread is +;; accessing it. However, gc might be deleting stuff from it, which is why it tests +;; key for deleted-hash-key-marker in addition to free-hash-marker value +(defun %lock-free-rehash-in-place (hash vector) + (let* ((vector-index (- $nhash.vector_overhead 2)) + (size (nhash.vector-size vector)) + (rehash-bits (%make-rehash-bits hash size)) + (index -1)) + (declare (fixnum size index vector-index)) + (%set-does-not-need-rehashing vector) + (loop + (when (>= (incf index) size) (return)) + (setq vector-index (+ vector-index 2)) + (unless (%already-rehashed-p index rehash-bits) + (let* ((value (%svref vector (%i+ vector-index 1))) + (key (%svref vector vector-index))) + (if (or (eq value free-hash-marker) + (eq key deleted-hash-key-marker)) + (unless (eq key free-hash-marker) + (setf (%svref vector vector-index) free-hash-marker)) + (let* ((last-index index) + (first t)) + (loop + (let ((found-index (%rehash-probe rehash-bits hash key vector))) + (%set-already-rehashed-p found-index rehash-bits) + (when (eq last-index found-index) + (return)) + (let* ((found-vector-index (index->vector-index found-index)) + (newvalue (%svref vector (the fixnum (1+ found-vector-index)))) + (newkey (%svref vector found-vector-index))) + (declare (fixnum found-vector-index)) + (when first ; or (eq last-index index) ? + (setq first nil) + (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker) + (setf (%svref vector vector-index) free-hash-marker)) + (%set-hash-table-vector-key vector found-vector-index key) + (setf (%svref vector (the fixnum (1+ found-vector-index))) value) + (when (or (eq newkey deleted-hash-key-marker) + (eq newvalue free-hash-marker)) + (return)) + (when (eq key newkey) + (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s" + key hash value newvalue index found-index) + (return)) + (setq key newkey + value newvalue + last-index found-index)))))))))) + t ) + + +(defun lock-free-gethash (key hash default) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (loop + (let* ((vector (nhash.vector hash)) + (vector-index (funcall (the function (nhash.find hash)) hash key))) + (declare (fixnum vector-index)) + ;; Need to punt if vector changed because no way to know whether nhash.find was + ;; using old or new vector. + (when (eq vector (nhash.vector hash)) + (cond ((eql vector-index -1) + (unless (%needs-rehashing-p vector) + (return-from lock-free-gethash (values default nil)))) + (t (let ((value (%svref vector (%i+ vector-index 1)))) + (unless (eq value rehashing-value-marker) + (if (eq value free-hash-marker) + (return-from lock-free-gethash (values default nil)) + (return-from lock-free-gethash (values value t))))))))) + ;; We're here because the table needs rehashing or it was getting rehashed while we + ;; were searching. Take care of it and try again. + (lock-free-rehash hash))) + +(defun lock-free-remhash (key hash) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (when (nhash.read-only hash) + (signal-read-only-hash-table-error hash)) ;; continuable + (loop + (let* ((vector (nhash.vector hash)) + (vector-index (funcall (the function (nhash.find hash)) hash key))) + (declare (fixnum vector-index)) + ;; Need to punt if vector changed because no way to know whether nhash.find was + ;; using old or new vector. + (when (eq vector (nhash.vector hash)) + (cond ((eql vector-index -1) + (unless (%needs-rehashing-p vector) + (return-from lock-free-remhash nil))) + (t (let ((old-value (%svref vector (%i+ vector-index 1)))) + (unless (eq old-value rehashing-value-marker) + (when (eq old-value free-hash-marker) + (return-from lock-free-remhash nil)) + (when (set-hash-value-conditional vector-index vector old-value free-hash-marker) + ;; We just use this as a flag - tell gc to scan the vector for deleted keys. + ;; It's just a hint, so don't worry about sync'ing + (setf (nhash.vector.deleted-count vector) 1) + (return-from lock-free-remhash t))))))) + ;; We're here because the table needs rehashing or it was getting rehashed while we + ;; were searching. Take care of it and try again. + (lock-free-rehash hash)))) + +(defun lock-free-clrhash (hash) + (when (nhash.read-only hash) + (signal-read-only-hash-table-error hash)) ;;continuable + (with-lock-context + (without-interrupts + (let ((lock (nhash.exclusion-lock hash))) + (%lock-recursive-lock-object lock) ;; disallow rehashing. + (loop + with vector = (nhash.vector hash) + for i1 fixnum from (%i+ $nhash.vector_overhead 1) below (uvsize vector) by 2 + do (setf (%svref vector i1) free-hash-marker) + ;; We just use this as a flag - tell gc to scan the vector for deleted keys. + ;; It's just a hint, so don't worry about sync'ing + finally (setf (nhash.vector.deleted-count vector) 1)) + (%unlock-recursive-lock-object lock)))) + hash) + +(defun lock-free-puthash (key hash value) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (when (or (eq value rehashing-value-marker) + (eq value free-hash-marker)) + (error "Illegal value ~s for storing in a hash table" value)) + (when (nhash.read-only hash) + (signal-read-only-hash-table-error hash)) ;;continuable + (loop + (let* ((vector (nhash.vector hash)) + (vector-index (funcall (nhash.find-new hash) hash key))) + ;; Need to punt if vector changed because no way to know whether nhash.find-new was + ;; using old or new vector. + (when (eq vector (nhash.vector hash)) + (cond ((or (eql vector-index -1) + (eq (%svref vector vector-index) free-hash-marker)) + (unless (or (%needs-rehashing-p vector) + (%i<= (nhash.grow-threshold hash) 0)) + ;; Note if the puthash fails, grow-threshold will end up too small. This + ;; just means we might rehash sooner than absolutely necessary, no real + ;; harm done (the most likely cause of failing is that somebody is + ;; already rehashing anyway). DON'T try to incf it back on failure -- + ;; that risks grow-threshold ending up too big (e.g. if somebody rehashes + ;; before the incf), which _could_ be harmful. + (atomic-decf (nhash.grow-threshold hash)) + (if (set-hash-key-conditional vector-index vector free-hash-marker key) + (when (set-hash-value-conditional vector-index vector free-hash-marker value) + (return-from lock-free-puthash value))))) + (t (let ((old-value (%svref vector (%i+ vector-index 1)))) + (unless (eq old-value rehashing-value-marker) + (when (set-hash-value-conditional vector-index vector old-value value) + (return-from lock-free-puthash value)))))))) + ;; We're here because the table needs rehashing or it was getting rehashed while we + ;; were searching, or no room for new entry, or somebody else claimed the key from + ;; under us (that last case doesn't need to retry, but it's unlikely enough that + ;; it's not worth checking for). Take care of it and try again. + (lock-free-rehash hash))) + +(defun lock-free-count-entries (hash) + ;; Other threads could be adding/removing entries while we count, some of + ;; which will be included in the count (i.e. will be treated as if they + ;; happened after counting) and some won't (i.e. will be treated as if + ;; they happened before counting), but not necessarily in correlation + ;; with their temporal relationship. + (loop + with vector = (nhash.vector hash) + for i fixnum from $nhash.vector_overhead below (uvsize vector) by 2 + count (let ((value (%svref vector (%i+ i 1)))) + (when (eq value rehashing-value-marker) + ;; This table is being rehashed. Wait for it to be + ;; done and try again. + (lock-free-rehash hash) + (return-from lock-free-count-entries (lock-free-count-entries hash))) + (neq value free-hash-marker)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun gethash (key hash &optional default) + "Finds the entry in HASH-TABLE whose key is KEY and returns the associated + value and T as multiple values, or returns DEFAULT and NIL if there is no + such entry. Entries can be added using SETF." + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (return-from gethash (values default nil))) + (when (hash-lock-free-p hash) + (return-from gethash (lock-free-gethash key hash default))) + (let* ((value nil) + (gc-locked nil) + (readonly nil) + (foundp nil)) + (with-lock-context + (without-interrupts + (setq readonly (eq (read-lock-hash-table hash) :readonly)) + (let* ((vector (nhash.vector hash))) + (if (and (eq key (nhash.vector.cache-key vector)) + ;; Check twice: the GC might nuke the cached key/value pair + (progn (setq value (nhash.vector.cache-value vector)) + (eq key (nhash.vector.cache-key vector)))) + (setq foundp t) + (loop + (let* ((vector-index (funcall (nhash.find hash) hash key))) + (declare (fixnum vector-index)) + (cond ((setq foundp (not (eql vector-index -1))) + ;; Referencing both key and value here - and referencing + ;; value first - is an attempt to compensate for the + ;; possibility that the GC deletes a weak-on-key pair. + (setq value (%svref vector (%i+ vector-index 1))) + (when (nhash.owner hash) + (setf (nhash.vector.cache-key vector) + (%svref vector vector-index) + (nhash.vector.cache-value vector) + value + (nhash.vector.cache-idx vector) + (vector-index->index (the fixnum vector-index)))) + (return)) + ((%needs-rehashing-p vector) + (%lock-gc-lock) + (setq gc-locked t) + (unless readonly + (let* ((lock (nhash.exclusion-lock hash))) + (when lock (%promote-rwlock lock)))) + (when (%needs-rehashing-p vector) + (%rehash hash))) + (t (return))))))) + (when gc-locked (%unlock-gc-lock)) + (unlock-hash-table hash readonly))) + (if foundp + (values value t) + (values default nil)))) + +(defun remhash (key hash) + "Remove the entry in HASH-TABLE associated with KEY. Return T if there + was such an entry, or NIL if not." + (unless (typep hash 'hash-table) + (setq hash (require-type hash 'hash-table))) + (when (hash-lock-free-p hash) + (return-from remhash (lock-free-remhash key hash))) + (let* ((foundp nil)) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (%lock-gc-lock) + (let* ((vector (nhash.vector hash))) + (when (%needs-rehashing-p vector) + (%rehash hash)) + (if (eq key (nhash.vector.cache-key vector)) + (progn + (setf (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil) + (let ((vidx (index->vector-index (nhash.vector.cache-idx vector)))) + (setf (%svref vector vidx) deleted-hash-key-marker) + (setf (%svref vector (the fixnum (1+ vidx))) nil)) + (incf (the fixnum (nhash.vector.deleted-count vector))) + (decf (the fixnum (nhash.vector.count vector))) + (setq foundp t)) + (let* ((vector-index (funcall (nhash.find hash) hash key))) + (declare (fixnum vector-index)) + (unless (eql vector-index -1) + ;; always clear the cache cause I'm too lazy to call the + ;; comparison function and don't want to keep a possibly + ;; deleted key from being GC'd + (setf (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil) + ;; Update the count + (incf (the fixnum (nhash.vector.deleted-count vector))) + (decf (the fixnum (nhash.vector.count vector))) + ;; Delete the value from the table. + (setf (%svref vector vector-index) deleted-hash-key-marker + (%svref vector (the fixnum (1+ vector-index))) nil) + (setq foundp t)))) + (when (and foundp + (zerop (the fixnum (nhash.vector.count vector)))) + (do* ((i $nhash.vector_overhead (1+ i)) + (n (uvsize vector))) + ((= i n)) + (declare (fixnum i n)) + (setf (%svref vector i) free-hash-marker)) + (setf (nhash.grow-threshold hash) + (+ (nhash.vector.deleted-count vector) + (nhash.vector.weak-deletions-count vector) + (nhash.grow-threshold hash)) + (nhash.vector.deleted-count vector) 0 + (nhash.vector.weak-deletions-count vector) 0))) + ;; Return T if we deleted something + (%unlock-gc-lock) + (unlock-hash-table hash nil))) + foundp)) + +;;; what if somebody is mapping, growing, rehashing? +(defun clrhash (hash) + "This removes all the entries from HASH-TABLE and returns the hash table + itself." + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (hash-lock-free-p hash) + (return-from clrhash (lock-free-clrhash hash))) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (let* ((vector (nhash.vector hash)) + (size (nhash.vector-size vector)) + (count (+ size size)) + (index $nhash.vector_overhead)) + (declare (fixnum size count index)) + (dotimes (i count) + (setf (%svref vector index) free-hash-marker) + (incf index)) + (incf (the fixnum (nhash.grow-threshold hash)) + (the fixnum (+ (the fixnum (nhash.vector.count vector)) + (the fixnum (nhash.vector.deleted-count vector))))) + (setf (nhash.vector.count vector) 0 + (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil + (nhash.vector.finalization-alist vector) nil + (nhash.vector.free-alist vector) nil + (nhash.vector.weak-deletions-count vector) 0 + (nhash.vector.deleted-count vector) 0 + (nhash.vector.flags vector) (logand $nhash_weak_flags_mask + (nhash.vector.flags vector)))) + (unlock-hash-table hash nil) + hash))) + + +(defun puthash (key hash default &optional (value default)) + (declare (optimize (speed 3) (space 0))) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (error "Can't use ~s as a hash-table key" key)) + (when (hash-lock-free-p hash) + (return-from puthash (lock-free-puthash key hash value))) + (with-lock-context + (without-interrupts + (block protected + (tagbody + (write-lock-hash-table hash) + AGAIN + (%lock-gc-lock) + (let ((vector (nhash.vector hash))) + (when (%needs-rehashing-p vector) + (%rehash hash)) + (when (eq key (nhash.vector.cache-key vector)) + (let* ((idx (nhash.vector.cache-idx vector))) + (declare (fixnum idx)) + (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx))))) + value) + (setf (nhash.vector.cache-value vector) value) + (return-from protected))) + (let* ((vector-index (funcall (nhash.find-new hash) hash key)) + (old-value (%svref vector vector-index))) + (declare (fixnum vector-index)) + + (cond ((eq old-value deleted-hash-key-marker) + (%set-hash-table-vector-key vector vector-index key) + (setf (%svref vector (the fixnum (1+ vector-index))) value) + (incf (the fixnum (nhash.vector.count vector))) + ;; Adjust deleted-count + (when (> 0 (the fixnum + (decf (the fixnum + (nhash.vector.deleted-count vector))))) + (%normalize-hash-table-count hash))) + ((eq old-value free-hash-marker) + (when (eql 0 (nhash.grow-threshold hash)) + (%unlock-gc-lock) + (%grow-hash-table hash) + (go AGAIN)) + (%set-hash-table-vector-key vector vector-index key) + (setf (%svref vector (the fixnum (1+ vector-index))) value) + (decf (the fixnum (nhash.grow-threshold hash))) + (incf (the fixnum (nhash.vector.count vector)))) + (t + ;; Key was already there, update value. + (setf (%svref vector (the fixnum (1+ vector-index))) value))) + (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index) + (nhash.vector.cache-key vector) key + (nhash.vector.cache-value vector) value))))) + (%unlock-gc-lock) + (unlock-hash-table hash nil))) + value) + + +(defun count-entries (hash) + (if (hash-lock-free-p hash) + (lock-free-count-entries hash) + (let* ((vector (nhash.vector hash)) + (size (uvsize vector)) + (idx $nhash.vector_overhead) + (count 0)) + (loop + (when (neq (%svref vector idx) free-hash-marker) + (incf count)) + (when (>= (setq idx (+ idx 2)) size) + (return count)))))) + + + + + + + +(defun grow-hash-table (hash) + (unless (typep hash 'hash-table) + (setq hash (require-type hash 'hash-table))) + (%grow-hash-table hash)) + +;;; Interrupts are disabled, and the caller has an exclusive +;;; lock on the hash table. +(defun %grow-hash-table (hash) + (block grow-hash-table + (%normalize-hash-table-count hash) + (let* ((old-vector (nhash.vector hash)) + (old-size (nhash.vector.count old-vector)) + (old-total-size (nhash.vector.size old-vector)) + (flags 0) + (flags-sans-weak 0) + (weak-flags nil)) + (declare (fixnum old-total-size flags flags-sans-weak)) + (when (> (nhash.vector.deleted-count old-vector) 0) + ;; There are enough deleted entries. Rehash to get rid of them + (%rehash hash) + (return-from grow-hash-table)) + (multiple-value-bind (size total-size) + (compute-hash-size + old-size (nhash.rehash-size hash) (nhash.rehash-ratio hash)) + (unless (eql 0 (nhash.grow-threshold hash)) ; maybe it's done already - shouldnt happen + (return-from grow-hash-table )) + (progn + (unwind-protect + (let ((gc-count (%get-gc-count)) + vector) + (setq flags (nhash.vector.flags old-vector) + flags-sans-weak (logand flags (logxor -1 $nhash_weak_flags_mask)) + weak-flags (logand flags $nhash_weak_flags_mask)) + (setf (nhash.vector.flags old-vector) flags-sans-weak) ; disable GC weak stuff + (%normalize-hash-table-count hash) + (when (> (nhash.vector.deleted-count old-vector) 0) + (setf (nhash.vector.flags old-vector) flags) + (setq weak-flags nil) + (return-from grow-hash-table (%rehash hash))) + (setq vector (%cons-nhash-vector total-size 0)) + (do* ((index 0 (1+ index)) + (vector-index (index->vector-index 0) (+ vector-index 2))) + ((>= index old-total-size)) + (declare (fixnum index vector-index)) + + (let ((key (%svref old-vector vector-index))) + (unless (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (let* ((new-index (%growhash-probe vector hash key)) + (new-vector-index (index->vector-index new-index))) + (setf (%svref vector new-vector-index) key) + (setf (%svref vector (the fixnum (1+ new-vector-index))) + (%svref old-vector (the fixnum (1+ vector-index)))))))) + (progn + (setf (nhash.vector.finalization-alist vector) + (nhash.vector.finalization-alist old-vector) + (nhash.vector.free-alist vector) + (nhash.vector.free-alist old-vector) + (nhash.vector.count vector) old-size + (nhash.vector.flags vector) + (logior (the fixnum weak-flags) + (the fixnum (nhash.vector.flags vector)))) + (setf (nhash.rehash-bits hash) nil + (nhash.vector hash) vector + (nhash.vector.hash vector) hash + (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil + (nhash.vector.gc-count vector) gc-count + (nhash.grow-threshold hash) (- size old-size)) + (setq weak-flags nil) ; tell clean-up form we finished the loop + ;; If the old vector's in some static heap, zero it + ;; so that less garbage is retained. + (%init-misc 0 old-vector))) + (when weak-flags + (setf (nhash.vector.flags old-vector) + (logior (the fixnum weak-flags) + (the fixnum (nhash.vector.flags old-vector))))))))))) + + + +(defun general-hash-find (hash key) + (%hash-probe hash key nil)) + +(defun general-hash-find-for-put (hash key) + (%hash-probe hash key (if (hash-lock-free-p hash) :free :reuse))) + +;;; returns a single value: +;;; index - the index in the vector for key (where it was or where +;;; to insert if the current key at that index is deleted-hash-key-marker +;;; or free-hash-marker) + + + +(defun %hash-probe (hash key for-put-p) + (declare (optimize (speed 3) (space 0))) + (multiple-value-bind (hash-code index entries) + (compute-hash-code hash key for-put-p) + (locally (declare (fixnum hash-code index entries)) + (let* ((compareF (nhash.compareF hash)) + (vector (nhash.vector hash)) + (vector-index 0) + table-key + (first-deleted-index nil)) + (declare (fixnum vector-index)) + (macrolet ((return-it (form) + `(return-from %hash-probe ,form))) + (macrolet ((test-it (predicate) + (unless (listp predicate) (setq predicate (list predicate))) + `(progn + (setq vector-index (index->vector-index index) + table-key (%svref vector vector-index)) + (cond ((eq table-key free-hash-marker) + (return-it (if for-put-p + (or first-deleted-index + vector-index) + -1))) + ((eq table-key deleted-hash-key-marker) + (when (and (eq for-put-p :reuse) + (null first-deleted-index)) + (setq first-deleted-index vector-index))) + ((,@predicate key table-key) + (return-it vector-index)))))) + (macrolet ((do-it (predicate) + `(progn + (test-it ,predicate) + ; First probe failed. Iterate on secondary key + (let ((initial-index index) + (secondary-hash (%svref secondary-keys (logand 7 hash-code)))) + (declare (fixnum secondary-hash initial-index)) + (loop + (incf index secondary-hash) + (when (>= index entries) + (decf index entries)) + (when (eql index initial-index) + (return-it (if for-put-p + (or first-deleted-index + (error "Bug: no room in table")) + -1))) + (test-it ,predicate)))))) + (if (fixnump comparef) + ;; EQ or EQL hash table + (if (or (eql 0 comparef) + (immediate-p-macro key) + (not (need-use-eql key))) + ;; EQ hash table or EQL == EQ for KEY + (do-it eq) + (do-it eql)) + ;; general compare function + (do-it (funcall comparef)))))))))) + +(defun eq-hash-find (hash key) + (declare (optimize (speed 3) (safety 0))) + (let* ((vector (nhash.vector hash)) + (hash-code + (let* ((typecode (typecode key))) + (if (eq typecode target::tag-fixnum) + (mixup-hash-code key) + (if (eq typecode target::subtag-instance) + (mixup-hash-code (instance.hash key)) + (if (symbolp key) + (%hash-symbol key) + (mixup-hash-code (strip-tag-to-fixnum key))))))) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code entries vector-index)) + (if (eq table-key key) + vector-index + (if (eq table-key free-hash-marker) + -1 + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return -1)) + (if (eq table-key key) + (return vector-index) + (when (eq table-key free-hash-marker) + (return -1))))))))) + +;;; As above, but note whether the key is in some way address-based +;;; and update the hash-vector's flags word if so. +;;; This only needs to be done by PUTHASH, and it only really needs +;;; to be done if we're adding a new key. +(defun eq-hash-find-for-put (hash key) + (declare (optimize (speed 3) (safety 0))) + (let* ((vector (nhash.vector hash)) + (hash-code + (let* ((typecode (typecode key))) + (if (eq typecode target::tag-fixnum) + (mixup-hash-code key) + (if (eq typecode target::subtag-instance) + (mixup-hash-code (instance.hash key)) + (if (symbolp key) + (%hash-symbol key) + (progn + (unless (immediate-p-macro key) + (update-hash-flags hash vector :key)) + (mixup-hash-code (strip-tag-to-fixnum key)))))))) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index)) + (reuse (not (hash-lock-free-p hash)))) + (declare (fixnum hash-code vector-index)) + (if (or (eq key table-key) + (eq table-key free-hash-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (and reuse + (eq table-key deleted-hash-key-marker) + vector-index)) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return (or first-deleted-index + (error "Bug: no room in table")))) + (if (eq table-key key) + (return vector-index) + (if (eq table-key free-hash-marker) + (return (or first-deleted-index vector-index)) + (if (and reuse + (null first-deleted-index) + (eq table-key deleted-hash-key-marker)) + (setq first-deleted-index vector-index))))))))) + +(defun eql-hash-find (hash key) + (declare (optimize (speed 3) (safety 0))) + (if (need-use-eql key) + (let* ((vector (nhash.vector hash)) + (hash-code (%%eqlhash-internal key)) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code entries vector-index)) + (if (eql key table-key) + vector-index + (if (eq table-key free-hash-marker) + -1 + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return -1)) + (if (eql table-key key) + (return vector-index) + (when (eq table-key free-hash-marker) + (return -1)))))))) + (eq-hash-find hash key))) + +(defun eql-hash-find-for-put (hash key) + (declare (optimize (speed 3) (safety 0))) + (if (need-use-eql key) + (let* ((vector (nhash.vector hash)) + (hash-code (%%eqlhash-internal key)) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index)) + (reuse (not (hash-lock-free-p hash)))) + (declare (fixnum hash-code entries vector-index)) + (if (or (eql key table-key) + (eq table-key free-hash-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (and reuse + (eq table-key deleted-hash-key-marker) + vector-index)) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return (or first-deleted-index + (error "Bug: no room in table")))) + (if (eql table-key key) + (return vector-index) + (if (eq table-key free-hash-marker) + (return (or first-deleted-index vector-index)) + (if (and reuse + (null first-deleted-index) + (eq table-key deleted-hash-key-marker)) + (setq first-deleted-index vector-index)))))))) + (eq-hash-find-for-put hash key))) + +(defun %make-rehash-bits (hash &optional (size (nhash.vector-size (nhash.vector hash)))) + (declare (fixnum size)) + (let ((rehash-bits (nhash.rehash-bits hash))) + (unless (and rehash-bits + (>= (uvsize rehash-bits) size)) + (return-from %make-rehash-bits + (setf (nhash.rehash-bits hash) (make-array size :element-type 'bit :initial-element 0)))) + (fill (the simple-bit-vector rehash-bits) 0))) + +;;; Rehash. Caller should have exclusive access to the hash table +;;; and have disabled interrupts. +(defun %rehash (hash) + (when (hash-lock-free-p hash) + (error "How did we get here?")) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector)) + (vector-index (- $nhash.vector_overhead 2)) + (size (nhash.vector-size vector)) + (rehash-bits (%make-rehash-bits hash size)) + (index -1)) + (declare (fixnum size index vector-index)) + (setf (nhash.vector.flags vector) + (logand flags $nhash-clear-key-bits-mask)) + (setf (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil) + (%set-does-not-need-rehashing vector) + (loop + (when (>= (incf index) size) (return)) + (setq vector-index (+ vector-index 2)) + (unless (%already-rehashed-p index rehash-bits) + (let* ((key (%svref vector vector-index)) + (deleted (eq key deleted-hash-key-marker))) + (unless + (when (or deleted (eq key free-hash-marker)) + (if deleted ; one less deleted entry + (let ((count (1- (nhash.vector.deleted-count vector)))) + (declare (fixnum count)) + (setf (nhash.vector.deleted-count vector) count) + (if (< count 0) + (let ((wdc (nhash.vector.weak-deletions-count vector))) + (setf (nhash.vector.weak-deletions-count vector) 0) + (incf (nhash.vector.deleted-count vector) wdc) + (decf (nhash.vector.count vector) wdc))) + (incf (nhash.grow-threshold hash)) + ;; Change deleted to free + (setf (%svref vector vector-index) free-hash-marker))) + t) + (let* ((last-index index) + (value (%svref vector (the fixnum (1+ vector-index)))) + (first t)) + (loop + (let ((vector (nhash.vector hash)) + (found-index (%rehash-probe rehash-bits hash key))) + (%set-already-rehashed-p found-index rehash-bits) + (if (eq last-index found-index) + (return) + (let* ((found-vector-index (index->vector-index found-index)) + (newkey (%svref vector found-vector-index)) + (newvalue (%svref vector (the fixnum (1+ found-vector-index))))) + (declare (fixnum found-vector-index)) + (when first ; or (eq last-index index) ? + (setq first nil) + (setf (%svref vector vector-index) free-hash-marker) + (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker)) + (%set-hash-table-vector-key vector found-vector-index key) + (setf (%svref vector (the fixnum (1+ found-vector-index))) value) + (when (or (eq newkey free-hash-marker) + (setq deleted (eq newkey deleted-hash-key-marker))) + (when deleted + (let ((count (1- (nhash.vector.deleted-count vector)))) + (declare (fixnum count)) + (setf (nhash.vector.deleted-count vector) count) + (if (< count 0) + (let ((wdc (nhash.vector.weak-deletions-count vector))) + (setf (nhash.vector.weak-deletions-count vector) 0) + (incf (nhash.vector.deleted-count vector) wdc) + (decf (nhash.vector.count vector) wdc))) + (incf (nhash.grow-threshold hash)))) + (return)) + (when (eq key newkey) + (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s" + key hash value newvalue index found-index) + (decf (nhash.vector.count vector)) + (incf (nhash.grow-threshold hash)) + (return)) + (setq key newkey + value newvalue + last-index found-index))))))))))) + t ) + +;;; Hash to an index that is not set in rehash-bits + +(defun %rehash-probe (rehash-bits hash key &optional (vector (nhash.vector hash))) + (declare (optimize (speed 3)(safety 0))) + (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector) + (declare (fixnum hash-code index entries)) + (when (null hash-code)(cerror "nuts" "Nuts")) + (let* ((vector-index (index->vector-index index))) + (if (or (not (%already-rehashed-p index rehash-bits)) + (eq key (%svref vector vector-index))) + (return-from %rehash-probe index) + (let ((second (%svref secondary-keys (%ilogand 7 hash-code)))) + (declare (fixnum second)) + (loop + (setq index (+ index second)) + (when (>= index entries) + (setq index (- index entries))) + (when (or (not (%already-rehashed-p index rehash-bits)) + (eq key (%svref vector (index->vector-index index)))) + (return-from %rehash-probe index)))))))) + +;;; Returns one value: the index of the entry in the vector +;;; Since we're growing, we don't need to compare and can't find a key that's +;;; already there. +(defun %growhash-probe (vector hash key) + (declare (optimize (speed 3)(safety 0))) + (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector) + (declare (fixnum hash-code index entries)) + (let* ((vector-index (index->vector-index index)) + (vector-key nil)) + (declare (fixnum vector-index)) + (if (or (eq free-hash-marker + (setq vector-key (%svref vector vector-index))) + (eq deleted-hash-key-marker vector-key)) + (return-from %growhash-probe index) + (let ((second (%svref secondary-keys (%ilogand 7 hash-code)))) + (declare (fixnum second)) + (loop + (setq index (+ index second)) + (when (>= index entries) + (setq index (- index entries))) + (when (or (eq free-hash-marker + (setq vector-key (%svref vector (index->vector-index index)))) + (eq deleted-hash-key-marker vector-key)) + (return-from %growhash-probe index)))))))) + +;;;;;;;;;;;;; +;; +;; Mapping functions are in "ccl:lib;hash" +;; + + + +;;;;;;;;;;;;; +;; +;; Hashing functions +;; EQ & the EQ part of EQL are done in-line. +;; + + + + + + + + + +;;; so whats so special about bit vectors as opposed to any other vectors of bytes +;;; For starters, it's guaranteed that they exist in the implementation; that may +;;; not be true of other immediate vector types. +(defun bit-vector-hash (bv) + (declare (optimize (speed 3)(safety 0))) + (let ((length (length bv))) + (declare (fixnum length)) ;will this always be true? it's true of all vectors. + (multiple-value-bind (data offset) (array-data-and-offset bv) + (declare (type simple-bit-vector data) (fixnum offset)) + (let* ((hash 0) + (limit (+ length offset)) + (nbytes (ash (the fixnum (+ length 7)) -3))) + (declare (fixnum hash limit nbytes)) + (dotimes (i nbytes (mixup-hash-code hash)) + (let* ((w 0)) + (declare (fixnum w)) + (dotimes (j 8 (setq hash (+ (the fixnum (ash hash -3)) w))) + (setq w (the fixnum + (logxor + (the fixnum + (ash (if (< offset limit) + (the fixnum (sbit data offset)) + 0) + (the fixnum j))) + w))) + (incf offset)))))))) + +#| +(defun bit-vector-hash (bv) + (declare (optimize (speed 3)(safety 0))) + (let ((length (length bv))) + (declare (fixnum length)) + (let* ((all (+ length 15)) + (nwds (ash all -4)) + (rem (logand all 15)) + (hash 0) + (mask (ash (the fixnum (1- (the fixnum (expt 2 rem))))(the fixnum(- 16 rem))))) + (declare (fixnum all nwds rem hash mask)) + (multiple-value-bind (data offset) + (array-data-and-offset bv) + (declare (fixnum offset)) + (locally (declare (type (simple-array (unsigned-byte 16) (*)) data)) + (dotimes (i nwds) + (setq hash (%i+ hash (aref data (the fixnum (+ i offset)))))) + (when (neq 0 mask) + (setq hash (%i+ hash (%ilogand mask (aref data (the fixnum (+ offset nwds))))))) + (mixup-hash-code hash)))))) +|# + + +;;; Same as %%equalhash, but different: +;;; 1) Real numbers are hashed as if they were double-floats. The real components of complex numbers +;;; are hashed as double-floats and XORed together. +;;; 2) Characters and strings are hashed in a case-insensitive manner. +;;; 3) Hash tables are hashed based on their size and type. +;;; 4) Structures and CL array types are hashed based on their content. + + +;;; check fixnum befor immediate-p. call %%eqlhash + +(defun %%equalphash (key) + (cond ((or (fixnump key)(short-float-p key)) + (%dfloat-hash (float key 1.0d0))) + ((immediate-p-macro key) + (mixup-hash-code (strip-tag-to-fixnum (if (characterp key)(char-upcase key) key)))) + ((bignump key) + (if (<= most-negative-double-float key most-positive-double-float) + (%dfloat-hash (float key 1.0d0)) ; with-stack-double-floats + (%%eqlhash-internal key))) + ((double-float-p key) + (%dfloat-hash key)) + ((ratiop key) + (%ilogxor (%%equalphash (numerator key)) (%%equalphash (denominator key)))) + ((complexp key) + (%ilogxor (%%equalphash (realpart key)) (%%equalphash (imagpart key)))) + ((hash-table-p key) + (equalphash-hash-table key)) + ((or (istructp key) + (structurep key)) ; was (gvectorp key) + (%%equalphash-structure 11 key)) + ((or (arrayp key)) ;(uvectorp key)) ;?? + (%%equalphash-array 11 key)) + ((consp key) + (%%equalphash-aux 11 key)) + (t (%%eqlhash key)))) + + +(defun equalphash-hash-table (hash-table) + (let ((hash (%%equalhash "HASH-TABLE")) + addressp) + (declare (fixnum hash)) + (incf hash (the fixnum (%%eqhash (hash-table-count hash-table)))) + (multiple-value-bind (h ap) (%%eqhash (nhash.comparef hash-table)) + (declare (fixnum h)) + (incf hash h) + (if ap (setq addressp t))) + (multiple-value-bind (h ap) (%%eqhash (nhash.keytransF hash-table)) + (declare (fixnum h)) + (incf hash h) + (if ap (setq addressp t))) + (values hash addressp))) + +(defun %%equalphash-structure (limit key) + (let* ((size (uvsize key)) + (hash (mixup-hash-code size)) + addressp) + (declare (fixnum limit size hash)) + (dotimes (i size) + (multiple-value-bind (h ap) (%%equalphash-aux limit (%svref key i)) + (declare (fixnum h)) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h))) + (if ap (setq addressp t))) + (when (<= (decf limit) 0) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) + (the fixnum (mixup-hash-code 11))))) + (return))) + (values hash addressp))) + +(defun %%equalphash-array (limit key) + (multiple-value-bind (array offset) (array-data-and-offset key) + (let* ((rank (array-rank key)) + (vectorp (eql rank 1)) + (size (if vectorp (length key) (array-total-size key))) + (hash (mixup-hash-code rank)) + addressp) + (declare (fixnum size hash limit rank)) + (if vectorp + (setq hash + (the fixnum + (+ (the fixnum (rotate-hash-code hash)) + (the fixnum (mixup-hash-code size))))) + (dotimes (i rank) + (declare (fixnum i)) + (setq hash + (the fixnum + (+ (the fixnum (rotate-hash-code hash)) + (the fixnum + (mixup-hash-code (array-dimension key i)))))))) + (dotimes (i size) + (declare (fixnum i)) + (multiple-value-bind (h ap) (%%equalphash-aux limit (uvref array offset)) + (declare (fixnum h)) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h))) + (if ap (setq addressp t))) + (when (<= (decf limit) 0) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) + (the fixnum (mixup-hash-code 11))))) + (return)) + (incf offset)) + (values hash addressp)))) + +(defun %%equalphash-aux (limit key) + (if (<= limit 0) + (mixup-hash-code 11) + (if (null key) (mixup-hash-code 17) + (cond ((consp key) + (let ((hash 0) + address-p) + (do ((l limit (1- l))) + ((eq l 0)(values hash address-p)) + (multiple-value-bind (ahash ap) + (%%equalphash-aux l (if (consp key)(car key) key)) + (setq hash (mixup-hash-code (logxor ahash hash))) + (if ap (setq address-p t))) + (when (not (consp key)) + (return (values hash address-p))) + (setq key (cdr key))))) + ((typep key 'hash-table) + (equalphash-hash-table key)) + ; what are the dudes called that contain bits? they are uvectors but not gvectors? + ; ivectors. + ((or (istructp key) + (structurep key)) ;was (gvectorp key) + (%%equalphash-structure limit key)) + ((or (arrayp key)) ; (uvectorp key)) + (%%equalphash-array limit key)) + (t (%%equalphash key)))))) + +(defun alist-hash-table (alist &rest hash-table-args) + (declare (dynamic-extent hash-table-args)) + (if (typep alist 'hash-table) + alist + (let ((hash-table (apply #'make-hash-table hash-table-args))) + (dolist (cons alist) (puthash (car cons) hash-table (cdr cons))) + hash-table))) + +(defun %hash-table-equalp (x y) + ;; X and Y are both hash tables + (and (eq (hash-table-test x) + (hash-table-test y)) + (eql (hash-table-count x) + (hash-table-count y)) + (block nil + (let* ((default (cons nil nil)) + (foo #'(lambda (k v) + (let ((y-value (gethash k y default))) + (unless (and (neq default y-value) + (equalp v y-value)) + (return nil)))))) + (declare (dynamic-extent foo default)) + (maphash foo x)) + t))) + +(defun sxhash (s-expr) + "Computes a hash code for S-EXPR and returns it as an integer." + (logand (sxhash-aux s-expr 7 17) target::target-most-positive-fixnum)) + +(defun sxhash-aux (expr counter key) + (declare (fixnum counter)) + (if (> counter 0) + (typecase expr + ((or string bit-vector number character) (+ key (%%equalhash expr))) + (logical-pathname + (dotimes (i (uvsize expr) key) + (declare (fixnum i)) + (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key))))) + (pathname + ;; Don't consider %PHYSICAL-PATHNAME-VERSION to be significant + (dotimes (i (uvsize expr) key) + (declare (fixnum i)) + (unless (= i %physical-pathname-version) + (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key)))))) + (symbol (+ key (%%equalhash (symbol-name expr)))) + (cons (sxhash-aux + (cdr expr) + (the fixnum (1- counter)) + (+ key (sxhash-aux (car expr) (the fixnum (1- counter)) key)))) + (t (+ key (%%equalhash (symbol-name (%type-of expr)))))) + key)) + + + +#+(or ppc32-target x8632-target) +(defun immediate-p (thing) + (let* ((tag (lisptag thing))) + (declare (fixnum tag)) + (or (= tag target::tag-fixnum) + (= tag target::tag-imm)))) + +#+ppc64-target +(defun immediate-p (thing) + (let* ((tag (lisptag thing))) + (declare (fixnum tag)) + (or (= tag ppc64::tag-fixnum) + (= (logand tag ppc64::lowtagmask) ppc64::lowtag-imm)))) + +#+x8664-target +(defun immediate-p (thing) + (let* ((tag (lisptag thing))) + (declare (type (unsigned-byte 3) tag)) + (logbitp tag + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::tag-imm-0) + (ash 1 x8664::tag-imm-1))))) + + + +(defun %cons-nhash-vector (size &optional (flags 0)) + (declare (fixnum size)) + (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector free-hash-marker))) + (%init-nhash-vector vector flags) + vector)) + +(defun %init-nhash-vector (vector flags) + (let ((size (vector-index->index (uvsize vector)))) + (declare (fixnum size)) + (setf (nhash.vector.link vector) 0 + (nhash.vector.flags vector) flags + (nhash.vector.gc-count vector) (%get-gc-count) + (nhash.vector.free-alist vector) nil + (nhash.vector.finalization-alist vector) nil + (nhash.vector.weak-deletions-count vector) 0 + (nhash.vector.hash vector) nil + (nhash.vector.deleted-count vector) 0 + (nhash.vector.count vector) 0 + (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil + (nhash.vector.cache-idx vector) nil + (nhash.vector.size vector) size + (nhash.vector.size-reciprocal vector) (floor (ash 1 (- target::nbits-in-word target::fixnumshift)) size)))) + +(defun assert-hash-table-readonly (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (or (nhash.read-only hash) + (when (nhash.owner hash) + (error "Hash~table ~s is thread-private and can't be made read-only for that reason" hash)) + (if (hash-lock-free-p hash) + (setf (nhash.read-only hash) t) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (let* ((flags (nhash.vector.flags (nhash.vector hash)))) + (declare (fixnum flags)) + (when (or (logbitp $nhash_track_keys_bit flags) + (logbitp $nhash_component_address_bit flags)) + (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash) + (unlock-hash-table hash nil) + (return-from assert-hash-table-readonly nil)) + (setf (nhash.read-only hash) t) + (unlock-hash-table hash nil) + t)))))) + +;; This is dangerous, if multiple threads are accessing a read-only +;; hash table. Use it responsibly. +(defun assert-hash-table-writeable (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (nhash.read-only hash) + (setf (nhash.read-only hash) nil) + t)) + +(defun readonly-hash-table-p (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (nhash.read-only hash)) + +(defun hash-table-owner (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (nhash.owner hash)) + +(defun claim-hash-table (hash &optional steal) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (let* ((owner (nhash.owner hash))) + (if owner + (or (eq owner *current-process*) + (when steal + (setf (nhash.owner hash) *current-process*))) + (progn + (unless (hash-lock-free-p hash) + (write-lock-hash-table hash) + (setf (nhash.exclusion-lock hash) nil)) + (setf (nhash.owner hash) *current-process*) + t)))) + + +;; ** TODO: for lock-free hash tables, we don't need to copy, +;; we could map over the actual hash table vector, because it's +;; always valid. +(defun lock-free-enumerate-hash-keys-and-values (hash keys values) + (do* ((in (nhash.vector hash)) + (in-idx $nhash.vector_overhead (+ in-idx 2)) + (insize (uvsize in)) + (outsize (length (or keys values))) + (out-idx 0)) + ((or (= in-idx insize) + (= out-idx outsize)) + out-idx) + (declare (fixnum in-idx insize out-idx outsize)) + (let* ((key (%svref in in-idx))) + (unless (eq key free-hash-marker) + (let ((val (%svref in (%i+ in-idx 1)))) + (when (eq val rehashing-value-marker) + ;; This table is being rehashed. Wait to finish and try again + (lock-free-rehash hash) + (return-from lock-free-enumerate-hash-keys-and-values + (lock-free-enumerate-hash-keys-and-values hash keys values))) + (unless (eq val free-hash-marker) + (when (eql key deleted-hash-key-marker) + (error "Bug: deleted key but not value?")) + (when keys (setf (%svref keys out-idx) key)) + (when values (setf (%svref values out-idx) val)) + (incf out-idx))))))) + +(defun enumerate-hash-keys-and-values (hash keys values) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (hash-lock-free-p hash) + (return-from enumerate-hash-keys-and-values + (lock-free-enumerate-hash-keys-and-values hash keys values))) + (with-lock-context + (without-interrupts + (let* ((readonly (eq (read-lock-hash-table hash) :readonly))) + (do* ((in (nhash.vector hash)) + (in-idx $nhash.vector_overhead (+ in-idx 2)) + (insize (uvsize in)) + (outsize (length (or keys values))) + (out-idx 0)) + ((or (= in-idx insize) + (= out-idx outsize)) + (unlock-hash-table hash readonly) + out-idx) + (declare (fixnum in-idx insize out-idx outsize)) + (let* ((key (%svref in in-idx))) + (unless (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (when keys + (setf (%svref keys out-idx) key)) + (when values + (setf (%svref values out-idx) (%svref in (%i+ in-idx 1)))) + (incf out-idx)))))))) + +(defun enumerate-hash-keys (hash out) + (enumerate-hash-keys-and-values hash out nil)) Index: /branches/qres/ccl/level-0/l0-init.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-init.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-init.lisp (revision 13564) @@ -0,0 +1,173 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant array-total-size-limit + #.(expt 2 (- target::nbits-in-word target::num-subtag-bits)) + "the exclusive upper bound on the total number of elements in an array") + + +;Features for #+/- conditionalization: +(defparameter *features* + '(:common-lisp + :openmcl + :ccl + :ccl-1.2 + :ccl-1.3 + :ccl-1.4 + :ccl-0711 + :clozure + :clozure-common-lisp + :ansi-cl + #-windows-target :unix + :openmcl-unicode-strings + ;; Threads and MOP stuff is pretty redundant. + :openmcl-native-threads + :openmcl-partial-mop + :mcl-common-mop-subset + :openmcl-mop-2 + ;; Thread-private hash-tables were introduced in version 1.0 + :openmcl-private-hash-tables + ;; Hash-consing support (special primitives for allocating + ;; and managing statically allocated CONS cells) will be + ;; added in 1.1 + ;; Was dropped in 1.2 + ;; :openmcl-hash-consing + #+eabi-target :eabi-target + #+ppc-target :powerpc + #+ppc-target :ppc-target + #+ppc-target :ppc-clos ; used in encapsulate + #+ppc32-target :ppc32-target + #+ppc32-target :ppc32-host + #+ppc64-target :ppc64-target + #+ppc64-target :ppc64-host + #+x8632-target :x8632-target + #+x8632-target :x8632-host + #+x8664-target :x86-64 + #+x8664-target :x86_64 + #+x8632-target :x86 + #+x86-target :x86-target + #+x86-target :x86-host + #+x8664-target :x8664-target + #+x8664-target :x8664-host + #+linux-target :linux-host + #+linux-target :linux-target + #+linuxppc-target :linuxppc-target + #+linuxppc-target :linuxppc-host + #+linuxx86-target :linuxx86-target + #+linuxx8664-target :linuxx8664-target + #+linuxx8664-target :linuxx8664-host + #+linuxx8632-target :linuxx8632-target + #+linuxx8632-target :linuxx8632-host + #+darwinppc-target :darwinppc-target + #+darwinppc-target :darwinppc-host + #+darwinppc-target :darwin-target + #+freebsd-target :freebsd-host + #+freebsd-target :freebsd-target + #+freebsdx86-target :freebsdx86-target + #+freebsdx8664-target :freebsdx8664-target + #+freebsdx8664-target :freebsdx8664-host + #+freebsdx8632-target :freebsdx8632-target + #+freebsdx8632-target :freebsdx8632-host + #+darwin-target :darwin-host + #+darwin-target :darwin-target + #+darwinx86-target :darwinx86-target + #+darwinx8632-target :darwinx8632-target + #+darwinx8632-target :darwinx8632-host + #+darwinx8664-target :darwinx8664-target + #+darwinx8664-target :darwinx8664-host + #+windows-target :windows-host + #+windows-target :windows-target + #+win64-target :win64-target + #+win64-target :win64-host + #+win32-target :win32-target + #+win32-target :win32-host + #+solaris-target :solaris-host + #+solaris-target :solaris-target + #+solarisx86-target :solarisx86-target + #+solarisx8664-target :solarisx8664-target + #+solarisx8664-target :solarisx8664-host + #+solarisx8632-target :solarisx8632-target + #+solarisx8632-target :solarisx8632-host + #+(and ppc-target poweropen-target) :poweropen-target + #+64-bit-target :64-bit-target + #+64-bit-target :64-bit-host + #+32-bit-target :32-bit-target + #+32-bit-target :32-bit-host + #+ppc-target :big-endian-target + #+ppc-target :big-endian-host + #+x86-target :little-endian-target + #+x86-target :little-endian-host + #+darwin-target :darwin + #+linux-target :linux + #+freebsd-target :freebsd + #+solaris-target :solaris + #+windows-target :windows + ) + "a list of symbols that describe features provided by the + implementation") + +(defparameter *optional-features* () "Set by build process") + +(defparameter *load-verbose* nil + "the default for the :VERBOSE argument to LOAD") + +;All Lisp package variables... Dunno if this still matters, but it +;used to happen in the kernel... +(dolist (x '(* ** *** *APPLYHOOK* *DEBUG-IO* + *DEFAULT-PATHNAME-DEFAULTS* *ERROR-OUTPUT* *EVALHOOK* + *FEATURES* *LOAD-VERBOSE* *MACROEXPAND-HOOK* *MODULES* + *PACKAGE* *PRINT-ARRAY* *PRINT-BASE* *PRINT-CASE* *PRINT-CIRCLE* + *PRINT-ESCAPE* *PRINT-GENSYM* *PRINT-LENGTH* *PRINT-LEVEL* + *PRINT-PRETTY* *PRINT-RADIX* *QUERY-IO* *RANDOM-STATE* *READ-BASE* + *READ-DEFAULT-FLOAT-FORMAT* *READ-SUPPRESS* *READTABLE* + *STANDARD-INPUT* *STANDARD-OUTPUT* *TERMINAL-IO* *TRACE-OUTPUT* + + ++ +++ - / // /// ARRAY-DIMENSION-LIMIT ARRAY-RANK-LIMIT + ARRAY-TOTAL-SIZE-LIMIT BOOLE-1 BOOLE-2 BOOLE-AND BOOLE-ANDC1 + BOOLE-ANDC2 BOOLE-C1 BOOLE-C2 BOOLE-CLR BOOLE-EQV BOOLE-IOR + BOOLE-NAND BOOLE-NOR BOOLE-ORC1 BOOLE-ORC2 BOOLE-SET BOOLE-XOR + CALL-ARGUMENTS-LIMIT CHAR-CODE-LIMIT + DOUBLE-FLOAT-EPSILON DOUBLE-FLOAT-NEGATIVE-EPSILON + INTERNAL-TIME-UNITS-PER-SECOND LAMBDA-LIST-KEYWORDS + LAMBDA-PARAMETERS-LIMIT LEAST-NEGATIVE-DOUBLE-FLOAT + LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-SHORT-FLOAT + LEAST-NEGATIVE-SINGLE-FLOAT LEAST-POSITIVE-DOUBLE-FLOAT + LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-SHORT-FLOAT + LEAST-POSITIVE-SINGLE-FLOAT LONG-FLOAT-EPSILON + LONG-FLOAT-NEGATIVE-EPSILON MOST-NEGATIVE-DOUBLE-FLOAT + MOST-NEGATIVE-FIXNUM MOST-NEGATIVE-LONG-FLOAT + MOST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SINGLE-FLOAT + MOST-POSITIVE-DOUBLE-FLOAT MOST-POSITIVE-FIXNUM + MOST-POSITIVE-LONG-FLOAT MOST-POSITIVE-SHORT-FLOAT + MOST-POSITIVE-SINGLE-FLOAT MULTIPLE-VALUES-LIMIT PI + SHORT-FLOAT-EPSILON SHORT-FLOAT-NEGATIVE-EPSILON + SINGLE-FLOAT-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)) + (%symbol-bits x (%ilogior2 (%symbol-bits x) (ash 1 $sym_bit_special)))) + +(defparameter *loading-file-source-file* nil) +(defparameter *loading-toplevel-location* nil) + +(defvar *nx-speed* 1) +(defvar *nx-space* 1) +(defvar *nx-safety* 1) +(defvar *nx-cspeed* 1) +(defvar *nx-debug* 1) + +(defparameter *case-sensitive-filesystem* t) + +;;; end Index: /branches/qres/ccl/level-0/l0-int.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-int.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-int.lisp (revision 13564) @@ -0,0 +1,189 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") +) + + +(defun lsh (fixnum count) + (require-type fixnum 'fixnum) + (require-type count 'fixnum) + (if (> count 0) + (%ilsl count fixnum) + (%ilsr (- count) fixnum))) + +; this called with fixnum +(defun %iabs (n) + (declare (fixnum n)) + (if (minusp n) (- n) n)) + +; called with any integer - is there a cmu version of integer/bignum-abs? +(defun %integer-abs (n) + (number-case n + (fixnum + (locally + (declare (fixnum n)) + (if (minusp n) (- n) n))) + (bignum + (if (minusp n) (- n) n)))) + + +(eval-when (:compile-toplevel :execute) + (assert (< (char-code #\9) (char-code #\A) (char-code #\a)))) + +(defun token2int (string start len radix) + ; simple minded in case you hadn't noticed + (let* ((n start) + (end (+ start len)) + (char0 (schar string n)) + (val 0) + minus) + (declare (fixnum n end start len radix)) ; as if it mattered + (when (or (eq char0 #\+)(eq char0 #\-)) + (setq n (1+ n)) + (if (eq char0 #\-)(setq minus t))) + (while (< n end) + (let ((code (%scharcode string n))) + (if (<= code (char-code #\9)) + (setq code (- code (char-code #\0))) + (progn + (when (>= code (char-code #\a)) + (setq code (- code (- (char-code #\a) (char-code #\A))))) + (setq code (- code (- (char-code #\A) 10))))) + (setq val (+ (* val radix) code)) + (setq n (1+ n)))) + (if minus (- val) val))) + + +(defun %integer-to-string (int &optional (radix 10)) + (%pr-integer int radix nil t)) + + +;;; it may be hard to believe, but this is much faster than the lap +;;; version (3 or 4X) for fixnums that is (stream-write-string vs +;;; stream-tyo ???) + +(defun %pr-integer (int &optional (radix 10) (stream *standard-output*) return-it negate-it) + (declare (fixnum radix)) ; assume caller has checked + (if stream + (if (eq stream t) (setq stream *terminal-io*)) + (setq stream *standard-output*)) + (let ((digit-string "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")) + (cond ((fixnump int) ; ugh + (let ((temstring (make-string (- target::nbits-in-word target::fixnumshift) :element-type 'base-char)) + (i (- target::nbits-in-word target::fixnumshift 1)) + (neg (< int 0)) + (rem 0)) + (declare (fixnum i rem)) + (declare (dynamic-extent temstring)) + (when neg (setq int (- int))) + (when (not (fixnump int)) + (return-from %pr-integer (%pr-integer int radix stream return-it t))) + (locally (declare (fixnum int)) + (loop + (multiple-value-setq (int rem) (%fixnum-truncate int radix)) + (setf (%schar temstring i)(%schar digit-string rem)) + (when (eq 0 int) + (return)) + (setq i (1- i))) + (when neg + (setf (%schar temstring (setq i (1- i))) #\-)) + (if return-it + (%substr temstring i (- target::nbits-in-word + target::fixnumshift)) + (write-string temstring stream :start i :end (- target::nbits-in-word target::fixnumshift)))))) + (t (let* ((size-vect #(nil nil 32 21 16 14 13 12 11 + 11 10 10 9 9 9 9 8 8 + 8 8 8 8 8 8 7 7 7 + 7 7 7 7 7 7 7 7 7 7)) + ;; overestimate # digits by a little for weird + ;; radix + (bigwords (uvsize int)) + (strlen (1+ (* bigwords (svref size-vect radix)))) + (temstring (make-string strlen :element-type 'base-char)) + (i (1- strlen)) + (neg (< int 0)) + ; ;(rem 0) + ;; ;better-bignum-print? + ) ; warn + (declare (dynamic-extent temstring) + (fixnum i strlen)) + (flet ((do-it (newbig) + (print-bignum-2 newbig radix temstring digit-string))) + (declare (dynamic-extent #'do-it)) + (setq i (with-one-negated-bignum-buffer int do-it))) + (when (or neg negate-it) + (setf (%schar temstring (setq i (1- i))) #\-)) + (if return-it + (%substr temstring i strlen) + (write-string temstring stream :start i :end strlen))))))) + + + +;;; *BASE-POWER* holds the number that we keep dividing into the bignum for +;;; each *print-base*. We want this number as close to *most-positive-fixnum* +;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)). +;;; +(defparameter *base-power* ()) + +;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that +;;; fit in the corresponding *base-power*. +;;; +(defparameter *fixnum-power--1* ()) + +(do* ((b (make-array 37 :initial-element nil)) + (f (make-array 37 :initial-element nil)) + (base 2 (1+ base))) + ((= base 37) (setq *base-power* b *fixnum-power--1* f)) + (do ((power-1 -1 (1+ power-1)) + (new-divisor base (* new-divisor base)) + (divisor 1 new-divisor)) + ((not (fixnump new-divisor)) + (setf (aref b base) divisor) + (setf (aref f base) power-1)))) + + +(defun print-bignum-2 (big radix string digit-string) + (declare (optimize (speed 3) (safety 0)) + (simple-base-string string digit-string)) + (let* ((divisor (aref *base-power* radix)) + (power (aref *fixnum-power--1* radix)) + (index (1- (length string))) + (rem 0)) + (declare (fixnum index divisor power)) + ;;(print index) + (loop + (multiple-value-setq (big rem) (truncate big divisor)) + (let* ((int rem) + (rem 0) + (final-index (- index power 1))) + (loop + (multiple-value-setq (int rem) (%fixnum-truncate int radix)) + (setf (schar string index)(schar digit-string rem)) + (when (eql 0 int) + (return index)) + (setq index (1- index))) + (if (zerop big) + (return index) + (dotimes (i (- index final-index) index) + (declare (fixnum i)) + (setq index (1- index)) + (setf (schar string index) #\0))))))) Index: /branches/qres/ccl/level-0/l0-io.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-io.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-io.lisp (revision 13564) @@ -0,0 +1,316 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + + +(defun utf-8-octets-in-string (string start end) + (if (>= end start) + (do* ((noctets 0) + (i start (1+ i))) + ((= i end) noctets) + (declare (fixnum noctets)) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (incf noctets + (if (< code #x80) + 1 + (if (< code #x800) + 2 + (if (< code #x10000) + 3 + 4)))))) + 0)) + +(defun utf-16-octets-in-string (string start end) + (if (>= end start) + (do* ((noctets 0) + (i start (1+ i))) + ((= i end) noctets) + (declare (fixnum noctets)) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (incf noctets + (if (< code #x10000) + 2 + 4)))) + 0)) + +(defun utf-8-memory-encode (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (cond ((< code #x80) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx)) + ((< code #x800) + (setf (%get-unsigned-byte pointer idx) + (logior #xc0 (the fixnum (ash code -6)))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 2)) + ((< code #x10000) + (setf (%get-unsigned-byte pointer idx) + (logior #xe0 (the fixnum (ash code -12)))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 3)) + (t + (setf (%get-unsigned-byte pointer idx) + (logior #xf0 + (the fixnum (logand #x7 (the fixnum (ash code -18)))))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3))) + (logior #x80 (logand #x3f code))) + (incf idx 4)))))) + +(defun native-utf-16-memory-encode (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) code) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10)))) + (incf idx 2) + (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + (incf idx 2)))))) + +(defun utf-8-memory-decode (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) (if (= index end) index 0)) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((char (if (< 1st-unit #x80) + (code-char 1st-unit) + (if (>= 1st-unit #xc2) + (let* ((2nd-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 2nd-unit)) + (if (< 1st-unit #xe0) + (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (code-char + (logior + (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) + (the fixnum (logxor 2nd-unit #x80))))) + (let* ((3rd-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 3rd-unit)) + (if (< 1st-unit #xf0) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (or (>= 1st-unit #xe1) + (>= 2nd-unit #xa0))) + (code-char (the fixnum + (logior (the fixnum + (ash (the fixnum (logand 1st-unit #xf)) + 12)) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 2nd-unit #x3f)) + 6)) + (the fixnum (logand 3rd-unit #x3f)))))))) + (if (< 1st-unit #xf8) + (let* ((4th-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 4th-unit)) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (< (the fixnum (logxor 4th-unit #x80)) #x40) + (or (>= 1st-unit #xf1) + (>= 2nd-unit #x90))) + (code-char + (logior + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 1st-unit 7)) 18)) + (the fixnum + (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logxor 3rd-unit #x80)) 6)) + (the fixnum (logxor 4th-unit #x80))))))))))))))))) + (setf (schar string i) (or char #\Replacement_Character)))))) + +(defun utf-8-length-of-memory-encoding (pointer noctets start) + (do* ((i start) + (end (+ start noctets)) + (nchars 0 (1+ nchars))) + ((= i end) (values nchars (- i start))) + (let* ((code (%get-unsigned-byte pointer i)) + (nexti (+ i (cond ((< code #xc2) 1) + ((< code #xe0) 2) + ((< code #xf0) 3) + ((< code #xf8) 4) + (t 1))))) + (declare (type (unsigned-byte 8) code)) + (if (> nexti end) + (return (values nchars (- i start))) + (setq i nexti))))) + + + +;;; write nbytes bytes from buffer buf to file-descriptor fd. +(defun fd-write (fd buf nbytes) + (ignoring-eintr + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-write) + :int fd :address buf :ssize_t nbytes :ssize_t))) + +(defun fd-read (fd buf nbytes) + (ignoring-eintr + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-read) + :int fd :address buf :ssize_t nbytes :ssize_t))) + + +(let* ((pathname-encoding-name ())) + (declare (ignorable pathname-encoding-name)) + (defun pathname-encoding-name () + #+darwin-target :utf-8 + #+windows-target :utf-16le + #-(or darwin-target windows-target) pathname-encoding-name) + (defun set-pathname-encoding-name (new) + #+(or darwin-target windows-target) (declare (ignore new)) + #+darwin-target :utf-8 + #+windows-target :utf-16le + #-(or darwin-target windows-target) + (let* ((encoding (ensure-character-encoding new))) + (setq pathname-encoding-name + (unless (eq encoding (get-character-encoding nil)) + (character-encoding-name encoding)))))) + + +(defun fd-open-path (p flags create-mode) + (let* ((fd (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-open) + :address p :int flags :mode_t create-mode :int))) + (declare (fixnum fd)) + (when (or (= fd (- #$EMFILE)) + (= fd (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq fd (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-open) + :address p :int flags :mode_t create-mode :int))) + fd)) + +(defun fd-open (path flags &optional (create-mode #o666)) + #+darwin-target (with-utf-8-cstrs ((p path)) + (fd-open-path p flags create-mode)) + #+windows-target (with-native-utf-16-cstrs ((p path)) + (fd-open-path p flags create-mode)) + #-(or darwin-target windows-target) + (let* ((encoding (pathname-encoding-name))) + (if encoding + (with-encoded-cstrs encoding ((p path)) + (fd-open-path p flags create-mode)) + (with-cstrs ((p path)) + (fd-open-path p flags create-mode))))) + +(defun fd-chmod (fd mode) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fchmod) + :int fd + :mode_t mode + :int)) + +(defun fd-lseek (fd offset whence) + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-lseek) + :int fd + :signed-doubleword offset + :int whence + :signed-doubleword)) + +(defun fd-close (fd) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-close) + :int fd + :int)) + +(defun fd-tell (fd) + (fd-lseek fd 0 #$SEEK_CUR)) + +;;; Kernels prior to 2.4 don't seem to have a "stat" variant +;;; that handles 64-bit file offsets. +(defun fd-size (fd) + (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat)) + (if (eql 0 (ff-call (%kernel-import target::kernel-import-lisp-fstat) + :int fd + :address stat + :int)) + (pref stat + #-windows-target :stat.st_size + #+win64-target #>_stat64.st_size + #+win32-target #>__stat64.st_size) + -1))) + + +(defun fd-ftruncate (fd new) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-ftruncate) + :int fd :off_t new :int)) + +(defun %string-to-stderr (str) + (with-cstrs ((s str)) + (fd-write 2 s (length str)))) + +(defun pdbg (string) + (%string-to-stderr string) + (%string-to-stderr #.(string #\LineFeed))) + + + +;;; Not really I/O, but ... +(defun malloc (size) + (ff-call + (%kernel-import target::kernel-import-malloc) + :unsigned-fullword size :address)) + +(defun free (ptr) + (let* ((size (uvsize ptr)) + (flags (if (= size target::xmacptr.size) + (uvref ptr target::xmacptr.flags-cell) + $flags_DisposPtr))) + (declare (fixnum size flags)) + (if (= flags $flags_DisposPtr) + (with-macptrs ((addr ptr)) + (when (= size target::xmacptr.size) + (%setf-macptr ptr (%null-ptr)) + (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal)) + (ff-call + (%kernel-import target::kernel-import-free) + :address addr :void))))) + + + + Index: /branches/qres/ccl/level-0/l0-misc.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-misc.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-misc.lisp (revision 13564) @@ -0,0 +1,1132 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +;;; Bootstrapping for futexes +#+(and linux-target x86-target) +(eval-when (:compile-toplevel :execute) + (pushnew :futex *features*)) + +#+futex +(eval-when (:compile-toplevel :execute) + ;; We only need a few constants from , which may + ;; not have been included in the :libc .cdb files. + (defconstant FUTEX-WAIT 0) + (defconstant FUTEX-WAKE 1) + (defconstant futex-avail 0) + (defconstant futex-locked 1) + (defconstant futex-contended 2) + (declaim (inline %lock-futex %unlock-futex))) + +;;; Miscellany. + +(defun memq (item list) + (do* ((tail list (%cdr tail))) + ((null tail)) + (if (eq item (car tail)) + (return tail)))) + +(defun %copy-u8-to-string (u8-vector source-idx string dest-idx n) + (declare (optimize (speed 3) (safety 0)) + (fixnum source-idx dest-idx n) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (simple-base-string string)) + (do* ((i 0 (1+ i))) + ((= i n) string) + (declare (fixnum i)) + (setf (%scharcode string dest-idx) (aref u8-vector source-idx)) + (incf source-idx) + (incf dest-idx))) + +(defun %copy-string-to-u8 (string source-idx u8-vector dest-idx n) + (declare (optimize (speed 3) (safety 0)) + (fixnum source-idx dest-idx n) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (simple-base-string string)) + (do* ((i 0 (1+ i))) + ((= i n) u8-vector) + (declare (fixnum i)) + (let* ((code (%scharcode string source-idx))) + (declare (type (mod #x11000) code)) + (if (> code #xff) + (setq code (char-code #\Sub))) + (setf (aref u8-vector dest-idx) code) + (incf source-idx) + (incf dest-idx)))) + + + + +(defun append-2 (y z) + (if (null y) + z + (let* ((new (cons (car y) nil)) + (tail new)) + (declare (list new tail)) + (dolist (head (cdr y)) + (setq tail (cdr (rplacd tail (cons head nil))))) + (rplacd tail z) + new))) + + + + + + + + + +(defun dbg (&optional arg) + (dbg arg)) + + +; This takes a simple-base-string and passes a C string into +; the kernel "Bug" routine. Not too fancy, but neither is #_DebugStr, +; and there's a better chance that users would see this message. +(defun bug (arg) + (if (typep arg 'simple-base-string) + #+x86-target + (debug-trap-with-string arg) + #-x86-target + (let* ((len (length arg))) + (%stack-block ((buf (1+ len))) + (%cstr-pointer arg buf) + (ff-call + (%kernel-import target::kernel-import-lisp-bug) + :address buf + :void))) + (bug "Bug called with non-simple-base-string."))) + +(defun total-bytes-allocated () + (%heap-bytes-allocated) + #+not-any-more + (+ (unsignedwide->integer *total-bytes-freed*) + (%heap-bytes-allocated))) + +(defun %freebytes () + (with-macptrs (p) + (%setf-macptr-to-object p + (%fixnum-ref (%get-kernel-global 'all-areas) + target::area.succ)) + (- (%get-natural p target::area.high) + (%get-natural p target::area.active)))) + +(defun %reservedbytes () + (with-macptrs (p) + (%setf-macptr-to-object p (%get-kernel-global 'all-areas)) + (- #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high) + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low)))) + +(defun object-in-application-heap-p (address) + (declare (ignore address)) + t) + +(defun frozen-space-dnodes () + "Returns the current size of the frozen area." + (%fixnum-ref-natural (%get-kernel-global 'tenured-area) + target::area.static-dnodes)) +(defun %usedbytes () + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (%normalize-areas) + (let ((static 0) + (dynamic 0) + (library 0)) + (do-consing-areas (area) + (let* ((active (%fixnum-ref area target::area.active)) + (bytes (ash (- active + (%fixnum-ref area target::area.low)) + target::fixnumshift)) + (code (%fixnum-ref area target::area.code))) + (when (object-in-application-heap-p active) + (if (eql code area-dynamic) + (incf dynamic bytes) + (if (eql code area-managed-static) + (incf library bytes) + (incf static bytes)))))) + (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift))) + (decf dynamic frozen-size) + (values dynamic static library frozen-size)))))) + + + +(defun %stack-space () + (%normalize-areas) + (let ((free 0) + (used 0)) + (with-macptrs (p) + (do-gc-areas (area) + (when (member (%fixnum-ref area target::area.code) + '(#.area-vstack + #.area-cstack + #.area-tstack)) + (%setf-macptr-to-object p area) + (let ((active + #+32-bit-target + (%get-unsigned-long p target::area.active) + #+64-bit-target + (%%get-unsigned-longlong p target::area.active)) + (high + #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high)) + (low + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low))) + (incf used (- high active)) + (incf free (- active low)))))) + (values (+ free used) used free))) + + + +; Returns an alist of the form: +; ((thread cstack-free cstack-used vstack-free vstack-used tstack-free tstack-used) +; ...) +(defun %stack-space-by-lisp-thread () + (let* ((res nil)) + (without-interrupts + (dolist (p (all-processes)) + (let* ((thread (process-thread p))) + (when thread + (push (cons thread (multiple-value-list (%thread-stack-space thread))) res))))) + res)) + + + +;;; Returns six values. +;;; sp free +;;; sp used +;;; vsp free +;;; vsp used +;;; tsp free +;;; tsp used +(defun %thread-stack-space (&optional (thread *current-lisp-thread*)) + (when (eq thread *current-lisp-thread*) + (%normalize-areas)) + (labels ((free-and-used (area) + (with-macptrs (p) + (%setf-macptr-to-object p area) + (let* ((low + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low)) + (high + #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high)) + (active + #+32-bit-target + (%get-unsigned-long p target::area.active) + #+64-bit-target + (%%get-unsigned-longlong p target::area.active)) + (free (- active low)) + (used (- high active))) + (loop + (setq area (%fixnum-ref area target::area.older)) + (when (eql area 0) (return)) + (%setf-macptr-to-object p area) + (let ((low + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low)) + (high + #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high))) + (declare (fixnum low high)) + (incf used (- high low)))) + (values free used))))) + (let* ((tcr (lisp-thread.tcr thread))) + (if (or (null tcr) + (zerop (%fixnum-ref (%fixnum-ref tcr target::tcr.cs-area)))) + (values 0 0 0 0 0 0) + (multiple-value-bind (cf cu) (free-and-used (%fixnum-ref tcr target::tcr.cs-area)) + (multiple-value-bind (vf vu) (free-and-used (%fixnum-ref tcr target::tcr.vs-area)) + (multiple-value-bind (tf tu) (free-and-used (%fixnum-ref tcr target::tcr.ts-area )) + (values cf cu vf vu tf tu)))))))) + + +(defun room (&optional (verbose :default)) + "Print to *STANDARD-OUTPUT* information about the state of internal + storage and its management. The optional argument controls the + verbosity of output. If it is T, ROOM prints out a maximal amount of + information. If it is NIL, ROOM prints out a minimal amount of + information. If it is :DEFAULT or it is not supplied, ROOM prints out + an intermediate amount of information." + (let* ((freebytes nil) + (usedbytes nil) + (static-used nil) + (staticlib-used nil) + (frozen-space-size nil) + (lispheap nil) + (reserved nil) + (static nil) + (stack-total) + (stack-used) + (stack-free) + (stack-used-by-thread nil)) + (progn + (progn + (setq freebytes (%freebytes)) + (when verbose + (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size) + (%usedbytes)) + (setq lispheap (+ freebytes usedbytes) + reserved (%reservedbytes) + static (+ static-used staticlib-used frozen-space-size)) + (multiple-value-setq (stack-total stack-used stack-free) + (%stack-space)) + (unless (eq verbose :default) + (setq stack-used-by-thread (%stack-space-by-lisp-thread)))))) + (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes) + (when verbose + (flet ((k (n) (round n 1024))) + (princ " + Total Size Free Used") + (format t "~&Lisp Heap:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" + lispheap (k lispheap) + freebytes (k freebytes) + usedbytes (k usedbytes)) + (format t "~&Stacks:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" + stack-total (k stack-total) + stack-free (k stack-free) + stack-used (k stack-used)) + (format t "~&Static:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" + static (k static) + 0 0 + static (k static)) + (when (and frozen-space-size (not (zerop frozen-space-size))) + (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory" + (/ frozen-space-size (float (ash 1 20))))) + (format t "~&~,3f MB reserved for heap expansion." + (/ reserved (float (ash 1 20)))) + (unless (eq verbose :default) + (terpri) + (let* ((processes (all-processes))) + (dolist (thread-info stack-used-by-thread) + (destructuring-bind (thread sp-free sp-used vsp-free vsp-used tsp-free tsp-used) + thread-info + (let* ((process (dolist (p processes) + (when (eq (process-thread p) thread) + (return p))))) + (when process + (let ((sp-total (+ sp-used sp-free)) + (vsp-total (+ vsp-used vsp-free)) + (tsp-total (+ tsp-used tsp-free))) + (format t "~%~a(~d)~% cstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)~ + ~% vstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)~ + ~% tstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)" + (process-name process) + (process-serial-number process) + sp-total (k sp-total) sp-free (k sp-free) sp-used (k sp-used) + vsp-total (k vsp-total) vsp-free (k vsp-free) vsp-used (k vsp-used) + tsp-total (k tsp-total) tsp-free (k tsp-free) tsp-used (k tsp-used))))))))))))) + + +(defun list-length (l) + "Return the length of the given LIST, or NIL if the LIST is circular." + (do* ((n 0 (+ n 2)) + (fast l (cddr fast)) + (slow l (cdr slow))) + ((null fast) n) + (declare (fixnum n)) + (if (null (cdr fast)) + (return (the fixnum (1+ n))) + (if (and (eq fast slow) + (> n 0)) + (return nil))))) + +(defun proper-list-p (l) + (and (typep l 'list) + (do* ((n 0 (+ n 2)) + (fast l (if (and (listp fast) (listp (cdr fast))) + (cddr fast) + (return-from proper-list-p nil))) + (slow l (cdr slow))) + ((null fast) n) + (declare (fixnum n)) + (if (atom fast) + (return nil) + (if (null (cdr fast)) + (return t) + (if (and (eq fast slow) + (> n 0)) + (return nil))))))) + +(defun proper-sequence-p (x) + (cond ((typep x 'vector)) + ((typep x 'list) (not (null (list-length x)))))) + + +(defun length (seq) + "Return an integer that is the length of SEQUENCE." + (seq-dispatch + seq + (or (list-length seq) + (%err-disp $XIMPROPERLIST seq)) + (if (= (the fixnum (typecode seq)) target::subtag-vectorH) + (%svref seq target::vectorH.logsize-cell) + (uvsize seq)))) + +(defun %str-from-ptr (pointer len &optional (dest (make-string len))) + (declare (fixnum len) + (optimize (speed 3) (safety 0))) + (dotimes (i len dest) + (setf (%scharcode dest i) (%get-unsigned-byte pointer i)))) + +(defun %get-cstring (pointer) + (do* ((end 0 (1+ end))) + ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) + (%str-from-ptr pointer end)) + (declare (fixnum end)))) + +(defun %get-utf-8-cstring (pointer) + (do* ((end 0 (1+ end))) + ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) + (let* ((len (utf-8-length-of-memory-encoding pointer end 0)) + (string (make-string len))) + (utf-8-memory-decode pointer end 0 string) + string)) + (declare (fixnum end)))) + +;;; Assumes that pointer is terminated by a 0-valued 16-bit word +;;; and that it points to a valid utf-16 string with native endianness. +(defun %get-native-utf-16-cstring (pointer) + (do* ((nchars 0 (1+ nchars)) + (i 0 (+ i 2)) + (code (%get-unsigned-word pointer i) (%get-unsigned-word pointer i))) + ((zerop code) + (do* ((string (make-string nchars)) + (out 0 (1+ out)) + (i 0 (+ i 2))) + ((= out nchars) string) + (declare (fixnum i out)) + (let* ((code (%get-unsigned-word pointer i))) + (declare (type (unsigned-byte 16) code)) + (when (and (>= code #xd800) + (< code #xdc00)) + (incf i 2) + (let* ((code2 (%get-unsigned-word pointer i))) + (declare (type (unsigned-byte 16) code2)) + (setq code (utf-16-combine-surrogate-pairs code code2)))) + (setf (schar string out) (code-char code))))) + (when (and (>= code #xd800) (< code #xdc00)) + (incf i 2)))) + + +;;; This is mostly here so we can bootstrap shared libs without +;;; having to bootstrap #_strcmp. +;;; Return true if the cstrings are equal, false otherwise. +(defun %cstrcmp (x y) + (do* ((i 0 (1+ i)) + (bx (%get-byte x i) (%get-byte x i)) + (by (%get-byte y i) (%get-byte y i))) + ((not (= bx by))) + (declare (fixnum i bx by)) + (when (zerop bx) + (return t)))) + +(defun %cnstrcmp (x y n) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (bx (%get-byte x i) (%get-byte x i)) + (by (%get-byte y i) (%get-byte y i))) + ((= i n) t) + (declare (fixnum i bx by)) + (unless (= bx by) + (return)))) + +(defvar %documentation nil) + +(defvar %documentation-lock% nil) + +(setq %documentation + (make-hash-table :weak t :size 100 :test 'eq :rehash-threshold .95) + %documentation-lock% (make-lock)) + +(defun %put-documentation (thing doc-id doc) + (with-lock-grabbed (%documentation-lock%) + (let* ((info (gethash thing %documentation)) + (pair (assoc doc-id info))) + (if doc + (progn + (unless (typep doc 'string) + (report-bad-arg doc 'string)) + (if pair + (setf (cdr pair) doc) + (setf (gethash thing %documentation) (cons (cons doc-id doc) info)))) + (when pair + (if (setq info (nremove pair info)) + (setf (gethash thing %documentation) info) + (remhash thing %documentation)))))) + doc) + +(defun %get-documentation (object doc-id) + (cdr (assoc doc-id (gethash object %documentation)))) + +;;; This pretends to be (SETF DOCUMENTATION), until that generic function +;;; is defined. It handles a few common cases. +(defun %set-documentation (thing doc-id doc-string) + (case doc-id + (function + (if (typep thing 'function) + (%put-documentation thing t doc-string) + (if (typep thing 'symbol) + (let* ((def (fboundp thing))) + (if def + (%put-documentation def t doc-string))) + (if (setf-function-name-p thing) + (%set-documentation + (setf-function-name thing) doc-id doc-string))))) + (variable + (if (typep thing 'symbol) + (%put-documentation thing doc-id doc-string))) + (t (%put-documentation thing doc-id doc-string))) + doc-string) + + +(%fhave 'set-documentation #'%set-documentation) + + + +;;; This is intended for use by debugging tools. It's a horrible thing +;;; to do otherwise. The caller really needs to hold the heap-segment +;;; lock; this grabs the tcr queue lock as well. + + +(defparameter *spin-lock-tries* 1) +(defparameter *spin-lock-timeouts* 0) + +#+(and (not futex) (not x86-target)) +(defun %get-spin-lock (p) + (let* ((self (%current-tcr)) + (n *spin-lock-tries*)) + (declare (fixnum n)) + (loop + (dotimes (i n) + (when (eql 0 (%ptr-store-fixnum-conditional p 0 self)) + (return-from %get-spin-lock t))) + (%atomic-incf-node 1 '*spin-lock-timeouts* target::symbol.vcell) + (yield)))) + +(eval-when (:compile-toplevel :execute) + (declaim (inline note-lock-wait note-lock-held note-lock-released))) + + + + + +#-futex +(defun %lock-recursive-lock-object (lock &optional flag) + (let* ((ptr (recursive-lock-ptr lock))) + (with-macptrs ((p) + (owner (%get-ptr ptr target::lockptr.owner)) + (signal (%get-ptr ptr target::lockptr.signal)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (%setf-macptr-to-object p (%current-tcr)) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (loop + (without-interrupts + (when (eql p owner) + (incf (%get-natural ptr target::lockptr.count)) + (when flag + (setf (lock-acquisition.status flag) t)) + (return t)) + (%get-spin-lock spin) + (when (eql 1 (incf (%get-natural ptr target::lockptr.avail))) + (setf (%get-ptr ptr target::lockptr.owner) p + (%get-natural ptr target::lockptr.count) 1) + (setf (%get-natural spin 0) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + (return t)) + (setf (%get-natural spin 0) 0)) + (%process-wait-on-semaphore-ptr signal 1 0 (recursive-lock-whostate lock)))))) + + + +#+futex +(progn + #-monitor-futex-wait + (defun futex-wait (p val whostate) + (with-process-whostate (whostate) + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-futex) + :address p :int FUTEX-WAIT :int val :address (%null-ptr) :address (%null-ptr) :int 0 :int))) + #+monitor-futex-wait + (progn + (defparameter *total-futex-wait-calls* 0) + (defparameter *total-futex-wait-times* 0) + (defun futex-wait (p val whostate) + (with-process-whostate (whostate) + (let* ((start (get-internal-real-time))) + (incf *total-futex-wait-calls*) + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-futex) + :address p :int FUTEX-WAIT :int val :address (%null-ptr) :address (%null-ptr) :int 0 :int) + (incf *total-futex-wait-times* (- (get-internal-real-time) start))))))) + + + + +#+futex +(defun futex-wake (p n) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-futex) + :address p :int FUTEX-WAKE :int n :address (%null-ptr) :address (%null-ptr) :int 0 :int)) + +#+futex +(defun %lock-futex (p wait-level lock fwhostate) + (let* ((val (%ptr-store-conditional p futex-avail futex-locked))) + (declare (fixnum val)) + (or (eql val futex-avail) + (loop + (if (eql val futex-contended) + (let* ((*interrupt-level* wait-level)) + (futex-wait p val (if fwhostate (funcall fwhostate lock) "futex wait"))) + (setq val futex-contended)) + (when (eql futex-avail (xchgl val p)) + (return t)))))) + +#+futex +(defun %unlock-futex (p) + (unless (eql futex-avail (%atomic-decf-ptr p)) + (setf (%get-natural p target::lockptr.avail) futex-avail) + (futex-wake p #$INT_MAX))) + + + + +#+futex +(defun %lock-recursive-lock-object (lock &optional flag) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((self (%current-tcr)) + (level *interrupt-level*) + (ptr (recursive-lock-ptr lock))) + (declare (fixnum self)) + (without-interrupts + (cond ((eql self (%get-object ptr target::lockptr.owner)) + (incf (%get-natural ptr target::lockptr.count))) + (t (%lock-futex ptr level lock #'recursive-lock-whostate) + (%set-object ptr target::lockptr.owner self) + (setf (%get-natural ptr target::lockptr.count) 1))) + (when flag + (setf (lock-acquisition.status flag) t)) + t))) + + + + + + +#-futex +(defun %try-recursive-lock-object (lock &optional flag) + (let* ((ptr (recursive-lock-ptr lock))) + (with-macptrs ((p) + (owner (%get-ptr ptr target::lockptr.owner)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (%setf-macptr-to-object p (%current-tcr)) + (if flag + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (report-bad-arg flag 'lock-acquisition))) + (without-interrupts + (cond ((eql p owner) + (incf (%get-natural ptr target::lockptr.count)) + (if flag (setf (lock-acquisition.status flag) t)) + t) + (t + (let* ((win nil)) + (%get-spin-lock spin) + (when (setq win (eql 1 (incf (%get-natural ptr target::lockptr.avail)))) + (setf (%get-ptr ptr target::lockptr.owner) p + (%get-natural ptr target::lockptr.count) 1) + (if flag (setf (lock-acquisition.status flag) t))) + (setf (%get-ptr spin) (%null-ptr)) + win))))))) + + + +#+futex +(defun %try-recursive-lock-object (lock &optional flag) + (let* ((self (%current-tcr)) + (ptr (recursive-lock-ptr lock))) + (declare (fixnum self)) + (if flag + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (report-bad-arg flag 'lock-acquisition))) + (without-interrupts + (cond ((eql (%get-object ptr target::lockptr.owner) self) + (incf (%get-natural ptr target::lockptr.count)) + (if flag (setf (lock-acquisition.status flag) t)) + t) + (t + (when (eql 0 (%ptr-store-conditional ptr futex-avail futex-locked)) + (%set-object ptr target::lockptr.owner self) + (setf (%get-natural ptr target::lockptr.count) 1) + (if flag (setf (lock-acquisition.status flag) t)) + t)))))) + + + + + +#-futex +(defun %unlock-recursive-lock-object (lock) + (let* ((ptr (%svref lock target::lock._value-cell))) + (with-macptrs ((signal (%get-ptr ptr target::lockptr.signal)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr)) + (error 'not-lock-owner :lock lock)) + (without-interrupts + (when (eql 0 (decf (the fixnum + (%get-natural ptr target::lockptr.count)))) + (%get-spin-lock spin) + (setf (%get-ptr ptr target::lockptr.owner) (%null-ptr)) + (let* ((pending (+ (the fixnum + (1- (the fixnum (%get-fixnum ptr target::lockptr.avail)))) + (the fixnum (%get-fixnum ptr target::lockptr.waiting))))) + (declare (fixnum pending)) + (setf (%get-natural ptr target::lockptr.avail) 0 + (%get-natural ptr target::lockptr.waiting) 0) + (decf pending) + (if (> pending 0) + (setf (%get-natural ptr target::lockptr.waiting) pending)) + (setf (%get-ptr spin) (%null-ptr)) + (if (>= pending 0) + (%signal-semaphore-ptr signal))))))) + nil) + + + +#+futex +(defun %unlock-recursive-lock-object (lock) + (let* ((ptr (%svref lock target::lock._value-cell))) + (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr)) + (error 'not-lock-owner :lock lock)) + (without-interrupts + (when (eql 0 (decf (the fixnum + (%get-natural ptr target::lockptr.count)))) + (setf (%get-natural ptr target::lockptr.owner) 0) + (%unlock-futex ptr)))) + nil) + + + + +(defun %%lock-owner (lock) + "Intended for debugging only; ownership may change while this code + is running." + (let* ((tcr (%get-object (recursive-lock-ptr lock) target::lockptr.owner))) + (unless (zerop tcr) + (tcr->process tcr)))) + + + + + + + +(defun %rplaca-conditional (cons-cell old new) + (%store-node-conditional target::cons.car cons-cell old new)) + +(defun %rplacd-conditional (cons-cell old new) + (%store-node-conditional target::cons.cdr cons-cell old new)) + +;;; Atomically push NEW onto the list in the I'th cell of uvector V. + +(defun atomic-push-uvector-cell (v i new) + (let* ((cell (cons new nil)) + (offset (+ target::misc-data-offset (ash i target::word-shift)))) + (loop + (let* ((old (%svref v i))) + (rplacd cell old) + (when (%store-node-conditional offset v old cell) + (return cell)))))) + +(defun atomic-pop-uvector-cell (v i) + (let* ((offset (+ target::misc-data-offset (ash i target::word-shift)))) + (loop + (let* ((old (%svref v i))) + (if (null old) + (return (values nil nil)) + (let* ((tail (cdr old))) + (when (%store-node-conditional offset v old tail) + (return (values (car old) t))))))))) + + +(defun store-gvector-conditional (index gvector old new) + (%store-node-conditional (+ target::misc-data-offset + (ash index target::word-shift)) + gvector + old + new)) + +(defun %atomic-incf-car (cell &optional (by 1)) + (%atomic-incf-node (require-type by 'fixnum) + (require-type cell 'cons) + target::cons.car)) + +(defun %atomic-incf-cdr (cell &optional (by 1)) + (%atomic-incf-node (require-type by 'fixnum) + (require-type cell 'cons) + target::cons.cdr)) + +(defun %atomic-incf-gvector (v i &optional (by 1)) + (setq v (require-type v 'gvector)) + (setq i (require-type i 'fixnum)) + (%atomic-incf-node by v (+ target::misc-data-offset (ash i target::word-shift)))) + +(defun %atomic-incf-symbol-value (s &optional (by 1)) + (setq s (require-type s 'symbol)) + (multiple-value-bind (base offset) (%symbol-binding-address s) + (%atomic-incf-node by base offset))) + +;;; What happens if there are some pending readers and another writer, +;;; and we abort out of the semaphore wait ? If the writer semaphore is +;;; signaled before we abandon interest in it +#-futex +(defun %write-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) ) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (incf (%get-signed-natural ptr target::rwlock.state)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (do* () + ((eql 0 (%get-signed-natural ptr target::rwlock.state)) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) 1 + (%get-natural ptr target::rwlock.spin) 0) + (%set-object ptr target::rwlock.writer tcr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (incf (%get-natural ptr target::rwlock.blocked-writers)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (let* ((*interrupt-level* level)) + (%process-wait-on-semaphore-ptr write-signal 1 0 (rwlock-write-whostate lock))) + (%get-spin-lock ptr))))))) +#+futex +(defun %write-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) ) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%lock-futex ptr level lock nil) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (incf (%get-signed-natural ptr target::rwlock.state)) + (%unlock-futex ptr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (do* () + ((eql 0 (%get-signed-natural ptr target::rwlock.state)) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) 1) + (%unlock-futex ptr) + (%set-object ptr target::rwlock.writer tcr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (incf (%get-natural ptr target::rwlock.blocked-writers)) + (let* ((waitval (%get-natural write-signal 0))) + (%unlock-futex ptr) + (with-process-whostate ((rwlock-write-whostate lock)) + (let* ((*interrupt-level* level)) + (futex-wait write-signal waitval (rwlock-write-whostate lock))))) + (%lock-futex ptr level lock nil) + (decf (%get-natural ptr target::rwlock.blocked-writers)))))))) + + + +(defun write-lock-rwlock (lock &optional flag) + (%write-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) + +#-futex +(defun %read-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'deadlock :lock lock)) + (do* ((state + (%get-signed-natural ptr target::rwlock.state) + (%get-signed-natural ptr target::rwlock.state))) + ((<= state 0) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) + (the fixnum (1- state)) + (%get-natural ptr target::rwlock.spin) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (declare (fixnum state)) + (incf (%get-natural ptr target::rwlock.blocked-readers)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (let* ((*interrupt-level* level)) + (%process-wait-on-semaphore-ptr read-signal 1 0 (rwlock-read-whostate lock))) + (%get-spin-lock ptr))))))) + +#+futex +(defun %read-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%lock-futex ptr level lock nil) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (%unlock-futex ptr) + (error 'deadlock :lock lock)) + (do* ((state + (%get-signed-natural ptr target::rwlock.state) + (%get-signed-natural ptr target::rwlock.state))) + ((<= state 0) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) + (the fixnum (1- state))) + (%unlock-futex ptr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (declare (fixnum state)) + (incf (%get-natural ptr target::rwlock.blocked-readers)) + (let* ((waitval (%get-natural reader-signal 0))) + (%unlock-futex ptr) + (let* ((*interrupt-level* level)) + (futex-wait reader-signal waitval (rwlock-read-whostate lock)))) + (%lock-futex ptr level lock nil) + (decf (%get-natural ptr target::rwlock.blocked-readers)))))))) + + + +(defun read-lock-rwlock (lock &optional flag) + (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) + + + +#-futex +(defun %unlock-rwlock-ptr (ptr lock) + (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal)) + (writer-signal (%get-ptr ptr target::rwlock.writer-signal))) + (without-interrupts + (%get-spin-lock ptr) + (let* ((state (%get-signed-natural ptr target::rwlock.state)) + (tcr (%current-tcr))) + (declare (fixnum state tcr)) + (cond ((> state 0) + (unless (eql tcr (%get-object ptr target::rwlock.writer)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'not-lock-owner :lock lock)) + (decf state)) + ((< state 0) (incf state)) + (t (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'not-locked :lock lock))) + (setf (%get-signed-natural ptr target::rwlock.state) state) + (when (zerop state) + ;; We want any thread waiting for a lock semaphore to + ;; be able to wait interruptibly. When a thread waits, + ;; it increments either the "blocked-readers" or "blocked-writers" + ;; field, but since it may get interrupted before obtaining + ;; the semaphore that's more of "an expression of interest" + ;; in taking the lock than it is "a firm commitment to take it." + ;; It's generally (much) better to signal the semaphore(s) + ;; too often than it would be to not signal them often + ;; enough; spurious wakeups are better than deadlock. + ;; So: if there are blocked writers, the writer-signal + ;; is raised once for each apparent blocked writer. (At most + ;; one writer will actually succeed in taking the lock.) + ;; If there are blocked readers, the reader-signal is raised + ;; once for each of them. (It's possible for both the + ;; reader and writer semaphores to be raised on the same + ;; unlock; the writer semaphore is raised first, so in that + ;; sense, writers still have priority but it's not guaranteed.) + ;; Both the "blocked-writers" and "blocked-readers" fields + ;; are cleared here (they can't be changed from another thread + ;; until this thread releases the spinlock.) + (setf (%get-signed-natural ptr target::rwlock.writer) 0) + (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) + (nreaders (%get-natural ptr target::rwlock.blocked-readers))) + (declare (fixnum nreaders nwriters)) + (when (> nwriters 0) + (setf (%get-natural ptr target::rwlock.blocked-writers) 0) + (dotimes (i nwriters) + (%signal-semaphore-ptr writer-signal))) + (when (> nreaders 0) + (setf (%get-natural ptr target::rwlock.blocked-readers) 0) + (dotimes (i nreaders) + (%signal-semaphore-ptr reader-signal))))) + (setf (%get-natural ptr target::rwlock.spin) 0) + t)))) + +#+futex +(defun %unlock-rwlock-ptr (ptr lock) + (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal)) + (writer-signal (%INC-ptr ptr target::rwlock.writer-signal))) + (let* ((signal nil) + (wakeup 0)) + (without-interrupts + (%lock-futex ptr -1 lock nil) + (let* ((state (%get-signed-natural ptr target::rwlock.state)) + (tcr (%current-tcr))) + (declare (fixnum state tcr)) + (cond ((> state 0) + (unless (eql tcr (%get-object ptr target::rwlock.writer)) + (%unlock-futex ptr) + (error 'not-lock-owner :lock lock)) + (decf state)) + ((< state 0) (incf state)) + (t (%unlock-futex ptr) + (error 'not-locked :lock lock))) + (setf (%get-signed-natural ptr target::rwlock.state) state) + (when (zerop state) + (setf (%get-signed-natural ptr target::rwlock.writer) 0) + (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) + (nreaders (%get-natural ptr target::rwlock.blocked-readers))) + (declare (fixnum nreaders nwriters)) + (if (> nwriters 0) + (setq signal writer-signal wakeup 1) + (if (> nreaders 0) + (setq signal reader-signal wakeup #$INT_MAX))))) + (when signal (incf (%get-signed-natural signal 0))) + (%unlock-futex ptr) + (when signal (futex-wake signal wakeup)) + t))))) + + +(defun unlock-rwlock (lock) + (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock)) + +;;; There are all kinds of ways to lose here. +;;; The caller must have read access to the lock exactly once, +;;; or have write access. +;;; there's currently no way to detect whether the caller has +;;; read access at all. +;;; If we have to block and get interrupted, cleanup code may +;;; try to unlock a lock that we don't hold. (It might be possible +;;; to circumvent that if we use the same notifcation object here +;;; that controls that cleanup process.) + +(defun %promote-rwlock (lock &optional flag) + (let* ((ptr (read-write-lock-ptr lock))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (without-interrupts + #+futex + (%lock-futex ptr level lock nil) + #-futex + (%get-spin-lock ptr) + (let* ((state (%get-signed-natural ptr target::rwlock.state))) + (declare (fixnum state)) + (cond ((> state 0) + (unless (eql (%get-object ptr target::rwlock.writer) tcr) + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (error :not-lock-owner :lock lock))) + ((= state 0) + #+futex (%unlock-futex ptr) + #-futex (setf (%get-natural ptr target::rwlock.spin) 0) + (error :not-locked :lock lock)) + (t + (if (= state -1) + (progn + (setf (%get-signed-natural ptr target::rwlock.state) 1) + (%set-object ptr target::rwlock.writer tcr) + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (progn + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (%unlock-rwlock-ptr ptr lock) + (let* ((*interrupt-level* level)) + (%write-lock-rwlock-ptr ptr lock flag))))))))))) + + + +(defun safe-get-ptr (p &optional dest) + (if (null dest) + (setq dest (%null-ptr)) + (unless (typep dest 'macptr) + (check-type dest macptr))) + (without-interrupts ;reentrancy + (%safe-get-ptr p dest))) + + +;;; Useless for anything but using RLET in early level-1 code without +;;; having to bootstrap canonical type ordinals. +(%fhave 'parse-foreign-type (lambda (spec) (declare (ignore spec)))) +(%fhave 'foreign-type-ordinal (lambda (thing) (declare (ignore thing)) 0)) +(%fhave '%foreign-type-or-record (lambda (x) (declare (ignore x)))) Index: /branches/qres/ccl/level-0/l0-numbers.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-numbers.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-numbers.lisp (revision 13564) @@ -0,0 +1,2009 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; +;;; level-0;l0-numbers.lisp + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "ARCH") + (require "LISPEQU") + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") + + + + (defvar *dfloat-dops* '((* . %double-float*-2!)(/ . %double-float/-2!) + (+ . %double-float+-2!)(- . %double-float--2!))) + + (defvar *sfloat-dops* '((* . %short-float*-2!)(/ . %short-float/-2!) + (+ . %short-float+-2!)(- . %short-float--2!))) + + (defmacro dfloat-rat (op x y &optional (destructive-op (cdr (assq op *dfloat-dops*)))) + (if destructive-op + (let ((f2 (gensym))) + `(let ((,f2 (%double-float ,y (%make-dfloat)))) + (,destructive-op ,x ,f2 ,f2))) + `(,op (the double-float ,x) (the double-float (%double-float ,y))))) + + (defmacro rat-dfloat (op x y &optional (destructive-op (cdr (assq op *dfloat-dops*)))) + (if destructive-op + (let ((f1 (gensym))) + `(let ((,f1 (%double-float ,x (%make-dfloat)))) + (,destructive-op ,f1 ,y ,f1))) + `(,op (the double-float (%double-float ,x)) (the double-float ,y)))) + + (defmacro sfloat-rat (op x y &optional (destructive-op (cdr (assq op *sfloat-dops*)))) + (let* ((use-destructive-op + (target-word-size-case + (32 destructive-op) + (64 nil)))) + (if use-destructive-op + (let ((f2 (gensym))) + `(let ((,f2 (%short-float ,y (%make-sfloat)))) + (,destructive-op ,x ,f2 ,f2))) + `(,op (the short-float ,x) (the short-float (%short-float ,y)))))) + + (defmacro rat-sfloat (op x y &optional (destructive-op (cdr (assq op *sfloat-dops*)))) + (let* ((use-destructive-op + (target-word-size-case + (32 destructive-op) + (64 nil)))) + (if use-destructive-op + (let ((f1 (gensym))) + `(let ((,f1 (%short-float ,x (%make-sfloat)))) + (,destructive-op ,f1 ,y ,f1))) + `(,op (the short-float (%short-float ,x)) (the short-float ,y))))) + + + + + + (declaim (inline %make-complex %make-ratio)) + (declaim (inline canonical-complex)) + (declaim (inline build-ratio)) + (declaim (inline maybe-truncate))) + + + +(defun %make-complex (realpart imagpart) + (gvector :complex realpart imagpart)) + +(defun %make-ratio (numerator denominator) + (gvector :ratio numerator denominator)) + + + +; this is no longer used +(defun %integer-signum (num) + (if (fixnump num) + (%fixnum-signum num) + ; there is no such thing as bignum zero we hope + (if (bignum-minusp num) -1 1))) + + +; Destructive primitives. +(macrolet ((defdestructive-df-op (non-destructive-name destructive-name op) + `(progn + (defun ,non-destructive-name (x y) + (,destructive-name x y (%make-dfloat))) + (defun ,destructive-name (x y result) + (declare (double-float x y result)) + (%setf-double-float result (the double-float (,op x y))))))) + (defdestructive-df-op %double-float+-2 %double-float+-2! +) + (defdestructive-df-op %double-float--2 %double-float--2! -) + (defdestructive-df-op %double-float*-2 %double-float*-2! *) + (defdestructive-df-op %double-float/-2 %double-float/-2! /)) + +#-64-bit-target +(macrolet ((defdestructive-sf-op (non-destructive-name destructive-name op) + `(progn + (defun ,non-destructive-name (x y) + (,destructive-name x y (%make-sfloat))) + (defun ,destructive-name (x y result) + (declare (short-float x y result)) + (%setf-short-float result (the short-float (,op x y))))))) + (defdestructive-sf-op %short-float+-2 %short-float+-2! +) + (defdestructive-sf-op %short-float--2 %short-float--2! -) + (defdestructive-sf-op %short-float*-2 %short-float*-2! *) + (defdestructive-sf-op %short-float/-2 %short-float/-2! /)) + + +(defun %negate (x) + (number-case x + (fixnum (- (the fixnum x))) + (double-float (%double-float-negate! x (%make-dfloat))) + (short-float + #+32-bit-target (%short-float-negate! x (%make-sfloat)) + #+64-bit-target (%short-float-negate x)) + (bignum (negate-bignum x)) + (ratio (%make-ratio (%negate (%numerator x)) (%denominator x))) + (complex (%make-complex (%negate (%realpart X))(%negate (%imagpart X))) ))) + +(defun %double-float-zerop (n) + (zerop (the double-float n))) + +(defun %short-float-zerop (n) + (zerop (the single-float n))) + +(defun zerop (number) + "Is this number zero?" + (number-case number + (integer (eq number 0)) + (short-float (%short-float-zerop number)) + (double-float (%double-float-zerop number)) + (ratio nil) + (complex + (number-case (%realpart number) + (short-float (and (%short-float-zerop (%realpart number)) + (%short-float-zerop (%imagpart number)))) + (double-float (and (%double-float-zerop (%realpart number)) + (%double-float-zerop (%imagpart number)))) + (t (and (eql 0 (%realpart number))(eql 0 (%imagpart number)))))))) + +(defun %short-float-plusp (x) + (> (the single-float x) 0.0f0)) + +(defun %double-float-plusp (x) + (> (the double-float x) 0.0d0)) + +(defun plusp (number) + "Is this real number strictly positive?" + (number-case number + (fixnum (%i> number 0)) + (bignum (bignum-plusp number)) + (short-float (%short-float-plusp number)) + (double-float (%double-float-plusp number)) + (ratio (plusp (%numerator number))))) + + +(defun minusp (number) + "Is this real number strictly negative?" + (number-case number + (fixnum (%i< number 0)) + (bignum (bignum-minusp number)) + (short-float (%short-float-minusp number)) + (double-float (%double-float-minusp number)) + (ratio (minusp (%numerator number))))) + + +(defun oddp (n) + "Is this integer odd?" + (case (typecode n) + (#.target::tag-fixnum (logbitp 0 (the fixnum n))) + (#.target::subtag-bignum (%bignum-oddp n)) + (t (report-bad-arg n 'integer)))) + +(defun evenp (n) + "Is this integer even?" + (case (typecode n) + (#.target::tag-fixnum (not (logbitp 0 (the fixnum n)))) + (#.target::subtag-bignum (not (%bignum-oddp n))) + (t (report-bad-arg n 'integer)))) + +;; expansion slightly changed +(defun =-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (eq x y)) + (double-float (eq 0 (fixnum-dfloat-compare x y))) + (short-float (eq 0 (fixnum-sfloat-compare x y))) + ((bignum ratio) nil) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (double-float (number-case y ; x + (double-float (= (the double-float x)(the double-float y))) ;x + (short-float (with-stack-double-floats ((dy y)) + (= (the double-float x) (the double-float dy)))) + (fixnum (eq 0 (fixnum-dfloat-compare y x))) + (bignum (eq 0 (bignum-dfloat-compare y x))) + (ratio (= (rational x) y)) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (short-float (number-case y + (short-float (= (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (= (the double-float dx) (the double-float y)))) + (fixnum (eq 0 (fixnum-sfloat-compare y x))) + (bignum (eq 0 (bignum-sfloat-compare y x))) + (ratio (= (rational x) y)) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (bignum (number-case y + (bignum (eq 0 (bignum-compare x y))) + ((fixnum ratio) nil) + (double-float (eq 0 (bignum-dfloat-compare x y))) + (short-float (eq 0 (bignum-sfloat-compare x y))) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (ratio (number-case y + (integer nil) + (ratio + (and (eql (%numerator x) (%numerator y)) + (eql (%denominator x) (%denominator y)))) + (float (= x (rational y))) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (complex (number-case y + (complex (and (= (%realpart x) (%realpart y)) + (= (%imagpart x) (%imagpart y)))) + ((float rational) + (and (zerop (%imagpart x)) (= (%realpart x) y))))))) + +(defun /=-2 (x y) + (declare (notinline =-2)) + (not (= x y))) + + +; true iff (< x y) is false. +(defun >=-2 (x y) + (declare (notinline <-2)) + (not (< x y))) + + + +(defun <=-2 (x y) + (declare (notinline >-2)) + (not (> x y))) + +(defun <-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (< (the fixnum x) (the fixnum y))) + (double-float (eq -1 (fixnum-dfloat-compare x y))) + (short-float (eq -1 (fixnum-sfloat-compare x y))) + (bignum (bignum-plusp y)) + (ratio (< x (ceiling (%numerator y)(%denominator y)))))) + (double-float (number-case y ; x + (double-float (< (the double-float x)(the double-float y))) ;x + (short-float (with-stack-double-floats ((dy y)) + (< (the double-float x) (the double-float dy)))) + (fixnum (eq 1 (fixnum-dfloat-compare y x))) + (bignum (eq 1 (bignum-dfloat-compare y x))) + (ratio (< (rational x) y)))) + (short-float (number-case y + (short-float (< (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (< (the double-float dx) (the double-float y)))) + (fixnum (eq 1 (fixnum-sfloat-compare y x))) + (bignum (eq 1 (bignum-sfloat-compare y x))) + (ratio (< (rational x) y)))) + (bignum (number-case y + (bignum (EQ -1 (bignum-compare x y))) + (fixnum (not (bignum-plusp x))) + (ratio (< x (ceiling (%numerator y)(%denominator y)))) + (double-float (eq -1 (bignum-dfloat-compare x y))) + (short-float (eq -1 (bignum-sfloat-compare x y))))) + (ratio (number-case y + (integer (< (floor (%numerator x)(%denominator x)) y)) + (ratio + (< (* (%numerator (the ratio x)) + (%denominator (the ratio y))) + (* (%numerator (the ratio y)) + (%denominator (the ratio x))))) + (float (< x (rational y))))))) + + + +(defun >-2 (x y) + ;(declare (optimize (speed 3)(safety 0))) + (number-case x + (fixnum (number-case y + (fixnum (> (the fixnum x) (the fixnum y))) + (bignum (not (bignum-plusp y))) + (double-float (eq 1 (fixnum-dfloat-compare x y))) + (short-float (eq 1 (fixnum-sfloat-compare x y))) + ;; or (> (* x denom) num) ? + (ratio (> x (floor (%numerator y) (%denominator y)))))) + (double-float (number-case y + (double-float (> (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (> (the double-float x) (the double-float dy)))) + (fixnum (eq -1 (fixnum-dfloat-compare y x))) + (bignum (eq -1 (bignum-dfloat-compare y x))) + (ratio (> (rational x) y)))) + (short-float (number-case y + (short-float (> (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (> (the double-float dx) (the double-float y)))) + (fixnum (eq -1 (fixnum-sfloat-compare y x))) + (bignum (eq -1 (bignum-sfloat-compare y x))) + (ratio (> (rational x) y)))) + (bignum (number-case y + (fixnum (bignum-plusp x)) + (bignum (eq 1 (bignum-compare x y))) + ;; or (> (* x demon) num) + (ratio (> x (floor (%numerator y) (%denominator y)))) + (double-float (eq 1 (bignum-dfloat-compare x y))) + (short-float (eq 1 (bignum-sfloat-compare x y))))) + (ratio (number-case y + ;; or (> num (* y denom)) + (integer (> (ceiling (%numerator x) (%denominator x)) y)) + (ratio + (> (* (%numerator (the ratio x)) + (%denominator (the ratio y))) + (* (%numerator (the ratio y)) + (%denominator (the ratio x))))) + (float (> x (rational y))))))) + + +; t if any bits set after exp (unbiased) +(defun hi-lo-fraction-p (hi lo exp) + (declare (fixnum hi lo exp)) + (if (> exp 24) + (not (eql 0 (%ilogand lo (%ilsr (- exp 25) #xfffffff)))) + (or (not (zerop lo))(not (eql 0 (%ilogand hi (%ilsr exp #x1ffffff))))))) + + + +(defun negate-hi-lo (hi lo) + (setq hi (%ilogxor hi #x3ffffff)) + (if (eq 0 lo) + (setq hi (+ hi 1)) + (setq lo (+ (%ilogxor lo #xfffffff) 1))) + (values hi lo)) + + + +(defun fixnum-dfloat-compare (int dfloat) + (declare (double-float dfloat) (fixnum int)) + (if (and (eq int 0)(= dfloat 0.0d0)) + 0 + (with-stack-double-floats ((d1 int)) + (locally (declare (double-float d1)) + (if (eq int (%truncate-double-float->fixnum d1)) + (cond ((< d1 dfloat) -1) + ((= d1 dfloat) 0) + (t 1)) + ;; Whatever we do here should have the effect + ;; of comparing the integer to the result of calling + ;; RATIONAL on the float. We could probably + ;; skip the call to RATIONAL in more cases, + ;; but at least check the obvious ones here + ;; (e.g. different signs) + (multiple-value-bind (mantissa exponent sign) + (integer-decode-double-float dfloat) + (declare (type (integer -1 1) sign) + (fixnum exponent)) + (cond ((zerop int) + (- sign)) + ((and (< int 0) (eql sign 1)) -1) + ((and (> int 0) (eql sign -1)) 1) + (t + ;; See RATIONAL. Can probably avoid this if + ;; magnitudes are clearly dissimilar. + (if (= sign -1) (setq mantissa (- mantissa))) + (let* ((rat (if (< exponent 0) + (/ mantissa (ash 1 (the fixnum (- exponent)))) + (ash mantissa exponent)))) + (if (< int rat) + -1 + (if (eq int rat) + 0 + 1))))))))))) + + + +(defun fixnum-sfloat-compare (int sfloat) + (declare (short-float sfloat) (fixnum int)) + (if (and (eq int 0)(= sfloat 0.0s0)) + 0 + (#+32-bit-target target::with-stack-short-floats #+32-bit-target ((s1 int)) + #-32-bit-target let* #-32-bit-target ((s1 (%int-to-sfloat int))) + (locally + (declare (short-float s1)) + (if (eq (%truncate-short-float->fixnum s1) int) + (cond ((< s1 sfloat) -1) + ((= s1 sfloat) 0) + (t 1)) + ;; Whatever we do here should have the effect + ;; of comparing the integer to the result of calling + ;; RATIONAL on the float. We could probably + ;; skip the call to RATIONAL in more cases, + ;; but at least check the obvious ones here + ;; (e.g. different signs) + (multiple-value-bind (mantissa exponent sign) + (integer-decode-short-float sfloat) + (declare (type (integer -1 1) sign) + (fixnum exponent)) + (cond ((zerop int) + (- sign)) + ((and (< int 0) (eql sign 1)) -1) + ((and (> int 0) (eql sign -1)) 1) + (t + ;; See RATIONAL. Can probably avoid this if + ;; magnitudes are clearly dissimilar. + (if (= sign -1) (setq mantissa (- mantissa))) + (let* ((rat (if (< exponent 0) + (/ mantissa (ash 1 (the fixnum (- exponent)))) + (ash mantissa exponent)))) + (if (< int rat) + -1 + (if (eq int rat) + 0 + 1))))))))))) + + + +;;; lotta stuff to avoid making a rational from a float +;;; returns -1 less, 0 equal, 1 greater +(defun bignum-dfloat-compare (int float) + (cond + ((and (eq int 0)(= float 0.0d0)) 0) + (t + (let* ((fminus (%double-float-minusp float)) + (iminus (minusp int)) + (gt (if iminus -1 1))) + (declare (fixnum gt)) + (if (neq fminus iminus) + gt ; if different signs, done + (let ((intlen (integer-length int)) + (exp (- (the fixnum (%double-float-exp float)) 1022))) + (declare (fixnum intlen exp)) + (cond + ((and (not fminus) (< intlen exp)) -1) + ((> intlen exp) gt) ; if different exp, done + ((and fminus (or (< (1+ intlen) exp) + (and (= (1+ intlen) exp) + (neq (one-bignum-factor-of-two int) intlen)))) + ;(print 'zow) + (the fixnum (- gt))) ; ; integer-length is strange for neg powers of 2 + (t (multiple-value-bind (hi lo)(fixnum-decode-float float) + (declare (fixnum hi lo)) + (when fminus (multiple-value-setq (hi lo)(negate-hi-lo hi lo))) + (let* ((sz 26) ; exp > 28 always + (pos (- exp 25)) + (big-bits (%ldb-fixnum-from-bignum int sz pos))) + (declare (fixnum pos big-bits sz)) + ;(print (list big-bits hi sz pos)) + (cond + ((< big-bits hi) -1) + ((> big-bits hi) 1) + (t (let* ((sz (min (- exp 25) 28)) + (pos (- exp 25 sz)) ; ? + (ilo (if (< exp 53) (ash lo (- exp 53)) lo)) + (big-bits (%ldb-fixnum-from-bignum int sz pos))) + (declare (fixnum pos sz ilo big-bits)) + ;(PRINT (list big-bits ilo)) + (cond + ((< big-bits ilo) -1) + ((> big-bits ilo) 1) + ((eq exp 53) 0) + ((< exp 53) + (if (not (hi-lo-fraction-p hi lo exp)) 0 -1)) ; -1 if pos + (t (if (%i< (one-bignum-factor-of-two int) (- exp 53)) 1 0))))))) + ))))))))) + + + +;;; I don't know if it's worth doing a more "real" version of this. +(defun bignum-sfloat-compare (int float) + (with-stack-double-floats ((df float)) + (bignum-dfloat-compare int df))) + +;;;; Canonicalization utilities: + +;;; CANONICAL-COMPLEX -- Internal +;;; +;;; If imagpart is 0, return realpart, otherwise make a complex. This is +;;; used when we know that realpart and imagpart are the same type, but +;;; rational canonicalization might still need to be done. +;;; + +(defun canonical-complex (realpart imagpart) + (if (eql imagpart 0) + realpart + (%make-complex realpart imagpart))) + + + + +(defun +-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (+ (the fixnum x) (the fixnum y))) + (double-float (rat-dfloat + x y)) + (short-float (rat-sfloat + x y)) + (bignum (add-bignum-and-fixnum y x)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))) + (ratio (let* ((dy (%denominator y)) + (n (+ (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (double-float (number-case y + (double-float (+ (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (+ (the double-float x) (the double-float dy)))) + (rational (dfloat-rat + x y)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))))) + (short-float (number-case y + (short-float (+ (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (+ (the double-float dx) (the double-float y)))) + (rational (sfloat-rat + x y)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))))) + (bignum (number-case y + (bignum (add-bignums x y)) + (fixnum (add-bignum-and-fixnum x y)) + (double-float (rat-dfloat + x y)) + (short-float (rat-sfloat + x y)) + (complex (complex (+ x (realpart y)) + (%imagpart y))) + (ratio + (let* ((dy (%denominator y)) + (n (+ (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (complex (number-case y + (complex (canonical-complex (+ (%realpart x) (%realpart y)) + (+ (%imagpart x) (%imagpart y)))) + ((rational float) (complex (+ (%realpart x) y) (%imagpart x))))) + (ratio (number-case y + (ratio + (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd dx dy))) + (if (eql g1 1) + (%make-ratio (+ (* nx dy) (* dx ny)) (* dx dy)) + (let* ((t1 (+ (* nx (truncate dy g1)) (* (truncate dx g1) ny))) + (g2 (gcd t1 g1)) + (t2 (truncate dx g1))) + (cond ((eql t1 0) 0) + ((eql g2 1) (%make-ratio t1 (* t2 dy))) + (t + (let* ((nn (truncate t1 g2)) + (t3 (truncate dy g2)) + (nd (if (eql t2 1) t3 (* t2 t3)))) + (if (eql nd 1) nn (%make-ratio nn nd))))))))) + (integer + (let* ((dx (%denominator x)) (n (+ (%numerator x) (* y dx)))) + (%make-ratio n dx))) + (double-float (rat-dfloat + x y)) + (short-float (rat-sfloat + x y)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))))))) + +(defun --2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (- (the fixnum x) (the fixnum y))) + (double-float (rat-dfloat - x y)) + (short-float (rat-sfloat - x y)) + (bignum + (with-small-bignum-buffers ((bx x)) + (subtract-bignum bx y))) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))) + (ratio (let* ((dy (%denominator y)) + (n (- (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (double-float (number-case y + (double-float (- (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (- (the double-float x) (the double-float dy)))) + (rational (dfloat-rat - x y)) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))))) + (short-float (number-case y + (short-float (- (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (- (the double-float dx) (the double-float y)))) + (rational (sfloat-rat - x y)) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))))) + (bignum (number-case y + (bignum (subtract-bignum x y)) + (fixnum (if (eql y target::target-most-negative-fixnum) + (with-small-bignum-buffers ((by y)) + (subtract-bignum x by)) + (add-bignum-and-fixnum x (- y)))) + (double-float (rat-dfloat - x y)) + (short-float (rat-sfloat - x y)) + (complex (complex (- x (realpart y)) + (- (%imagpart y)))) + (ratio + (let* ((dy (%denominator y)) + (n (- (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (complex (number-case y + (complex (canonical-complex (- (%realpart x) (%realpart y)) + (- (%imagpart x) (%imagpart y)))) + ((rational float) (complex (- (%realpart x) y) (%imagpart x))))) + (ratio (number-case y + (ratio + (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd dx dy))) + (if (eql g1 1) + (%make-ratio (- (* nx dy) (* dx ny)) (* dx dy)) + (let* ((t1 (- (* nx (truncate dy g1)) (* (truncate dx g1) ny))) + (g2 (gcd t1 g1)) + (t2 (truncate dx g1))) + (cond ((eql t1 0) 0) + ((eql g2 1) (%make-ratio t1 (* t2 dy))) + (t + (let* ((nn (truncate t1 g2)) + (t3 (truncate dy g2)) + (nd (if (eql t2 1) t3 (* t2 t3)))) + (if (eql nd 1) nn (%make-ratio nn nd))))))))) + (integer + (let* ((dx (%denominator x)) (n (- (%numerator x) (* y dx)))) + (%make-ratio n dx))) + (double-float (rat-dfloat - x y)) + (short-float (rat-sfloat - x y)) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))))))) + + +;;; BUILD-RATIO -- Internal +;;; +;;; Given a numerator and denominator with the GCD already divided out, make +;;; a canonical rational. We make the denominator positive, and check whether +;;; it is 1. +;;; + +(defun build-ratio (num den) + (if (minusp den) (setq num (- num) den (- den))) + (case den + (0 (divide-by-zero-error 'build-ratio num den)) + (1 num) + (t (%make-ratio num den)))) + + + + +;;; MAYBE-TRUNCATE -- Internal +;;; +;;; Truncate X and Y, but bum the case where Y is 1. +;;; + + +(defun maybe-truncate (x y) + (if (eql y 1) + x + (truncate x y))) + +(defun *-2 (x y) + ;(declare (optimize (speed 3)(safety 0))) + (flet ((integer*ratio (x y) + (if (eql x 0) 0 + (let* ((ny (%numerator y)) + (dy (%denominator y)) + (gcd (gcd x dy))) + (if (eql gcd 1) + (%make-ratio (* x ny) dy) + (let ((nn (* (truncate x gcd) ny)) + (nd (truncate dy gcd))) + (if (eql nd 1) + nn + (%make-ratio nn nd))))))) + (complex*real (x y) + (canonical-complex (* (%realpart x) y) (* (%imagpart x) y)))) + (number-case x + (double-float (number-case y + (double-float (* (the double-float x)(the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (* (the double-float x) (the double-float dy)))) + (rational (dfloat-rat * x y)) + (complex (complex*real y x)))) + (short-float (number-case y + (double-float (with-stack-double-floats ((dx x)) + (* (the double-float dx) (the double-float y)))) + (short-float (* (the short-float x) (the short-float y))) + (rational (sfloat-rat * x y)) + (complex (complex*real y x)))) + (bignum (number-case y + (fixnum (multiply-bignum-and-fixnum x y)) + (bignum (multiply-bignums x y)) + (double-float (dfloat-rat * y x)) + (short-float (sfloat-rat * y x)) + (ratio (integer*ratio x y)) + (complex (complex*real y x)))) + (fixnum (number-case y + (bignum (multiply-bignum-and-fixnum y x)) + (fixnum (multiply-fixnums (the fixnum x) (the fixnum y))) + (short-float (sfloat-rat * y x)) + (double-float (dfloat-rat * y x)) + (ratio (integer*ratio x y)) + (complex (complex*real y x)))) + (complex (number-case y + (complex (let* ((rx (%realpart x)) + (ix (%imagpart x)) + (ry (%realpart y)) + (iy (%imagpart y))) + (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry))))) + (real (complex*real x y)))) + (ratio (number-case y + (ratio (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd nx dy)) + (g2 (gcd dx ny))) + (build-ratio (* (maybe-truncate nx g1) + (maybe-truncate ny g2)) + (* (maybe-truncate dx g2) + (maybe-truncate dy g1))))) + (integer (integer*ratio y x)) + (double-float (rat-dfloat * x y)) + (short-float (rat-sfloat * x y)) + (complex (complex*real y x))))))) + + + +(defun integer*integer (x y &optional res) + (declare (ignore res)) + (number-case x + (fixnum (number-case y + (fixnum (* (the fixnum x) (the fixnum y))) + (t (multiply-bignum-and-fixnum y x)))) + (bignum (number-case y + (fixnum (multiply-bignum-and-fixnum x y)) + (t (multiply-bignums x y)))))) + + + + + +;;; INTEGER-/-INTEGER -- Internal +;;; +;;; Divide two integers, producing a canonical rational. If a fixnum, we +;;; see if they divide evenly before trying the GCD. In the bignum case, we +;;; don't bother, since bignum division is expensive, and the test is not very +;;; likely to suceed. +;;; +(defun integer-/-integer (x y) + (if (and (typep x 'fixnum) (typep y 'fixnum)) + (multiple-value-bind (quo rem) (%fixnum-truncate x y) + (if (eql 0 rem) + quo + (let ((gcd (gcd x y))) + (declare (fixnum gcd)) + (if (eql gcd 1) + (build-ratio x y) + (build-ratio (%fixnum-truncate x gcd) (%fixnum-truncate y gcd)))))) + (let ((gcd (gcd x y))) + (if (eql gcd 1) + (build-ratio x y) + (build-ratio (truncate x gcd) (truncate y gcd)))))) + + + +(defun /-2 (x y) + (number-case x + (double-float (number-case y + (double-float (/ (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (/ (the double-float x) (the double-float dy)))) + (rational (dfloat-rat / x y)) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))))) + (short-float (number-case y + (short-float (/ (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (/ (the double-float dx) (the double-float y)))) + (rational (sfloat-rat / x y)) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))))) + (integer (number-case y + (double-float (rat-dfloat / x y)) + (short-float (rat-sfloat / x y)) + (integer (integer-/-integer x y)) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))) + (ratio + (if (eql 0 x) + 0 + (let* ((ny (%numerator y)) + (dy (%denominator y)) + (gcd (gcd x ny))) + (build-ratio (* (maybe-truncate x gcd) dy) + (maybe-truncate ny gcd))))))) + (complex (number-case y + (complex (let* ((rx (%realpart x)) + (ix (%imagpart x)) + (ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (+ (* rx ry) (* ix iy)) dn) + (/ (- (* ix ry) (* rx iy)) dn)))) + ((rational float) + (canonical-complex (/ (%realpart x) y) (/ (%imagpart x) y))))) + (ratio (number-case y + (double-float (rat-dfloat / x y)) + (short-float (rat-sfloat / x y)) + (integer + (when (eql y 0) + (divide-by-zero-error '/ x y)) + (let* ((nx (%numerator x)) (gcd (gcd nx y))) + (build-ratio (maybe-truncate nx gcd) + (* (maybe-truncate y gcd) (%denominator x))))) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))) + (ratio + (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd nx ny)) + (g2 (gcd dx dy))) + (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2)) + (* (maybe-truncate dx g2) (maybe-truncate ny g1))))))))) + + + +(defun divide-by-zero-error (operation &rest operands) + (error (make-condition 'division-by-zero + :operation operation + :operands operands))) + + +(defun 1+ (number) + "Returns NUMBER + 1." + (+-2 number 1)) + +(defun 1- (number) + "Returns NUMBER - 1." + (--2 number 1)) + + + + +(defun conjugate (number) + "Return the complex conjugate of NUMBER. For non-complex numbers, this is + an identity." + (number-case number + (complex (complex (%realpart number) (- (%imagpart number)))) + (number number))) + +(defun numerator (rational) + "Return the numerator of NUMBER, which must be rational." + (number-case rational + (ratio (%numerator rational)) + (integer rational))) + +(defun denominator (rational) + "Return the denominator of NUMBER, which must be rational." + (number-case rational + (ratio (%denominator rational)) + (integer 1))) + + + +(defun abs (number) + "Return the absolute value of the number." + (number-case number + (fixnum + (locally (declare (fixnum number)) + (if (minusp number) (- number) number))) + (double-float + (%double-float-abs number)) + (short-float + (%short-float-abs number)) + (bignum + (if (bignum-minusp number)(negate-bignum number) number)) + (ratio + (if (minusp number) (- number) number)) + (complex + (let ((rx (%realpart number)) + (ix (%imagpart number))) + (number-case rx + (rational + (sqrt (+ (* rx rx) (* ix ix)))) + (short-float + (%short-float (%hypot (%double-float rx) + (%double-float ix)))) + (double-float + (%hypot rx ix))))))) + + + +(defun phase (number) + "Return the angle part of the polar representation of a complex number. + For complex numbers, this is (atan (imagpart number) (realpart number)). + For non-complex positive numbers, this is 0. For non-complex negative + numbers this is PI." + (number-case number + (rational + (if (minusp number) + (%short-float pi) + 0.0f0)) + (double-float + (if (minusp number) + (%double-float pi) + 0.0d0)) + (complex + (atan (%imagpart number) (%realpart number))) + (short-float + (if (minusp number) + (%short-float pi) + 0.0s0)))) + + + +; from Lib;numbers.lisp, sort of +(defun float (number &optional other) + "Converts any REAL to a float. If OTHER is not provided, it returns a + SINGLE-FLOAT if NUMBER is not already a FLOAT. If OTHER is provided, the + result is the same float format as OTHER." + (if (null other) + (if (typep number 'float) + number + (%short-float number)) + (if (typep other 'double-float) + (%double-float number) + (if (typep other 'short-float) + (%short-float number) + (float number (require-type other 'float)))))) + + + + + +;;; If the numbers do not divide exactly and the result of (/ number divisor) +;;; would be negative then decrement the quotient and augment the remainder by +;;; the divisor. +;;; +(defun floor (number &optional divisor) + "Return the greatest integer not greater than number, or number/divisor. + The second returned value is (mod number divisor)." + (if (null divisor)(setq divisor 1)) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (if (called-for-mv-p) + (values (1- tru) (+ rem divisor)) + (1- tru)) + (values tru rem)))) + + + +(defun %fixnum-floor (number divisor) + (declare (fixnum number divisor)) + (if (eq divisor 1) + (values number 0) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (eq rem 0) + (values tru 0) + (locally (declare (fixnum tru rem)) + (if (and ;(not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (values (the fixnum (1- tru)) (the fixnum (+ rem divisor))) + (values tru rem))))))) + + + +;;; If the numbers do not divide exactly and the result of (/ number divisor) +;;; would be positive then increment the quotient and decrement the remainder by +;;; the divisor. +;;; +(defun ceiling (number &optional divisor) + "Return the smallest integer not less than number, or number/divisor. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (if (called-for-mv-p) + (values (+ tru 1) (- rem divisor)) + (+ tru 1)) + (values tru rem)))) + + + +(defun %fixnum-ceiling (number divisor) + "Returns the smallest integer not less than number, or number/divisor. + The second returned value is the remainder." + (declare (fixnum number divisor)) + (multiple-value-bind (tru rem) (%fixnum-truncate number divisor) + (if (eq 0 rem) + (values tru 0) + (locally (declare (fixnum tru rem)) + (if (and ;(not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (values (the fixnum (+ tru 1))(the fixnum (- rem divisor))) + (values tru rem)))))) + + + +(defun integer-decode-denorm-short-float (mantissa sign) + (declare (fixnum mantissa sign)) + (do* ((bias 0 (1+ bias)) + (sig mantissa (ash sig 1))) + ((logbitp 23 sig) + (values sig + (- (- IEEE-single-float-bias) + IEEE-single-float-digits + bias) + sign)))) + + +(defun integer-decode-short-float (sfloat) + (multiple-value-bind (mantissa exp sign)(fixnum-decode-short-float sfloat) + (let* ((biased (- exp IEEE-single-float-bias IEEE-single-float-digits))) + (setq sign (if (eql 0 sign) 1 -1)) + (if (eq exp 255) + (error "Can't decode NAN/Inf: ~s" sfloat)) + (if (eql 0 exp) + (if (eql 0 mantissa) + (values 0 biased sign) + (integer-decode-denorm-short-float (ash mantissa 1) sign)) + (values (logior #x800000 mantissa) biased sign))))) + + + + +;;; INTEGER-DECODE-FLOAT -- Public +;;; +;;; Dispatch to the correct type-specific i-d-f function. +;;; +(defun integer-decode-float (x) + "Returns three values: + 1) an integer representation of the significand. + 2) the exponent for the power of 2 that the significand must be multiplied + by to get the actual value. This differs from the DECODE-FLOAT exponent + by FLOAT-DIGITS, since the significand has been scaled to have all its + digits before the radix point. + 3) -1 or 1 (i.e. the sign of the argument.)" + (number-case x + (short-float + (integer-decode-short-float x)) + (double-float + (integer-decode-double-float x)))) + + +;;; %UNARY-TRUNCATE -- Interface +;;; +;;; This function is called when we are doing a truncate without any funky +;;; divisor, i.e. converting a float or ratio to an integer. Note that we do +;;; *not* return the second value of truncate, so it must be computed by the +;;; caller if needed. +;;; +;;; In the float case, we pick off small arguments so that compiler can use +;;; special-case operations. We use an exclusive test, since (due to round-off +;;; error), (float most-positive-fixnum) may be greater than +;;; most-positive-fixnum. +;;; +(defun %unary-truncate (number) + (number-case number + (integer number) + (ratio (truncate-no-rem (%numerator number) (%denominator number))) + (double-float + (if (and (< (the double-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 0.0d0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 0.0d0) + (the double-float number))) + (%truncate-double-float->fixnum number) + (%truncate-double-float number))) + (short-float + (if (and (< (the short-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 0.0s0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 0.0s0) + (the short-float number))) + (%truncate-short-float->fixnum number) + (%truncate-short-float number))))) + + + +; cmucl:compiler:float-tran.lisp +(defun xform-truncate (x) + (let ((res (%unary-truncate x))) + (values res (- x res)))) + + + +(defun truncate (number &optional divisor) + "Returns number (or number/divisor) as an integer, rounded toward 0. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (when (not (called-for-mv-p)) + (return-from truncate (truncate-no-rem number divisor))) + (macrolet + ((truncate-rat-dfloat (number divisor) + `(with-stack-double-floats ((fnum ,number) + (f2)) + (let ((res (%unary-truncate (%double-float/-2! fnum ,divisor f2)))) + (values res + (%double-float--2 fnum (%double-float*-2! (%double-float res f2) ,divisor f2)))))) + (truncate-rat-sfloat (number divisor) + #+32-bit-target + `(target::with-stack-short-floats ((fnum ,number) + (f2)) + (let ((res (%unary-truncate (%short-float/-2! fnum ,divisor f2)))) + (values res + (%short-float--2 fnum (%short-float*-2! (%short-float res f2) ,divisor f2))))) + #+64-bit-target + `(let* ((temp (%short-float ,number)) + (res (%unary-truncate (/ (the short-float temp) + (the short-float ,divisor))))) + (values res + (- (the short-float temp) + (the short-float (* (the short-float (%short-float res)) + (the short-float ,divisor))))))) + ) + (number-case number + (fixnum + (number-case divisor + (fixnum (if (eq divisor 1) (values number 0) (%fixnum-truncate number divisor))) + (bignum (values 0 number)) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) ; this was wrong + (%numerator divisor)))) + (values q (- number (* q divisor))))))) + (bignum (number-case divisor + (fixnum (if (eq divisor 1) (values number 0) + (if (eq divisor target::target-most-negative-fixnum);; << aargh + (with-small-bignum-buffers ((bd divisor)) + (bignum-truncate number bd)) + (bignum-truncate-by-fixnum number divisor)))) + (bignum (bignum-truncate number divisor)) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) ; so was this + (%numerator divisor)))) + (values q (- number (* q divisor))))))) + (short-float (if (eql divisor 1) + (let* ((res (%unary-truncate number))) + (values res (- number res))) + (number-case divisor + (short-float + #+32-bit-target + (target::with-stack-short-floats ((f2)) + (let ((res (%unary-truncate (%short-float/-2! number divisor f2)))) + (values res + (%short-float--2 + number + (%short-float*-2! (%short-float res f2) divisor f2))))) + #+64-bit-target + (let ((res (%unary-truncate + (/ (the short-float number) + (the short-float divisor))))) + (values res + (- (the short-float number) + (* (the short-float (%short-float res)) + (the short-float divisor)))))) + ((fixnum bignum ratio) + #+32-bit-target + (target::with-stack-short-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%short-float/-2! number fdiv f2)))) + (values res + (%short-float--2 + number + (%short-float*-2! (%short-float res f2) fdiv f2))))) + #+64-bit-target + (let* ((fdiv (%short-float divisor)) + (res (%unary-truncate + (/ (the short-float number) + (the short-float fdiv))))) + (values res (- number (* res fdiv)))) + + ) + (double-float + (with-stack-double-floats ((fnum number) + (f2)) + (let* ((res (%unary-truncate (%double-float/-2! fnum divisor f2)))) + (values res + (%double-float--2 + fnum + (%double-float*-2! (%double-float res f2) divisor f2))))))))) + (double-float (if (eql divisor 1) + (let ((res (%unary-truncate number))) + (values res (- number res))) + (number-case divisor + ((fixnum bignum ratio short-float) + (with-stack-double-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%double-float/-2! number fdiv f2)))) + (values res + (%double-float--2 + number + (%double-float*-2! (%double-float res f2) fdiv f2)))))) + (double-float + (with-stack-double-floats ((f2)) + (let ((res (%unary-truncate (%double-float/-2! number divisor f2)))) + (values res + (%double-float--2 + number + (%double-float*-2! (%double-float res f2) divisor f2))))))))) + (ratio (number-case divisor + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (rational + (let ((q (truncate (%numerator number) + (* (%denominator number) divisor)))) + (values q (- number (* q divisor)))))))))) + +(defun truncate-no-rem (number divisor) + "Returns number (or number/divisor) as an integer, rounded toward 0." + (macrolet + ((truncate-rat-dfloat (number divisor) + `(with-stack-double-floats ((fnum ,number) + (f2)) + (%unary-truncate (%double-float/-2! fnum ,divisor f2)))) + (truncate-rat-sfloat (number divisor) + #+32-bit-target + `(target::with-stack-short-floats ((fnum ,number) + (f2)) + (%unary-truncate (%short-float/-2! fnum ,divisor f2))) + #+64-bit-target + `(let ((fnum (%short-float ,number))) + (%unary-truncate (/ (the short-float fnum) + (the short-float ,divisor)))))) + (number-case number + (fixnum + (if (eql number target::target-most-negative-fixnum) + (if (zerop divisor) + (error 'division-by-zero :operation 'truncate :operands (list number divisor)) + (with-small-bignum-buffers ((bn number)) + (let* ((result (truncate-no-rem bn divisor))) + (if (eq result bn) + number + result)))) + (number-case divisor + (fixnum (if (eq divisor 1) number (values (%fixnum-truncate number divisor)))) + (bignum 0) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) + (%numerator divisor)))) + q))))) + (bignum (number-case divisor + (fixnum (if (eq divisor 1) number + (if (eq divisor target::target-most-negative-fixnum) + (with-small-bignum-buffers ((bd divisor)) + (bignum-truncate number bd :no-rem)) + (bignum-truncate-by-fixnum number divisor)))) + (bignum (bignum-truncate number divisor :no-rem)) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) + (%numerator divisor)))) + Q)))) + (double-float (if (eql divisor 1) + (let ((res (%unary-truncate number))) + RES) + (number-case divisor + ((fixnum bignum ratio) + (with-stack-double-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%double-float/-2! number fdiv f2)))) + RES))) + (short-float + (with-stack-double-floats ((ddiv divisor) + (f2)) + (%unary-truncate (%double-float/-2! number ddiv f2)))) + (double-float + (with-stack-double-floats ((f2)) + (%unary-truncate (%double-float/-2! number divisor f2))))))) + (short-float (if (eql divisor 1) + (let ((res (%unary-truncate number))) + RES) + (number-case divisor + ((fixnum bignum ratio) + #+32-bit-target + (target::with-stack-short-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%short-float/-2! number fdiv f2)))) + RES)) + #+64-bit-target + (%unary-truncate (/ (the short-float number) + (the short-float (%short-float divisor))))) + (short-float + #+32-bit-target + (target::with-stack-short-floats ((ddiv divisor) + (f2)) + (%unary-truncate (%short-float/-2! number ddiv f2))) + #+64-bit-target + (%unary-truncate (/ (the short-float number) + (the short-float (%short-float divisor))))) + (double-float + (with-stack-double-floats ((n2 number) + (f2)) + (%unary-truncate (%double-float/-2! n2 divisor f2))))))) + (ratio (number-case divisor + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (rational + (let ((q (truncate (%numerator number) + (* (%denominator number) divisor)))) + Q))))))) + + +;;; %UNARY-ROUND -- Interface +;;; +;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we +;;; can't use the round primitive, then we do our own round-to-nearest on the +;;; result of i-d-f. [Note that this rounding will really only happen with +;;; double floats, since the whole single-float fraction will fit in a fixnum, +;;; so all single-floats larger than most-positive-fixnum can be precisely +;;; represented by an integer.] +;;; +;;; returns both values today + +(defun %unary-round (number) + (number-case number + (integer (values number 0)) + (ratio (let ((q (round (%numerator number) (%denominator number)))) + (values q (- number q)))) + (double-float + (if (and (< (the double-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 1.0d0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 1.0d0) + (the double-float number))) + (let ((round (%unary-round-to-fixnum number))) + (values round (- number round))) + (multiple-value-bind (trunc rem) (truncate number) + (if (not (%double-float-minusp number)) + (if (or (> rem 0.5d0)(and (= rem 0.5d0) (oddp trunc))) + (values (+ trunc 1) (- rem 1.0d0)) + (values trunc rem)) + (if (or (> rem -0.5d0)(and (evenp trunc)(= rem -0.5d0))) + (values trunc rem) + (values (1- trunc) (+ 1.0d0 rem))))))) + (short-float + (if (and (< (the short-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 1.0s0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 1.0s0) + (the double-float number))) + (let ((round (%unary-round-to-fixnum number))) + (values round (- number round))) + (multiple-value-bind (trunc rem) (truncate number) + (if (not (%short-float-minusp number)) + (if (or (> rem 0.5s0)(and (= rem 0.5s0) (oddp trunc))) + (values (+ trunc 1) (- rem 1.0s0)) + (values trunc rem)) + (if (or (> rem -0.5s0)(and (evenp trunc)(= rem -0.5s0))) + (values trunc rem) + (values (1- trunc) (+ 1.0s0 rem))))))))) + +(defun %unary-round-to-fixnum (number) + (number-case number + (double-float + (%round-nearest-double-float->fixnum number)) + (short-float + (%round-nearest-short-float->fixnum number)))) + + + + +; cmucl:compiler:float-tran.lisp +#| +(defun xform-round (x) + (let ((res (%unary-round x))) + (values res (- x res)))) +|# + +#| +(defun round (number &optional divisor) + "Rounds number (or number/divisor) to nearest integer. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (if (eql divisor 1) + (xform-round number) + (multiple-value-bind (tru rem) (truncate number divisor) + (let ((thresh (if (integerp divisor) (ash (abs divisor) -1)(/ (abs divisor) 2)))) ; does this need to be a ratio? + (cond ((or (> rem thresh) + (and (= rem thresh) (oddp tru))) + (if (minusp divisor) + (values (- tru 1) (+ rem divisor)) + (values (+ tru 1) (- rem divisor)))) + ((let ((-thresh (- thresh))) + (or (< rem -thresh) + (and (= rem -thresh) (oddp tru)))) + (if (minusp divisor) + (values (+ tru 1) (- rem divisor)) + (values (- tru 1) (+ rem divisor)))) + (t (values tru rem))))))) +|# + + +(defun %fixnum-round (number divisor) + (declare (fixnum number divisor)) + (multiple-value-bind (quo rem)(truncate number divisor) ; should => %fixnum-truncate + (if (= 0 rem) + (values quo rem) + (locally (declare (fixnum quo rem)) + (let* ((minusp-num (minusp number)) + (minusp-div (minusp divisor)) + (2rem (* rem (if (neq minusp-num minusp-div) -2 2)))) + ;(declare (fixnum 2rem)) ; no way jose + ;(truncate (1- most-positive-fixnum) most-positive-fixnum) + ; 2rem has same sign as divisor + (cond (minusp-div + (if (or (< 2rem divisor) + (and (= 2rem divisor)(logbitp 0 quo))) + (if minusp-num + (values (the fixnum (+ quo 1))(the fixnum (- rem divisor))) + (values (the fixnum (- quo 1))(the fixnum (+ rem divisor)))) + (values quo rem))) + (t (if (or (> 2rem divisor) + (and (= 2rem divisor)(logbitp 0 quo))) + (if minusp-num + (values (the fixnum (- quo 1))(the fixnum (+ rem divisor))) + (values (the fixnum (+ quo 1))(the fixnum (- rem divisor)))) + (values quo rem))))))))) +#| +; + + => + + +; + - => - + +; - + => - - +; - - => + - +(defun %fixnum-round (number divisor) + (declare (fixnum number divisor)) + "Rounds number (or number/divisor) to nearest integer. + The second returned value is the remainder." + (if (eq divisor 1) + (values number 0) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (= 0 rem) + (values tru rem) + (locally (declare (fixnum tru rem)) + (let* ((minusp-num (minusp number)) + (minusp-div (minusp divisor)) + (half-div (ash (if minusp-div (- divisor) divisor) -1)) + (abs-rem (if minusp-num (- rem) rem))) + (declare (fixnum half-div abs-rem)) ; true of abs-rem? + (if (or (> abs-rem half-div) + (and + (not (logbitp 0 divisor)) + (logbitp 0 tru) ; oddp + (= abs-rem half-div))) + (if (eq minusp-num minusp-div) + (values (the fixnum (+ tru 1))(the fixnum (- rem divisor))) + (values (the fixnum (- tru 1))(the fixnum (+ rem divisor)))) + (values tru rem)))))))) +|# + + + +;; makes 1 piece of garbage instead of average of 2 +(defun round (number &optional divisor) + "Rounds number (or number/divisor) to nearest integer. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (if (eql divisor 1) + (%unary-round number) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (= 0 rem) + (values tru rem) + (let* ((mv-p (called-for-mv-p)) + (minusp-num (minusp number)) + (minusp-div (minusp divisor)) + (2rem (* rem (if (neq minusp-num minusp-div) -2 2)))) + ; 2rem has same sign as divisor + (cond (minusp-div + (if (or (< 2rem divisor) + (and (= 2rem divisor)(oddp tru))) + (if mv-p + (if minusp-num + (values (+ tru 1)(- rem divisor)) + (values (- tru 1)(+ rem divisor))) + (if minusp-num (+ tru 1)(- tru 1))) + (values tru rem))) + (t (if (or (> 2rem divisor) + (and (= 2rem divisor)(oddp tru))) + (if mv-p + (if minusp-num + (values (- tru 1)(+ rem divisor)) + (values (+ tru 1)(- rem divisor))) + (if minusp-num (- tru 1)(+ tru 1))) + (values tru rem))))))))) + + +;; #-PPC IN L1-NUMBERS.LISP (or implement %%numdiv) +;; Anyone caught implementing %%numdiv will be summarily executed. +(defun rem (number divisor) + "Returns second result of TRUNCATE." + (number-case number + (fixnum + (number-case divisor + (fixnum (nth-value 1 (%fixnum-truncate number divisor))) + (bignum number) + (t (nth-value 1 (truncate number divisor))))) + (bignum + (number-case divisor + (fixnum + (if (eq divisor target::target-most-negative-fixnum) + (nth-value 1 (truncate number divisor)) + (bignum-truncate-by-fixnum-no-quo number divisor))) + (bignum + (bignum-rem number divisor)) + (t (nth-value 1 (truncate number divisor))))) + (t (nth-value 1 (truncate number divisor))))) + +;; #-PPC IN L1-NUMBERS.LISP (or implement %%numdiv) +;; See above. +(defun mod (number divisor) + "Returns second result of FLOOR." + (let ((rem (rem number divisor))) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (+ rem divisor) + rem))) + +(defun cis (theta) + "Return cos(Theta) + i sin(Theta), i.e. exp(i Theta)." + (if (complexp theta) + (error "Argument to CIS is complex: ~S" theta) + (complex (cos theta) (sin theta)))) + + +(defun complex (realpart &optional (imagpart 0)) + "Return a complex number with the specified real and imaginary components." + (number-case realpart + (short-float + (number-case imagpart + (short-float (canonical-complex realpart imagpart)) + (double-float (canonical-complex (%double-float realpart) imagpart)) + (rational (canonical-complex realpart (%short-float imagpart))))) + (double-float + (number-case imagpart + (double-float (canonical-complex + (the double-float realpart) + (the double-float imagpart))) + (short-float (canonical-complex realpart (%double-float imagpart))) + (rational (canonical-complex + (the double-float realpart) + (the double-float (%double-float imagpart)))))) + (rational (number-case imagpart + (double-float (canonical-complex + (the double-float (%double-float realpart)) + (the double-float imagpart))) + (short-float (canonical-complex (%short-float realpart) imagpart)) + (rational (canonical-complex realpart imagpart)))))) + +;; #-PPC IN L1-NUMBERS.LISP +(defun realpart (number) + "Extract the real part of a number." + (number-case number + (complex (%realpart number)) + (number number))) + +;; #-PPC IN L1-NUMBERS.LISP +(defun imagpart (number) + "Extract the imaginary part of a number." + (number-case number + (complex (%imagpart number)) + (float (* 0 number)) + (rational 0))) + +(defun logand-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum + (%ilogand (the fixnum x)(the fixnum y))) + (bignum (fix-big-logand x y)))) + (bignum (number-case y + (fixnum (fix-big-logand y x)) + (bignum (bignum-logical-and x y)))))) + +(defun logior-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (%ilogior2 x y)) + (bignum + (if (zerop x) + y + (with-small-bignum-buffers ((bx x)) + (bignum-logical-ior bx y)))))) + (bignum (number-case y + (fixnum (if (zerop y) + x + (with-small-bignum-buffers ((by y)) + (bignum-logical-ior x by)))) + (bignum (bignum-logical-ior x y)))))) + +(defun logxor-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (%ilogxor2 x y)) + (bignum + (with-small-bignum-buffers ((bx x)) + (bignum-logical-xor bx y))))) + (bignum (number-case y + (fixnum (with-small-bignum-buffers ((by y)) + (bignum-logical-xor x by))) + (bignum (bignum-logical-xor x y)))))) + + + +; see cmucl:compiler:srctran.lisp for transforms + +(defun lognand (integer1 integer2) + "Complement the logical AND of INTEGER1 and INTEGER2." + (lognot (logand integer1 integer2))) + +(defun lognor (integer1 integer2) + "Complement the logical AND of INTEGER1 and INTEGER2." + (lognot (logior integer1 integer2))) + +(defun logandc1 (x y) + "Return the logical AND of (LOGNOT integer1) and integer2." + (number-case x + (fixnum (number-case y + (fixnum (%ilogand (%ilognot x) y)) + (bignum (fix-big-logandc1 x y)))) ; (%ilogand-fix-big (%ilognot x) y)))) + (bignum (number-case y + (fixnum (fix-big-logandc2 y x)) ; (%ilogandc2-fix-big y x)) + (bignum (bignum-logandc2 y x)))))) ;(bignum-logical-and (bignum-logical-not x) y)))))) + + +#| ; its in numbers +(defun logandc2 (integer1 integer2) + "Returns the logical AND of integer1 and (LOGNOT integer2)." + (logand integer1 (lognot integer2))) +|# + +(defun logorc1 (integer1 integer2) + "Return the logical OR of (LOGNOT integer1) and integer2." + (logior (lognot integer1) integer2)) + +#| +(defun logorc2 (integer1 integer2) + "Returns the logical OR of integer1 and (LOGNOT integer2)." + (logior integer1 (lognot integer2))) +|# + +(defun logtest (integer1 integer2) + "Predicate which returns T if logand of integer1 and integer2 is not zero." + ; (not (zerop (logand integer1 integer2))) + (number-case integer1 + (fixnum (number-case integer2 + (fixnum (not (= 0 (%ilogand integer1 integer2)))) + (bignum (logtest-fix-big integer1 integer2)))) + (bignum (number-case integer2 + (fixnum (logtest-fix-big integer2 integer1)) + (bignum (bignum-logtest integer1 integer2)))))) + + + +(defun lognot (number) + "Return the bit-wise logical not of integer." + (number-case number + (fixnum (%ilognot number)) + (bignum (bignum-logical-not number)))) + +(defun logcount (integer) + "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits + if INTEGER is negative." + (number-case integer + (fixnum + (%ilogcount (if (minusp (the fixnum integer)) + (%ilognot integer) + integer))) + (bignum + (bignum-logcount integer)))) + + + +(defun ash (integer count) + "Shifts integer left by count places preserving sign. - count shifts right." + (etypecase integer + (fixnum + (etypecase count + (fixnum + (if (eql integer 0) + 0 + (if (eql count 0) + integer + (let ((length (integer-length (the fixnum integer)))) + (declare (fixnum length count)) + (cond ((and (plusp count) + (> (+ length count) + (- (1- target::nbits-in-word) target::fixnumshift))) + (with-small-bignum-buffers ((bi integer)) + (bignum-ashift-left bi count))) + ((and (minusp count) (< count (- (1- target::nbits-in-word)))) + (if (minusp integer) -1 0)) + (t (%iash (the fixnum integer) count))))))) + (bignum + (if (minusp count) + (if (minusp integer) -1 0) + (error "Count ~s too large for ASH" count))))) + (bignum + (etypecase count + (fixnum + (if (eql count 0) + integer + (if (plusp count) + (bignum-ashift-left integer count) + (bignum-ashift-right integer (- count))))) + (bignum + (if (minusp count) + (if (minusp integer) -1 0) + (error "Count ~s too large for ASH" count))))))) + +(defun integer-length (integer) + "Return the number of significant bits in the absolute value of integer." + (number-case integer + (fixnum + (%fixnum-intlen (the fixnum integer))) + (bignum + (bignum-integer-length integer)))) + + +; not CL, used below +(defun byte-mask (size) + (1- (ash 1 (the fixnum size)))) + +(defun byte-position (bytespec) + "Return the position part of the byte specifier bytespec." + (if (> bytespec 0) + (- (integer-length bytespec) (logcount bytespec)) + (- bytespec))) + + +; CMU CL returns T. +(defun upgraded-complex-part-type (type) + "Return the element type of the most specialized COMPLEX number type that + can hold parts of type SPEC." + (declare (ignore type)) + 'real) + +;;; This is the MRG31k3p random number generator described in +;;; P. L'Ecuyer and R. Touzin, "Fast Combined Multiple Recursive +;;; Generators with Multipliers of the form a = +/- 2^d +/- 2^e", +;;; Proceedings of the 2000 Winter Simulation Conference, Dec. 2000, +;;; 683--689. +;;; +;;; A link to the paper is available on L'Ecuyer's web site: +;;; http://www.iro.umontreal.ca/~lecuyer/papers.html. +;;; +;;; This generator has a period of about 2^185. It produces values in +;;; in the half-open interval [0, 2^31 - 1). +;;; +;;; It uses 6 words of state. + +(defconstant mrg31k3p-m1 #.(- (expt 2 31) 1)) +(defconstant mrg31k3p-m2 #.(- (expt 2 31) 21069)) +(defconstant mrg31k3p-limit #.(1- (expt 2 31)) + "Exclusive upper bound on values returned by %mrg31k3p.") + + +;;; This is a portable version of the MRG31k3p generator. It's not +;;; too bad in a 64-bit CCL, but the generator pretty much has to be +;;; in LAP for 32-bit ports. +#-(or x8632-target ppc32-target x8664-target ppc64-target) +(defun %mrg31k3p (state) + (let* ((v (random.mrg31k3p-state state))) + (declare (type (simple-array (unsigned-byte 32) (*)) v) + (optimize speed)) + (let ((y1 (+ (+ (ash (logand (aref v 1) #x1ff) 22) + (ash (aref v 1) -9)) + (+ (ash (logand (aref v 2) #xffffff) 7) + (ash (aref v 2) -24))))) + (declare (type (unsigned-byte 32) y1)) + (if (>= y1 mrg31k3p-m1) (decf y1 mrg31k3p-m1)) + (incf y1 (aref v 2)) + (if (>= y1 mrg31k3p-m1) (decf y1 mrg31k3p-m1)) + (setf (aref v 2) (aref v 1) + (aref v 1) (aref v 0) + (aref v 0) y1)) + (let ((y1 (+ (ash (logand (aref v 3) #xffff) 15) + (* 21069 (ash (aref v 3) -16)))) + (y2 (+ (ash (logand (aref v 5) #xffff) 15) + (* 21069 (ash (aref v 5) -16))))) + (declare (type (unsigned-byte 32) y1 y2)) + (if (>= y1 mrg31k3p-m2) (decf y1 mrg31k3p-m2)) + (if (>= y2 mrg31k3p-m2) (decf y2 mrg31k3p-m2)) + (incf y2 (aref v 5)) + (if (>= y2 mrg31k3p-m2) (decf y2 mrg31k3p-m2)) + (incf y2 y1) + (if (>= y2 mrg31k3p-m2) (decf y2 mrg31k3p-m2)) + (setf (aref v 5) (aref v 4) + (aref v 4) (aref v 3) + (aref v 3) y2)) + (let* ((x10 (aref v 0)) + (x20 (aref v 3))) + (if (<= x10 x20) + (+ (- x10 x20) mrg31k3p-m1) + (- x10 x20))))) + +(eval-when (:compile-toplevel :execute) + (declaim (inline %16-random-bits))) + +(defun %16-random-bits (state) + (logand #xffff (the fixnum (%mrg31k3p state)))) + +#+64-bit-target +(defun %big-fixnum-random (number state) + (declare (fixnum number) + (ftype (function (random-state) fixnum) %mrg31k3p)) + (let ((low (ldb (byte 30 0) (%mrg31k3p state))) + (high (ldb (byte 30 0) (%mrg31k3p state)))) + (declare (fixnum low high)) + (fast-mod (logior low (the fixnum (ash high 30))) + number))) + +;;; When using a dead simple random number generator, it's reasonable +;;; to take 16 bits of the output and discard the rest. With a more +;;; expensive generator, however, it may be worthwhile to do more bit +;;; fiddling here here so that we can use all of the random bits +;;; produced by %mrg31k2p. +#+32-bit-target +(defun %bignum-random (number state) + (let* ((bits (+ (integer-length number) 8)) + (half-words (ash (the fixnum (+ bits 15)) -4)) + (long-words (ash (+ half-words 1) -1)) + (dividend (%alloc-misc long-words target::subtag-bignum)) + (16-bit-dividend dividend) + (index 1)) + (declare (fixnum long-words index bits) + (dynamic-extent dividend) + (type (simple-array (unsigned-byte 16) (*)) 16-bit-dividend) ;lie + (optimize (speed 3) (safety 0))) + (loop + ;; This had better inline due to the lie above, or it will error + #+big-endian-target + (setf (aref 16-bit-dividend index) (%16-random-bits state)) + #+little-endian-target + (setf (aref 16-bit-dividend (the fixnum (1- index))) + (%16-random-bits state)) + (decf half-words) + (when (<= half-words 0) (return)) + #+big-endian-target + (setf (aref 16-bit-dividend (the fixnum (1- index))) + (%16-random-bits state)) + #+little-endian-target + (setf (aref 16-bit-dividend index) (%16-random-bits state)) + (decf half-words) + (when (<= half-words 0) (return)) + (incf index 2)) + ;; The bignum code expects normalized bignums + (let* ((result (mod dividend number))) + (if (eq dividend result) + (copy-uvector result) + result)))) + +(defun %float-random (number state) + (let ((ratio (gvector :ratio (random target::target-most-positive-fixnum state) target::target-most-positive-fixnum))) + (declare (dynamic-extent ratio)) + (* number ratio))) + +(defun random (number &optional (state *random-state*)) + (if (not (typep state 'random-state)) (report-bad-arg state 'random-state)) + (cond + ((and (fixnump number) (> (the fixnum number) 0)) + #+32-bit-target + (fast-mod (%mrg31k3p state) number) + #+64-bit-target + (if (< number mrg31k3p-limit) + (fast-mod (%mrg31k3p state) number) + (%big-fixnum-random number state))) + ((and (typep number 'double-float) (> (the double-float number) 0.0)) + (%float-random number state)) + ((and (typep number 'short-float) (> (the short-float number) 0.0s0)) + (%float-random number state)) + ((and (bignump number) (> number 0)) + (%bignum-random number state)) + (t (report-bad-arg number '(or (integer (0)) (float (0.0))))))) + +(eval-when (:compile-toplevel :execute) + (defmacro bignum-abs (nexp) + (let ((n (gensym))) + `(let ((,n ,nexp)) + (if (bignum-minusp ,n) (negate-bignum ,n) ,n)))) + + (defmacro fixnum-abs (nexp) + (let ((n (gensym))) + `(let ((,n ,nexp)) + (if (minusp (the fixnum ,n)) + (if (eq ,n target::target-most-negative-fixnum) + (- ,n) + (the fixnum (- (the fixnum ,n)))) + ,n)))) + ) + + +;;; TWO-ARG-GCD -- Internal +;;; +;;; Do the GCD of two integer arguments. With fixnum arguments, we use the +;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly +;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case +;;; of 0 before the dispatch so that the bignum code doesn't have to worry +;;; about "small bignum" zeros. +;;; +(defun gcd-2 (n1 n2) + ;(declare (optimize (speed 3)(safety 0))) + (cond + ((eql n1 0) (%integer-abs n2)) + ((eql n2 0) (%integer-abs n1)) + (t (number-case n1 + (fixnum + (number-case n2 + (fixnum + (if (eql n1 target::target-most-negative-fixnum) + (if (eql n2 target::target-most-negative-fixnum) + (- target::target-most-negative-fixnum) + (bignum-fixnum-gcd (- target::target-most-negative-fixnum) (abs n2))) + (if (eql n2 target::target-most-negative-fixnum) + (bignum-fixnum-gcd (- target::target-most-negative-fixnum) (abs n1)) + (locally + (declare (optimize (speed 3) (safety 0)) + (fixnum n1 n2)) + (if (minusp n1)(setq n1 (the fixnum (- n1)))) + (if (minusp n2)(setq n2 (the fixnum (- n2)))) + (%fixnum-gcd n1 n2))))) + (bignum (if (eql n1 target::target-most-negative-fixnum) + (%bignum-bignum-gcd n2 (- target::target-most-negative-fixnum)) + (bignum-fixnum-gcd (bignum-abs n2)(fixnum-abs n1)))))) + (bignum + (number-case n2 + (fixnum + (if (eql n2 target::target-most-negative-fixnum) + (%bignum-bignum-gcd (bignum-abs n1)(fixnum-abs n2)) + (bignum-fixnum-gcd (bignum-abs n1)(fixnum-abs n2)))) + (bignum (%bignum-bignum-gcd n1 n2)))))))) + +#| +(defun fixnum-gcd (n1 n2) + (declare (optimize (speed 3) (safety 0)) + (fixnum n1 n2)) + (do* ((k 0 (%i+ 1 k)) + (n1 n1 (%iasr 1 n1)) + (n2 n2 (%iasr 1 n2))) + ((oddp (logior n1 n2)) + (do ((temp (if (oddp n1) (the fixnum (- n2)) (%iasr 1 n1)) + (%iasr 1 temp))) + (nil) + (declare (fixnum temp)) + (when (oddp temp) + (if (plusp temp) + (setq n1 temp) + (setq n2 (- temp))) + (setq temp (the fixnum (- n1 n2))) + (when (zerop temp) + (let ((res (%ilsl k n1))) + (return res)))))) + (declare (fixnum n1 n2 k)))) +|# + + + +(defun %quo-1 (n) + (/ 1 n)) + +; x & y must both be double floats +(defun %hypot (x y) + (with-stack-double-floats ((x**2) (y**2)) + (let ((res**2 x**2)) + (%double-float*-2! x x x**2) + (%double-float*-2! y y y**2) + (%double-float+-2! x**2 y**2 res**2) + (fsqrt res**2)))) + + Index: /branches/qres/ccl/level-0/l0-pred.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-pred.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-pred.lisp (revision 13564) @@ -0,0 +1,1115 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; Non-portable type-predicates & such. + + +;; bootstrapping defs - real ones in l1-typesys, l1-clos, sysutils + +(defun find-builtin-cell (type &optional create) + (declare (ignore create)) + (cons type nil)) + + +(defun builtin-typep (form cell) + (typep form (class-cell-name cell))) + +(defun class-cell-typep (arg class-cell) + (typep arg (class-cell-name class-cell))) + +(defun class-cell-find-class (class-cell errorp) + (declare (ignore errorp)) ; AARGH can't be right + ;(dbg-paws #x100) + (let ((class (and class-cell (class-cell-class class-cell)))) + (or class + (if (fboundp 'find-class) + (find-class (class-cell-name class-cell) nil))))) + +(defun %require-type-builtin (form foo) + (declare (ignore foo)) + form) + +(defun %require-type-class-cell (form cell) + (declare (ignore cell)) + form) + +(defun non-nil-symbol-p (x) + (if (symbolp x) x)) + +(defun pathnamep (thing) + (or (istruct-typep thing 'pathname) (istruct-typep thing 'logical-pathname))) + +(defun compiled-function-p (form) + "Return true if OBJECT is a COMPILED-FUNCTION, and NIL otherwise." + (and (functionp form) + (not (logbitp $lfbits-trampoline-bit (the fixnum (lfun-bits form)))))) + +;;; all characters are base-chars. +(defun extended-char-p (c) + (declare (ignore c))) + + +;;; Some of these things are probably open-coded. +;;; The functions have to exist SOMEWHERE ... +(defun fixnump (x) + (= (the fixnum (lisptag x)) target::tag-fixnum)) + +(defun bignump (x) + (= (the fixnum (typecode x)) target::subtag-bignum)) + +(defun integerp (x) + "Return true if OBJECT is an INTEGER, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (or (= typecode target::tag-fixnum) + (= typecode target::subtag-bignum)))) + +(defun ratiop (x) + (= (the fixnum (typecode x)) target::subtag-ratio)) + + +(defun rationalp (x) + "Return true if OBJECT is a RATIONAL, and NIL otherwise." + (or (fixnump x) + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + #+(or ppc32-target x8632-target) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-rational-subtag)) + #+(or ppc64-target x8664-target) + (cond ((= typecode target::subtag-bignum) t) + ((= typecode target::subtag-ratio) t))))) + +(defun short-float-p (x) + (= (the fixnum (typecode x)) target::subtag-single-float)) + + +(defun double-float-p (x) + (= (the fixnum (typecode x)) target::subtag-double-float)) + +(defun floatp (x) + "Return true if OBJECT is a FLOAT, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-single-float) + (= typecode target::subtag-double-float)))) + +(defun realp (x) + "Return true if OBJECT is a REAL, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + #+(or ppc32-target x8632-target) + (or (= typecode target::tag-fixnum) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-real-subtag))) + #+ppc64-target + (if (<= typecode ppc64::subtag-double-float) + (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode) + (logior (ash 1 ppc64::tag-fixnum) + (ash 1 ppc64::subtag-single-float) + (ash 1 ppc64::subtag-double-float) + (ash 1 ppc64::subtag-bignum) + (ash 1 ppc64::subtag-ratio)))) + #+x8664-target + (if (<= typecode x8664::subtag-double-float) + (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode) + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::subtag-bignum) + (ash 1 x8664::tag-single-float) + (ash 1 x8664::subtag-double-float) + (ash 1 x8664::subtag-ratio)))))) + +(defun complexp (x) + "Return true if OBJECT is a COMPLEX, and NIL otherwise." + (= (the fixnum (typecode x)) target::subtag-complex)) + +(defun numberp (x) + "Return true if OBJECT is a NUMBER, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + #+(or ppc32-target x8632-target) + (or (= typecode target::tag-fixnum) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-numeric-subtag))) + #+ppc64-target + (if (<= typecode ppc64::subtag-double-float) + (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode) + (logior (ash 1 ppc64::tag-fixnum) + (ash 1 ppc64::subtag-bignum) + (ash 1 ppc64::subtag-single-float) + (ash 1 ppc64::subtag-double-float) + (ash 1 ppc64::subtag-ratio) + (ash 1 ppc64::subtag-complex)))) + #+x8664-target + (if (< typecode x8664::nbits-in-word) + (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode) + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::subtag-bignum) + (ash 1 x8664::tag-single-float) + (ash 1 x8664::subtag-double-float) + (ash 1 x8664::subtag-ratio) + (ash 1 x8664::subtag-complex)))) + + )) + +(defun arrayp (x) + "Return true if OBJECT is an ARRAY, and NIL otherwise." + (>= (the fixnum (typecode x)) target::min-array-subtag)) + +(defun vectorp (x) + "Return true if OBJECT is a VECTOR, and NIL otherwise." + (>= (the fixnum (typecode x)) target::min-vector-subtag)) + + +(defun stringp (x) + "Return true if OBJECT is a STRING, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-vectorH) + (setq typecode (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref x target::arrayH.flags-cell))))) + (= typecode target::subtag-simple-base-string))) + + +(defun simple-base-string-p (x) + (= (the fixnum (typecode x)) target::subtag-simple-base-string)) + +(defun simple-string-p (x) + "Return true if OBJECT is a SIMPLE-STRING, and NIL otherwise." + (= (the fixnum (typecode x)) target::subtag-simple-base-string)) + +(defun complex-array-p (x) + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (not (%array-header-simple-p x))))) + +(defun simple-array-p (thing) + "Returns T if the object is a simple array, else returns NIL. + That's why it's called SIMPLE-ARRAY-P. Get it ? + A simple-array may have no fill-pointer, may not be displaced, + and may not be adjustable." + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (%array-header-simple-p thing) + (> typecode target::subtag-vectorH)))) + +(defun macptrp (x) + (= (the fixnum (typecode x)) target::subtag-macptr)) + +(defun dead-macptr-p (x) + (= (the fixnum (typecode x)) target::subtag-dead-macptr)) + + +;;; Note that this is true of symbols and functions and many other +;;; things that it wasn't true of on the 68K. +(defun gvectorp (x) + #+(or ppc32-target x8632-target) + (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::fulltag-nodeheader) + #+ppc64-target + (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader) + #+x8664-target + (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask))) + (declare (fixnum fulltag)) + (or (= fulltag x8664::fulltag-nodeheader-0) + (= fulltag x8664::fulltag-nodeheader-1))) + ) + + +(setf (type-predicate 'gvector) 'gvectorp) + +(defun ivectorp (x) + #+(or ppc32-target x8632-target) + (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) + target::fulltag-immheader) + #+ppc64-target + (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader) + #+x8664-target + (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask))) + (declare (fixnum fulltag)) + (or (= fulltag x8664::fulltag-immheader-0) + (= fulltag x8664::fulltag-immheader-1) + (= fulltag x8664::fulltag-immheader-2))) + ) + +(setf (type-predicate 'ivector) 'ivectorp) + +(defun miscobjp (x) + #+(or ppc32-target x8632-target x8664-target) + (= (the fixnum (lisptag x)) target::tag-misc) + #+ppc64-target + (= (the fixnum (fulltag x)) ppc64::fulltag-misc) + ) + +(defun simple-vector-p (x) + "Return true if OBJECT is a SIMPLE-VECTOR, and NIL otherwise." + (= (the fixnum (typecode x)) target::subtag-simple-vector)) + +(defun base-string-p (thing) + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-simple-base-string) + (and (= typecode target::subtag-vectorh) + (= (the fixnum + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell)))) + target::subtag-simple-base-string))))) + +(defun simple-bit-vector-p (form) + "Return true if OBJECT is a SIMPLE-BIT-VECTOR, and NIL otherwise." + (= (the fixnum (typecode form)) target::subtag-bit-vector)) + +(defun bit-vector-p (thing) + "Return true if OBJECT is a BIT-VECTOR, and NIL otherwise." + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-bit-vector) + (and (= typecode target::subtag-vectorh) + (= (the fixnum + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell)))) + target::subtag-bit-vector))))) + +(defun displaced-array-p (array) + (if (%array-is-header array) + (do* ((disp (%svref array target::arrayH.displacement-cell) + (+ disp (the fixnum (%svref target target::arrayH.displacement-cell)))) + (target (%svref array target::arrayH.data-vector-cell) + (%svref target target::arrayH.data-vector-cell))) + ((not (%array-is-header target)) + (values target disp))) + (values nil 0))) + + + +(defun eq (x y) + "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL." + (eq x y)) + + +(defun cons-equal (x y) + (declare (cons x y)) + (if (equal (car x) (car y)) + (equal (cdr x) (cdr y)))) + +(defun hairy-equal (x y) + (declare (optimize (speed 3))) + ;; X and Y are not EQL, and are both of tag target::fulltag-misc. + (let* ((x-type (typecode x)) + (y-type (typecode y))) + (declare (fixnum x-type y-type)) + (if (and (>= x-type target::subtag-vectorH) + (>= y-type target::subtag-vectorH)) + (let* ((x-simple (if (= x-type target::subtag-vectorH) + (ldb target::arrayH.flags-cell-subtag-byte + (the fixnum (%svref x target::arrayH.flags-cell))) + x-type)) + (y-simple (if (= y-type target::subtag-vectorH) + (ldb target::arrayH.flags-cell-subtag-byte + (the fixnum (%svref y target::arrayH.flags-cell))) + y-type))) + (declare (fixnum x-simple y-simple)) + (if (= x-simple target::subtag-simple-base-string) + (if (= y-simple target::subtag-simple-base-string) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((x-len (if (= x-type target::subtag-vectorH) + (%svref x target::vectorH.logsize-cell) + (uvsize x))) + (x-pos 0) + (y-len (if (= y-type target::subtag-vectorH) + (%svref y target::vectorH.logsize-cell) + (uvsize y))) + (y-pos 0)) + (declare (fixnum x-len x-pos y-len y-pos)) + (when (= x-type target::subtag-vectorH) + (multiple-value-setq (x x-pos) (array-data-and-offset x))) + (when (= y-type target::subtag-vectorH) + (multiple-value-setq (y y-pos) (array-data-and-offset y))) + (%simple-string= x y x-pos y-pos (the fixnum (+ x-pos x-len)) (the fixnum (+ y-pos y-len)))))) + ;;Bit-vector case or fail. + (and (= x-simple target::subtag-bit-vector) + (= y-simple target::subtag-bit-vector) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((x-len (if (= x-type target::subtag-vectorH) + (%svref x target::vectorH.logsize-cell) + (uvsize x))) + (x-pos 0) + (y-len (if (= y-type target::subtag-vectorH) + (%svref y target::vectorH.logsize-cell) + (uvsize y))) + (y-pos 0)) + (declare (fixnum x-len x-pos y-len y-pos)) + (when (= x-len y-len) + (when (= x-type target::subtag-vectorH) + (multiple-value-setq (x x-pos) (array-data-and-offset x))) + (when (= y-type target::subtag-vectorH) + (multiple-value-setq (y y-pos) (array-data-and-offset y))) + (do* ((i 0 (1+ i))) + ((= i x-len) t) + (declare (fixnum i)) + (unless (= (the bit (sbit x x-pos)) (the bit (sbit y y-pos))) + (return)) + (incf x-pos) + (incf y-pos)))))))) + (if (= x-type y-type) + (if (= x-type target::subtag-istruct) + (and (let* ((structname (istruct-cell-name (%svref x 0)))) + (and (eq structname (istruct-cell-name (%svref y 0))) + (or (eq structname 'pathname) + (eq structname 'logical-pathname))) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((x-size (uvsize x)) + (skip (if (eq structname 'pathname) + %physical-pathname-version + -1))) + (declare (fixnum x-size skip)) + (when (= x-size (the fixnum (uvsize y))) + (if *case-sensitive-filesystem* + (do* ((i 1 (1+ i))) + ((= i x-size) t) + (declare (fixnum i)) + (unless (or (= i skip) + (equal (%svref x i) (%svref y i))) + (return))) + (do* ((i 1 (1+ i))) + ((= i x-size) t) + (declare (fixnum i)) + (unless (or (= i skip) + (equalp (%svref x i) (%svref y i))) + (return)))))))))))))) + +#+ppc32-target +(progn +(defparameter *nodeheader-types* + #(bogus ; 0 + ratio ; 1 + bogus ; 2 + complex ; 3 + catch-frame ; 4 + function ; 5 + basic-stream ; 6 + symbol ; 7 + lock ; 8 + hash-table-vector ; 9 + pool ; 10 + population ; 11 + package ; 12 + slot-vector ; 13 + standard-instance ; 14 + structure ; 15 + internal-structure ; 16 + value-cell ; 17 + xfunction ; 18 + array-header ; 19 + vector-header ; 20 + simple-vector ; 21 + bogus ; 22 + bogus ; 23 + bogus ; 24 + bogus ; 25 + bogus ; 26 + bogus ; 27 + bogus ; 28 + bogus ; 29 + bogus ; 30 + bogus ; 31 + )) + + +(defparameter *immheader-types* + #(bignum ; 0 + short-float ; 1 + double-float ; 2 + macptr ; 3 + dead-macptr ; 4 + code-vector ; 5 + creole-object ; 6 + ;; 8-19 are unused + xcode-vector ; 7 + bogus ; 8 + bogus ; 9 + bogus ; 10 + bogus ; 11 + bogus ; 12 + bogus ; 13 + bogus ; 14 + bogus ; 15 + bogus ; 16 + bogus ; 17 + bogus ; 18 + bogus ; 19 + simple-short-float-vector ; 20 + simple-unsigned-long-vector ; 21 + simple-signed-long-vector ; 22 + simple-fixnum-vector ; 23 + simple-base-string ; 24 + simple-unsigned-byte-vector ; 25 + simple-signed-byte-vector ; 26 + bogus ; 27 + simple-unsigned-word-vector ; 28 + simple-signed-word-vector ; 29 + simple-double-float-vector ; 30 + simple-bit-vector ; 31 + )) + +(defun %type-of (thing) + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (if (= typecode ppc32::tag-fixnum) + 'fixnum + (if (= typecode ppc32::tag-list) + (if thing 'cons 'null) + (if (= typecode ppc32::tag-imm) + (if (base-char-p thing) + 'base-char + 'immediate) + (if (= typecode ppc32::subtag-macptr) + (if (classp thing) + (class-name thing) + 'macptr) + (let* ((tag-type (logand typecode ppc32::full-tag-mask)) + (tag-val (ash typecode (- ppc32::ntagbits)))) + (declare (fixnum tag-type tag-val)) + (if (/= tag-type ppc32::fulltag-nodeheader) + (%svref *immheader-types* tag-val) + (let ((type (%svref *nodeheader-types* tag-val))) + (if (eq type 'function) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function))) + (if (eq type 'lock) + (or (uvref thing ppc32::lock.kind-cell) + type) + type))))))))))) + +);#+ppc32-target + +#+ppc64-target +(progn +(defparameter *immheader-types* + #(bogus + bogus + code-vector + bogus + bogus + bogus + xcode-vector + macptr + bogus + bogus + bignum + dead-macptr + bogus + bogus + double-float + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-signed-byte-vector + simple-signed-word-vector + simple-signed-long-vector + simple-signed-doubleword-vector + simple-unsigned-byte-vector + simple-unsigned-word-vector + simple-unsigned-long-vector + simple-unsigned-doubleword-vector + bogus + bogus + simple-short-float-vector + simple-fixnum-vector + bogus + bogus + bogus + simple-double-float-vector + bogus + bogus + simple-base-string + bogus + bogus + bogus + bogus + bogus + bogus + simple-bit-vector + bogus + bogus)) + +(defparameter *nodeheader-types* + #(function + catch-frame + slot-vector + ratio + symbol + basic-stream + standard-instance + complex + bogus + lock + structure + bogus + bogus + hash-vector + internal-structure + bogus + bogus + pool + value-cell + bogus + bogus + population + xfunction + bogus + bogus + package + bogus + bogus + bogus + bogus + bogus + bogus + bogus + array-header + vector-header + simple-vector + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + ) + ) + + +(defun %type-of (thing) + (if (null thing) + 'null + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (cond ((= typecode ppc64::tag-fixnum) 'fixnum) + ((= typecode ppc64::fulltag-cons) 'cons) + ((= typecode ppc64::subtag-character) 'character) + ((= typecode ppc64::subtag-single-float) 'short-float) + (t (let* ((lowtag (logand typecode ppc64::lowtagmask))) + (declare (fixnum lowtag)) + (cond ((= lowtag ppc64::lowtag-immheader) + (%svref *immheader-types* (ash typecode -2))) + ((= lowtag ppc64::lowtag-nodeheader) + (let* ((type (%svref *nodeheader-types* + (ash typecode -2)))) + (cond ((eq type 'function) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function)))) + ((eq type 'lock) + (or (uvref thing ppc64::lock.kind-cell) + type)) + (t type)))) + (t 'immediate)))))))) +);#+ppc64-target + + +#+x8632-target +(progn +(defparameter *nodeheader-types* + #(bogus ; 0 + ratio ; 1 + bogus ; 2 + complex ; 3 + catch-frame ; 4 + function ; 5 + basic-stream ; 6 + symbol ; 7 + lock ; 8 + hash-table-vector ; 9 + pool ; 10 + population ; 11 (weak?) + package ; 12 + slot-vector ; 13 + standard-instance ; 14 + structure ; 15 + internal-structure ; 16 + value-cell ; 17 + xfunction ; 18 + array-header ; 19 + vector-header ; 20 + simple-vector ; 21 + bogus ; 22 + bogus ; 23 + bogus ; 24 + bogus ; 25 + bogus ; 26 + bogus ; 27 + bogus ; 28 + bogus ; 29 + bogus ; 30 + bogus ; 31 + )) + + +(defparameter *immheader-types* + #(bignum ; 0 + short-float ; 1 + double-float ; 2 + macptr ; 3 + dead-macptr ; 4 + code-vector ; 5 + creole-object ; 6 + xcode-vector ; 7 + bogus ; 8 + bogus ; 9 + bogus ; 10 + bogus ; 11 + bogus ; 12 + bogus ; 13 + bogus ; 14 + bogus ; 15 + bogus ; 16 + bogus ; 17 + bogus ; 18 + bogus ; 19 + simple-short-float-vector ; 20 + simple-unsigned-long-vector ; 21 + simple-signed-long-vector ; 22 + simple-fixnum-vector ; 23 + simple-base-string ; 24 + simple-unsigned-byte-vector ; 25 + simple-signed-byte-vector ; 26 + bogus ; 27 + simple-unsigned-word-vector ; 28 + simple-signed-word-vector ; 29 + simple-double-float-vector ; 30 + simple-bit-vector ; 31 + )) + +(defun %type-of (thing) + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (if (= typecode x8632::tag-fixnum) + 'fixnum + (if (= typecode x8632::tag-list) ;a misnomer on x8632... + (if (= (fulltag thing) x8632::fulltag-cons) + (if thing 'cons 'null) + 'tagged-return-address) + (if (= typecode x8632::tag-imm) + (if (base-char-p thing) + 'base-char + 'immediate) + (if (= typecode x8632::subtag-macptr) + (if (classp thing) + (class-name thing) + 'macptr) + (let* ((tag-type (logand typecode x8632::fulltagmask)) + (tag-val (ash typecode (- x8632::ntagbits)))) + (declare (fixnum tag-type tag-val)) + (if (/= tag-type x8632::fulltag-nodeheader) + (%svref *immheader-types* tag-val) + (let ((type (%svref *nodeheader-types* tag-val))) + (if (eq type 'function) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function))) + (if (eq type 'lock) + (or (uvref thing x8632::lock.kind-cell) + type) + type))))))))))) + +) ;x8632-target + +#+x8664-target +(progn +(defparameter *nodeheader-0-types* + #(bogus + symbol-vector + catch-frame + hash-vector + pool + population + package + slot-vector + basic-stream + function-vector ;8 + array-header + bogus + bogus + bogus + bogus + bogus + )) + +(defparameter *nodeheader-1-types* + #(bogus + ratio + complex + structure + internal-structure + value-cell + xfunction + lock + instance + bogus + vector-header + simple-vector + bogus + bogus + bogus + bogus + )) + +(defparameter *immheader-0-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-signed-word-vector + simple-unsigned-word-vector + bogus + simple-signed-byte-vector + simple-unsigned-byte-vector + bit-vector)) + +(defparameter *immheader-1-types* + #(bogus + bignum + double-float + xcode-vector + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-base-string + simple-signed-long-vector + simple-unsigned-long-vector + single-float-vector)) + +(defparameter *immheader-2-types* + #(bogus + macptr + dead-macptr + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-fixnum-vector + simple-signed-doubleword-vector + simple-unsigned-doubleword-vector + double-float-vector)) + + +(defparameter *x8664-%type-of-functions* nil) + +(let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum)) + (tra (lambda (x) (declare (ignore x)) 'tagged-return-address)) + (bogus (lambda (x) (declare (ignore x)) 'bogus))) + (setq *x8664-%type-of-functions* + (vector + fixnum ;0 + (lambda (x) (declare (ignore x)) 'short-float) ;1 + (lambda (x) (if (characterp x) 'character 'immediate)) ;2 + (lambda (x) (declare (ignore x)) 'cons) ;3 + tra ;4 + bogus ;5 + bogus ;6 + bogus ;7 + fixnum ;8 + bogus ;9 + bogus ;10 + (lambda (x) (declare (ignore x)) 'null) ;11 + tra ;12 + (lambda (x) (let* ((typecode (typecode x)) + (low4 (logand typecode x8664::fulltagmask)) + (high4 (ash typecode (- x8664::ntagbits)))) + (declare (type (unsigned-byte 8) typecode) + (type (unsigned-byte 4) low4 high4)) + (let* ((name + (cond ((= low4 x8664::fulltag-immheader-0) + (%svref *immheader-0-types* high4)) + ((= low4 x8664::fulltag-immheader-1) + (%svref *immheader-1-types* high4)) + ((= low4 x8664::fulltag-immheader-2) + (%svref *immheader-2-types* high4)) + ((= low4 x8664::fulltag-nodeheader-0) + (%svref *nodeheader-0-types* high4)) + ((= low4 x8664::fulltag-nodeheader-1) + (%svref *nodeheader-1-types* high4)) + (t 'bogus)))) + (or (and (eq name 'lock) + (uvref x x8664::lock.kind-cell)) + name)))) ;13 + (lambda (x) (declare (ignore x)) 'symbol) ;14 + (lambda (thing) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function))))))) ;15 + + + + + +(defun %type-of (thing) + (let* ((f (fulltag thing))) + (funcall (%svref *x8664-%type-of-functions* f) thing))) + + + +);#+x8664-target + + +;;; real machine specific huh +(defun consp (x) + "Return true if OBJECT is a CONS, and NIL otherwise." + (consp x)) + +(defun characterp (arg) + "Return true if OBJECT is a CHARACTER, and NIL otherwise." + (characterp arg)) + +(defun base-char-p (c) + (base-char-p c)) + + + + +(defun structurep (form) + "True if the given object is a named structure, Nil otherwise." + (= (the fixnum (typecode form)) target::subtag-struct)) + +(defun istructp (form) + (= (the fixnum (typecode form)) target::subtag-istruct)) + + +;;; Not to be conused with STRUCTURE-TYPE-P, defined in ccl:lib;pprint.lisp. +;;; (If you've ever been "conused", I'm sure you know just how painful +;;; that can be.) +(defun structure-typep (thing type) + (if (= (the fixnum (typecode thing)) target::subtag-struct) + (let* ((types (%svref thing 0))) + (if (typep type 'symbol) + (dolist (x types) + (when (eq (class-cell-name x) type) + (return t))) + (dolist (x types) + (when (eq x type) + (return t))))))) + + + +(defun istruct-typep (thing type) + (if (= (the fixnum (typecode thing)) target::subtag-istruct) + (eq (istruct-cell-name (%svref thing 0)) type))) + +(defun istruct-type-name (thing) + (if (= (the fixnum (typecode thing)) target::subtag-istruct) + (istruct-cell-name (%svref thing 0)))) + + +;;; This is actually set to an alist in the xloader. +(defparameter *istruct-cells* nil) + +;;; This should only ever push anything on the list in the cold +;;; load (e.g., when running single-threaded.) +(defun register-istruct-cell (name) + (or (assq name *istruct-cells*) + (let* ((pair (cons name nil))) + (push pair *istruct-cells*) + pair))) + +(defun set-istruct-cell-info (cell info) + (etypecase cell + (cons (%rplacd cell info))) + info) + + +(defun symbolp (thing) + "Return true if OBJECT is a SYMBOL, and NIL otherwise." + #+(or ppc32-target x8632-target) + (if thing + (= (the fixnum (typecode thing)) target::subtag-symbol) + t) + #+ppc64-target + (= (the fixnum (typecode thing)) ppc64::subtag-symbol) + #+x8664-target + (if thing + (= (the fixnum (lisptag thing)) x8664::tag-symbol) + t) + ) + +(defun packagep (thing) + (= (the fixnum (typecode thing)) target::subtag-package)) + +;;; 1 if by land, 2 if by sea. +(defun sequence-type (x) + (unless (>= (the fixnum (typecode x)) target::min-vector-subtag) + (or (listp x) + (report-bad-arg x 'sequence)))) + +(defun uvectorp (x) + (= (the fixnum (fulltag x)) target::fulltag-misc)) + +(setf (type-predicate 'uvector) 'uvectorp) + +(defun listp (x) + (listp x)) + +(defparameter *type-cells* nil) + + + +(defparameter *type-cells-lock* nil) + + +;;; The weird handling to the special variables here has to do with +;;; xload issues. +(defun register-type-cell (specifier) + (with-lock-grabbed ((or *type-cells-lock* + (setq *type-cells-lock* (make-lock)))) + (unless *type-cells* + (setq *type-cells* (make-hash-table :test 'equal))) + (or (values (gethash specifier *type-cells*)) + (setf (gethash specifier *type-cells*) + (make-type-cell specifier))))) + + +(defvar %find-classes% nil) + +(setq %find-classes% (make-hash-table :test 'eq)) + + +(defun find-class-cell (name create?) + (unless %find-classes% + (dbg name)) + (let ((cell (gethash name %find-classes%))) + (or cell + (and create? + (setf (gethash name %find-classes%) (make-class-cell name)))))) + Index: /branches/qres/ccl/level-0/l0-symbol.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-symbol.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-symbol.lisp (revision 13564) @@ -0,0 +1,266 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; No error checking, no interrupts, no protect_caller, no nuthin. +;;; No error, no cons. No problem. +(defun %progvrestore (saved) + (declare (optimize (speed 3) (safety 0))) + (dolist (pair saved) + (%set-sym-value (car pair) (cdr pair)))) + +;;; Check that something that's supposed to be a proper list of +;;; symbols is; error otherwise. +;;; This is called only by the compiler output of a PROGV form. +;;; It checks for the maximum length that the progvsave subprim +;;; can handle. + +(defun check-symbol-list (l &optional (max-length + (floor (- 4096 20) (* target::node-size 3)) + )) + (let ((len (list-length l))) + (if (and len + (or (null max-length) + (< len max-length)) + (dolist (s l t) + (unless (and (symbolp s) + (not (constant-symbol-p s)) + (not (logbitp $sym_vbit_global (the fixnum (%symbol-bits s)))) + (ensure-binding-index s)) + (return nil)))) + l + (error "~s is not a proper list of bindable symbols~@[ of length < ~s~]." l max-length)))) + +;;; The type-checking done on the "plist" arg shouldn't be removed. +(defun set-symbol-plist (sym plist) + (when plist + (let* ((len (list-length plist))) + (unless (and len (evenp len)) + (error "Bad plist: ~s" plist)))) + (let* ((vector (symptr->symvector (%symbol->symptr sym))) + (cell (%svref vector target::symbol.plist-cell))) + (if plist + (if (consp cell) + (setf (cdr cell) plist) + (cdr (setf (%svref vector target::symbol.plist-cell) (cons nil plist)))) + (if (car cell) + (setf (cdr cell) nil) + (if cell (setf (cdr cell) nil)))))) + + +(eval-when (:compile-toplevel :execute) + (declaim (inline %pl-search))) + +(defun %pl-search (l key) + (declare (list l) (optimize (speed 3))) + (loop + (if (eq (car l) key) + (return) + (if l + (setq l (cdr (the list (cdr l)))) + (return)))) + l) + + +(defun symbol-plist (sym) + "Return SYMBOL's property list." + (cdr (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell))) + + +(defun get (sym key &optional default) + "Look on the property list of SYMBOL for the specified INDICATOR. If this + is found, return the associated value, else return DEFAULT." + (let* ((tail (%pl-search + (cdr (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)) key))) + (if tail (%cadr tail) default))) + +(defun put (sym key value) + (let* ((symptr (%symbol->symptr sym)) + (vector (symptr->symvector symptr)) + (cell (%svref vector target::symbol.plist-cell)) + (plist (cdr cell)) + (tail (%pl-search plist key))) + (if tail + (%rplaca (%cdr tail) value) + (progn + (setq plist (cons key (cons value plist))) + (if cell + (setf (cdr cell) plist) + (setf (%svref vector target::symbol.plist-cell) (cons nil plist))))) + value)) + + +(defun get-type-predicate (name) + (let* ((symvec (symptr->symvector (%symbol->symptr name))) + (pp (%svref symvec target::symbol.package-predicate-cell))) + (if (consp pp) + (%cdr pp)))) + +(defun set-type-predicate (name function) + (let* ((bits (%symbol-bits name)) + (symvec (symptr->symvector (%symbol->symptr name))) + (spp (%svref symvec target::symbol.package-predicate-cell))) + (declare (fixnum bits)) + (if (logbitp $sym_vbit_typeppred bits) + (%rplacd spp function) + (progn + (%symbol-bits name (the fixnum (bitset $sym_vbit_typeppred bits))) + (setf (%svref symvec target::symbol.package-predicate-cell) (cons spp function)))) + function)) + +(defun symbol-value (sym) + "Return SYMBOL's current bound value." + (let* ((val (%sym-value sym))) + (if (eq val (%unbound-marker)) + (%kernel-restart $xvunbnd sym) + val))) + +(defun set (sym value) + "Set SYMBOL's value cell to NEW-VALUE." + (let* ((bits (%symbol-bits sym))) + (declare (fixnum bits)) + (if (logbitp $sym_vbit_const bits) + (%err-disp $XCONST sym) + (%set-sym-value sym value)))) + +(defun constant-symbol-p (sym) + (and (symbolp sym) + (%ilogbitp $sym_vbit_const (%symbol-bits sym)))) + +;;; This leaves the SPECIAL bit alone, clears the others. +(defun makunbound (sym) + "Make SYMBOL unbound, removing any value it may currently have." + (if (and *warn-if-redefine-kernel* + (constant-symbol-p sym)) + (cerror "Make ~S be unbound anyway." + "~S is a constant; making it unbound might be a bad idea." sym)) + (%symbol-bits sym (the fixnum (logand (logior #xff00 (ash 1 $sym_bit_special)) + (the fixnum (%symbol-bits sym))))) + (%set-sym-value sym (%unbound-marker)) + sym) + +(defun non-nil-symbolp (x) + "Returns symbol if true" + (if (symbolp x) x)) + +(defun symbol-package (sym) + "Return the package SYMBOL was interned in, or NIL if none." + (let* ((pp (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.package-predicate-cell))) + (if (consp pp) (car pp) pp))) + +(defun boundp (sym) + "Return non-NIL if SYMBOL is bound to a value." + (not (eq (%sym-value sym) (%unbound-marker)))) + +(defun make-symbol (name) + "Make and return a new symbol with the NAME as its print name." + (symvector->symptr + (%gvector target::subtag-symbol + (ensure-simple-string name) ; pname + (%unbound-marker) ; value cell + %unbound-function% ; function cell + nil ; package&predicate + 0 ; flags + nil ; plist + 0))) ; binding-index + +(defun %symbol-bits (sym &optional new) + (let* ((p (%symbol->symptr sym)) + (bits (%svref (symptr->symvector p) target::symbol.flags-cell))) + (if new + (setf (%svref (symptr->symvector p) target::symbol.flags-cell) new)) + bits)) + +(defun %sym-value (name) + (%symptr-value (%symbol->symptr name))) + +(defun %set-sym-value (name val) + (%set-symptr-value (%symbol->symptr name) val)) + +(defun %sym-global-value (name) + (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell)) + +(defun %set-sym-global-value (name val) + (setf (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell) val)) + +(defun symbol-name (sym) + "Return SYMBOL's name as a string." + #+(or ppc32-target x8632-target x8664-target) + (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell) + #+ppc64-target + (if sym ;NIL's pname is implicit + (%svref (%symbol->symptr sym) ppc64::symbol.pname-cell) + "NIL") + ) + + + + +(defun %global-macro-function (symbol) + (let* ((fbinding (fboundp symbol))) + (if (and (typep fbinding 'simple-vector) + (= (the fixnum (uvsize fbinding)) 2)) + (let* ((fun (%svref fbinding 1))) + (if (functionp fun) fun))))) + +(defun %symbol-binding-address (sym) + (%symptr-binding-address (%symbol->symptr sym))) + +(defun symbol-binding-index (sym) + (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)) + +(defvar *interrupt-level* -1) + +;;; Special binding indices, and the inverse mapping between indices +;;; and symbols +(let* ((binding-index-lock (make-lock)) + (binding-index-reverse-map (make-hash-table :test #'eq :weak :value)) + (next-binding-index 0)) + (defun %set-binding-index (val) (setq next-binding-index val)) + (defun next-binding-index () (1+ next-binding-index)) + (defun ensure-binding-index (sym) + (with-lock-grabbed (binding-index-lock) + (let* ((symvec (symptr->symvector (%symbol->symptr sym))) + (idx (%svref symvec target::symbol.binding-index-cell)) + (bits (%symbol-bits sym))) + (declare (fixnum idx bits)) + (if (or (logbitp $sym_vbit_global bits) + (logbitp $sym_vbit_const bits)) + (unless (zerop idx) + (remhash idx binding-index-reverse-map) + (setf (%svref symvec target::symbol.binding-index-cell) 0)) + (if (zerop idx) + (let* ((new-idx (incf next-binding-index))) + (setf (%svref symvec target::symbol.binding-index-cell) new-idx) + (setf (gethash new-idx binding-index-reverse-map) sym)))) + sym))) + (defun binding-index-symbol (idx) + (with-lock-grabbed (binding-index-lock) + (gethash idx binding-index-reverse-map))) + (defun cold-load-binding-index (sym) + ;; Index may have been assigned via xloader. Update + ;; reverse map + (with-lock-grabbed (binding-index-lock) + (let* ((idx (%svref (symptr->symvector (%symbol->symptr sym)) + target::symbol.binding-index-cell))) + (declare (fixnum idx)) + (unless (zerop idx) + (setf (gethash idx binding-index-reverse-map) sym)))))) + + + Index: /branches/qres/ccl/level-0/l0-utils.lisp =================================================================== --- /branches/qres/ccl/level-0/l0-utils.lisp (revision 13564) +++ /branches/qres/ccl/level-0/l0-utils.lisp (revision 13564) @@ -0,0 +1,197 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +; l0-utils.lisp + + +(in-package "CCL") + +(defun %proclaim-notspecial (sym) + (%symbol-bits sym (logandc2 (%symbol-bits sym) (ash 1 $sym_bit_special)))) + + +(defun heap-area-name (code) + (cond ((eq code area-void) :void) + ((eq code area-cstack) :cstack) + ((eq code area-vstack) :vstack) + ((eq code area-tstack) :tstack) + ((eq code area-readonly) :readonly) + ((eq code area-watched) :watched) + ((eq code area-managed-static) :managed-static) + ((eq code area-static) :static) + ((eq code area-dynamic) :dynamic) + (t code))) + +(defun heap-area-code (name) + (case name + (:void area-void) + (:cstack area-cstack) + (:vstack area-vstack) + (:tstack area-tstack) + (:readonly area-readonly) + (:watched area-watched) + (:managed-static area-managed-static) + (:static area-static) + (:dynamic area-dynamic) + (t (if (and (fixnump name) + (<= area-readonly name area-dynamic)) + name + (heap-area-code (require-type name '(member :void :cstack :vstack :tstack + :readonly :managed-static :static :dynamic))))))) + + +;;; We MAY need a scheme for finding all of the areas in a lisp library. +(defun %map-areas (function &optional area) + (let* ((area (cond ((or (eq area t) (eq area nil)) nil) + ((consp area) (mapcar #'heap-area-code area)) ;; list of areas + (t (heap-area-code area)))) + (mincode area-readonly) + (maxcode area-dynamic)) + (declare (fixnum maxcode mincode)) + (do* ((a (%normalize-areas) (%lisp-word-ref a (ash target::area.succ (- target::fixnumshift)))) + (code area-dynamic (%lisp-word-ref a (ash target::area.code (- target::fixnumshift)))) + (dynamic t nil)) + ((= code area-void)) + (declare (fixnum code)) + (if (and (<= code maxcode) + (>= code mincode) + (or (null area) + (eql code area) + (and (consp area) (member code area)))) + (if dynamic + (walk-dynamic-area a function) + (unless (= code area-dynamic) ; ignore egc areas, 'cause walk-dynamic-area sees them. + (walk-static-area a function))))))) + + +;;; there'll be functions in static lib areas. +;;; (Well, there would be if there were really static lib areas.) + +(defun %map-lfuns (f) + (let* ((filter #'(lambda (obj) (when (= (the fixnum (typecode obj)) + target::subtag-function) + (funcall f (lfun-vector-lfun obj)))))) + (declare (dynamic-extent filter)) + (%map-areas filter '(:dynamic :static :managed-static)))) + + +(defun ensure-simple-string (s) + (cond ((simple-string-p s) s) + ((stringp s) + (let* ((len (length s)) + (new (make-string len :element-type 'base-char))) + (declare (fixnum len)(optimize (speed 3)(safety 0))) + (multiple-value-bind (ss offset) (array-data-and-offset s) + (%copy-ivector-to-ivector ss (ash offset 2) new 0 (ash len 2))) + new)) + (t (report-bad-arg s 'string)))) + +(defun nremove (elt list) + (let* ((handle (cons nil list)) + (splice handle)) + (declare (dynamic-extent handle)) + (loop + (if (eq elt (car (%cdr splice))) + (unless (setf (%cdr splice) (%cddr splice)) (return)) + (unless (cdr (setq splice (%cdr splice))) + (return)))) + (%cdr handle))) + + +(eval-when (:compile-toplevel :execute) + #+32-bit-target + (defmacro need-use-eql-macro (key) + `(let* ((typecode (typecode ,key))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-macptr) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-numeric-subtag))))) + #+64-bit-target + (defmacro need-use-eql-macro (key) + `(let* ((typecode (typecode ,key))) + (declare (fixnum typecode)) + (cond ((= typecode target::tag-fixnum) t) + ((= typecode target::subtag-single-float) t) + ((= typecode target::subtag-bignum) t) + ((= typecode target::subtag-double-float) t) + ((= typecode target::subtag-ratio) t) + ((= typecode target::subtag-complex) t) + ((= typecode target::subtag-macptr) t)))) + +) + +(defun asseql (item list) + (if (need-use-eql-macro item) + (dolist (pair list) + (if pair + (if (eql item (car pair)) + (return pair)))) + (assq item list))) + +(defun assequal (item list) + (dolist (pair list) + (if pair + (if (equal item (car pair)) + (return pair))))) + + +;;; (memeql item list) <=> (member item list :test #'eql :key #'identity) +(defun memeql (item list) + (if (need-use-eql-macro item) + (do* ((l list (%cdr l))) + ((endp l)) + (when (eql (%car l) item) (return l))) + (memq item list))) + +(defun memequal (item list) + (do* ((l list (%cdr l))) + ((endp l)) + (when (equal (%car l) item) (return l)))) + + +; (member-test item list test-fn) +; <=> +; (member item list :test test-fn :key #'identity) +(defun member-test (item list test-fn) + (if (or (eq test-fn 'eq)(eq test-fn #'eq) + (and (or (eq test-fn 'eql)(eq test-fn #'eql)) + (not (need-use-eql-macro item)))) + (do* ((l list (cdr l))) + ((null l)) + (when (eq item (car l))(return l))) + (if (or (eq test-fn 'eql)(eq test-fn #'eql)) + (do* ((l list (cdr l))) + ((null l)) + (when (eql item (car l))(return l))) + (do* ((l list (cdr l))) + ((null l)) + (when (funcall test-fn item (car l)) (return l)))))) + +(defun s32->u32 (s32) + (%stack-block ((buf 4)) + (setf (%get-signed-long buf) s32) + (%get-unsigned-long buf))) + +(defun u32->s32 (u32) + (%stack-block ((buf 4)) + (setf (%get-unsigned-long buf) u32) + (%get-signed-long buf))) + + +; end Index: /branches/qres/ccl/level-0/nfasload.lisp =================================================================== --- /branches/qres/ccl/level-0/nfasload.lisp (revision 13564) +++ /branches/qres/ccl/level-0/nfasload.lisp (revision 13564) @@ -0,0 +1,1157 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + +(require "FASLENV" "ccl:xdump;faslenv") + + +(defconstant $primsizes (make-array 23 + :element-type '(unsigned-byte 16) + :initial-contents + '(41 61 97 149 223 337 509 769 887 971 1153 1559 1733 + 2609 2801 3917 5879 8819 13229 19843 24989 29789 32749))) +(defconstant $hprimes (make-array 8 + :element-type '(unsigned-byte 16) + :initial-contents '(5 7 11 13 17 19 23 29))) + +;;; Symbol hash tables: (htvec . (hcount . hlimit)) + +(defmacro htvec (htab) `(%car ,htab)) +(defmacro htcount (htab) `(%cadr ,htab)) +(defmacro htlimit (htab) `(%cddr ,htab)) +) + +(eval-when (:execute :compile-toplevel) + (assert (= 80 numfaslops))) + + + + + +(defvar *fasl-dispatch-table* #80(%bad-fasl)) + + + + + +(defun %bad-fasl (s) + (error "bad opcode near position ~d in FASL file ~s" + (%fasl-get-file-pos s) + (faslstate.faslfname s))) + +(defun %cant-epush (s) + (if (faslstate.faslepush s) + (%bad-fasl s))) + +(defun %epushval (s val) + (setf (faslstate.faslval s) val) + (when (faslstate.faslepush s) + (setf (svref (faslstate.faslevec s) (faslstate.faslecnt s)) val) + (incf (the fixnum (faslstate.faslecnt s)))) + val) + +(defun %simple-fasl-read-buffer (s) + (let* ((fd (faslstate.faslfd s)) + (buffer (faslstate.iobuffer s)) + (bufptr (%get-ptr buffer))) + (declare (dynamic-extent bufptr) + (type macptr buffer bufptr)) + (%setf-macptr bufptr (%inc-ptr buffer target::node-size)) + (setf (%get-ptr buffer) bufptr) + (let* ((n (fd-read fd bufptr $fasl-buf-len))) + (declare (fixnum n)) + (if (> n 0) + (setf (faslstate.bufcount s) n) + (error "Fix this: look at errno, EOF"))))) + + +(defun %simple-fasl-read-byte (s) + (loop + (let* ((buffer (faslstate.iobuffer s)) + (bufptr (%get-ptr buffer))) + (declare (dynamic-extent bufptr) + (type macptr buffer bufptr)) + (if (>= (the fixnum (decf (the fixnum (faslstate.bufcount s)))) + 0) + (return + (prog1 + (%get-unsigned-byte bufptr) + (setf (%get-ptr buffer) + (%incf-ptr bufptr)))) + (%fasl-read-buffer s))))) + +(defun %fasl-read-word (s) + (the fixnum + (logior (the fixnum (ash (the fixnum (%fasl-read-byte s)) 8)) + (the fixnum (%fasl-read-byte s))))) + + +(defun %fasl-read-long (s) + (logior (ash (%fasl-read-word s) 16) (%fasl-read-word s))) + +(defun %fasl-read-signed-long (s) + (logior (ash (%word-to-int (%fasl-read-word s)) 16) + (%fasl-read-word s))) + + +(defun %fasl-read-count (s) + (do* ((val 0) + (shift 0 (+ shift 7)) + (done nil)) + (done val) + (let* ((b (%fasl-read-byte s))) + (declare (type (unsigned-byte 8) b)) + (setq done (logbitp 7 b) val (logior val (ash (logand b #x7f) shift)))))) + +(defun %simple-fasl-read-n-bytes (s ivector byte-offset n) + (declare (fixnum byte-offset n)) + (do* () + ((= n 0)) + (let* ((count (faslstate.bufcount s)) + (buffer (faslstate.iobuffer s)) + (bufptr (%get-ptr buffer)) + (nthere (if (< count n) count n))) + (declare (dynamic-extent bufptr) + (type macptr buffer bufptr) + (fixnum count nthere)) + (if (= nthere 0) + (%fasl-read-buffer s) + (progn + (decf n nthere) + (decf (the fixnum (faslstate.bufcount s)) nthere) + (%copy-ptr-to-ivector bufptr 0 ivector byte-offset nthere) + (incf byte-offset nthere) + (setf (%get-ptr buffer) + (%incf-ptr bufptr nthere))))))) + + +(defun %fasl-vreadstr (s) + (let* ((nbytes (%fasl-read-count s)) + (copy t) + (n nbytes) + (str (faslstate.faslstr s))) + (declare (fixnum n nbytes)) + (if (> n (length str)) + (setq str (make-string n :element-type 'base-char)) + (setq copy nil)) + (%fasl-read-n-bytes s str 0 nbytes) + (values str n copy))) + + +(defun %fasl-read-n-string (s string start n) + (declare (fixnum start n)) + (do* ((i start (1+ i)) + (n n (1- n))) + ((<= n 0)) + (declare (fixnum i n)) + (setf (schar string i) (code-char (%fasl-read-count s))))) + +(defun %fasl-nvreadstr (s) + (let* ((nchars (%fasl-read-count s)) + (copy t) + (n nchars) + (str (faslstate.faslstr s))) + (declare (fixnum n nchars)) + (if (> n (length str)) + (setq str (make-string n :element-type 'base-char)) + (setq copy nil)) + (%fasl-read-n-string s str 0 nchars) + (values str n copy))) + +(defun %fasl-copystr (str len) + (declare (fixnum len)) + (let* ((new (make-string len :element-type 'base-char))) + (declare (simple-base-string new)) + (declare (optimize (speed 3)(safety 0))) + (dotimes (i len new) + (setf (schar new i) (schar str i))))) + +(defun %fasl-dispatch (s op) + (declare (fixnum op)) + (setf (faslstate.faslepush s) (logbitp $fasl-epush-bit op)) + #+debug + (format t "~& dispatch: op = ~d at ~x" (logand op (lognot (ash 1 $fasl-epush-bit))) + (1- (%fasl-get-file-pos s))) + (funcall (svref (faslstate.fasldispatch s) (logand op (lognot (ash 1 $fasl-epush-bit)))) + s)) + +(defun %fasl-expr (s) + (%fasl-dispatch s (%fasl-read-byte s)) + (faslstate.faslval s)) + +(defun %fasl-expr-preserve-epush (s) + (let* ((epush (faslstate.faslepush s)) + (val (%fasl-expr s))) + (setf (faslstate.faslepush s) epush) + val)) + + +(defun %fasl-vmake-symbol (s &optional idx) + (let* ((n (%fasl-read-count s)) + (str (make-string n :element-type 'base-char))) + (declare (fixnum n)) + (%fasl-read-n-bytes s str 0 n) + (let* ((sym (make-symbol str))) + (when idx (ensure-binding-index sym)) + (%epushval s sym)))) + +(defun %fasl-nvmake-symbol (s &optional idx) + (let* ((n (%fasl-read-count s)) + (str (make-string n :element-type 'base-char))) + (declare (fixnum n)) + (%fasl-read-n-string s str 0 n) + (let* ((sym (make-symbol str))) + (when idx (ensure-binding-index sym)) + (%epushval s sym)))) + +(defun %fasl-vintern (s package &optional binding-index) + (multiple-value-bind (str len new-p) (%fasl-vreadstr s) + (with-package-lock (package) + (multiple-value-bind (symbol access internal-offset external-offset) + (%find-symbol str len package) + (unless access + (unless new-p (setq str (%fasl-copystr str len))) + (setq symbol (%add-symbol str package internal-offset external-offset))) + (when binding-index + (ensure-binding-index symbol)) + (%epushval s symbol))))) + +(defun %fasl-nvintern (s package &optional binding-index) + (multiple-value-bind (str len new-p) (%fasl-nvreadstr s) + (with-package-lock (package) + (multiple-value-bind (symbol access internal-offset external-offset) + (%find-symbol str len package) + (unless access + (unless new-p (setq str (%fasl-copystr str len))) + (setq symbol (%add-symbol str package internal-offset external-offset))) + (when binding-index + (ensure-binding-index symbol)) + (%epushval s symbol))))) + +(defvar *package-refs*) +(setq *package-refs* (make-hash-table :test #'equal)) +(defvar *package-refs-lock*) +(setq *package-refs-lock* (make-lock)) + +(defun register-package-ref (name) + (unless (typep name 'string) + (report-bad-arg name 'string)) + (let* ((ref + (or (gethash name *package-refs*) + (with-lock-grabbed (*package-refs-lock*) + (or + (gethash name *package-refs*) ; check again + (let* ((r (make-package-ref name))) + (setf (gethash name *package-refs*) r))))))) + (unless (package-ref.pkg ref) + (setf (package-ref.pkg ref) (find-package name))) + ref)) + + +(dolist (p %all-packages%) + (dolist (name (pkg.names p)) + (setf (package-ref.pkg (register-package-ref name)) p))) + + +(defun find-package (name) + (if (typep name 'package) + name + (%find-pkg (string name)))) + +(defun %pkg-ref-find-package (ref) + (package-ref.pkg ref)) + +(defun set-package (name &aux (pkg (find-package name))) + (if pkg + (setq *package* pkg) + (set-package (%kernel-restart $xnopkg name)))) + + +(defun %find-pkg (name &optional (len (length name))) + (declare (fixnum len)) + (with-package-list-read-lock + (dolist (p %all-packages%) + (if (dolist (pkgname (pkg.names p)) + (when (and (= (the fixnum (length pkgname)) len) + (dotimes (i len t) + ;; Aref: allow non-simple strings + (unless (eq (aref name i) (schar pkgname i)) + (return)))) + (return t))) + (return p))))) + + + +(defun pkg-arg (thing &optional deleted-ok) + (let* ((xthing (cond ((or (symbolp thing) (typep thing 'character)) + (string thing)) + ((typep thing 'string) + (ensure-simple-string thing)) + (t + thing)))) + (let* ((typecode (typecode xthing))) + (declare (fixnum typecode)) + (cond ((= typecode target::subtag-package) + (if (or deleted-ok (pkg.names xthing)) + xthing + (error "~S is a deleted package ." thing))) + ((= typecode target::subtag-simple-base-string) + (or (%find-pkg xthing) + (%kernel-restart $xnopkg xthing))) + (t (report-bad-arg thing 'simple-string)))))) + +(defun %fasl-vpackage (s) + (multiple-value-bind (str len new-p) (%fasl-vreadstr s) + (let* ((p (%find-pkg str len))) + (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))) + + +(defun %fasl-nvpackage (s) + (multiple-value-bind (str len new-p) (%fasl-nvreadstr s) + (let* ((p (%find-pkg str len))) + (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))) + +(defun %fasl-vlistX (s dotp) + (let* ((len (%fasl-read-count s))) + (declare (fixnum len)) + (let* ((val (%epushval s (cons nil nil))) + (tail val)) + (declare (type cons val tail)) + (setf (car val) (%fasl-expr s)) + (dotimes (i len) + (setf (cdr tail) (setq tail (cons (%fasl-expr s) nil)))) + (if dotp + (setf (cdr tail) (%fasl-expr s))) + (setf (faslstate.faslval s) val)))) + +(deffaslop $fasl-noop (s) + (%cant-epush s)) + + +(deffaslop $fasl-vetab-alloc (s) + (%cant-epush s) + (setf (faslstate.faslevec s) (make-array (the fixnum (%fasl-read-count s))) + (faslstate.faslecnt s) 0)) + +(deffaslop $fasl-platform (s) + (%cant-epush s) + (let* ((platform (%fasl-expr s)) + (host-platform (%get-kernel-global 'host-platform))) + (declare (fixnum platform host-platform)) + (unless (= platform host-platform) + (error "Not a native fasl file : ~s" (faslstate.faslfname s))))) + + +(deffaslop $fasl-veref (s) + (let* ((idx (%fasl-read-count s))) + (declare (fixnum idx)) + (if (>= idx (the fixnum (faslstate.faslecnt s))) + (%bad-fasl s)) + (%epushval s (svref (faslstate.faslevec s) idx)))) + +#+x86-target +;;; Read a "concatenated" lisp function, in which the machine code +;;; and constants are both contained in the same underlying uvector. +(deffaslop $fasl-clfun (s) + (let* ((size-in-elements (%fasl-read-count s)) + (size-of-code (%fasl-read-count s)) + (vector (%alloc-misc size-in-elements target::subtag-function)) + (function (function-vector-to-function vector))) + (declare (fixnum size-in-elements size-of-code)) + (%epushval s function) + (%fasl-read-n-bytes s vector 0 (ash size-of-code target::word-shift)) + #+x8632-target + (%update-self-references vector) + (do* ((numconst (- size-in-elements size-of-code)) + (i 0 (1+ i)) + (constidx size-of-code (1+ constidx))) + ((= i numconst) + (setf (faslstate.faslval s) function)) + (declare (fixnum i numconst constidx)) + (setf (%svref vector constidx) (%fasl-expr s))))) + + +(deffaslop $fasl-lfuncall (s) + (let* ((fun (%fasl-expr-preserve-epush s))) + ;(break "fun = ~s" fun) + (%epushval s (funcall fun)))) + +(deffaslop $fasl-globals (s) + (setf (faslstate.faslgsymbols s) (%fasl-expr s))) + +(deffaslop $fasl-char (s) + (%epushval s (code-char (%fasl-read-count s)))) + +;;; Deprecated +(deffaslop $fasl-fixnum (s) + (%epushval + s + (logior (the fixnum (ash (the fixnum (%word-to-int (%fasl-read-word s))) + 16)) + (the fixnum (%fasl-read-word s))) )) + +(deffaslop $fasl-s32 (s) + (%epushval s (%fasl-read-signed-long s))) + +(deffaslop $fasl-s64 (s) + (%epushval s (logior (ash (%fasl-read-signed-long s) 32) + (%fasl-read-long s)))) + +(deffaslop $fasl-dfloat (s) + ;; A double-float is a 3-element "misc" object. + ;; Element 0 is always 0 and exists solely to keep elements 1 and 2 + ;; aligned on a 64-bit boundary. + (%epushval s (double-float-from-bits (%fasl-read-long s) (%fasl-read-long s)))) + +(deffaslop $fasl-sfloat (s) + (%epushval s (host-single-float-from-unsigned-byte-32 (%fasl-read-long s)))) + +(deffaslop $fasl-vstr (s) + (let* ((n (%fasl-read-count s)) + (str (make-string (the fixnum n) :element-type 'base-char))) + (%epushval s str) + (%fasl-read-n-bytes s str 0 n))) + +(deffaslop $fasl-nvstr (s) + (let* ((n (%fasl-read-count s)) + (str (make-string (the fixnum n) :element-type 'base-char))) + (%epushval s str) + (%fasl-read-n-string s str 0 n))) + +(deffaslop $fasl-word-fixnum (s) + (%epushval s (%word-to-int (%fasl-read-word s)))) + +(deffaslop $fasl-vmksym (s) + (%fasl-vmake-symbol s)) + +(deffaslop $fasl-nvmksym (s) + (%fasl-nvmake-symbol s)) + +(deffaslop $fasl-vmksym-special (s) + (%fasl-vmake-symbol s t)) + +(deffaslop $fasl-nvmksym-special (s) + (%fasl-nvmake-symbol s t)) + +(deffaslop $fasl-vintern (s) + (%fasl-vintern s *package*)) + +(deffaslop $fasl-nvintern (s) + (%fasl-nvintern s *package*)) + +(deffaslop $fasl-vintern-special (s) + (%fasl-vintern s *package* t)) + +(deffaslop $fasl-nvintern-special (s) + (%fasl-nvintern s *package* t)) + + + + +(deffaslop $fasl-vpkg-intern (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-vintern s pkg))) + +(deffaslop $fasl-nvpkg-intern (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-nvintern s pkg))) + +(deffaslop $fasl-vpkg-intern-special (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-vintern s pkg t))) + +(deffaslop $fasl-nvpkg-intern-special (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-nvintern s pkg t))) + +(deffaslop $fasl-vpkg (s) + (%fasl-vpackage s)) + +(deffaslop $fasl-nvpkg (s) + (%fasl-nvpackage s)) + +(deffaslop $fasl-cons (s) + (let* ((cons (%epushval s (cons nil nil)))) + (declare (type cons cons)) + (setf (car cons) (%fasl-expr s) + (cdr cons) (%fasl-expr s)) + (setf (faslstate.faslval s) cons))) + +(deffaslop $fasl-vlist (s) + (%fasl-vlistX s nil)) + +(deffaslop $fasl-vlist* (s) + (%fasl-vlistX s t)) + +(deffaslop $fasl-nil (s) + (%epushval s nil)) + +(deffaslop $fasl-timm (s) + (rlet ((p :int)) + (setf (%get-long p) (%fasl-read-long s)) + (%epushval s (%get-unboxed-ptr p)))) + +(deffaslop $fasl-symfn (s) + (%epushval s (%function (%fasl-expr-preserve-epush s)))) + +(deffaslop $fasl-eval (s) + (%epushval s (eval (%fasl-expr-preserve-epush s)))) + +;;; For bootstrapping. The real version is cheap-eval in l1-readloop +(when (not (fboundp 'eval)) + (defun eval (form) + (if (and (listp form) + (let ((f (%car form))) + (and (symbolp f) + (functionp (fboundp f))))) + (do* ((tail (%cdr form) (%cdr tail))) + ((null tail) (apply (%car form) (%cdr form))) + (let* ((head (car tail))) + (when (and (consp head) (eq (car head) 'quote)) + (setf (car tail) (cadr head))))) + (error "Can't eval yet: ~s" form)))) + + +(deffaslop $fasl-vivec (s) + (let* ((subtag (%fasl-read-byte s)) + (element-count (%fasl-read-count s)) + (size-in-bytes (subtag-bytes subtag element-count)) + (vector (%alloc-misc element-count subtag)) + (byte-offset (or #+32-bit-target (if (= subtag target::subtag-double-float-vector) 4) 0))) + (declare (fixnum subtag element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector byte-offset size-in-bytes) + vector)) + +(defun fasl-read-ivector (s subtag) + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (subtag-bytes subtag element-count)) + (vector (%alloc-misc element-count subtag))) + (declare (fixnum subtag element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector 0 size-in-bytes) + vector)) + +(deffaslop $fasl-u8-vector (s) + (fasl-read-ivector s target::subtag-u8-vector)) + +(deffaslop $fasl-s8-vector (s) + (fasl-read-ivector s target::subtag-s8-vector)) + +(deffaslop $fasl-u16-vector (s) + (fasl-read-ivector s target::subtag-u16-vector)) + +(deffaslop $fasl-s16-vector (s) + (fasl-read-ivector s target::subtag-s16-vector)) + +(deffaslop $fasl-u32-vector (s) + (fasl-read-ivector s target::subtag-u32-vector)) + +(deffaslop $fasl-s32-vector (s) + (fasl-read-ivector s target::subtag-s32-vector)) + +#+64-bit-target +(deffaslop $fasl-u64-vector (s) + (fasl-read-ivector s target::subtag-u64-vector)) + +#+64-bit-target +(deffaslop $fasl-u64-vector (s) + (fasl-read-ivector s target::subtag-s64-vector)) + +(deffaslop $fasl-bit-vector (s) + (fasl-read-ivector s target::subtag-bit-vector)) + +(deffaslop $fasl-bignum32 (s) + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (* element-count 4)) + (num (%alloc-misc element-count target::subtag-bignum))) + (declare (fixnum element-count size-in-bytes)) + (%fasl-read-n-bytes s num 0 size-in-bytes) + (setq num (%normalize-bignum-2 t num)) + (%epushval s num) + num)) + +(deffaslop $fasl-single-float-vector (s) + (fasl-read-ivector s target::subtag-single-float-vector)) + +(deffaslop $fasl-double-float-vector (s) + #+64-bit-target + (fasl-read-ivector s target::subtag-double-float-vector) + #+32-bit-target + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (subtag-bytes target::subtag-double-float-vector + element-count)) + (vector (%alloc-misc element-count + target::subtag-double-float-vector))) + (declare (fixnum element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector (- target::misc-dfloat-offset + target::misc-data-offset) + size-in-bytes) + vector)) + + + +#-x86-target +(deffaslop $fasl-code-vector (s) + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (* 4 element-count)) + (vector (allocate-typed-vector :code-vector element-count))) + (declare (fixnum element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector 0 size-in-bytes) + (%make-code-executable vector) + vector)) + +(defun fasl-read-gvector (s subtype) + (let* ((n (%fasl-read-count s)) + (vector (%alloc-misc n subtype))) + (declare (fixnum n subtype)) + (%epushval s vector) + (dotimes (i n (setf (faslstate.faslval s) vector)) + (setf (%svref vector i) (%fasl-expr s))))) + +(deffaslop $fasl-vgvec (s) + (let* ((subtype (%fasl-read-byte s))) + (fasl-read-gvector s subtype))) + +(deffaslop $fasl-ratio (s) + (let* ((r (%alloc-misc target::ratio.element-count target::subtag-ratio))) + (%epushval s r) + (setf (%svref r target::ratio.numer-cell) (%fasl-expr s) + (%svref r target::ratio.denom-cell) (%fasl-expr s)) + (setf (faslstate.faslval s) r))) + +(deffaslop $fasl-complex (s) + (let* ((c (%alloc-misc target::complex.element-count + target::subtag-complex))) + (%epushval s c) + (setf (%svref c target::complex.realpart-cell) (%fasl-expr s) + (%svref c target::complex.imagpart-cell) (%fasl-expr s)) + (setf (faslstate.faslval s) c))) + +(deffaslop $fasl-t-vector (s) + (fasl-read-gvector s target::subtag-simple-vector)) + +(deffaslop $fasl-function (s) + (fasl-read-gvector s target::subtag-function)) + +(deffaslop $fasl-istruct (s) + (fasl-read-gvector s target::subtag-istruct)) + +(deffaslop $fasl-vector-header (s) + (fasl-read-gvector s target::subtag-vectorH)) + +(deffaslop $fasl-array-header (s) + (fasl-read-gvector s target::subtag-arrayH)) + + +(deffaslop $fasl-defun (s) + (%cant-epush s) + (%defun (%fasl-expr s) (%fasl-expr s))) + +(deffaslop $fasl-macro (s) + (%cant-epush s) + (%macro (%fasl-expr s) (%fasl-expr s))) + +(deffaslop $fasl-defconstant (s) + (%cant-epush s) + (%defconstant (%fasl-expr s) (%fasl-expr s) (%fasl-expr s))) + +(deffaslop $fasl-defparameter (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s)) + (val (%fasl-expr s))) + (%defvar sym (%fasl-expr s)) + (set sym val))) + +;;; (defvar var) +(deffaslop $fasl-defvar (s) + (%cant-epush s) + (%defvar (%fasl-expr s))) + +;;; (defvar var initfom doc) +(deffaslop $fasl-defvar-init (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s)) + (val (%fasl-expr s))) + (unless (%defvar sym (%fasl-expr s)) + (set sym val)))) + + +(deffaslop $fasl-prog1 (s) + (let* ((val (%fasl-expr s))) + (%fasl-expr s) + (setf (faslstate.faslval s) val))) + + + +(deffaslop $fasl-src (s) + (%cant-epush s) + (let* ((source-file (%fasl-expr s))) + ; (format t "~& source-file = ~s" source-file) + (setq *loading-file-source-file* source-file))) + +(deffaslop $fasl-toplevel-location (s) + (%cant-epush s) + (setq *loading-toplevel-location* (%fasl-expr s))) + +(defvar *modules* nil) + +;;; Bootstrapping version +(defun provide (module-name) + (push (string module-name) *modules*)) + +(deffaslop $fasl-provide (s) + (provide (%fasl-expr s))) + +(deffaslop $fasl-istruct-cell (s) + (%epushval s (register-istruct-cell (%fasl-expr-preserve-epush s)))) + + + +;;; files compiled with code coverage do this +;; list of lfuns and (source-fn-name . vector-of-lfuns), the latter put there by fasloading. +(defvar *code-covered-functions* nil) + +(defun register-code-covered-functions (functions) + ;; unpack the parent-note references - see comment at fcomp-digest-code-notes + (labels ((reg (lfun refs) + (unless (memq lfun refs) + (let* ((lfv (function-to-function-vector lfun)) + (start #+ppc-target 0 #+x86-target (%function-code-words lfun)) + (refs (cons lfun refs))) + (declare (dynamic-extent refs)) + (loop for i from start below (uvsize lfv) as imm = (uvref lfv i) + do (typecase imm + (code-note + (let ((parent (code-note-parent-note imm))) + (when (integerp parent) + (setf (code-note-parent-note imm) (uvref lfv parent))))) + (function (reg imm refs)))))))) + (loop for fn across functions do (reg fn nil))) + (let ((a (assoc (pathname *loading-file-source-file*) + *code-covered-functions* + :test #'(lambda (p q) + (and (equalp (pathname-name p) (pathname-name q)) + ;; same name, so worth trying harder to match 'em up. + (or (equal p q) + (let ((p (full-pathname p)) (q (full-pathname q))) + (and p q (equalp p q))) + (let ((p (probe-file p)) (q (probe-file q))) + (and p q (equalp p q))))))))) + (when (null a) + (push (setq a (list nil nil)) *code-covered-functions*)) + (setf (car a) *loading-file-source-file* (cdr a) functions)) + nil) + +;;; The loader itself + +(defun %simple-fasl-set-file-pos (s new) + (let* ((fd (faslstate.faslfd s)) + (posoffset (fd-tell fd))) + (if (>= (decf posoffset new) 0) + (let* ((count (faslstate.bufcount s))) + (if (>= (decf count posoffset ) 0) + (progn + (setf (faslstate.bufcount s) posoffset) + (incf #+32-bit-target (%get-long (faslstate.iobuffer s)) + #+64-bit-target (%%get-signed-longlong (faslstate.iobuffer s) + 0) + count) + (return-from %simple-fasl-set-file-pos nil))))) + (progn + (setf (faslstate.bufcount s) 0) + (fd-lseek fd new #$SEEK_SET)))) + +(defun %simple-fasl-get-file-pos (s) + (- (fd-tell (faslstate.faslfd s)) (faslstate.bufcount s))) + +(defparameter *%fasload-verbose* t) + +;;; the default fasl file opener sets up the fasl state and checks the header +(defun %simple-fasl-open (string s) + (let* ((ok nil) + (fd (fd-open string #$O_RDONLY)) + (err 0)) + (declare (fixnum fd)) + (if (>= fd 0) + (if (< (fd-lseek fd 0 #$SEEK_END) 4) + (setq err $xnotfasl) + (progn + (setq err 0) + (setf (faslstate.bufcount s) 0 + (faslstate.faslfd s) fd) + (fd-lseek fd 0 #$SEEK_SET) + (multiple-value-setq (ok err) (%fasl-check-header s)))) + (setq err fd)) + (unless (eql err 0) (setf (faslstate.faslerr s) err)) + ok)) + +;;; once the fasl state is set up, this checks the fasl header and +;;; returns (values ok err) +(defun %fasl-check-header (s) + (let* ((signature (%fasl-read-word s))) + (declare (fixnum signature)) + (if (= signature $fasl-file-id) + (values t 0) + (if (= signature $fasl-file-id1) + (progn + (%fasl-set-file-pos s (%fasl-read-long s)) + (values t 0)) + (values nil $xnotfasl))))) + +(defun %simple-fasl-close (s) + (let* ((fd (faslstate.faslfd s))) + (when fd (fd-close fd)))) + +(defun %simple-fasl-init-buffer (s) + (declare (ignore s)) + nil) + +(defvar *fasl-api* nil) +(setf *fasl-api* (%istruct 'faslapi + #'%simple-fasl-open + #'%simple-fasl-close + #'%simple-fasl-init-buffer + #'%simple-fasl-set-file-pos + #'%simple-fasl-get-file-pos + #'%simple-fasl-read-buffer + #'%simple-fasl-read-byte + #'%simple-fasl-read-n-bytes)) + +(defun %fasl-open (string s) + (funcall (faslapi.fasl-open *fasl-api*) string s)) +(defun %fasl-close (s) + (funcall (faslapi.fasl-close *fasl-api*) s)) +(defun %fasl-init-buffer (s) + (funcall (faslapi.fasl-init-buffer *fasl-api*) s)) +(defun %fasl-set-file-pos (s new) + (funcall (faslapi.fasl-set-file-pos *fasl-api*) s new)) +(defun %fasl-get-file-pos (s) + (funcall (faslapi.fasl-get-file-pos *fasl-api*) s)) +(defun %fasl-read-buffer (s) + (funcall (faslapi.fasl-read-buffer *fasl-api*) s)) +(defun %fasl-read-byte (s) + (funcall (faslapi.fasl-read-byte *fasl-api*) s)) +(defun %fasl-read-n-bytes (s ivector byte-offset n) + (funcall (faslapi.fasl-read-n-bytes *fasl-api*) s ivector byte-offset n)) + +(defun %fasload (string &optional (table *fasl-dispatch-table*)) + ;;(dbg string) + (when (and *%fasload-verbose* + (not *load-verbose*)) + (%string-to-stderr ";Loading ") (pdbg string)) + (let* ((s (%istruct + 'faslstate + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil))) + (declare (dynamic-extent s)) + (setf (faslstate.faslfname s) string) + (setf (faslstate.fasldispatch s) table) + (setf (faslstate.faslversion s) 0) + (%stack-block ((buffer (+ target::node-size $fasl-buf-len))) + (setf (faslstate.iobuffer s) buffer) + (%fasl-init-buffer s) + (let* ((parse-string (make-string 255 :element-type 'base-char))) + (declare (dynamic-extent parse-string)) + (setf (faslstate.oldfaslstr s) nil + (faslstate.faslstr s) parse-string) + (unwind-protect + (when (%fasl-open string s) + (let* ((nblocks (%fasl-read-word s))) + (declare (fixnum nblocks)) + (unless (= nblocks 0) + (let* ((pos (%fasl-get-file-pos s))) + (dotimes (i nblocks) + (%fasl-set-file-pos s pos) + (%fasl-set-file-pos s (%fasl-read-long s)) + (incf pos 8) + (let* ((version (%fasl-read-word s))) + (declare (fixnum version)) + (if (or (> version (+ #xff00 $fasl-vers)) + (< version (+ #xff00 $fasl-min-vers))) + (%err-disp (if (>= version #xff00) $xfaslvers $xnotfasl)) + (progn + (setf (faslstate.faslversion s) version) + (%fasl-read-word s) + (%fasl-read-word s) ; Ignore kernel version stuff + (setf (faslstate.faslevec s) nil + (faslstate.faslecnt s) 0) + (do* ((op (%fasl-read-byte s) (%fasl-read-byte s))) + ((= op $faslend)) + (declare (fixnum op)) + (%fasl-dispatch s op)))))))))) + (%fasl-close s)) + (let* ((err (faslstate.faslerr s))) + (if err + (progn + (when *%fasload-verbose* + (let* ((herald ";!!Error loading ") + (hlen (length herald)) + (len (length string)) + (msg (make-string (+ hlen len)))) + (declare (dynamic-extent msg)) + (%copy-ivector-to-ivector herald 0 msg 0 (* hlen 4)) + (%copy-ivector-to-ivector string 0 msg (* hlen 4) (* len 4)) + (bug msg))) + (values nil err)) + (values t nil))))))) + + +(defun %new-package-hashtable (size) + (%initialize-htab (cons nil (cons 0 0)) size)) + +(defun %initialize-htab (htab size) + (declare (fixnum size)) + ;; Ensure that "size" is relatively prime to all secondary hash values. + ;; If it's small enough, pick the next highest known prime out of the + ;; "primsizes" array. Otherwize, iterate through all all of "hprimes" + ;; until we find something relatively prime to all of them. + (setq size + (if (> size 32749) + (do* ((nextsize (logior 1 size) (+ nextsize 2))) + () + (declare (fixnum nextsize)) + (when (dotimes (i 8 t) + (unless (eql 1 (gcd nextsize (uvref #.$hprimes i))) + (return))) + (return nextsize))) + (dotimes (i (the fixnum (length #.$primsizes))) + (let* ((psize (uvref #.$primsizes i))) + (declare (fixnum psize)) + (if (>= psize size) + (return psize)))))) + (setf (htvec htab) (make-array size #|:initial-element 0|#)) + (setf (htcount htab) 0) + (setf (htlimit htab) (the fixnum (- size (the fixnum (ash size -3))))) + htab) + + +(defun %resize-htab (htab) + (declare (optimize (speed 3) (safety 0))) + (without-interrupts + (let* ((old-vector (htvec htab)) + (old-len (length old-vector))) + (declare (fixnum old-len) + (simple-vector old-vector)) + (let* ((nsyms 0)) + (declare (fixnum nsyms)) + (dovector (s old-vector) + (when (symbolp s) (incf nsyms))) + (%initialize-htab htab + (the fixnum (+ + (the fixnum + (+ nsyms (the fixnum (ash nsyms -2)))) + 2))) + (let* ((new-vector (htvec htab)) + (nnew 0)) + (declare (fixnum nnew) + (simple-vector new-vector)) + (dotimes (i old-len (setf (htcount htab) nnew)) + (let* ((s (svref old-vector i))) + (if (symbolp s) + (let* ((pname (symbol-name s))) + (setf (svref + new-vector + (nth-value + 2 + (%get-htab-symbol + pname + (length pname) + htab))) + s) + (incf nnew))))) + htab))))) + +(defun hash-pname (str len) + (declare (optimize (speed 3) (safety 0))) + (let* ((primary (%pname-hash str len))) + (declare (fixnum primary)) + (values primary (aref (the (simple-array (unsigned-byte 16) (8)) $hprimes) (logand primary 7))))) + + + +(defun %get-hashed-htab-symbol (str len htab primary secondary) + (declare (optimize (speed 3) (safety 0)) + (fixnum primary secondary len)) + (let* ((vec (htvec htab)) + (vlen (length vec))) + (declare (fixnum vlen)) + (do* ((idx (fast-mod primary vlen) (+ i secondary)) + (i idx (if (>= idx vlen) (- idx vlen) idx)) + (elt (svref vec i) (svref vec i))) + ((eql elt 0) (values nil nil i)) + (declare (fixnum i idx)) + (when (symbolp elt) + (let* ((pname (symbol-name elt))) + (if (and + (= (the fixnum (length pname)) len) + (dotimes (j len t) + (unless (eq (aref str j) (schar pname j)) + (return)))) + (return (values t (%symptr->symbol elt) i)))))))) + +(defun %get-htab-symbol (string len htab) + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (p s) (hash-pname string len) + (%get-hashed-htab-symbol string len htab p s))) + +(defun %find-symbol (string len package) + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (found-p sym internal-offset) + (%get-htab-symbol string len (pkg.itab package)) + (if found-p + (values sym :internal internal-offset nil) + (multiple-value-bind (found-p sym external-offset) + (%get-htab-symbol string len (pkg.etab package)) + (if found-p + (values sym :external internal-offset external-offset) + (dolist (p (pkg.used package) (values nil nil internal-offset external-offset)) + (multiple-value-bind (found-p sym) + (%get-htab-symbol string len (pkg.etab p)) + (when found-p + (return (values sym :inherited internal-offset external-offset)))))))))) + +(defun %htab-add-symbol (symbol htab idx) + (declare (optimize (speed 3) (safety 0))) + (setf (svref (htvec htab) idx) (%symbol->symptr symbol)) + (if (>= (incf (the fixnum (htcount htab))) + (the fixnum (htlimit htab))) + (%resize-htab htab)) + symbol) + +(defun %set-symbol-package (symbol package-or-nil) + (declare (optimize (speed 3) (safety 0))) + (let* ((symvec (symptr->symvector (%symbol->symptr symbol))) + (old-pp (%svref symvec target::symbol.package-predicate-cell))) + (if (consp old-pp) + (setf (car old-pp) package-or-nil) + (setf (%svref symvec target::symbol.package-predicate-cell) package-or-nil)))) + + +(let* ((force-export-packages (list *keyword-package*)) + (force-export-packages-lock (make-lock))) + (defun force-export-packages () + (with-lock-grabbed (force-export-packages-lock) + (copy-list force-export-packages))) + (defun package-force-export (p) + (let* ((pkg (pkg-arg p))) + (with-lock-grabbed (force-export-packages-lock) + (pushnew pkg force-export-packages)) + pkg)) + (defun force-export-package-p (pkg) + (with-lock-grabbed (force-export-packages-lock) + (if (memq pkg force-export-packages) + t)))) + + +(defun %insert-symbol (symbol package internal-idx external-idx &optional force-export) + (let* ((symvec (symptr->symvector (%symbol->symptr symbol))) + (package-predicate (%svref symvec target::symbol.package-predicate-cell)) + (keyword-package (eq package *keyword-package*))) + ;; Set home package + (if package-predicate + (if (listp package-predicate) + (unless (%car package-predicate) (%rplaca package-predicate package))) + (setf (%svref symvec target::symbol.package-predicate-cell) package)) + (if (or force-export (force-export-package-p package)) + (progn + (%htab-add-symbol symbol (pkg.etab package) external-idx) + (if keyword-package + ;;(define-constant symbol symbol) + (progn + (%set-sym-global-value symbol symbol) + (%symbol-bits symbol + (logior (ash 1 $sym_vbit_special) + (ash 1 $sym_vbit_const) + (the fixnum (%symbol-bits symbol))))))) + (%htab-add-symbol symbol (pkg.itab package) internal-idx)) + (let* ((hook (pkg.intern-hook package))) + (when hook (funcall hook symbol))) + symbol)) + +;;; PNAME must be a simple string! +(defun %add-symbol (pname package internal-idx external-idx &optional force-export) + (let* ((sym (make-symbol pname))) + (%insert-symbol sym package internal-idx external-idx force-export))) + + + + +;;; The initial %toplevel-function% sets %toplevel-function% to NIL; +;;; if the %fasload call fails, the lisp should exit (instead of +;;; repeating the process endlessly ... + + +(defvar %toplevel-function% + #'(lambda () + (declare (special *xload-cold-load-functions* + *xload-cold-load-documentation* + *xload-startup-file* + *early-class-cells*)) + (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot. + (setq %system-locks% (%cons-population nil)) + ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually + ;; do SET-PACKAGE in cold load functions. + (setq %all-packages-lock% (make-read-write-lock)) + (dolist (f (prog1 *xload-cold-load-functions* (setq *xload-cold-load-functions* nil))) + (funcall f)) + (dolist (pair (prog1 *early-class-cells* (setq *early-class-cells* nil))) + (setf (gethash (car pair) %find-classes%) (cdr pair))) + (dolist (p %all-packages%) + (%resize-htab (pkg.itab p)) + (%resize-htab (pkg.etab p))) + (dolist (f (prog1 *xload-cold-load-documentation* (setq *xload-cold-load-documentation* nil))) + (apply 'set-documentation f)) + ;; Can't bind any specials until this happens + (let* ((max 0)) + (%map-areas #'(lambda (symvec) + (when (= (the fixnum (typecode symvec)) + target::subtag-symbol) + (let* ((s (symvector->symptr symvec)) + (idx (symbol-binding-index s))) + (when (> idx 0) + (cold-load-binding-index s)) + (when (> idx max) + (setq max idx)))))) + (%set-binding-index max)) + (%fasload *xload-startup-file*))) + Index: /branches/qres/ccl/level-1/.cvsignore =================================================================== --- /branches/qres/ccl/level-1/.cvsignore (revision 13564) +++ /branches/qres/ccl/level-1/.cvsignore (revision 13564) @@ -0,0 +1,1 @@ +*~.* Index: /branches/qres/ccl/level-1/l1-application.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-application.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-application.lisp (revision 13564) @@ -0,0 +1,314 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions Copyright (C) 2001-2009, Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; Application classes + +(defstruct command-line-argument + keyword + help-string + option-char + long-name + may-take-operand + allow-multiple ; option can appear multiple times +) + +(defvar *standard-help-argument* + (make-command-line-argument + :keyword :help + :help-string "this text" + :option-char #\h + :long-name "help")) + +(defvar *standard-version-argument* + (make-command-line-argument + :keyword :version + :help-string "print (LISP-IMPLEMENTATION-VERSION) and exit" + :option-char #\V + :long-name "version")) + +(defvar *standard-terminal-encoding-argument* + (make-command-line-argument + :option-char #\K + :long-name "terminal-encoding" + :help-string "specify character encoding to use for *TERMINAL-IO*" + :may-take-operand t + :keyword :terminal-encoding + :allow-multiple nil)) + +(defclass application () + ((command-line-arguments + :initform + (list *standard-help-argument* *standard-version-argument*)) + (ui-object :initform nil :initarg :ui-object :accessor application-ui-object))) + +(defclass ui-object () + ()) + +;;; It's intended that this be specialized ... +(defmethod ui-object-do-operation ((u ui-object) operation &rest args) + (declare (ignore operation args))) + + +(defun %usage-exit (banner exit-status other-args) + (with-cstrs ((banner banner) + (other-args other-args)) + (ff-call (%kernel-import target::kernel-import-usage-exit) + :address banner + :signed-fullword exit-status + :address other-args + :void))) + +(defloadvar *unprocessed-command-line-arguments* ()) + +;;; Returns four values: error-flag, options-alist, non-option-arguments, unprocessed arguments +(defmethod parse-application-arguments ((a application)) + (let* ((cla (slot-value a 'command-line-arguments)) + (vals (cdr *command-line-argument-list*)) + (options ()) + (non-options ()) + (rest-arg nil)) + (do* () + ((null vals) + (values nil (nreverse options) (nreverse non-options) rest-arg)) + (let* ((val (pop vals)) + (val-len (length val)) + (short-p nil) + (option + (if (and (>= val-len 2) + (eql (schar val 0) #\-)) + (if (eql (schar val 1) #\-) + (find val cla + :key #'command-line-argument-long-name + :test #'(lambda (k v) (string= k v :start1 2))) + (progn + (setq short-p t) + (find (schar val 1) cla + :key #'command-line-argument-option-char)))))) + (if (null option) + (if (and (>= val-len 1) + (eql (schar val 0) #\-)) + (if (and (= val-len 2) + (eql (schar val 1) #\-)) + (setq rest-arg vals + vals nil) + (return (values :unknown-option val nil nil))) + (push val non-options)) ;non-option argument + ;; We recognized the option. Is it a duplicate of + ;; something already seen? + (let* ((key (command-line-argument-keyword option)) + (operand nil)) + (when (and (assoc key options) + (not (command-line-argument-allow-multiple option))) + (return (values :duplicate-option val nil))) + (when (command-line-argument-may-take-operand option) + ;; A short option name can be followed by the operand, + ;; without intervening whitespace. + (if (and short-p (> val-len 2)) + (setq operand (subseq val 2)) + (if vals + (setq operand (pop vals)) + (return (values :missing-operand val nil))))) + (push (cons key operand) options))))))) + +(defmethod summarize-option-syntax ((a application)) + (flet ((summarize-option (o) + (format nil "~8t-~a, --~a : ~a~%" + (command-line-argument-option-char o) + (command-line-argument-long-name o) + (command-line-argument-help-string o)))) + (format nil "~{~a~}" (mapcar #'summarize-option + (slot-value a 'command-line-arguments))))) + + +;;; Process the "help" and "version" options, report parsing errors. +(defmethod process-application-arguments ((a application) error-flag opts args) + (declare (ignore args)) + (if (null error-flag) + (if (assoc :help opts) + (%usage-exit "" 0 (summarize-option-syntax a)) + (if (assoc :version opts) + ;; Can't use lisp streams yet. + (progn + (with-cstrs ((s (format nil "~&~a~&" (application-version-string a)))) + (fd-write 1 s (%cstrlen s))) + (#_ _exit 0)) + (let* ((encoding (assoc :terminal-encoding opts))) + (when (cdr encoding) + (let* ((encoding-name + (let* ((*package* (find-package "KEYWORD"))) + (ignore-errors (read-from-string (cdr encoding)))))) + (when encoding-name + (let* ((character-encoding (lookup-character-encoding encoding-name))) + (when character-encoding + (setq *terminal-character-encoding-name* + (character-encoding-name character-encoding)))))))))) + (%usage-exit + (format nil + (case error-flag + (:missing-argument "Missing argument to ~a option") + (:duplicate-argument "Duplicate ~a option") + (:unknown-option "Unknown option: ~a") + (t "~a")) + opts) + #-windows-target #$EX_USAGE #+windows-target #$EXIT_FAILURE + (summarize-option-syntax a)))) + + +;;; an example method to base a specialization on +(defmethod toplevel-function ((a application) init-file) + (declare (ignore init-file)) + nil ) + +(defmethod toplevel-function :before ((a application) init-file) + (declare (ignore init-file)) + (multiple-value-bind (error-flag options args rest-arg) + (parse-application-arguments a) + (setq *unprocessed-command-line-arguments* rest-arg) + (process-application-arguments a error-flag options args) + (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))) + (when encoding + (set-terminal-encoding (character-encoding-name encoding)))))) + +(defmethod repl-function-name ((a application)) + "Return the name of a function that should be run in a TTY-like +listener thread (if that concept makes sense); return NIL otherwise." + nil) + +(defmethod application-version-string ((a application)) + "Return a string which (arbitrarily) represents the application version. +Default version returns Clozure CL version info." + (lisp-implementation-version)) + +(defmethod application-ui-operation ((a application) operation &rest args) + (let* ((ui-object (application-ui-object a))) + (when ui-object + (apply #'ui-object-do-operation ui-object operation args)))) + + + + +(defmethod application-init-file ((app application)) nil) + + +(defclass lisp-development-system (application) + ((command-line-arguments + :initform + (list *standard-help-argument* + *standard-version-argument* + *standard-terminal-encoding-argument* + (make-command-line-argument + :option-char #\n + :long-name "no-init" + :keyword :noinit + :help-string "suppress loading of init file") + (make-command-line-argument + :option-char #\e + :long-name "eval" + :keyword :eval + :help-string "evaluate
(may need to quote in shell)" + :may-take-operand t + :allow-multiple t) + (make-command-line-argument + :option-char #\l + :long-name "load" + :keyword :load + :help-string "load " + :may-take-operand t + :allow-multiple t) + (make-command-line-argument + :option-char #\T + :long-name "set-lisp-heap-gc-threshold" + :help-string "set lisp-heap-gc-threshold to " + :keyword :gc-threshold + :may-take-operand t + :allow-multiple nil) + (make-command-line-argument + :option-char #\Q + :long-name "quiet" + :help-string "if --batch, also suppress printing of heralds, prompts" + :keyword :quiet + :may-take-operand nil + :allow-multiple nil) + )) + (initial-listener-process :initform nil))) + +(defparameter *application* + (make-instance 'lisp-development-system)) + +(defvar *load-lisp-init-file* t) +(defvar *lisp-startup-parameters* ()) + +(defmethod process-application-arguments ((a lisp-development-system) + error-flag options args) + (declare (ignorable error-flag)) + (call-next-method) ; handle help, errors + (if args + (%usage-exit (format nil "Unrecognized non-option arguments: ~a" args) + #-windows-target #$EX_USAGE #+windows-target #$EXIT_FAILURE + (summarize-option-syntax a)) + (progn + (setq *load-lisp-init-file* (not (assoc :noinit options)) + *quiet-flag* (if *batch-flag* + (not (null (assoc :quiet options)))) + *lisp-startup-parameters* + (mapcan #'(lambda (x) + (and (member (car x) '(:load :eval :gc-threshold)) (list x))) + options))))) + + +(defmethod repl-function-name ((a lisp-development-system)) + 'listener-function) + +(defmethod toplevel-function ((a lisp-development-system) init-file) + (let* ((sr (input-stream-shared-resource *terminal-input*)) + (f (or (repl-function-name a) 'listener-function))) + (with-slots (initial-listener-process) a + (setq initial-listener-process + (make-mcl-listener-process + "listener" + *terminal-input* + *terminal-output* + #'(lambda () (when sr (setf (shared-resource-primary-owner sr) + *initial-process*))) + :initial-function + #'(lambda () + (startup-ccl (and *load-lisp-init-file* init-file)) + (funcall f) + nil) + :close-streams nil + :control-stack-size *initial-listener-default-control-stack-size* + :value-stack-size *initial-listener-default-value-stack-size* + :temp-stack-size *initial-listener-default-temp-stack-size* + :class 'tty-listener + :process initial-listener-process)))) + (%set-toplevel #'housekeeping-loop) + (toplevel)) + +(defun housekeeping-loop () + (with-standard-abort-handling nil + (loop + #+windows-target (#_SleepEx 333 #$true) + #-windows-target (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*) + (housekeeping)))) + + +(defmethod application-init-file ((app lisp-development-system)) + ;; This is the init file loaded before cocoa. + #+unix '("home:ccl-init" "home:\\.ccl-init") + #+windows "home:ccl-init") Index: /branches/qres/ccl/level-1/l1-aprims.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-aprims.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-aprims.lisp (revision 13564) @@ -0,0 +1,3636 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-aprims.lisp + + +(in-package "CCL") + + +(let* ((standard-initial-bindings ()) + (standard-initial-bindings-lock (make-read-write-lock))) + + (defun standard-initial-bindings () + (with-read-lock (standard-initial-bindings-lock) + (copy-list standard-initial-bindings))) + + (defun define-standard-initial-binding (symbol initform) + (setq symbol (require-type symbol 'symbol)) + (%proclaim-special symbol) + (unless (boundp symbol) + (set symbol (funcall initform))) + (with-write-lock (standard-initial-bindings-lock) + (let* ((pair (assoc symbol standard-initial-bindings))) + (if pair + (setf (cdr pair) initform) + (push (cons symbol initform) standard-initial-bindings)))) + (record-source-file symbol 'variable) + symbol)) + +(defstatic *kernel-tcr-area-lock* (%make-lock (%null-ptr) "Kernel tcr-area-lock")) + +(defstatic *kernel-exception-lock* (%make-lock (%null-ptr) "Kernel exception-lock")) + +(def-ccl-pointers kernel-locks () + (let* ((p (recursive-lock-ptr *kernel-tcr-area-lock*)) + (q (recursive-lock-ptr *kernel-exception-lock*))) + (%revive-macptr p) + (%revive-macptr q) + (%get-kernel-global-ptr area-lock p) + (%get-kernel-global-ptr exception-lock q))) + +(def-standard-initial-binding *package*) +(def-standard-initial-binding *gensym-counter* 0) +(def-standard-initial-binding *random-state* (initial-random-state)) +(def-standard-initial-binding *whostate* "Reset") +(setq *whostate* "Reset") +(def-standard-initial-binding *error-print-length* 20) +(def-standard-initial-binding *error-print-level* 8) + +(defun %badarg (arg type) + (%err-disp $XWRONGTYPE arg type)) + +(defun atom (arg) + "Return true if OBJECT is an ATOM, and NIL otherwise." + (not (consp arg))) + +(defun list (&rest args) + "Return constructs and returns a list of its arguments." + args) + +(%fhave '%temp-list #'list) + +(defun list* (arg &rest others) + "Return a list of the arguments with last cons a dotted pair" + (cond ((null others) arg) + ((null (cdr others)) (cons arg (car others))) + (t (do ((x others (cdr x))) + ((null (cddr x)) (rplacd x (cadr x)))) + (cons arg others)))) + + + +(defun funcall (fn &rest args) + "Call FUNCTION with the given ARGUMENTS." + (declare (dynamic-extent args)) + (apply fn args)) + + +(defun apply (function arg &rest args) + "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in + the manner of LIST*. That is, a list is made of the values of all but the + last argument, appended to the value of the last argument, which must be a + list." + (declare (dynamic-extent args)) + (cond ((null args) + (apply function arg)) + ((null (cdr args)) + (apply function arg (car args))) + (t (do* ((a1 args a2) + (a2 (cdr args) (cdr a2))) + ((atom (cdr a2)) + (rplacd a1 (car a2)) + (apply function arg args)))))) + + +;;; This is not fast, but it gets the functionality that +;;; Wood and possibly other code depend on. +(defun applyv (function arg &rest other-args) + (declare (dynamic-extent other-args)) + (let* ((other-args (cons arg other-args)) + (last-arg (car (last other-args))) + (last-arg-length (length last-arg)) + (butlast-args (nbutlast other-args)) + (rest-args (make-list last-arg-length)) + (rest-args-tail rest-args)) + (declare (dynamic-extent other-args rest-args)) + (dotimes (i last-arg-length) + (setf (car rest-args-tail) (aref last-arg i)) + (pop rest-args-tail)) + (apply function (nconc butlast-args rest-args)))) + +;;; This is slow, and since %apply-lexpr isn't documented either, +;;; nothing in the world should depend on it. This is just being +;;; anal retentive. VERY anal retentive. + +(defun %apply-lexpr (function arg &rest args) + (cond ((null args) (%apply-lexpr function arg)) + (t (apply function arg (nconc (nbutlast args) + (collect-lexpr-args (car (last args)) 0)))))) + + +(defun values-list (arg) + "Return all of the elements of LIST, in order, as values." + (apply #'values arg)) + + + + + + +; copy-list + +(defun copy-list (list) + "Return a new list which is EQUAL to LIST." + (if list + (let ((result (cons (car list) '()) )) + (do ((x (cdr list) (cdr x)) + (splice result + (%cdr (%rplacd splice (cons (%car x) '() ))) )) + ((atom x) (unless (null x) + (%rplacd splice x)) result))))) + +(defun alt-list-length (l) + "Detect (and complain about) cirucular lists; allow any atom to +terminate the list" + (do* ((n 0 (1+ n)) + (fast l) + (slow l)) + ((atom fast) n) + (declare (fixnum n)) + (setq fast (cdr fast)) + (if (logbitp 0 n) + (if (eq (setq slow (cdr slow)) fast) + (%err-disp $XIMPROPERLIST l))))) + + +(defun last (list &optional (n 1)) + "Return the last N conses (not the last element!) of a list." + (if (and (typep n 'fixnum) + (>= (the fixnum n) 0)) + (locally (declare (fixnum n)) + (do* ((checked-list list (cdr checked-list)) + (returned-list list) + (index 0 (1+ index))) + ((atom checked-list) returned-list) + (declare (type fixnum index)) + (if (>= index n) + (pop returned-list)))) + (if (and (typep n 'bignum) + (> n 0)) + (require-type list 'list) + (report-bad-arg n 'unsigned-byte)))) + + + + + +(defun nthcdr (index list) + "Performs the cdr function n times on a list." + (setq list (require-type list 'list)) + (if (and (typep index 'fixnum) + (>= (the fixnum index) 0)) + (locally (declare (fixnum index)) + (dotimes (i index list) + (when (null (setq list (cdr list))) (return)))) + (progn + (unless (typep index 'unsigned-byte) + (report-bad-arg index 'unsigned-byte)) + (do* ((n index (- n target::target-most-positive-fixnum))) + ((typep n 'fixnum) (nthcdr n list)) + (unless (setq list (nthcdr target::target-most-positive-fixnum list)) + (return)))))) + + +(defun nth (index list) + "Return the nth object in a list where the car is the zero-th element." + (car (nthcdr index list))) + + +(defun nconc (&rest lists) + (declare (dynamic-extent lists)) + "Concatenates the lists given as arguments (by changing them)" + (do* ((top lists (cdr top))) + ((null top) nil) + (let* ((top-of-top (car top))) + (cond + ((consp top-of-top) + (let* ((result top-of-top) + (splice result)) + (do* ((elements (cdr top) (cdr elements))) + ((endp elements)) + (let ((ele (car elements))) + (typecase ele + (cons (rplacd (last splice) ele) + (setf splice ele)) + (null (rplacd (last splice) nil)) + (atom (if (cdr elements) + (report-bad-arg ele 'list) + (rplacd (last splice) ele))) + (t (report-bad-arg ele 'list))))) + (return result))) + ((null top-of-top) nil) + (t + (if (cdr top) + (report-bad-arg top-of-top 'list) + (return top-of-top))))))) + + +(defvar %setf-function-names% (make-hash-table :weak t :test 'eq)) +(defvar %setf-function-name-inverses% (make-hash-table :weak t :test 'eq)) + +(defun setf-function-name (sym) + "Returns the symbol in the SETF package that holds the binding of (SETF sym)" + (or (gethash sym %setf-function-names%) + (progn + (let* ((setf-package-sym (construct-setf-function-name sym))) + (setf (gethash setf-package-sym %setf-function-name-inverses%) sym + (gethash sym %setf-function-names%) setf-package-sym))))) + +(defun existing-setf-function-name (sym) + (gethash sym %setf-function-names%)) + +(defun maybe-setf-name (sym) + (let* ((other (gethash sym %setf-function-name-inverses%))) + (if other + `(setf ,other) + sym))) + + + +(defconstant *setf-package* (or (find-package "SETF") (make-package "SETF" :use nil :external-size 1))) + +(defun construct-setf-function-name (sym) + (let ((pkg (symbol-package sym))) + (setq sym (symbol-name sym)) + (if (null pkg) + (gentemp sym *setf-package*) + (values + (intern + ;;I wonder, if we didn't check, would anybody report it as a bug? + (if (not (%str-member #\: (setq pkg (package-name pkg)))) + (%str-cat pkg "::" sym) + (%str-cat (prin1-to-string pkg) "::" (princ-to-string sym))) + *setf-package*))))) + +(defun setf-function-name-p (name) + (and (consp name) + (consp (%cdr name)) + (null (%cddr name)) + (symbolp (%cadr name)) + (eq (car name) 'setf))) + +(defun valid-function-name-p (name) + (if (symbolp name) ; Nil is a valid function name. I guess. + (values t name) + (if (setf-function-name-p name) + (values t (setf-function-name (%cadr name))) + ; What other kinds of function names do we care to support ? + (values nil nil)))) + +;;; Why isn't this somewhere else ? +(defun ensure-valid-function-name (name) + (multiple-value-bind (valid-p nm) (valid-function-name-p name) + (if valid-p nm (error "Invalid function name ~s." name)))) + + +(defun maybe-setf-function-name (name) + (if (setf-function-name-p name) + (setf-function-name (cadr name)) + name)) + + +;;; Returns index if char appears in string, else nil. + +(defun %str-member (char string &optional start end) + (let* ((base-string-p (typep string 'simple-base-string))) + (unless base-string-p + (setq string (require-type string 'simple-string))) + (unless (characterp char) + (setq char (require-type char 'character))) + (do* ((i (or start 0) (1+ i)) + (n (or end (uvsize string)))) + ((= i n)) + (declare (fixnum i n) (optimize (speed 3) (safety 0))) + (if (eq (schar (the simple-base-string string) i) char) + (return i))))) + + + +;;; Returns index of elt in vector, or nil if it's not there. +(defun %vector-member (elt vector) + (unless (typep vector 'simple-vector) + (report-bad-arg vector 'simple-vector)) + (dotimes (i (the fixnum (length vector))) + (when (eq elt (%svref vector i)) (return i)))) + +(defun logical-pathname-p (thing) (istruct-typep thing 'logical-pathname)) + +(progn +;;; It's back ... +(defun list-nreverse (list) + (nreconc list nil)) + +;;; We probably want to make this smarter so that less boxing +;;; (and bignum/double-float consing!) takes place. + +(defun vector-nreverse (v) + (let* ((len (length v)) + (middle (ash (the fixnum len) -1))) + (declare (fixnum middle len)) + (do* ((left 0 (1+ left)) + (right (1- len) (1- right))) + ((= left middle) v) + (declare (fixnum left right)) + (rotatef (aref v left) (aref v right))))) + +(defun nreverse (seq) + "Return a sequence of the same elements in reverse order; the argument + is destroyed." + (when seq + (seq-dispatch seq + (list-nreverse seq) + (vector-nreverse seq))))) + +(defun nreconc (x y) + "Return (NCONC (NREVERSE X) Y)." + (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st))) + (2nd x 1st) ;2nd follows first down the list. + (3rd y 2nd)) ;3rd follows 2nd down the list. + ((atom 2nd) 3rd) + (rplacd 2nd 3rd))) + +;;; The two-arg case is maybe a bit faster. We -don't- want to +;;; do the two-arg case repeatedly to implement the N-arg case. +(defun append (&rest lists) + (declare (dynamic-extent lists)) + "Construct a new list by concatenating the list arguments" + (if lists + (let* ((head (cons nil nil)) + (tail head)) + (declare (dynamic-extent head) + (cons head tail)) + (do* () + ((null lists) (cdr head)) + (let* ((list (pop lists))) + (if (null lists) + (rplacd tail list) + (dolist (element list) + (setq tail (cdr (rplacd tail (cons element nil))))))))))) + + + + + + + + + + + +(progn +(defun list-reverse (l) + (do* ((new ())) + ((null l) new) + (push (pop l) new))) + +; Again, it's worth putting more work into this when the dust settles. +(defun vector-reverse (v) + (let* ((len (length v)) + (new (make-array (the fixnum len) :element-type (array-element-type v)))) ; a LOT more work ... + (declare (fixnum len)) + (do* ((left 0 (1+ left)) + (right (1- len) (1- right))) + ((= left len) new) + (declare (fixnum left right)) + (setf (uvref new left) + (aref v right))))) + +(defun reverse (seq) + "Return a new sequence containing the same elements but in reverse order." + (seq-dispatch seq (list-reverse seq) (vector-reverse seq))) +) + + +(defun check-sequence-bounds (seq start end) + (flet ((bad-sequence-interval (seq start end) + (unless (typep start 'unsigned-byte) + (report-bad-arg start 'unsigned-byte)) + (if (and end (not (typep end 'unsigned-byte))) + (report-bad-arg end '(or null unsigned-byte))) + (error "Bad interval for sequence operation on ~s : start = ~s, end = ~s" seq start end))) + (let* ((length (length seq))) + (declare (fixnum length)) + (if (and (typep start 'fixnum) + (<= 0 (the fixnum start)) + (if (null end) + (<= (the fixnum start) (the fixnum (setq end length))) + (and (typep end 'fixnum) + (<= (the fixnum start) (the fixnum end)) + (<= (the fixnum end) (the fixnum length))))) + + end + (bad-sequence-interval seq start end))))) + + + +(defun byte-length (string &optional (start 0) end) + (setq end (check-sequence-bounds string start end)) + (- end start)) + + + +(defun make-cstring (string) + (let* ((len (length string))) + (declare (fixnum len)) + (let* ((s (malloc (the fixnum (1+ len))))) + (setf (%get-byte s len) 0) + (multiple-value-bind (data offset) (array-data-and-offset string) + (dotimes (i len s) + (setf (%get-unsigned-byte s i) (%scharcode data (+ offset i)))) + s)))) + +(defun move-string-bytes (source dest off1 off2 n) + (declare (fixnum off1 off2 n) + (simple-base-string source dest) + (optimize (speed 3) (safety 0))) + (dotimes (i n dest) + (setf (schar dest off2) (schar source off1)) + (incf off1) + (incf off2))) + + +(defun %str-cat (s1 s2 &rest more) + (declare (dynamic-extent more)) + (require-type s1 'simple-string) + (require-type s2 'simple-string) + (let* ((len1 (length s1)) + (len2 (length s2)) + (len (%i+ len2 len1))) + (declare (optimize (speed 3)(safety 0))) + (dolist (s more) + (require-type s 'simple-string) + (setq len (+ len (length s)))) + (let ((new-string (make-string len :element-type 'base-char))) + (move-string-bytes s1 new-string 0 0 len1) + (move-string-bytes s2 new-string 0 len1 len2) + (dolist (s more) + (setq len2 (%i+ len1 len2)) + (move-string-bytes s new-string 0 len2 (setq len1 (length s)))) + new-string))) + + +(defun %substr (str start end) + (require-type start 'fixnum) + (require-type end 'fixnum) + (require-type str 'string) + (let ((len (length str))) + (multiple-value-bind (str strb)(array-data-and-offset str) + (let ((newlen (%i- end start))) + (when (%i> end len)(error "End ~S exceeds length ~S." end len)) + (when (%i< start 0)(error "Negative start")) + (let ((new (make-string newlen))) + (do* ((i 0 (1+ i)) + (pos (%i+ start strb) (1+ pos))) + ((= i newlen) new) + (declare (fixnum i pos)) + (setf (schar new i) (schar str pos)))))))) + + + +;;; 3 callers +(defun %list-to-uvector (subtype list) ; subtype may be nil (meaning simple-vector + (let* ((n (length list)) + (new (%alloc-misc n (or subtype target::subtag-simple-vector)))) ; yech + (dotimes (i n) + (declare (fixnum i)) + (uvset new i (%car list)) + (setq list (%cdr list))) + new)) + + +; appears to be unused +(defun upgraded-array-element-type (type &optional env) + "Return the element type that will actually be used to implement an array + with the specifier :ELEMENT-TYPE Spec." + (declare (ignore env)) + (element-subtype-type (element-type-subtype type))) + +(defun upgraded-complex-part-type (type &optional env) + (declare (ignore env)) + (declare (ignore type)) ; Ok, ok. So (upgraded-complex-part-type 'bogus) is 'REAL. So ? + 'real) + + +#+ppc32-target +(progn + (defparameter array-element-subtypes + #(single-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + base-char ;ucs4 + (unsigned-byte 8) + (signed-byte 8) + base-char + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + + ;; given uvector subtype - what is the corresponding element-type + (defun element-subtype-type (subtype) + (declare (fixnum subtype)) + (if (= subtype ppc32::subtag-simple-vector) t + (svref array-element-subtypes + (ash (- subtype ppc32::min-cl-ivector-subtag) (- ppc32::ntagbits))))) + ) + +#+x8632-target +(progn + (defparameter array-element-subtypes + #(single-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + base-char ;ucs4 + (unsigned-byte 8) + (signed-byte 8) + base-char + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + + ;; given uvector subtype - what is the corresponding element-type + (defun element-subtype-type (subtype) + (declare (fixnum subtype)) + (if (= subtype x8632::subtag-simple-vector) t + (svref array-element-subtypes + (ash (- subtype x8632::min-cl-ivector-subtag) (- x8632::ntagbits))))) + ) + +#+ppc64-target +(progn + +(defparameter array-element-subtypes + #(bogus + bogus + bogus + bogus + (signed-byte 8) + (signed-byte 16) + (signed-byte 32) + (signed-byte 64) + (unsigned-byte 8) + (unsigned-byte 16) + (unsigned-byte 32) + (unsigned-byte 64) + bogus + bogus + single-float + fixnum + bogus + bogus + bogus + double-float + bogus + bogus + base-char + bogus + bogus + bogus + bogus + bogus + bogus + bit + bogus + bogus)) + + + ;;; given uvector subtype - what is the corresponding element-type + (defun element-subtype-type (subtype) + (declare (fixnum subtype)) + (if (= subtype ppc64::subtag-simple-vector) + t + (svref array-element-subtypes + (ash (- subtype 128) -2)))) + ) + +#+x8664-target +(progn + + ;;; 1, 8, 16-bit element types + (defparameter *immheader-0-array-element-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + (signed-byte 16) + (unsigned-byte 16) + base-char + (signed-byte 8) + (unsigned-byte 8) + bit)) + + ;;; 32-bit element types + (defparameter *immheader-1-array-element-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + base-char + (signed-byte 32) + (unsigned-byte 32) + single-float)) + + ;;; 64-bit element types + (defparameter *immheader-2-array-element-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + fixnum + (signed-byte 64) + (unsigned-byte 64) + double-float)) + + + (defun element-subtype-type (subtype) + (declare (type (unsigned-byte 8) subtype)) + (if (= subtype x8664::subtag-simple-vector) + t + (let* ((class (ash subtype (- x8664::ntagbits))) + (tag (logand subtype x8664::fulltagmask))) + (declare (type (unsigned-byte 4) class tag)) + (cond ((= tag x8664::fulltag-immheader-0) + (%svref *immheader-0-array-element-types* class)) + ((= tag x8664::fulltag-immheader-1) + (%svref *immheader-1-array-element-types* class)) + ((= tag x8664::fulltag-immheader-2) + (%svref *immheader-2-array-element-types* class)) + (t 'bogus))))) + ) + + +;;; %make-displaced-array assumes the following + +(eval-when (:compile-toplevel) + (assert (eql target::arrayH.flags-cell target::vectorH.flags-cell)) + (assert (eql target::arrayH.displacement-cell target::vectorH.displacement-cell)) + (assert (eql target::arrayH.data-vector-cell target::vectorH.data-vector-cell))) + + +(defun %make-displaced-array (dimensions displaced-to + &optional fill adjustable + offset explicitp) + (if offset + (unless (and (fixnump offset) (>= (the fixnum offset) 0)) + (setq offset (require-type offset '(and fixnum (integer 0 *))))) + (setq offset 0)) + (locally (declare (fixnum offset)) + (let* ((disp-size (array-total-size displaced-to)) + (rank (if (listp dimensions)(length dimensions) 1)) + (new-size (if (fixnump dimensions) + dimensions + (if (listp dimensions) + (if (eql rank 1) + (car dimensions) + (if (eql rank 0) 1 ; why not 0? + (apply #'* dimensions)))))) + (vect-subtype (typecode displaced-to)) + (target displaced-to) + (real-offset offset) + (flags 0)) + (declare (fixnum disp-size rank flags vect-subtype real-offset)) + (when explicitp + (setq flags (bitset $arh_exp_disp_bit flags))) + (if (not (fixnump new-size))(error "Bad array dimensions ~s." dimensions)) + (locally (declare (fixnum new-size)) + ; (when (> (+ offset new-size) disp-size) ...), but don't cons bignums + (when (or (> new-size disp-size) + (let ((max-offset (- disp-size new-size))) + (declare (fixnum max-offset)) + (> offset max-offset))) + (%err-disp $err-disp-size displaced-to)) + (if adjustable (setq flags (bitset $arh_adjp_bit flags))) + (when fill + (if (eq fill t) + (setq fill new-size) + (unless (and (eql rank 1) + (fixnump fill) + (locally (declare (fixnum fill)) + (and (>= fill 0) (<= fill new-size)))) + (error "Bad fill pointer ~s" fill))) + (setq flags (bitset $arh_fill_bit flags)))) + ; If displaced-to is an array or vector header and is either + ; adjustable or its target is a header, then we need to set the + ; $arh_disp_bit. If displaced-to is not adjustable, then our + ; target can be its target instead of itself. + (when (or (eql vect-subtype target::subtag-arrayH) + (eql vect-subtype target::subtag-vectorH)) + (let ((dflags (%svref displaced-to target::arrayH.flags-cell))) + (declare (fixnum dflags)) + (when (or (logbitp $arh_adjp_bit dflags) + t + (progn + #+nope + (setq target (%svref displaced-to target::arrayH.data-vector-cell) + real-offset (+ offset (%svref displaced-to target::arrayH.displacement-cell))) + (logbitp $arh_disp_bit dflags) + #-nope t)) + (setq flags (bitset $arh_disp_bit flags)))) + (setq vect-subtype (%array-header-subtype displaced-to))) + ; assumes flags is low byte + (setq flags (dpb vect-subtype target::arrayH.flags-cell-subtag-byte flags)) + (if (eq rank 1) + (%gvector target::subtag-vectorH + (if (fixnump fill) fill new-size) + new-size + target + real-offset + flags) + (let ((val (%alloc-misc (+ target::arrayh.dim0-cell rank) target::subtag-arrayH))) + (setf (%svref val target::arrayH.rank-cell) rank) + (setf (%svref val target::arrayH.physsize-cell) new-size) + (setf (%svref val target::arrayH.data-vector-cell) target) + (setf (%svref val target::arrayH.displacement-cell) real-offset) + (setf (%svref val target::arrayH.flags-cell) flags) + (do* ((dims dimensions (cdr dims)) + (i 0 (1+ i))) + ((null dims)) + (declare (fixnum i)(list dims)) + (setf (%svref val (%i+ target::arrayH.dim0-cell i)) (car dims))) + val))))) + +(defun make-array (dims &key (element-type t element-type-p) + displaced-to + displaced-index-offset + adjustable + fill-pointer + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p)) + (when (and initial-element-p initial-contents-p) + (error "Cannot specify both ~S and ~S" :initial-element-p :initial-contents-p)) + (make-array-1 dims element-type element-type-p + displaced-to + displaced-index-offset + adjustable + fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + nil)) + + + + + +(defun vector-pop (vector) + "Decrease the fill pointer by 1 and return the element pointed to by the + new fill pointer." + (let* ((fill (fill-pointer vector))) + (declare (fixnum fill)) + (if (zerop fill) + (error "Fill pointer of ~S is 0 ." vector) + (progn + (decf fill) + (%set-fill-pointer vector fill) + (aref vector fill))))) + + + + +(defun elt (sequence idx) + "Return the element of SEQUENCE specified by INDEX." + (seq-dispatch + sequence + (let* ((cell (nthcdr idx sequence))) + (if (consp cell) + (car (the cons cell)) + (if cell + (report-bad-arg sequence '(satisfies proper-list-p)) + (%err-disp $XACCESSNTH idx sequence)))) + + (progn + (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0)) + (report-bad-arg idx 'unsigned-byte)) + (locally + (if (>= idx (length sequence)) + (%err-disp $XACCESSNTH idx sequence) + (aref sequence idx)))))) + + + + +(defun set-elt (sequence idx value) + (seq-dispatch + sequence + (let* ((cell (nthcdr idx sequence))) + (if (consp cell) + (setf (car (the cons cell)) value) + (if cell + (report-bad-arg sequence '(satisfies proper-list-p)) + (%err-disp $XACCESSNTH idx sequence)))) + (progn + (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0)) + (report-bad-arg idx 'unsigned-byte)) + (locally + (declare (fixnum idx)) + (if (>= idx (length sequence)) + (%err-disp $XACCESSNTH idx sequence) + (setf (aref sequence idx) value)))))) + + + + +(%fhave 'equalp #'equal) ; bootstrapping + +(defun copy-tree (tree) + "Recursively copy trees of conses." + (if (atom tree) + tree + (locally (declare (type cons tree)) + (do* ((tail (cdr tree) (cdr tail)) + (result (cons (copy-tree (car tree)) nil)) + (ptr result (cdr ptr))) + ((atom tail) + (setf (cdr ptr) tail) + result) + (declare (type cons ptr result)) + (locally + (declare (type cons tail)) + (setf (cdr ptr) (cons (copy-tree (car tail)) nil))))))) + + + + +(defvar *periodic-task-interval* 0.3) +(defvar *periodic-task-seconds* 0) +(defvar *periodic-task-nanoseconds* 300000000) + +(defun set-periodic-task-interval (n) + (multiple-value-setq (*periodic-task-seconds* *periodic-task-nanoseconds*) + (nanoseconds n)) + (setq *periodic-task-interval* n)) + +(defun periodic-task-interval () + *periodic-task-interval*) + + + +(defun char-downcase (c) + "Return CHAR converted to lower-case if that is possible." + (declare (optimize (speed 3))) ; open-code the %CHAR-CODE-DOWNCASE here. + (code-char (the valid-char-code (%char-code-downcase (char-code c))))) + + + +(defun digit-char-p (char &optional radix) + "If char is a digit in the specified radix, returns the fixnum for + which that digit stands, else returns NIL." + (let* ((code (char-code char)) + (r (if radix (if (and (typep radix 'fixnum) + (%i>= radix 2) + (%i<= radix 36)) + radix + (%validate-radix radix)) 10)) + (weight (if (and (<= code (char-code #\9)) + (>= code (char-code #\0))) + (the fixnum (- code (char-code #\0))) + (if (and (<= code (char-code #\Z)) + (>= code (char-code #\A))) + (the fixnum (+ 10 (the fixnum (- code (char-code #\A))))) + (if (and (<= code (char-code #\z)) + (>= code (char-code #\a))) + (the fixnum (+ 10 (the fixnum (- code (char-code #\a)))))))))) + (declare (fixnum code r)) + (and weight (< (the fixnum weight) r) weight))) + + + + + + + +(defun string-start-end (string start end) + (setq string (string string)) + (let ((len (length (the string string)))) + (flet ((are (a i)(error "Array index ~S out of bounds for ~S." i a))) + (if (and end (> end len))(are string end)) + (if (and start (or (< start 0)(> start len)))(are string start)) + (setq start (or start 0) end (or end len)) + (if (%i> start end) + (error "Start ~S exceeds end ~S." start end)) + (if (typep string 'simple-string) + (values string start end) + (multiple-value-bind (str off)(array-data-and-offset string) + (values str (%i+ off start)(%i+ off end))))))) + +(defun get-properties (place indicator-list) + "Like GETF, except that INDICATOR-LIST is a list of indicators which will + be looked for in the property list stored in PLACE. Three values are + returned, see manual for details." + (do ((plist place (cddr plist))) + ((null plist) (values nil nil nil)) + (cond ((atom (cdr plist)) + (report-bad-arg place '(satisfies proper-list-p))) + ((memq (car plist) indicator-list) ;memq defined in kernel + (return (values (car plist) (cadr plist) plist)))))) + +(defun string= (string1 string2 &key start1 end1 start2 end2) + "Given two strings (string1 and string2), and optional integers start1, + start2, end1 and end2, compares characters in string1 to characters in + string2 (using char=)." + (locally (declare (optimize (speed 3)(safety 0))) + (if (and (simple-string-p string1)(null start1)(null end1)) + (setq start1 0 end1 (length string1)) + (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1))) + (if (and (simple-string-p string2)(null start2)(null end2)) + (setq start2 0 end2 (length string2)) + (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2))) + (%simple-string= string1 string2 start1 start2 end1 end2))) + + +(defun lfun-keyvect (lfun) + (let ((bits (lfun-bits lfun))) + (declare (fixnum bits)) + (and (logbitp $lfbits-keys-bit bits) + (or (logbitp $lfbits-method-bit bits) + (and (not (logbitp $lfbits-gfn-bit bits)) + (not (logbitp $lfbits-cm-bit bits)))) + (nth-immediate lfun 1)))) + + +(defun function-entry-code-note (fn) + (let ((bits (lfun-bits (setq fn (require-type fn 'function))))) + (declare (fixnum bits)) + (and (logbitp $lfbits-code-coverage-bit bits) + (loop for i upfrom 1 as imm = (nth-immediate fn i) + when (code-note-p imm) do (return imm))))) + + +(defun function-lambda-expression (fn) + "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where + DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument + to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition + might have been enclosed in some non-null lexical environment, and + NAME is some name (for debugging only) or NIL if there is no name." + ;(declare (values def env-p name)) + (let* ((bits (lfun-bits (setq fn (require-type fn 'function))))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (function-lambda-expression (nth-immediate fn 1)) + (values (uncompile-function fn) + (logbitp $lfbits-nonnullenv-bit bits) + (function-name fn))))) + +; env must be a lexical-environment or NIL. +; If env contains function or variable bindings or SPECIAL declarations, return t. +; Else return nil +(defun %non-empty-environment-p (env) + (loop + (when (or (null env) (istruct-typep env 'definition-environment)) + (return nil)) + (when (or (consp (lexenv.variables env)) + (consp (lexenv.functions env)) + (dolist (vdecl (lexenv.vdecls env)) + (when (eq (cadr vdecl) 'special) + (return t)))) + (return t)) + (setq env (lexenv.parent-env env)))) + +;(coerce object 'compiled-function) +(defun coerce-to-compiled-function (object) + (setq object (coerce-to-function object)) + (unless (typep object 'compiled-function) + (multiple-value-bind (def envp) (function-lambda-expression object) + (when (or envp (null def)) + (%err-disp $xcoerce object 'compiled-function)) + (setq object (compile-user-function def nil)))) + object) + + + +(defun %set-toplevel (&optional (fun nil fun-p)) + ;(setq fun (require-type fun '(or symbol function))) + (let* ((tcr (%current-tcr))) + (prog1 (%tcr-toplevel-function tcr) + (when fun-p + (%set-tcr-toplevel-function tcr fun))))) + + +(defun gccounts () + (let* ((total (%get-gc-count)) + (full (full-gccount)) + (g2-count 0) + (g1-count 0) + (g0-count 0)) + (when (egc-enabled-p) + (let* ((a (%active-dynamic-area))) + (setq g0-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older)) + (setq g1-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older)) + (setq g2-count (%fixnum-ref a target::area.gc-count)))) + (values total full g2-count g1-count g0-count))) + + + + + +(defstatic %pascal-functions% + #(NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL NIL NIL NIL NIL NIL NIL)) + + +(defun gc-retain-pages (arg) + "Try to influence the GC to retain/recycle the pages allocated between +GCs if arg is true, and to release them otherwise. This is generally a +gtradeoff between paging and other VM considerations." + (setq *gc-event-status-bits* + (if arg + (bitset $gc-retain-pages-bit *gc-event-status-bits*) + (bitclr $gc-retain-pages-bit *gc-event-status-bits*))) + (not (null arg))) + +(defun gc-retaining-pages () + "Return T if the GC tries to retain pages between full GCs and NIL if +it's trying to release them to improve VM paging performance." + (logbitp $gc-retain-pages-bit *gc-event-status-bits*)) + + +(defun gc-verbose (on-full-gc &optional (egc-too on-full-gc)) + "If the first (required) argument is non-NIL, configures the GC to print +informational messages on entry and exit to each full GC; if the first argument +is NIL, suppresses those messages. The second (optional) argument controls printing of messages on entry and exit to an ephemeral GC. Returns values as per GC-VERBOSE-P." + (let* ((bits *gc-event-status-bits*)) + (if on-full-gc + (bitsetf $gc-verbose-bit bits) + (bitclrf $gc-verbose-bit bits)) + (if egc-too + (bitsetf $egc-verbose-bit bits) + (bitclrf $egc-verbose-bit bits)) + (setq *gc-event-status-bits* bits) + (values on-full-gc egc-too))) + + +(defun gc-verbose-p () + "Returns two values: the first is true if the GC is configured to +print messages on each full GC; the second is true if the GC is configured +to print messages on each ephemeral GC." + (let* ((bits *gc-event-status-bits*)) + (values (logbitp $gc-verbose-bit bits) + (logbitp $egc-verbose-bit bits)))) + +(defun egc-active-p () + "Return T if the EGC was active at the time of the call, NIL otherwise. +Since this is generally a volatile piece of information, it's not clear +whether this function serves a useful purpose when native threads are +involved." + (and (egc-enabled-p) + (not (eql 0 (%get-kernel-global 'oldest-ephemeral))))) + +; this IS effectively a passive way of inquiring about enabled status. +(defun egc-enabled-p () + "Return T if the EGC was enabled at the time of the call, NIL otherwise." + (not (eql 0 (%fixnum-ref (%active-dynamic-area) target::area.older)))) + +(defun egc-configuration () + "Return as multiple values the sizes in kilobytes of the thresholds +associated with the youngest ephemeral generation, the middle ephemeral +generation, and the oldest ephemeral generation." + (let* ((ta (%get-kernel-global 'tenured-area)) + (g2 (%fixnum-ref ta target::area.younger)) + (g1 (%fixnum-ref g2 target::area.younger)) + (g0 (%fixnum-ref g1 target::area.younger))) + (values (ash (the fixnum (%fixnum-ref g0 target::area.threshold)) (- (- 10 target::fixnum-shift))) + (ash (the fixnum (%fixnum-ref g1 target::area.threshold)) (- (- 10 target::fixnum-shift))) + (ash (the fixnum (%fixnum-ref g2 target::area.threshold)) (- (- 10 target::fixnum-shift)))))) + + +(defun configure-egc (e0size e1size e2size) + "If the EGC is currently disabled, put the indicated threshold sizes in +effect and returns T, otherwise, returns NIL. The provided threshold sizes +are rounded up to a multiple of 64Kbytes." + (let* ((was-enabled (egc-active-p)) + (e2size (require-type e2size '(unsigned-byte 18))) + (e1size (require-type e1size '(unsigned-byte 18))) + (e0size (require-type e0size '(integer 1 #.(ash 1 18))))) + (unless (<= e0size e1size e2size) + (error "Generation ~s threshold cannot be smaller than generation ~s threshold" + (if (> e0size e1size) 1 2) (if (> e0size e1size) 0 1))) + (unwind-protect + (progn + (egc nil) + (setq e2size (logand (lognot #xffff) (+ #xffff (ash e2size 10))) + e1size (logand (lognot #xffff) (+ #xffff (ash e1size 10))) + e0size (logand (lognot #xffff) (+ #xffff (ash e0size 10)))) + (%configure-egc e0size e1size e2size)) + (egc was-enabled)))) + + + +(defun macptr-flags (macptr) + (if (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1) + 0 + (uvref macptr TARGET::XMACPTR.FLAGS-CELL))) + + +; This doesn't really make the macptr be gcable (now has to be +; on linked list), but we might have other reasons for setting +; other flag bits. +(defun set-macptr-flags (macptr value) + (unless (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1) + (setf (%svref macptr TARGET::XMACPTR.FLAGS-CELL) value) + value)) + +(defun %new-gcable-ptr (size &optional clear-p) + (let ((p (make-gcable-macptr $flags_DisposPtr))) + (%setf-macptr p (malloc size)) + (if clear-p + (#_memset p 0 size)) + p)) + +(defun %gcable-ptr-p (p) + (and (typep p 'macptr) + (= (uvsize p) target::xmacptr.element-count))) + +(defstatic *upper-to-lower* nil) +(defstatic *lower-to-upper* nil) + +;;; "address" should be the address (as returned by FOREIGN-SYMBOL-ADDRESS) +;;; of a foreign function that accepts a pointer as an argument and does +;;; whatever's needed to dispose of it. That function can be called from +;;; the GC, so it shouldn't call back into lisp. +(defun register-xmacptr-dispose-function (address) + (ff-call (%kernel-import target::kernel-import-register-xmacptr-dispose-function) + :address address + :int)) + + +;;; This alist is automatically (and not too cleverly ...) generated. +;;; +;;; NB: it was generated from Unicode 5.0 character tables, check to +;;; see if anything's changed in 5.1 or later versions. +;;; +;;; The (upper . lower) pairs have the property that UPPER is the +;;; value "simple uppercase equivalent" entry for LOWER in the +;;; UnicodeData.txt file and LOWER is the corresponding entry for +;;; UPPER, +(let* ((mapping + '((#\Latin_Capital_Letter_A_With_Grave . #\Latin_Small_Letter_A_With_Grave) + (#\Latin_Capital_Letter_A_With_Acute . #\Latin_Small_Letter_A_With_Acute) + (#\Latin_Capital_Letter_A_With_Circumflex + . #\Latin_Small_Letter_A_With_Circumflex) + (#\Latin_Capital_Letter_A_With_Tilde . #\Latin_Small_Letter_A_With_Tilde) + (#\Latin_Capital_Letter_A_With_Diaeresis + . #\Latin_Small_Letter_A_With_Diaeresis) + (#\Latin_Capital_Letter_A_With_Ring_Above + . #\Latin_Small_Letter_A_With_Ring_Above) + + (#\Latin_Capital_Letter_Ae . #\Latin_Small_Letter_Ae) + + (#\Latin_Capital_Letter_C_With_Cedilla . #\Latin_Small_Letter_C_With_Cedilla) + + (#\Latin_Capital_Letter_E_With_Grave . #\Latin_Small_Letter_E_With_Grave) + + (#\Latin_Capital_Letter_E_With_Acute . #\Latin_Small_Letter_E_With_Acute) + + (#\Latin_Capital_Letter_E_With_Circumflex + . #\Latin_Small_Letter_E_With_Circumflex) + + (#\Latin_Capital_Letter_E_With_Diaeresis + . #\Latin_Small_Letter_E_With_Diaeresis) + + (#\Latin_Capital_Letter_I_With_Grave . #\Latin_Small_Letter_I_With_Grave) + + (#\Latin_Capital_Letter_I_With_Acute . #\Latin_Small_Letter_I_With_Acute) + + (#\Latin_Capital_Letter_I_With_Circumflex + . #\Latin_Small_Letter_I_With_Circumflex) + + (#\Latin_Capital_Letter_I_With_Diaeresis + . #\Latin_Small_Letter_I_With_Diaeresis) + + (#\Latin_Capital_Letter_Eth . #\Latin_Small_Letter_Eth) + + (#\Latin_Capital_Letter_N_With_Tilde . #\Latin_Small_Letter_N_With_Tilde) + + (#\Latin_Capital_Letter_O_With_Grave . #\Latin_Small_Letter_O_With_Grave) + + (#\Latin_Capital_Letter_O_With_Acute . #\Latin_Small_Letter_O_With_Acute) + + (#\Latin_Capital_Letter_O_With_Circumflex + . #\Latin_Small_Letter_O_With_Circumflex) + + (#\Latin_Capital_Letter_O_With_Tilde . #\Latin_Small_Letter_O_With_Tilde) + + (#\Latin_Capital_Letter_O_With_Diaeresis + . #\Latin_Small_Letter_O_With_Diaeresis) + + (#\Latin_Capital_Letter_O_With_Stroke . #\Latin_Small_Letter_O_With_Stroke) + + (#\Latin_Capital_Letter_U_With_Grave . #\Latin_Small_Letter_U_With_Grave) + + (#\Latin_Capital_Letter_U_With_Acute . #\Latin_Small_Letter_U_With_Acute) + + (#\Latin_Capital_Letter_U_With_Circumflex + . #\Latin_Small_Letter_U_With_Circumflex) + + (#\Latin_Capital_Letter_U_With_Diaeresis + . #\Latin_Small_Letter_U_With_Diaeresis) + + (#\Latin_Capital_Letter_Y_With_Acute . #\Latin_Small_Letter_Y_With_Acute) + + (#\Latin_Capital_Letter_Thorn . #\Latin_Small_Letter_Thorn) + + (#\Latin_Capital_Letter_A_With_Macron . #\Latin_Small_Letter_A_With_Macron) + + (#\Latin_Capital_Letter_A_With_Breve . #\Latin_Small_Letter_A_With_Breve) + + (#\Latin_Capital_Letter_A_With_Ogonek . #\Latin_Small_Letter_A_With_Ogonek) + + (#\Latin_Capital_Letter_C_With_Acute . #\Latin_Small_Letter_C_With_Acute) + + (#\Latin_Capital_Letter_C_With_Circumflex + . #\Latin_Small_Letter_C_With_Circumflex) + + (#\Latin_Capital_Letter_C_With_Dot_Above + . #\Latin_Small_Letter_C_With_Dot_Above) + + (#\Latin_Capital_Letter_C_With_Caron . #\Latin_Small_Letter_C_With_Caron) + + (#\Latin_Capital_Letter_D_With_Caron . #\Latin_Small_Letter_D_With_Caron) + + (#\Latin_Capital_Letter_D_With_Stroke . #\Latin_Small_Letter_D_With_Stroke) + + (#\Latin_Capital_Letter_E_With_Macron . #\Latin_Small_Letter_E_With_Macron) + + (#\Latin_Capital_Letter_E_With_Breve . #\Latin_Small_Letter_E_With_Breve) + + (#\Latin_Capital_Letter_E_With_Dot_Above + . #\Latin_Small_Letter_E_With_Dot_Above) + + (#\Latin_Capital_Letter_E_With_Ogonek . #\Latin_Small_Letter_E_With_Ogonek) + + (#\Latin_Capital_Letter_E_With_Caron . #\Latin_Small_Letter_E_With_Caron) + + (#\Latin_Capital_Letter_G_With_Circumflex + . #\Latin_Small_Letter_G_With_Circumflex) + + (#\Latin_Capital_Letter_G_With_Breve . #\Latin_Small_Letter_G_With_Breve) + + (#\Latin_Capital_Letter_G_With_Dot_Above + . #\Latin_Small_Letter_G_With_Dot_Above) + + (#\Latin_Capital_Letter_G_With_Cedilla . #\Latin_Small_Letter_G_With_Cedilla) + + (#\Latin_Capital_Letter_H_With_Circumflex + . #\Latin_Small_Letter_H_With_Circumflex) + + (#\Latin_Capital_Letter_H_With_Stroke . #\Latin_Small_Letter_H_With_Stroke) + + (#\Latin_Capital_Letter_I_With_Tilde . #\Latin_Small_Letter_I_With_Tilde) + + (#\Latin_Capital_Letter_I_With_Macron . #\Latin_Small_Letter_I_With_Macron) + + (#\Latin_Capital_Letter_I_With_Breve . #\Latin_Small_Letter_I_With_Breve) + + (#\Latin_Capital_Letter_I_With_Ogonek . #\Latin_Small_Letter_I_With_Ogonek) + + (#\Latin_Capital_Ligature_Ij . #\Latin_Small_Ligature_Ij) + + (#\Latin_Capital_Letter_J_With_Circumflex + . #\Latin_Small_Letter_J_With_Circumflex) + + (#\Latin_Capital_Letter_K_With_Cedilla . #\Latin_Small_Letter_K_With_Cedilla) + + (#\Latin_Capital_Letter_L_With_Acute . #\Latin_Small_Letter_L_With_Acute) + + (#\Latin_Capital_Letter_L_With_Cedilla . #\Latin_Small_Letter_L_With_Cedilla) + + (#\Latin_Capital_Letter_L_With_Caron . #\Latin_Small_Letter_L_With_Caron) + + (#\Latin_Capital_Letter_L_With_Middle_Dot + . #\Latin_Small_Letter_L_With_Middle_Dot) + + (#\Latin_Capital_Letter_L_With_Stroke . #\Latin_Small_Letter_L_With_Stroke) + + (#\Latin_Capital_Letter_N_With_Acute . #\Latin_Small_Letter_N_With_Acute) + + (#\Latin_Capital_Letter_N_With_Cedilla . #\Latin_Small_Letter_N_With_Cedilla) + + (#\Latin_Capital_Letter_N_With_Caron . #\Latin_Small_Letter_N_With_Caron) + + (#\Latin_Capital_Letter_Eng . #\Latin_Small_Letter_Eng) + + (#\Latin_Capital_Letter_O_With_Macron . #\Latin_Small_Letter_O_With_Macron) + + (#\Latin_Capital_Letter_O_With_Breve . #\Latin_Small_Letter_O_With_Breve) + + (#\Latin_Capital_Letter_O_With_Double_Acute + . #\Latin_Small_Letter_O_With_Double_Acute) + + (#\Latin_Capital_Ligature_Oe . #\Latin_Small_Ligature_Oe) + + (#\Latin_Capital_Letter_R_With_Acute . #\Latin_Small_Letter_R_With_Acute) + + (#\Latin_Capital_Letter_R_With_Cedilla . #\Latin_Small_Letter_R_With_Cedilla) + + (#\Latin_Capital_Letter_R_With_Caron . #\Latin_Small_Letter_R_With_Caron) + + (#\Latin_Capital_Letter_S_With_Acute . #\Latin_Small_Letter_S_With_Acute) + + (#\Latin_Capital_Letter_S_With_Circumflex + . #\Latin_Small_Letter_S_With_Circumflex) + + (#\Latin_Capital_Letter_S_With_Cedilla . #\Latin_Small_Letter_S_With_Cedilla) + + (#\Latin_Capital_Letter_S_With_Caron . #\Latin_Small_Letter_S_With_Caron) + + (#\Latin_Capital_Letter_T_With_Cedilla . #\Latin_Small_Letter_T_With_Cedilla) + + (#\Latin_Capital_Letter_T_With_Caron . #\Latin_Small_Letter_T_With_Caron) + + (#\Latin_Capital_Letter_T_With_Stroke . #\Latin_Small_Letter_T_With_Stroke) + + (#\Latin_Capital_Letter_U_With_Tilde . #\Latin_Small_Letter_U_With_Tilde) + + (#\Latin_Capital_Letter_U_With_Macron . #\Latin_Small_Letter_U_With_Macron) + + (#\Latin_Capital_Letter_U_With_Breve . #\Latin_Small_Letter_U_With_Breve) + + (#\Latin_Capital_Letter_U_With_Ring_Above + . #\Latin_Small_Letter_U_With_Ring_Above) + + (#\Latin_Capital_Letter_U_With_Double_Acute + . #\Latin_Small_Letter_U_With_Double_Acute) + + (#\Latin_Capital_Letter_U_With_Ogonek . #\Latin_Small_Letter_U_With_Ogonek) + + (#\Latin_Capital_Letter_W_With_Circumflex + . #\Latin_Small_Letter_W_With_Circumflex) + + (#\Latin_Capital_Letter_Y_With_Circumflex + . #\Latin_Small_Letter_Y_With_Circumflex) + + (#\Latin_Capital_Letter_Y_With_Diaeresis + . #\Latin_Small_Letter_Y_With_Diaeresis) + + (#\Latin_Capital_Letter_Z_With_Acute . #\Latin_Small_Letter_Z_With_Acute) + + (#\Latin_Capital_Letter_Z_With_Dot_Above + . #\Latin_Small_Letter_Z_With_Dot_Above) + + (#\Latin_Capital_Letter_Z_With_Caron . #\Latin_Small_Letter_Z_With_Caron) + + (#\Latin_Capital_Letter_B_With_Hook . #\Latin_Small_Letter_B_With_Hook) + + (#\Latin_Capital_Letter_B_With_Topbar . #\Latin_Small_Letter_B_With_Topbar) + + (#\Latin_Capital_Letter_Tone_Six . #\Latin_Small_Letter_Tone_Six) + + (#\Latin_Capital_Letter_Open_O . #\Latin_Small_Letter_Open_O) + + (#\Latin_Capital_Letter_C_With_Hook . #\Latin_Small_Letter_C_With_Hook) + + (#\Latin_Capital_Letter_African_D . #\Latin_Small_Letter_D_With_Tail) + + (#\Latin_Capital_Letter_D_With_Hook . #\Latin_Small_Letter_D_With_Hook) + + (#\Latin_Capital_Letter_D_With_Topbar . #\Latin_Small_Letter_D_With_Topbar) + + (#\Latin_Capital_Letter_Reversed_E . #\Latin_Small_Letter_Turned_E) + + (#\Latin_Capital_Letter_Schwa . #\Latin_Small_Letter_Schwa) + + (#\Latin_Capital_Letter_Open_E . #\Latin_Small_Letter_Open_E) + + (#\Latin_Capital_Letter_F_With_Hook . #\Latin_Small_Letter_F_With_Hook) + + (#\Latin_Capital_Letter_G_With_Hook . #\Latin_Small_Letter_G_With_Hook) + + (#\Latin_Capital_Letter_Gamma . #\Latin_Small_Letter_Gamma) + + (#\Latin_Capital_Letter_Iota . #\Latin_Small_Letter_Iota) + + (#\Latin_Capital_Letter_I_With_Stroke . #\Latin_Small_Letter_I_With_Stroke) + + (#\Latin_Capital_Letter_K_With_Hook . #\Latin_Small_Letter_K_With_Hook) + + (#\Latin_Capital_Letter_Turned_M . #\Latin_Small_Letter_Turned_M) + + (#\Latin_Capital_Letter_N_With_Left_Hook + . #\Latin_Small_Letter_N_With_Left_Hook) + + (#\Latin_Capital_Letter_O_With_Middle_Tilde . #\Latin_Small_Letter_Barred_O) + + (#\Latin_Capital_Letter_O_With_Horn . #\Latin_Small_Letter_O_With_Horn) + + (#\Latin_Capital_Letter_Oi . #\Latin_Small_Letter_Oi) + + (#\Latin_Capital_Letter_P_With_Hook . #\Latin_Small_Letter_P_With_Hook) + + (#\Latin_Letter_Yr . #\Latin_Letter_Small_Capital_R) + + (#\Latin_Capital_Letter_Tone_Two . #\Latin_Small_Letter_Tone_Two) + + (#\Latin_Capital_Letter_Esh . #\Latin_Small_Letter_Esh) + + (#\Latin_Capital_Letter_T_With_Hook . #\Latin_Small_Letter_T_With_Hook) + + (#\Latin_Capital_Letter_T_With_Retroflex_Hook + . #\Latin_Small_Letter_T_With_Retroflex_Hook) + + (#\Latin_Capital_Letter_U_With_Horn . #\Latin_Small_Letter_U_With_Horn) + + (#\Latin_Capital_Letter_Upsilon . #\Latin_Small_Letter_Upsilon) + + (#\Latin_Capital_Letter_V_With_Hook . #\Latin_Small_Letter_V_With_Hook) + + (#\Latin_Capital_Letter_Y_With_Hook . #\Latin_Small_Letter_Y_With_Hook) + + (#\Latin_Capital_Letter_Z_With_Stroke . #\Latin_Small_Letter_Z_With_Stroke) + + (#\Latin_Capital_Letter_Ezh . #\Latin_Small_Letter_Ezh) + + (#\Latin_Capital_Letter_Ezh_Reversed . #\Latin_Small_Letter_Ezh_Reversed) + + (#\Latin_Capital_Letter_Tone_Five . #\Latin_Small_Letter_Tone_Five) + + (#\Latin_Capital_Letter_Dz_With_Caron . #\Latin_Small_Letter_Dz_With_Caron) + + (#\Latin_Capital_Letter_Lj . #\Latin_Small_Letter_Lj) + + (#\Latin_Capital_Letter_Nj . #\Latin_Small_Letter_Nj) + + (#\Latin_Capital_Letter_A_With_Caron . #\Latin_Small_Letter_A_With_Caron) + + (#\Latin_Capital_Letter_I_With_Caron . #\Latin_Small_Letter_I_With_Caron) + + (#\Latin_Capital_Letter_O_With_Caron . #\Latin_Small_Letter_O_With_Caron) + + (#\Latin_Capital_Letter_U_With_Caron . #\Latin_Small_Letter_U_With_Caron) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Macron + . #\Latin_Small_Letter_U_With_Diaeresis_And_Macron) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Acute + . #\Latin_Small_Letter_U_With_Diaeresis_And_Acute) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Caron + . #\Latin_Small_Letter_U_With_Diaeresis_And_Caron) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Grave + . #\Latin_Small_Letter_U_With_Diaeresis_And_Grave) + + (#\Latin_Capital_Letter_A_With_Diaeresis_And_Macron + . #\Latin_Small_Letter_A_With_Diaeresis_And_Macron) + + (#\Latin_Capital_Letter_A_With_Dot_Above_And_Macron + . #\Latin_Small_Letter_A_With_Dot_Above_And_Macron) + + (#\Latin_Capital_Letter_Ae_With_Macron . #\Latin_Small_Letter_Ae_With_Macron) + + (#\Latin_Capital_Letter_G_With_Stroke . #\Latin_Small_Letter_G_With_Stroke) + + (#\Latin_Capital_Letter_G_With_Caron . #\Latin_Small_Letter_G_With_Caron) + + (#\Latin_Capital_Letter_K_With_Caron . #\Latin_Small_Letter_K_With_Caron) + + (#\Latin_Capital_Letter_O_With_Ogonek . #\Latin_Small_Letter_O_With_Ogonek) + + (#\Latin_Capital_Letter_O_With_Ogonek_And_Macron + . #\Latin_Small_Letter_O_With_Ogonek_And_Macron) + + (#\Latin_Capital_Letter_Ezh_With_Caron . #\Latin_Small_Letter_Ezh_With_Caron) + + (#\Latin_Capital_Letter_Dz . #\Latin_Small_Letter_Dz) + + (#\Latin_Capital_Letter_G_With_Acute . #\Latin_Small_Letter_G_With_Acute) + + (#\Latin_Capital_Letter_Hwair . #\Latin_Small_Letter_Hv) + + (#\Latin_Capital_Letter_Wynn . #\Latin_Letter_Wynn) + + (#\Latin_Capital_Letter_N_With_Grave . #\Latin_Small_Letter_N_With_Grave) + + (#\Latin_Capital_Letter_A_With_Ring_Above_And_Acute + . #\Latin_Small_Letter_A_With_Ring_Above_And_Acute) + + (#\Latin_Capital_Letter_Ae_With_Acute . #\Latin_Small_Letter_Ae_With_Acute) + + (#\Latin_Capital_Letter_O_With_Stroke_And_Acute + . #\Latin_Small_Letter_O_With_Stroke_And_Acute) + + (#\Latin_Capital_Letter_A_With_Double_Grave + . #\Latin_Small_Letter_A_With_Double_Grave) + + (#\Latin_Capital_Letter_A_With_Inverted_Breve + . #\Latin_Small_Letter_A_With_Inverted_Breve) + + (#\Latin_Capital_Letter_E_With_Double_Grave + . #\Latin_Small_Letter_E_With_Double_Grave) + + (#\Latin_Capital_Letter_E_With_Inverted_Breve + . #\Latin_Small_Letter_E_With_Inverted_Breve) + + (#\Latin_Capital_Letter_I_With_Double_Grave + . #\Latin_Small_Letter_I_With_Double_Grave) + + (#\Latin_Capital_Letter_I_With_Inverted_Breve + . #\Latin_Small_Letter_I_With_Inverted_Breve) + + (#\Latin_Capital_Letter_O_With_Double_Grave + . #\Latin_Small_Letter_O_With_Double_Grave) + + (#\Latin_Capital_Letter_O_With_Inverted_Breve + . #\Latin_Small_Letter_O_With_Inverted_Breve) + + (#\Latin_Capital_Letter_R_With_Double_Grave + . #\Latin_Small_Letter_R_With_Double_Grave) + + (#\Latin_Capital_Letter_R_With_Inverted_Breve + . #\Latin_Small_Letter_R_With_Inverted_Breve) + + (#\Latin_Capital_Letter_U_With_Double_Grave + . #\Latin_Small_Letter_U_With_Double_Grave) + + (#\Latin_Capital_Letter_U_With_Inverted_Breve + . #\Latin_Small_Letter_U_With_Inverted_Breve) + + (#\Latin_Capital_Letter_S_With_Comma_Below + . #\Latin_Small_Letter_S_With_Comma_Below) + + (#\Latin_Capital_Letter_T_With_Comma_Below + . #\Latin_Small_Letter_T_With_Comma_Below) + + (#\Latin_Capital_Letter_Yogh . #\Latin_Small_Letter_Yogh) + + (#\Latin_Capital_Letter_H_With_Caron . #\Latin_Small_Letter_H_With_Caron) + + (#\Latin_Capital_Letter_N_With_Long_Right_Leg + . #\Latin_Small_Letter_N_With_Long_Right_Leg) + + (#\Latin_Capital_Letter_Ou . #\Latin_Small_Letter_Ou) + + (#\Latin_Capital_Letter_Z_With_Hook . #\Latin_Small_Letter_Z_With_Hook) + + (#\Latin_Capital_Letter_A_With_Dot_Above + . #\Latin_Small_Letter_A_With_Dot_Above) + + (#\Latin_Capital_Letter_E_With_Cedilla . #\Latin_Small_Letter_E_With_Cedilla) + + (#\Latin_Capital_Letter_O_With_Diaeresis_And_Macron + . #\Latin_Small_Letter_O_With_Diaeresis_And_Macron) + + (#\Latin_Capital_Letter_O_With_Tilde_And_Macron + . #\Latin_Small_Letter_O_With_Tilde_And_Macron) + + (#\Latin_Capital_Letter_O_With_Dot_Above + . #\Latin_Small_Letter_O_With_Dot_Above) + + (#\Latin_Capital_Letter_O_With_Dot_Above_And_Macron + . #\Latin_Small_Letter_O_With_Dot_Above_And_Macron) + + (#\Latin_Capital_Letter_Y_With_Macron . #\Latin_Small_Letter_Y_With_Macron) + + (#\Latin_Capital_Letter_A_With_Stroke . #\U+2C65) + + (#\Latin_Capital_Letter_C_With_Stroke . #\Latin_Small_Letter_C_With_Stroke) + + (#\Latin_Capital_Letter_L_With_Bar . #\Latin_Small_Letter_L_With_Bar) + + (#\Latin_Capital_Letter_T_With_Diagonal_Stroke . #\U+2C66) + + (#\Latin_Capital_Letter_Glottal_Stop . #\Latin_Small_Letter_Glottal_Stop) + + (#\Latin_Capital_Letter_B_With_Stroke . #\Latin_Small_Letter_B_With_Stroke) + + (#\Latin_Capital_Letter_U_Bar . #\Latin_Small_Letter_U_Bar) + + (#\Latin_Capital_Letter_Turned_V . #\Latin_Small_Letter_Turned_V) + + (#\Latin_Capital_Letter_E_With_Stroke . #\Latin_Small_Letter_E_With_Stroke) + + (#\Latin_Capital_Letter_J_With_Stroke . #\Latin_Small_Letter_J_With_Stroke) + + (#\Latin_Capital_Letter_Small_Q_With_Hook_Tail + . #\Latin_Small_Letter_Q_With_Hook_Tail) + + (#\Latin_Capital_Letter_R_With_Stroke . #\Latin_Small_Letter_R_With_Stroke) + + (#\Latin_Capital_Letter_Y_With_Stroke . #\Latin_Small_Letter_Y_With_Stroke) + + (#\Greek_Capital_Letter_Alpha_With_Tonos + . #\Greek_Small_Letter_Alpha_With_Tonos) + + (#\Greek_Capital_Letter_Epsilon_With_Tonos + . #\Greek_Small_Letter_Epsilon_With_Tonos) + + (#\Greek_Capital_Letter_Eta_With_Tonos . #\Greek_Small_Letter_Eta_With_Tonos) + + (#\Greek_Capital_Letter_Iota_With_Tonos + . #\Greek_Small_Letter_Iota_With_Tonos) + + (#\Greek_Capital_Letter_Omicron_With_Tonos + . #\Greek_Small_Letter_Omicron_With_Tonos) + + (#\Greek_Capital_Letter_Upsilon_With_Tonos + . #\Greek_Small_Letter_Upsilon_With_Tonos) + + (#\Greek_Capital_Letter_Omega_With_Tonos + . #\Greek_Small_Letter_Omega_With_Tonos) + + (#\Greek_Capital_Letter_Alpha . #\Greek_Small_Letter_Alpha) + + (#\Greek_Capital_Letter_Beta . #\Greek_Small_Letter_Beta) + + (#\Greek_Capital_Letter_Gamma . #\Greek_Small_Letter_Gamma) + + (#\Greek_Capital_Letter_Delta . #\Greek_Small_Letter_Delta) + + (#\Greek_Capital_Letter_Epsilon . #\Greek_Small_Letter_Epsilon) + + (#\Greek_Capital_Letter_Zeta . #\Greek_Small_Letter_Zeta) + + (#\Greek_Capital_Letter_Eta . #\Greek_Small_Letter_Eta) + + (#\Greek_Capital_Letter_Theta . #\Greek_Small_Letter_Theta) + + (#\Greek_Capital_Letter_Iota . #\Greek_Small_Letter_Iota) + + (#\Greek_Capital_Letter_Kappa . #\Greek_Small_Letter_Kappa) + + (#\Greek_Capital_Letter_Lamda . #\Greek_Small_Letter_Lamda) + + (#\Greek_Capital_Letter_Mu . #\Greek_Small_Letter_Mu) + + (#\Greek_Capital_Letter_Nu . #\Greek_Small_Letter_Nu) + + (#\Greek_Capital_Letter_Xi . #\Greek_Small_Letter_Xi) + + (#\Greek_Capital_Letter_Omicron . #\Greek_Small_Letter_Omicron) + + (#\Greek_Capital_Letter_Pi . #\Greek_Small_Letter_Pi) + + (#\Greek_Capital_Letter_Rho . #\Greek_Small_Letter_Rho) + + (#\Greek_Capital_Letter_Sigma . #\Greek_Small_Letter_Sigma) + + (#\Greek_Capital_Letter_Tau . #\Greek_Small_Letter_Tau) + + (#\Greek_Capital_Letter_Upsilon . #\Greek_Small_Letter_Upsilon) + + (#\Greek_Capital_Letter_Phi . #\Greek_Small_Letter_Phi) + + (#\Greek_Capital_Letter_Chi . #\Greek_Small_Letter_Chi) + + (#\Greek_Capital_Letter_Psi . #\Greek_Small_Letter_Psi) + + (#\Greek_Capital_Letter_Omega . #\Greek_Small_Letter_Omega) + + (#\Greek_Capital_Letter_Iota_With_Dialytika + . #\Greek_Small_Letter_Iota_With_Dialytika) + + (#\Greek_Capital_Letter_Upsilon_With_Dialytika + . #\Greek_Small_Letter_Upsilon_With_Dialytika) + + (#\Greek_Letter_Archaic_Koppa . #\Greek_Small_Letter_Archaic_Koppa) + + (#\Greek_Letter_Stigma . #\Greek_Small_Letter_Stigma) + + (#\Greek_Letter_Digamma . #\Greek_Small_Letter_Digamma) + + (#\Greek_Letter_Koppa . #\Greek_Small_Letter_Koppa) + + (#\Greek_Letter_Sampi . #\Greek_Small_Letter_Sampi) + + (#\Coptic_Capital_Letter_Shei . #\Coptic_Small_Letter_Shei) + + (#\Coptic_Capital_Letter_Fei . #\Coptic_Small_Letter_Fei) + + (#\Coptic_Capital_Letter_Khei . #\Coptic_Small_Letter_Khei) + + (#\Coptic_Capital_Letter_Hori . #\Coptic_Small_Letter_Hori) + + (#\Coptic_Capital_Letter_Gangia . #\Coptic_Small_Letter_Gangia) + + (#\Coptic_Capital_Letter_Shima . #\Coptic_Small_Letter_Shima) + + (#\Coptic_Capital_Letter_Dei . #\Coptic_Small_Letter_Dei) + + (#\Greek_Capital_Letter_Sho . #\Greek_Small_Letter_Sho) + + (#\Greek_Capital_Lunate_Sigma_Symbol . #\Greek_Lunate_Sigma_Symbol) + + (#\Greek_Capital_Letter_San . #\Greek_Small_Letter_San) + + (#\Greek_Capital_Reversed_Lunate_Sigma_Symbol + . #\Greek_Small_Reversed_Lunate_Sigma_Symbol) + + (#\Greek_Capital_Dotted_Lunate_Sigma_Symbol + . #\Greek_Small_Dotted_Lunate_Sigma_Symbol) + + (#\Greek_Capital_Reversed_Dotted_Lunate_Sigma_Symbol + . #\Greek_Small_Reversed_Dotted_Lunate_Sigma_Symbol) + + (#\Cyrillic_Capital_Letter_Ie_With_Grave + . #\Cyrillic_Small_Letter_Ie_With_Grave) + + (#\Cyrillic_Capital_Letter_Io . #\Cyrillic_Small_Letter_Io) + + (#\Cyrillic_Capital_Letter_Dje . #\Cyrillic_Small_Letter_Dje) + + (#\Cyrillic_Capital_Letter_Gje . #\Cyrillic_Small_Letter_Gje) + + (#\Cyrillic_Capital_Letter_Ukrainian_Ie + . #\Cyrillic_Small_Letter_Ukrainian_Ie) + + (#\Cyrillic_Capital_Letter_Dze . #\Cyrillic_Small_Letter_Dze) + + (#\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I + . #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I) + + (#\Cyrillic_Capital_Letter_Yi . #\Cyrillic_Small_Letter_Yi) + + (#\Cyrillic_Capital_Letter_Je . #\Cyrillic_Small_Letter_Je) + + (#\Cyrillic_Capital_Letter_Lje . #\Cyrillic_Small_Letter_Lje) + + (#\Cyrillic_Capital_Letter_Nje . #\Cyrillic_Small_Letter_Nje) + + (#\Cyrillic_Capital_Letter_Tshe . #\Cyrillic_Small_Letter_Tshe) + + (#\Cyrillic_Capital_Letter_Kje . #\Cyrillic_Small_Letter_Kje) + + (#\Cyrillic_Capital_Letter_I_With_Grave + . #\Cyrillic_Small_Letter_I_With_Grave) + + (#\Cyrillic_Capital_Letter_Short_U . #\Cyrillic_Small_Letter_Short_U) + + (#\Cyrillic_Capital_Letter_Dzhe . #\Cyrillic_Small_Letter_Dzhe) + + (#\Cyrillic_Capital_Letter_A . #\Cyrillic_Small_Letter_A) + + (#\Cyrillic_Capital_Letter_Be . #\Cyrillic_Small_Letter_Be) + + (#\Cyrillic_Capital_Letter_Ve . #\Cyrillic_Small_Letter_Ve) + + (#\Cyrillic_Capital_Letter_Ghe . #\Cyrillic_Small_Letter_Ghe) + + (#\Cyrillic_Capital_Letter_De . #\Cyrillic_Small_Letter_De) + + (#\Cyrillic_Capital_Letter_Ie . #\Cyrillic_Small_Letter_Ie) + + (#\Cyrillic_Capital_Letter_Zhe . #\Cyrillic_Small_Letter_Zhe) + + (#\Cyrillic_Capital_Letter_Ze . #\Cyrillic_Small_Letter_Ze) + + (#\Cyrillic_Capital_Letter_I . #\Cyrillic_Small_Letter_I) + + (#\Cyrillic_Capital_Letter_Short_I . #\Cyrillic_Small_Letter_Short_I) + + (#\Cyrillic_Capital_Letter_Ka . #\Cyrillic_Small_Letter_Ka) + + (#\Cyrillic_Capital_Letter_El . #\Cyrillic_Small_Letter_El) + + (#\Cyrillic_Capital_Letter_Em . #\Cyrillic_Small_Letter_Em) + + (#\Cyrillic_Capital_Letter_En . #\Cyrillic_Small_Letter_En) + + (#\Cyrillic_Capital_Letter_O . #\Cyrillic_Small_Letter_O) + + (#\Cyrillic_Capital_Letter_Pe . #\Cyrillic_Small_Letter_Pe) + + (#\Cyrillic_Capital_Letter_Er . #\Cyrillic_Small_Letter_Er) + + (#\Cyrillic_Capital_Letter_Es . #\Cyrillic_Small_Letter_Es) + + (#\Cyrillic_Capital_Letter_Te . #\Cyrillic_Small_Letter_Te) + + (#\Cyrillic_Capital_Letter_U . #\Cyrillic_Small_Letter_U) + + (#\Cyrillic_Capital_Letter_Ef . #\Cyrillic_Small_Letter_Ef) + + (#\Cyrillic_Capital_Letter_Ha . #\Cyrillic_Small_Letter_Ha) + + (#\Cyrillic_Capital_Letter_Tse . #\Cyrillic_Small_Letter_Tse) + + (#\Cyrillic_Capital_Letter_Che . #\Cyrillic_Small_Letter_Che) + + (#\Cyrillic_Capital_Letter_Sha . #\Cyrillic_Small_Letter_Sha) + + (#\Cyrillic_Capital_Letter_Shcha . #\Cyrillic_Small_Letter_Shcha) + + (#\Cyrillic_Capital_Letter_Hard_Sign . #\Cyrillic_Small_Letter_Hard_Sign) + + (#\Cyrillic_Capital_Letter_Yeru . #\Cyrillic_Small_Letter_Yeru) + + (#\Cyrillic_Capital_Letter_Soft_Sign . #\Cyrillic_Small_Letter_Soft_Sign) + + (#\Cyrillic_Capital_Letter_E . #\Cyrillic_Small_Letter_E) + + (#\Cyrillic_Capital_Letter_Yu . #\Cyrillic_Small_Letter_Yu) + + (#\Cyrillic_Capital_Letter_Ya . #\Cyrillic_Small_Letter_Ya) + + (#\Cyrillic_Capital_Letter_Omega . #\Cyrillic_Small_Letter_Omega) + + (#\Cyrillic_Capital_Letter_Yat . #\Cyrillic_Small_Letter_Yat) + + (#\Cyrillic_Capital_Letter_Iotified_E . #\Cyrillic_Small_Letter_Iotified_E) + + (#\Cyrillic_Capital_Letter_Little_Yus . #\Cyrillic_Small_Letter_Little_Yus) + + (#\Cyrillic_Capital_Letter_Iotified_Little_Yus + . #\Cyrillic_Small_Letter_Iotified_Little_Yus) + + (#\Cyrillic_Capital_Letter_Big_Yus . #\Cyrillic_Small_Letter_Big_Yus) + + (#\Cyrillic_Capital_Letter_Iotified_Big_Yus + . #\Cyrillic_Small_Letter_Iotified_Big_Yus) + + (#\Cyrillic_Capital_Letter_Ksi . #\Cyrillic_Small_Letter_Ksi) + + (#\Cyrillic_Capital_Letter_Psi . #\Cyrillic_Small_Letter_Psi) + + (#\Cyrillic_Capital_Letter_Fita . #\Cyrillic_Small_Letter_Fita) + + (#\Cyrillic_Capital_Letter_Izhitsa . #\Cyrillic_Small_Letter_Izhitsa) + + (#\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent + . #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent) + + (#\Cyrillic_Capital_Letter_Uk . #\Cyrillic_Small_Letter_Uk) + + (#\Cyrillic_Capital_Letter_Round_Omega . #\Cyrillic_Small_Letter_Round_Omega) + + (#\Cyrillic_Capital_Letter_Omega_With_Titlo + . #\Cyrillic_Small_Letter_Omega_With_Titlo) + + (#\Cyrillic_Capital_Letter_Ot . #\Cyrillic_Small_Letter_Ot) + + (#\Cyrillic_Capital_Letter_Koppa . #\Cyrillic_Small_Letter_Koppa) + + (#\Cyrillic_Capital_Letter_Short_I_With_Tail + . #\Cyrillic_Small_Letter_Short_I_With_Tail) + + (#\Cyrillic_Capital_Letter_Semisoft_Sign + . #\Cyrillic_Small_Letter_Semisoft_Sign) + + (#\Cyrillic_Capital_Letter_Er_With_Tick + . #\Cyrillic_Small_Letter_Er_With_Tick) + + (#\Cyrillic_Capital_Letter_Ghe_With_Upturn + . #\Cyrillic_Small_Letter_Ghe_With_Upturn) + + (#\Cyrillic_Capital_Letter_Ghe_With_Stroke + . #\Cyrillic_Small_Letter_Ghe_With_Stroke) + + (#\Cyrillic_Capital_Letter_Ghe_With_Middle_Hook + . #\Cyrillic_Small_Letter_Ghe_With_Middle_Hook) + + (#\Cyrillic_Capital_Letter_Zhe_With_Descender + . #\Cyrillic_Small_Letter_Zhe_With_Descender) + + (#\Cyrillic_Capital_Letter_Ze_With_Descender + . #\Cyrillic_Small_Letter_Ze_With_Descender) + + (#\Cyrillic_Capital_Letter_Ka_With_Descender + . #\Cyrillic_Small_Letter_Ka_With_Descender) + + (#\Cyrillic_Capital_Letter_Ka_With_Vertical_Stroke + . #\Cyrillic_Small_Letter_Ka_With_Vertical_Stroke) + + (#\Cyrillic_Capital_Letter_Ka_With_Stroke + . #\Cyrillic_Small_Letter_Ka_With_Stroke) + + (#\Cyrillic_Capital_Letter_Bashkir_Ka . #\Cyrillic_Small_Letter_Bashkir_Ka) + + (#\Cyrillic_Capital_Letter_En_With_Descender + . #\Cyrillic_Small_Letter_En_With_Descender) + + (#\Cyrillic_Capital_Ligature_En_Ghe . #\Cyrillic_Small_Ligature_En_Ghe) + + (#\Cyrillic_Capital_Letter_Pe_With_Middle_Hook + . #\Cyrillic_Small_Letter_Pe_With_Middle_Hook) + + (#\Cyrillic_Capital_Letter_Abkhasian_Ha + . #\Cyrillic_Small_Letter_Abkhasian_Ha) + + (#\Cyrillic_Capital_Letter_Es_With_Descender + . #\Cyrillic_Small_Letter_Es_With_Descender) + + (#\Cyrillic_Capital_Letter_Te_With_Descender + . #\Cyrillic_Small_Letter_Te_With_Descender) + + (#\Cyrillic_Capital_Letter_Straight_U . #\Cyrillic_Small_Letter_Straight_U) + + (#\Cyrillic_Capital_Letter_Straight_U_With_Stroke + . #\Cyrillic_Small_Letter_Straight_U_With_Stroke) + + (#\Cyrillic_Capital_Letter_Ha_With_Descender + . #\Cyrillic_Small_Letter_Ha_With_Descender) + + (#\Cyrillic_Capital_Ligature_Te_Tse . #\Cyrillic_Small_Ligature_Te_Tse) + + (#\Cyrillic_Capital_Letter_Che_With_Descender + . #\Cyrillic_Small_Letter_Che_With_Descender) + + (#\Cyrillic_Capital_Letter_Che_With_Vertical_Stroke + . #\Cyrillic_Small_Letter_Che_With_Vertical_Stroke) + + (#\Cyrillic_Capital_Letter_Shha . #\Cyrillic_Small_Letter_Shha) + + (#\Cyrillic_Capital_Letter_Abkhasian_Che + . #\Cyrillic_Small_Letter_Abkhasian_Che) + + (#\Cyrillic_Capital_Letter_Abkhasian_Che_With_Descender + . #\Cyrillic_Small_Letter_Abkhasian_Che_With_Descender) + + (#\Cyrillic_Letter_Palochka . #\Cyrillic_Small_Letter_Palochka) + + (#\Cyrillic_Capital_Letter_Zhe_With_Breve + . #\Cyrillic_Small_Letter_Zhe_With_Breve) + + (#\Cyrillic_Capital_Letter_Ka_With_Hook + . #\Cyrillic_Small_Letter_Ka_With_Hook) + + (#\Cyrillic_Capital_Letter_El_With_Tail + . #\Cyrillic_Small_Letter_El_With_Tail) + + (#\Cyrillic_Capital_Letter_En_With_Hook + . #\Cyrillic_Small_Letter_En_With_Hook) + + (#\Cyrillic_Capital_Letter_En_With_Tail + . #\Cyrillic_Small_Letter_En_With_Tail) + + (#\Cyrillic_Capital_Letter_Khakassian_Che + . #\Cyrillic_Small_Letter_Khakassian_Che) + + (#\Cyrillic_Capital_Letter_Em_With_Tail + . #\Cyrillic_Small_Letter_Em_With_Tail) + + (#\Cyrillic_Capital_Letter_A_With_Breve + . #\Cyrillic_Small_Letter_A_With_Breve) + + (#\Cyrillic_Capital_Letter_A_With_Diaeresis + . #\Cyrillic_Small_Letter_A_With_Diaeresis) + + (#\Cyrillic_Capital_Ligature_A_Ie . #\Cyrillic_Small_Ligature_A_Ie) + + (#\Cyrillic_Capital_Letter_Ie_With_Breve + . #\Cyrillic_Small_Letter_Ie_With_Breve) + + (#\Cyrillic_Capital_Letter_Schwa . #\Cyrillic_Small_Letter_Schwa) + + (#\Cyrillic_Capital_Letter_Schwa_With_Diaeresis + . #\Cyrillic_Small_Letter_Schwa_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Zhe_With_Diaeresis + . #\Cyrillic_Small_Letter_Zhe_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Ze_With_Diaeresis + . #\Cyrillic_Small_Letter_Ze_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Abkhasian_Dze + . #\Cyrillic_Small_Letter_Abkhasian_Dze) + + (#\Cyrillic_Capital_Letter_I_With_Macron + . #\Cyrillic_Small_Letter_I_With_Macron) + + (#\Cyrillic_Capital_Letter_I_With_Diaeresis + . #\Cyrillic_Small_Letter_I_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_O_With_Diaeresis + . #\Cyrillic_Small_Letter_O_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Barred_O . #\Cyrillic_Small_Letter_Barred_O) + + (#\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis + . #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_E_With_Diaeresis + . #\Cyrillic_Small_Letter_E_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_U_With_Macron + . #\Cyrillic_Small_Letter_U_With_Macron) + + (#\Cyrillic_Capital_Letter_U_With_Diaeresis + . #\Cyrillic_Small_Letter_U_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_U_With_Double_Acute + . #\Cyrillic_Small_Letter_U_With_Double_Acute) + + (#\Cyrillic_Capital_Letter_Che_With_Diaeresis + . #\Cyrillic_Small_Letter_Che_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Ghe_With_Descender + . #\Cyrillic_Small_Letter_Ghe_With_Descender) + + (#\Cyrillic_Capital_Letter_Yeru_With_Diaeresis + . #\Cyrillic_Small_Letter_Yeru_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Ghe_With_Stroke_And_Hook + . #\Cyrillic_Small_Letter_Ghe_With_Stroke_And_Hook) + + (#\Cyrillic_Capital_Letter_Ha_With_Hook + . #\Cyrillic_Small_Letter_Ha_With_Hook) + + (#\Cyrillic_Capital_Letter_Ha_With_Stroke + . #\Cyrillic_Small_Letter_Ha_With_Stroke) + + (#\Cyrillic_Capital_Letter_Komi_De . #\Cyrillic_Small_Letter_Komi_De) + + (#\Cyrillic_Capital_Letter_Komi_Dje . #\Cyrillic_Small_Letter_Komi_Dje) + + (#\Cyrillic_Capital_Letter_Komi_Zje . #\Cyrillic_Small_Letter_Komi_Zje) + + (#\Cyrillic_Capital_Letter_Komi_Dzje . #\Cyrillic_Small_Letter_Komi_Dzje) + + (#\Cyrillic_Capital_Letter_Komi_Lje . #\Cyrillic_Small_Letter_Komi_Lje) + + (#\Cyrillic_Capital_Letter_Komi_Nje . #\Cyrillic_Small_Letter_Komi_Nje) + + (#\Cyrillic_Capital_Letter_Komi_Sje . #\Cyrillic_Small_Letter_Komi_Sje) + + (#\Cyrillic_Capital_Letter_Komi_Tje . #\Cyrillic_Small_Letter_Komi_Tje) + + (#\Cyrillic_Capital_Letter_Reversed_Ze . #\Cyrillic_Small_Letter_Reversed_Ze) + + (#\Cyrillic_Capital_Letter_El_With_Hook + . #\Cyrillic_Small_Letter_El_With_Hook) + + (#\Armenian_Capital_Letter_Ayb . #\Armenian_Small_Letter_Ayb) + + (#\Armenian_Capital_Letter_Ben . #\Armenian_Small_Letter_Ben) + + (#\Armenian_Capital_Letter_Gim . #\Armenian_Small_Letter_Gim) + + (#\Armenian_Capital_Letter_Da . #\Armenian_Small_Letter_Da) + + (#\Armenian_Capital_Letter_Ech . #\Armenian_Small_Letter_Ech) + + (#\Armenian_Capital_Letter_Za . #\Armenian_Small_Letter_Za) + + (#\Armenian_Capital_Letter_Eh . #\Armenian_Small_Letter_Eh) + + (#\Armenian_Capital_Letter_Et . #\Armenian_Small_Letter_Et) + + (#\Armenian_Capital_Letter_To . #\Armenian_Small_Letter_To) + + (#\Armenian_Capital_Letter_Zhe . #\Armenian_Small_Letter_Zhe) + + (#\Armenian_Capital_Letter_Ini . #\Armenian_Small_Letter_Ini) + + (#\Armenian_Capital_Letter_Liwn . #\Armenian_Small_Letter_Liwn) + + (#\Armenian_Capital_Letter_Xeh . #\Armenian_Small_Letter_Xeh) + + (#\Armenian_Capital_Letter_Ca . #\Armenian_Small_Letter_Ca) + + (#\Armenian_Capital_Letter_Ken . #\Armenian_Small_Letter_Ken) + + (#\Armenian_Capital_Letter_Ho . #\Armenian_Small_Letter_Ho) + + (#\Armenian_Capital_Letter_Ja . #\Armenian_Small_Letter_Ja) + + (#\Armenian_Capital_Letter_Ghad . #\Armenian_Small_Letter_Ghad) + + (#\Armenian_Capital_Letter_Cheh . #\Armenian_Small_Letter_Cheh) + + (#\Armenian_Capital_Letter_Men . #\Armenian_Small_Letter_Men) + + (#\Armenian_Capital_Letter_Yi . #\Armenian_Small_Letter_Yi) + + (#\Armenian_Capital_Letter_Now . #\Armenian_Small_Letter_Now) + + (#\Armenian_Capital_Letter_Sha . #\Armenian_Small_Letter_Sha) + + (#\Armenian_Capital_Letter_Vo . #\Armenian_Small_Letter_Vo) + + (#\Armenian_Capital_Letter_Cha . #\Armenian_Small_Letter_Cha) + + (#\Armenian_Capital_Letter_Peh . #\Armenian_Small_Letter_Peh) + + (#\Armenian_Capital_Letter_Jheh . #\Armenian_Small_Letter_Jheh) + + (#\Armenian_Capital_Letter_Ra . #\Armenian_Small_Letter_Ra) + + (#\Armenian_Capital_Letter_Seh . #\Armenian_Small_Letter_Seh) + + (#\Armenian_Capital_Letter_Vew . #\Armenian_Small_Letter_Vew) + + (#\Armenian_Capital_Letter_Tiwn . #\Armenian_Small_Letter_Tiwn) + + (#\Armenian_Capital_Letter_Reh . #\Armenian_Small_Letter_Reh) + + (#\Armenian_Capital_Letter_Co . #\Armenian_Small_Letter_Co) + + (#\Armenian_Capital_Letter_Yiwn . #\Armenian_Small_Letter_Yiwn) + + (#\Armenian_Capital_Letter_Piwr . #\Armenian_Small_Letter_Piwr) + + (#\Armenian_Capital_Letter_Keh . #\Armenian_Small_Letter_Keh) + + (#\Armenian_Capital_Letter_Oh . #\Armenian_Small_Letter_Oh) + + (#\Armenian_Capital_Letter_Feh . #\Armenian_Small_Letter_Feh) + + (#\U+10A0 . #\U+2D00) + (#\U+10A1 . #\U+2D01) + (#\U+10A2 . #\U+2D02) + + (#\U+10A3 . #\U+2D03) + (#\U+10A4 . #\U+2D04) + (#\U+10A5 . #\U+2D05) + + (#\U+10A6 . #\U+2D06) + (#\U+10A7 . #\U+2D07) + (#\U+10A8 . #\U+2D08) + + (#\U+10A9 . #\U+2D09) + (#\U+10AA . #\U+2D0A) + (#\U+10AB . #\U+2D0B) + + (#\U+10AC . #\U+2D0C) + (#\U+10AD . #\U+2D0D) + (#\U+10AE . #\U+2D0E) + + (#\U+10AF . #\U+2D0F) + (#\U+10B0 . #\U+2D10) + (#\U+10B1 . #\U+2D11) + + (#\U+10B2 . #\U+2D12) + (#\U+10B3 . #\U+2D13) + (#\U+10B4 . #\U+2D14) + + (#\U+10B5 . #\U+2D15) + (#\U+10B6 . #\U+2D16) + (#\U+10B7 . #\U+2D17) + + (#\U+10B8 . #\U+2D18) + (#\U+10B9 . #\U+2D19) + (#\U+10BA . #\U+2D1A) + + (#\U+10BB . #\U+2D1B) + (#\U+10BC . #\U+2D1C) + (#\U+10BD . #\U+2D1D) + + (#\U+10BE . #\U+2D1E) + (#\U+10BF . #\U+2D1F) + (#\U+10C0 . #\U+2D20) + + (#\U+10C1 . #\U+2D21) + (#\U+10C2 . #\U+2D22) + (#\U+10C3 . #\U+2D23) + + (#\U+10C4 . #\U+2D24) + (#\U+10C5 . #\U+2D25) + (#\U+1E00 . #\U+1E01) + + (#\U+1E02 . #\U+1E03) + (#\U+1E04 . #\U+1E05) + (#\U+1E06 . #\U+1E07) + + (#\U+1E08 . #\U+1E09) + (#\U+1E0A . #\U+1E0B) + (#\U+1E0C . #\U+1E0D) + + (#\U+1E0E . #\U+1E0F) + (#\U+1E10 . #\U+1E11) + (#\U+1E12 . #\U+1E13) + + (#\U+1E14 . #\U+1E15) + (#\U+1E16 . #\U+1E17) + (#\U+1E18 . #\U+1E19) + + (#\U+1E1A . #\U+1E1B) + (#\U+1E1C . #\U+1E1D) + (#\U+1E1E . #\U+1E1F) + + (#\U+1E20 . #\U+1E21) + (#\U+1E22 . #\U+1E23) + (#\U+1E24 . #\U+1E25) + + (#\U+1E26 . #\U+1E27) + (#\U+1E28 . #\U+1E29) + (#\U+1E2A . #\U+1E2B) + + (#\U+1E2C . #\U+1E2D) + (#\U+1E2E . #\U+1E2F) + (#\U+1E30 . #\U+1E31) + + (#\U+1E32 . #\U+1E33) + (#\U+1E34 . #\U+1E35) + (#\U+1E36 . #\U+1E37) + + (#\U+1E38 . #\U+1E39) + (#\U+1E3A . #\U+1E3B) + (#\U+1E3C . #\U+1E3D) + + (#\U+1E3E . #\U+1E3F) + (#\U+1E40 . #\U+1E41) + (#\U+1E42 . #\U+1E43) + + (#\U+1E44 . #\U+1E45) + (#\U+1E46 . #\U+1E47) + (#\U+1E48 . #\U+1E49) + + (#\U+1E4A . #\U+1E4B) + (#\U+1E4C . #\U+1E4D) + (#\U+1E4E . #\U+1E4F) + + (#\U+1E50 . #\U+1E51) + (#\U+1E52 . #\U+1E53) + (#\U+1E54 . #\U+1E55) + + (#\U+1E56 . #\U+1E57) + (#\U+1E58 . #\U+1E59) + (#\U+1E5A . #\U+1E5B) + + (#\U+1E5C . #\U+1E5D) + (#\U+1E5E . #\U+1E5F) + (#\U+1E60 . #\U+1E61) + + (#\U+1E62 . #\U+1E63) + (#\U+1E64 . #\U+1E65) + (#\U+1E66 . #\U+1E67) + + (#\U+1E68 . #\U+1E69) + (#\U+1E6A . #\U+1E6B) + (#\U+1E6C . #\U+1E6D) + + (#\U+1E6E . #\U+1E6F) + (#\U+1E70 . #\U+1E71) + (#\U+1E72 . #\U+1E73) + + (#\U+1E74 . #\U+1E75) + (#\U+1E76 . #\U+1E77) + (#\U+1E78 . #\U+1E79) + + (#\U+1E7A . #\U+1E7B) + (#\U+1E7C . #\U+1E7D) + (#\U+1E7E . #\U+1E7F) + + (#\U+1E80 . #\U+1E81) + (#\U+1E82 . #\U+1E83) + (#\U+1E84 . #\U+1E85) + + (#\U+1E86 . #\U+1E87) + (#\U+1E88 . #\U+1E89) + (#\U+1E8A . #\U+1E8B) + + (#\U+1E8C . #\U+1E8D) + (#\U+1E8E . #\U+1E8F) + (#\U+1E90 . #\U+1E91) + + (#\U+1E92 . #\U+1E93) + (#\U+1E94 . #\U+1E95) + (#\U+1EA0 . #\U+1EA1) + + (#\U+1EA2 . #\U+1EA3) + (#\U+1EA4 . #\U+1EA5) + (#\U+1EA6 . #\U+1EA7) + + (#\U+1EA8 . #\U+1EA9) + (#\U+1EAA . #\U+1EAB) + (#\U+1EAC . #\U+1EAD) + + (#\U+1EAE . #\U+1EAF) + (#\U+1EB0 . #\U+1EB1) + (#\U+1EB2 . #\U+1EB3) + + (#\U+1EB4 . #\U+1EB5) + (#\U+1EB6 . #\U+1EB7) + (#\U+1EB8 . #\U+1EB9) + + (#\U+1EBA . #\U+1EBB) + (#\U+1EBC . #\U+1EBD) + (#\U+1EBE . #\U+1EBF) + + (#\U+1EC0 . #\U+1EC1) + (#\U+1EC2 . #\U+1EC3) + (#\U+1EC4 . #\U+1EC5) + + (#\U+1EC6 . #\U+1EC7) + (#\U+1EC8 . #\U+1EC9) + (#\U+1ECA . #\U+1ECB) + + (#\U+1ECC . #\U+1ECD) + (#\U+1ECE . #\U+1ECF) + (#\U+1ED0 . #\U+1ED1) + + (#\U+1ED2 . #\U+1ED3) + (#\U+1ED4 . #\U+1ED5) + (#\U+1ED6 . #\U+1ED7) + + (#\U+1ED8 . #\U+1ED9) + (#\U+1EDA . #\U+1EDB) + (#\U+1EDC . #\U+1EDD) + + (#\U+1EDE . #\U+1EDF) + (#\U+1EE0 . #\U+1EE1) + (#\U+1EE2 . #\U+1EE3) + + (#\U+1EE4 . #\U+1EE5) + (#\U+1EE6 . #\U+1EE7) + (#\U+1EE8 . #\U+1EE9) + + (#\U+1EEA . #\U+1EEB) + (#\U+1EEC . #\U+1EED) + (#\U+1EEE . #\U+1EEF) + + (#\U+1EF0 . #\U+1EF1) + (#\U+1EF2 . #\U+1EF3) + (#\U+1EF4 . #\U+1EF5) + + (#\U+1EF6 . #\U+1EF7) + (#\U+1EF8 . #\U+1EF9) + (#\U+1F08 . #\U+1F00) + + (#\U+1F09 . #\U+1F01) + (#\U+1F0A . #\U+1F02) + (#\U+1F0B . #\U+1F03) + + (#\U+1F0C . #\U+1F04) + (#\U+1F0D . #\U+1F05) + (#\U+1F0E . #\U+1F06) + + (#\U+1F0F . #\U+1F07) + (#\U+1F18 . #\U+1F10) + (#\U+1F19 . #\U+1F11) + + (#\U+1F1A . #\U+1F12) + (#\U+1F1B . #\U+1F13) + (#\U+1F1C . #\U+1F14) + + (#\U+1F1D . #\U+1F15) + (#\U+1F28 . #\U+1F20) + (#\U+1F29 . #\U+1F21) + + (#\U+1F2A . #\U+1F22) + (#\U+1F2B . #\U+1F23) + (#\U+1F2C . #\U+1F24) + + (#\U+1F2D . #\U+1F25) + (#\U+1F2E . #\U+1F26) + (#\U+1F2F . #\U+1F27) + + (#\U+1F38 . #\U+1F30) + (#\U+1F39 . #\U+1F31) + (#\U+1F3A . #\U+1F32) + + (#\U+1F3B . #\U+1F33) + (#\U+1F3C . #\U+1F34) + (#\U+1F3D . #\U+1F35) + + (#\U+1F3E . #\U+1F36) + (#\U+1F3F . #\U+1F37) + (#\U+1F48 . #\U+1F40) + + (#\U+1F49 . #\U+1F41) + (#\U+1F4A . #\U+1F42) + (#\U+1F4B . #\U+1F43) + + (#\U+1F4C . #\U+1F44) + (#\U+1F4D . #\U+1F45) + (#\U+1F59 . #\U+1F51) + + (#\U+1F5B . #\U+1F53) + (#\U+1F5D . #\U+1F55) + (#\U+1F5F . #\U+1F57) + + (#\U+1F68 . #\U+1F60) + (#\U+1F69 . #\U+1F61) + (#\U+1F6A . #\U+1F62) + + (#\U+1F6B . #\U+1F63) + (#\U+1F6C . #\U+1F64) + (#\U+1F6D . #\U+1F65) + + (#\U+1F6E . #\U+1F66) + (#\U+1F6F . #\U+1F67) + (#\U+1F88 . #\U+1F80) + + (#\U+1F89 . #\U+1F81) + (#\U+1F8A . #\U+1F82) + (#\U+1F8B . #\U+1F83) + + (#\U+1F8C . #\U+1F84) + (#\U+1F8D . #\U+1F85) + (#\U+1F8E . #\U+1F86) + + (#\U+1F8F . #\U+1F87) + (#\U+1F98 . #\U+1F90) + (#\U+1F99 . #\U+1F91) + + (#\U+1F9A . #\U+1F92) + (#\U+1F9B . #\U+1F93) + (#\U+1F9C . #\U+1F94) + + (#\U+1F9D . #\U+1F95) + (#\U+1F9E . #\U+1F96) + (#\U+1F9F . #\U+1F97) + + (#\U+1FA8 . #\U+1FA0) + (#\U+1FA9 . #\U+1FA1) + (#\U+1FAA . #\U+1FA2) + + (#\U+1FAB . #\U+1FA3) + (#\U+1FAC . #\U+1FA4) + (#\U+1FAD . #\U+1FA5) + + (#\U+1FAE . #\U+1FA6) + (#\U+1FAF . #\U+1FA7) + (#\U+1FB8 . #\U+1FB0) + + (#\U+1FB9 . #\U+1FB1) + (#\U+1FBA . #\U+1F70) + (#\U+1FBB . #\U+1F71) + + (#\U+1FBC . #\U+1FB3) + (#\U+1FC8 . #\U+1F72) + (#\U+1FC9 . #\U+1F73) + + (#\U+1FCA . #\U+1F74) + (#\U+1FCB . #\U+1F75) + (#\U+1FCC . #\U+1FC3) + + (#\U+1FD8 . #\U+1FD0) + (#\U+1FD9 . #\U+1FD1) + (#\U+1FDA . #\U+1F76) + + (#\U+1FDB . #\U+1F77) + (#\U+1FE8 . #\U+1FE0) + (#\U+1FE9 . #\U+1FE1) + + (#\U+1FEA . #\U+1F7A) + (#\U+1FEB . #\U+1F7B) + (#\U+1FEC . #\U+1FE5) + + (#\U+1FF8 . #\U+1F78) + (#\U+1FF9 . #\U+1F79) + (#\U+1FFA . #\U+1F7C) + + (#\U+1FFB . #\U+1F7D) + (#\U+1FFC . #\U+1FF3) + (#\U+2132 . #\U+214E) + + (#\U+2160 . #\U+2170) + (#\U+2161 . #\U+2171) + (#\U+2162 . #\U+2172) + + (#\U+2163 . #\U+2173) + (#\U+2164 . #\U+2174) + (#\U+2165 . #\U+2175) + + (#\U+2166 . #\U+2176) + (#\U+2167 . #\U+2177) + (#\U+2168 . #\U+2178) + + (#\U+2169 . #\U+2179) + (#\U+216A . #\U+217A) + (#\U+216B . #\U+217B) + + (#\U+216C . #\U+217C) + (#\U+216D . #\U+217D) + (#\U+216E . #\U+217E) + + (#\U+216F . #\U+217F) + (#\U+2183 . #\U+2184) + (#\U+24B6 . #\U+24D0) + + (#\U+24B7 . #\U+24D1) + (#\U+24B8 . #\U+24D2) + (#\U+24B9 . #\U+24D3) + + (#\U+24BA . #\U+24D4) + (#\U+24BB . #\U+24D5) + (#\U+24BC . #\U+24D6) + + (#\U+24BD . #\U+24D7) + (#\U+24BE . #\U+24D8) + (#\U+24BF . #\U+24D9) + + (#\U+24C0 . #\U+24DA) + (#\U+24C1 . #\U+24DB) + (#\U+24C2 . #\U+24DC) + + (#\U+24C3 . #\U+24DD) + (#\U+24C4 . #\U+24DE) + (#\U+24C5 . #\U+24DF) + + (#\U+24C6 . #\U+24E0) + (#\U+24C7 . #\U+24E1) + (#\U+24C8 . #\U+24E2) + + (#\U+24C9 . #\U+24E3) + (#\U+24CA . #\U+24E4) + (#\U+24CB . #\U+24E5) + + (#\U+24CC . #\U+24E6) + (#\U+24CD . #\U+24E7) + (#\U+24CE . #\U+24E8) + + (#\U+24CF . #\U+24E9) + (#\U+2C00 . #\U+2C30) + (#\U+2C01 . #\U+2C31) + + (#\U+2C02 . #\U+2C32) + (#\U+2C03 . #\U+2C33) + (#\U+2C04 . #\U+2C34) + + (#\U+2C05 . #\U+2C35) + (#\U+2C06 . #\U+2C36) + (#\U+2C07 . #\U+2C37) + + (#\U+2C08 . #\U+2C38) + (#\U+2C09 . #\U+2C39) + (#\U+2C0A . #\U+2C3A) + + (#\U+2C0B . #\U+2C3B) + (#\U+2C0C . #\U+2C3C) + (#\U+2C0D . #\U+2C3D) + + (#\U+2C0E . #\U+2C3E) + (#\U+2C0F . #\U+2C3F) + (#\U+2C10 . #\U+2C40) + + (#\U+2C11 . #\U+2C41) + (#\U+2C12 . #\U+2C42) + (#\U+2C13 . #\U+2C43) + + (#\U+2C14 . #\U+2C44) + (#\U+2C15 . #\U+2C45) + (#\U+2C16 . #\U+2C46) + + (#\U+2C17 . #\U+2C47) + (#\U+2C18 . #\U+2C48) + (#\U+2C19 . #\U+2C49) + + (#\U+2C1A . #\U+2C4A) + (#\U+2C1B . #\U+2C4B) + (#\U+2C1C . #\U+2C4C) + + (#\U+2C1D . #\U+2C4D) + (#\U+2C1E . #\U+2C4E) + (#\U+2C1F . #\U+2C4F) + + (#\U+2C20 . #\U+2C50) + (#\U+2C21 . #\U+2C51) + (#\U+2C22 . #\U+2C52) + + (#\U+2C23 . #\U+2C53) + (#\U+2C24 . #\U+2C54) + (#\U+2C25 . #\U+2C55) + + (#\U+2C26 . #\U+2C56) + (#\U+2C27 . #\U+2C57) + (#\U+2C28 . #\U+2C58) + + (#\U+2C29 . #\U+2C59) + (#\U+2C2A . #\U+2C5A) + (#\U+2C2B . #\U+2C5B) + + (#\U+2C2C . #\U+2C5C) + (#\U+2C2D . #\U+2C5D) + (#\U+2C2E . #\U+2C5E) + + (#\U+2C60 . #\U+2C61) + (#\U+2C62 . #\Latin_Small_Letter_L_With_Middle_Tilde) + + (#\U+2C63 . #\U+1D7D) + (#\U+2C64 . #\Latin_Small_Letter_R_With_Tail) + + (#\U+2C67 . #\U+2C68) + (#\U+2C69 . #\U+2C6A) + (#\U+2C6B . #\U+2C6C) + + (#\U+2C75 . #\U+2C76) + (#\U+2C80 . #\U+2C81) + (#\U+2C82 . #\U+2C83) + + (#\U+2C84 . #\U+2C85) + (#\U+2C86 . #\U+2C87) + (#\U+2C88 . #\U+2C89) + + (#\U+2C8A . #\U+2C8B) + (#\U+2C8C . #\U+2C8D) + (#\U+2C8E . #\U+2C8F) + + (#\U+2C90 . #\U+2C91) + (#\U+2C92 . #\U+2C93) + (#\U+2C94 . #\U+2C95) + + (#\U+2C96 . #\U+2C97) + (#\U+2C98 . #\U+2C99) + (#\U+2C9A . #\U+2C9B) + + (#\U+2C9C . #\U+2C9D) + (#\U+2C9E . #\U+2C9F) + (#\U+2CA0 . #\U+2CA1) + + (#\U+2CA2 . #\U+2CA3) + (#\U+2CA4 . #\U+2CA5) + (#\U+2CA6 . #\U+2CA7) + + (#\U+2CA8 . #\U+2CA9) + (#\U+2CAA . #\U+2CAB) + (#\U+2CAC . #\U+2CAD) + + (#\U+2CAE . #\U+2CAF) + (#\U+2CB0 . #\U+2CB1) + (#\U+2CB2 . #\U+2CB3) + + (#\U+2CB4 . #\U+2CB5) + (#\U+2CB6 . #\U+2CB7) + (#\U+2CB8 . #\U+2CB9) + + (#\U+2CBA . #\U+2CBB) + (#\U+2CBC . #\U+2CBD) + (#\U+2CBE . #\U+2CBF) + + (#\U+2CC0 . #\U+2CC1) + (#\U+2CC2 . #\U+2CC3) + (#\U+2CC4 . #\U+2CC5) + + (#\U+2CC6 . #\U+2CC7) + (#\U+2CC8 . #\U+2CC9) + (#\U+2CCA . #\U+2CCB) + + (#\U+2CCC . #\U+2CCD) + (#\U+2CCE . #\U+2CCF) + (#\U+2CD0 . #\U+2CD1) + + (#\U+2CD2 . #\U+2CD3) + (#\U+2CD4 . #\U+2CD5) + (#\U+2CD6 . #\U+2CD7) + + (#\U+2CD8 . #\U+2CD9) + (#\U+2CDA . #\U+2CDB) + (#\U+2CDC . #\U+2CDD) + + (#\U+2CDE . #\U+2CDF) + (#\U+2CE0 . #\U+2CE1) + (#\U+2CE2 . #\U+2CE3) + + (#\U+FF21 . #\U+FF41) + (#\U+FF22 . #\U+FF42) + (#\U+FF23 . #\U+FF43) + + (#\U+FF24 . #\U+FF44) + (#\U+FF25 . #\U+FF45) + (#\U+FF26 . #\U+FF46) + + (#\U+FF27 . #\U+FF47) + (#\U+FF28 . #\U+FF48) + (#\U+FF29 . #\U+FF49) + + (#\U+FF2A . #\U+FF4A) + (#\U+FF2B . #\U+FF4B) + (#\U+FF2C . #\U+FF4C) + + (#\U+FF2D . #\U+FF4D) + (#\U+FF2E . #\U+FF4E) + (#\U+FF2F . #\U+FF4F) + + (#\U+FF30 . #\U+FF50) + (#\U+FF31 . #\U+FF51) + (#\U+FF32 . #\U+FF52) + + (#\U+FF33 . #\U+FF53) + (#\U+FF34 . #\U+FF54) + (#\U+FF35 . #\U+FF55) + + (#\U+FF36 . #\U+FF56) + (#\U+FF37 . #\U+FF57) + (#\U+FF38 . #\U+FF58) + + (#\U+FF39 . #\U+FF59) + (#\U+FF3A . #\U+FF5A) + (#\U+10400 . #\U+10428) + + (#\U+10401 . #\U+10429) + (#\U+10402 . #\U+1042A) + (#\U+10403 . #\U+1042B) + + (#\U+10404 . #\U+1042C) + (#\U+10405 . #\U+1042D) + (#\U+10406 . #\U+1042E) + + (#\U+10407 . #\U+1042F) + (#\U+10408 . #\U+10430) + (#\U+10409 . #\U+10431) + + (#\U+1040A . #\U+10432) + (#\U+1040B . #\U+10433) + (#\U+1040C . #\U+10434) + + (#\U+1040D . #\U+10435) + (#\U+1040E . #\U+10436) + (#\U+1040F . #\U+10437) + + (#\U+10410 . #\U+10438) + (#\U+10411 . #\U+10439) + (#\U+10412 . #\U+1043A) + + (#\U+10413 . #\U+1043B) + (#\U+10414 . #\U+1043C) + (#\U+10415 . #\U+1043D) + + (#\U+10416 . #\U+1043E) + (#\U+10417 . #\U+1043F) + (#\U+10418 . #\U+10440) + + (#\U+10419 . #\U+10441) + (#\U+1041A . #\U+10442) + (#\U+1041B . #\U+10443) + + (#\U+1041C . #\U+10444) + (#\U+1041D . #\U+10445) + (#\U+1041E . #\U+10446) + + (#\U+1041F . #\U+10447) + (#\U+10420 . #\U+10448) + (#\U+10421 . #\U+10449) + + (#\U+10422 . #\U+1044A) + (#\U+10423 . #\U+1044B) + (#\U+10424 . #\U+1044C) + + (#\U+10425 . #\U+1044D) + (#\U+10426 . #\U+1044E) + (#\U+10427 . #\U+1044F) + )) + (max-upper #\u+0000) + (max-lower #\u+0000)) + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + (dolist (pair mapping) + (destructuring-bind (upper . lower) pair + (when (char> upper max-upper) + (setq max-upper upper)) + (when (char> lower max-lower) + (setq max-lower lower)))) + (let* ((upper-to-lower (make-array (the fixnum (1+ (the fixnum (char-code max-upper)))) :element-type '(signed-byte 16))) + (lower-to-upper (make-array (the fixnum (1+ (the fixnum (char-code max-lower)))) :element-type '(signed-byte 16)))) + (dolist (pair mapping) + (destructuring-bind (upper . lower) pair + (let* ((upper-code (char-code upper)) + (lower-code (char-code lower)) + (diff (- lower-code upper-code))) + (declare (type (mod #x110000) upper-code lower-code) + (type (signed-byte 16) diff)) + (setf (aref upper-to-lower upper-code) diff + (aref lower-to-upper lower-code) (the fixnum (- diff)))))) + (do* ((upper (char-code #\A) (1+ upper)) + (lower (char-code #\a) (1+ lower))) + ((> upper (char-code #\Z))) + (setf (aref upper-to-lower upper) (- lower upper) + (aref lower-to-upper lower) (- upper lower))) + (setq *lower-to-upper* lower-to-upper + *upper-to-lower* upper-to-lower) + nil)) + +(eval-when (:compile-toplevel) + (declaim (inline %char-code-case-fold))) + +(defun %char-code-case-fold (code table) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) table)) + (if (>= code (length table)) + code + (locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (+ code (the (signed-byte 16) (aref table code))))))) + +(defun %char-code-upcase (code) + (%char-code-case-fold code *lower-to-upper*)) + +(defun char-upcase (c) + "Return CHAR converted to upper-case if that is possible. Don't convert + lowercase eszet (U+DF)." + (declare (optimize speed)) ; so that %char-code-case-fold inlines + (code-char (the valid-char-code (%char-code-case-fold (char-code c) *lower-to-upper*)))) + + + + +(defun %char-code-downcase (code) + (declare (type (mod #x110000) code)) + (let* ((table *upper-to-lower*)) + (declare (type (simple-array (signed-byte 16) (*)) table)) + (if (>= code (length table)) + code + (locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (+ code (the (signed-byte 16) (aref table code)))))))) + + +;;;True for a-z, and maybe other things. +(defun lower-case-p (c) + "The argument must be a character object; LOWER-CASE-P returns T if the + argument is a lower-case character, NIL otherwise." + (let* ((code (char-code c)) + (table *lower-to-upper*)) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) table)) + (if (< code (length table)) + (not (eql 0 (the (signed-byte 16) (aref table code))))))) + + + +(defstatic *alpha-char-bits* + (let* ((bits (make-array #x2fa1e :element-type 'bit))) + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + (dolist (range '((#x0041 . #x005A) + (#x0061 . #x007A) + #x00AA + #x00B5 + #x00BA + (#x00C0 . #x00D6) + (#x00D8 . #x00F6) + (#x00F8 . #x01BA) + #x01BB + (#x01BC . #x01BF) + (#x01C0 . #x01C3) + (#x01C4 . #x0293) + #x0294 + (#x0295 . #x02AF) + (#x02B0 . #x02C1) + (#x02C6 . #x02D1) + (#x02E0 . #x02E4) + #x02EC + #x02EE + #x0345 + (#x0370 . #x0373) + #x0374 + (#x0376 . #x0377) + #x037A + (#x037B . #x037D) + #x0386 + (#x0388 . #x038A) + #x038C + (#x038E . #x03A1) + (#x03A3 . #x03F5) + (#x03F7 . #x0481) + (#x048A . #x0523) + (#x0531 . #x0556) + #x0559 + (#x0561 . #x0587) + (#x05B0 . #x05BD) + #x05BF + (#x05C1 . #x05C2) + (#x05C4 . #x05C5) + #x05C7 + (#x05D0 . #x05EA) + (#x05F0 . #x05F2) + (#x0610 . #x061A) + (#x0621 . #x063F) + #x0640 + (#x0641 . #x064A) + (#x064B . #x0657) + (#x0659 . #x065E) + (#x066E . #x066F) + #x0670 + (#x0671 . #x06D3) + #x06D5 + (#x06D6 . #x06DC) + (#x06E1 . #x06E4) + (#x06E5 . #x06E6) + (#x06E7 . #x06E8) + #x06ED + (#x06EE . #x06EF) + (#x06FA . #x06FC) + #x06FF + #x0710 + #x0711 + (#x0712 . #x072F) + (#x0730 . #x073F) + (#x074D . #x07A5) + (#x07A6 . #x07B0) + #x07B1 + (#x07CA . #x07EA) + (#x07F4 . #x07F5) + #x07FA + (#x0901 . #x0902) + #x0903 + (#x0904 . #x0939) + #x093D + (#x093E . #x0940) + (#x0941 . #x0948) + (#x0949 . #x094C) + #x0950 + (#x0958 . #x0961) + (#x0962 . #x0963) + #x0971 + #x0972 + (#x097B . #x097F) + #x0981 + (#x0982 . #x0983) + (#x0985 . #x098C) + (#x098F . #x0990) + (#x0993 . #x09A8) + (#x09AA . #x09B0) + #x09B2 + (#x09B6 . #x09B9) + #x09BD + (#x09BE . #x09C0) + (#x09C1 . #x09C4) + (#x09C7 . #x09C8) + (#x09CB . #x09CC) + #x09CE + #x09D7 + (#x09DC . #x09DD) + (#x09DF . #x09E1) + (#x09E2 . #x09E3) + (#x09F0 . #x09F1) + (#x0A01 . #x0A02) + #x0A03 + (#x0A05 . #x0A0A) + (#x0A0F . #x0A10) + (#x0A13 . #x0A28) + (#x0A2A . #x0A30) + (#x0A32 . #x0A33) + (#x0A35 . #x0A36) + (#x0A38 . #x0A39) + (#x0A3E . #x0A40) + (#x0A41 . #x0A42) + (#x0A47 . #x0A48) + (#x0A4B . #x0A4C) + #x0A51 + (#x0A59 . #x0A5C) + #x0A5E + (#x0A70 . #x0A71) + (#x0A72 . #x0A74) + #x0A75 + (#x0A81 . #x0A82) + #x0A83 + (#x0A85 . #x0A8D) + (#x0A8F . #x0A91) + (#x0A93 . #x0AA8) + (#x0AAA . #x0AB0) + (#x0AB2 . #x0AB3) + (#x0AB5 . #x0AB9) + #x0ABD + (#x0ABE . #x0AC0) + (#x0AC1 . #x0AC5) + (#x0AC7 . #x0AC8) + #x0AC9 + (#x0ACB . #x0ACC) + #x0AD0 + (#x0AE0 . #x0AE1) + (#x0AE2 . #x0AE3) + #x0B01 + (#x0B02 . #x0B03) + (#x0B05 . #x0B0C) + (#x0B0F . #x0B10) + (#x0B13 . #x0B28) + (#x0B2A . #x0B30) + (#x0B32 . #x0B33) + (#x0B35 . #x0B39) + #x0B3D + #x0B3E + #x0B3F + #x0B40 + (#x0B41 . #x0B44) + (#x0B47 . #x0B48) + (#x0B4B . #x0B4C) + #x0B56 + #x0B57 + (#x0B5C . #x0B5D) + (#x0B5F . #x0B61) + (#x0B62 . #x0B63) + #x0B71 + #x0B82 + #x0B83 + (#x0B85 . #x0B8A) + (#x0B8E . #x0B90) + (#x0B92 . #x0B95) + (#x0B99 . #x0B9A) + #x0B9C + (#x0B9E . #x0B9F) + (#x0BA3 . #x0BA4) + (#x0BA8 . #x0BAA) + (#x0BAE . #x0BB9) + (#x0BBE . #x0BBF) + #x0BC0 + (#x0BC1 . #x0BC2) + (#x0BC6 . #x0BC8) + (#x0BCA . #x0BCC) + #x0BD0 + #x0BD7 + (#x0C01 . #x0C03) + (#x0C05 . #x0C0C) + (#x0C0E . #x0C10) + (#x0C12 . #x0C28) + (#x0C2A . #x0C33) + (#x0C35 . #x0C39) + #x0C3D + (#x0C3E . #x0C40) + (#x0C41 . #x0C44) + (#x0C46 . #x0C48) + (#x0C4A . #x0C4C) + (#x0C55 . #x0C56) + (#x0C58 . #x0C59) + (#x0C60 . #x0C61) + (#x0C62 . #x0C63) + (#x0C82 . #x0C83) + (#x0C85 . #x0C8C) + (#x0C8E . #x0C90) + (#x0C92 . #x0CA8) + (#x0CAA . #x0CB3) + (#x0CB5 . #x0CB9) + #x0CBD + #x0CBE + #x0CBF + (#x0CC0 . #x0CC4) + #x0CC6 + (#x0CC7 . #x0CC8) + (#x0CCA . #x0CCB) + #x0CCC + (#x0CD5 . #x0CD6) + #x0CDE + (#x0CE0 . #x0CE1) + (#x0CE2 . #x0CE3) + (#x0D02 . #x0D03) + (#x0D05 . #x0D0C) + (#x0D0E . #x0D10) + (#x0D12 . #x0D28) + (#x0D2A . #x0D39) + #x0D3D + (#x0D3E . #x0D40) + (#x0D41 . #x0D44) + (#x0D46 . #x0D48) + (#x0D4A . #x0D4C) + #x0D57 + (#x0D60 . #x0D61) + (#x0D62 . #x0D63) + (#x0D7A . #x0D7F) + (#x0D82 . #x0D83) + (#x0D85 . #x0D96) + (#x0D9A . #x0DB1) + (#x0DB3 . #x0DBB) + #x0DBD + (#x0DC0 . #x0DC6) + (#x0DCF . #x0DD1) + (#x0DD2 . #x0DD4) + #x0DD6 + (#x0DD8 . #x0DDF) + (#x0DF2 . #x0DF3) + (#x0E01 . #x0E30) + #x0E31 + (#x0E32 . #x0E33) + (#x0E34 . #x0E3A) + (#x0E40 . #x0E45) + #x0E46 + #x0E4D + (#x0E81 . #x0E82) + #x0E84 + (#x0E87 . #x0E88) + #x0E8A + #x0E8D + (#x0E94 . #x0E97) + (#x0E99 . #x0E9F) + (#x0EA1 . #x0EA3) + #x0EA5 + #x0EA7 + (#x0EAA . #x0EAB) + (#x0EAD . #x0EB0) + #x0EB1 + (#x0EB2 . #x0EB3) + (#x0EB4 . #x0EB9) + (#x0EBB . #x0EBC) + #x0EBD + (#x0EC0 . #x0EC4) + #x0EC6 + #x0ECD + (#x0EDC . #x0EDD) + #x0F00 + (#x0F40 . #x0F47) + (#x0F49 . #x0F6C) + (#x0F71 . #x0F7E) + #x0F7F + (#x0F80 . #x0F81) + (#x0F88 . #x0F8B) + (#x0F90 . #x0F97) + (#x0F99 . #x0FBC) + (#x1000 . #x102A) + (#x102B . #x102C) + (#x102D . #x1030) + #x1031 + (#x1032 . #x1036) + #x1038 + (#x103B . #x103C) + (#x103D . #x103E) + #x103F + (#x1050 . #x1055) + (#x1056 . #x1057) + (#x1058 . #x1059) + (#x105A . #x105D) + (#x105E . #x1060) + #x1061 + #x1062 + (#x1065 . #x1066) + (#x1067 . #x1068) + (#x106E . #x1070) + (#x1071 . #x1074) + (#x1075 . #x1081) + #x1082 + (#x1083 . #x1084) + (#x1085 . #x1086) + #x108E + (#x10A0 . #x10C5) + (#x10D0 . #x10FA) + #x10FC + (#x1100 . #x1159) + (#x115F . #x11A2) + (#x11A8 . #x11F9) + (#x1200 . #x1248) + (#x124A . #x124D) + (#x1250 . #x1256) + #x1258 + (#x125A . #x125D) + (#x1260 . #x1288) + (#x128A . #x128D) + (#x1290 . #x12B0) + (#x12B2 . #x12B5) + (#x12B8 . #x12BE) + #x12C0 + (#x12C2 . #x12C5) + (#x12C8 . #x12D6) + (#x12D8 . #x1310) + (#x1312 . #x1315) + (#x1318 . #x135A) + #x135F + (#x1380 . #x138F) + (#x13A0 . #x13F4) + (#x1401 . #x166C) + (#x166F . #x1676) + (#x1681 . #x169A) + (#x16A0 . #x16EA) + (#x16EE . #x16F0) + (#x1700 . #x170C) + (#x170E . #x1711) + (#x1712 . #x1713) + (#x1720 . #x1731) + (#x1732 . #x1733) + (#x1740 . #x1751) + (#x1752 . #x1753) + (#x1760 . #x176C) + (#x176E . #x1770) + (#x1772 . #x1773) + (#x1780 . #x17B3) + #x17B6 + (#x17B7 . #x17BD) + (#x17BE . #x17C5) + #x17C6 + (#x17C7 . #x17C8) + #x17D7 + #x17DC + (#x1820 . #x1842) + #x1843 + (#x1844 . #x1877) + (#x1880 . #x18A8) + #x18A9 + #x18AA + (#x1900 . #x191C) + (#x1920 . #x1922) + (#x1923 . #x1926) + (#x1927 . #x1928) + (#x1929 . #x192B) + (#x1930 . #x1931) + #x1932 + (#x1933 . #x1938) + (#x1950 . #x196D) + (#x1970 . #x1974) + (#x1980 . #x19A9) + (#x19B0 . #x19C0) + (#x19C1 . #x19C7) + (#x19C8 . #x19C9) + (#x1A00 . #x1A16) + (#x1A17 . #x1A18) + (#x1A19 . #x1A1B) + (#x1B00 . #x1B03) + #x1B04 + (#x1B05 . #x1B33) + #x1B35 + (#x1B36 . #x1B3A) + #x1B3B + #x1B3C + (#x1B3D . #x1B41) + #x1B42 + #x1B43 + (#x1B45 . #x1B4B) + (#x1B80 . #x1B81) + #x1B82 + (#x1B83 . #x1BA0) + #x1BA1 + (#x1BA2 . #x1BA5) + (#x1BA6 . #x1BA7) + (#x1BA8 . #x1BA9) + (#x1BAE . #x1BAF) + (#x1C00 . #x1C23) + (#x1C24 . #x1C2B) + (#x1C2C . #x1C33) + (#x1C34 . #x1C35) + (#x1C4D . #x1C4F) + (#x1C5A . #x1C77) + (#x1C78 . #x1C7D) + (#x1D00 . #x1D2B) + (#x1D2C . #x1D61) + (#x1D62 . #x1D77) + #x1D78 + (#x1D79 . #x1D9A) + (#x1D9B . #x1DBF) + (#x1E00 . #x1F15) + (#x1F18 . #x1F1D) + (#x1F20 . #x1F45) + (#x1F48 . #x1F4D) + (#x1F50 . #x1F57) + #x1F59 + #x1F5B + #x1F5D + (#x1F5F . #x1F7D) + (#x1F80 . #x1FB4) + (#x1FB6 . #x1FBC) + #x1FBE + (#x1FC2 . #x1FC4) + (#x1FC6 . #x1FCC) + (#x1FD0 . #x1FD3) + (#x1FD6 . #x1FDB) + (#x1FE0 . #x1FEC) + (#x1FF2 . #x1FF4) + (#x1FF6 . #x1FFC) + #x2071 + #x207F + (#x2090 . #x2094) + #x2102 + #x2107 + (#x210A . #x2113) + #x2115 + (#x2119 . #x211D) + #x2124 + #x2126 + #x2128 + (#x212A . #x212D) + (#x212F . #x2134) + (#x2135 . #x2138) + #x2139 + (#x213C . #x213F) + (#x2145 . #x2149) + #x214E + (#x2160 . #x2182) + (#x2183 . #x2184) + (#x2185 . #x2188) + (#x24B6 . #x24E9) + (#x2C00 . #x2C2E) + (#x2C30 . #x2C5E) + (#x2C60 . #x2C6F) + (#x2C71 . #x2C7C) + #x2C7D + (#x2C80 . #x2CE4) + (#x2D00 . #x2D25) + (#x2D30 . #x2D65) + #x2D6F + (#x2D80 . #x2D96) + (#x2DA0 . #x2DA6) + (#x2DA8 . #x2DAE) + (#x2DB0 . #x2DB6) + (#x2DB8 . #x2DBE) + (#x2DC0 . #x2DC6) + (#x2DC8 . #x2DCE) + (#x2DD0 . #x2DD6) + (#x2DD8 . #x2DDE) + (#x2DE0 . #x2DFF) + #x2E2F + #x3005 + #x3006 + #x3007 + (#x3021 . #x3029) + (#x3031 . #x3035) + (#x3038 . #x303A) + #x303B + #x303C + (#x3041 . #x3096) + (#x309D . #x309E) + #x309F + (#x30A1 . #x30FA) + (#x30FC . #x30FE) + #x30FF + (#x3105 . #x312D) + (#x3131 . #x318E) + (#x31A0 . #x31B7) + (#x31F0 . #x31FF) + (#x3400 . #x4DB5) + (#x4E00 . #x9FC3) + (#xA000 . #xA014) + #xA015 + (#xA016 . #xA48C) + (#xA500 . #xA60B) + #xA60C + (#xA610 . #xA61F) + (#xA62A . #xA62B) + (#xA640 . #xA65F) + (#xA662 . #xA66D) + #xA66E + #xA67F + (#xA680 . #xA697) + (#xA717 . #xA71F) + (#xA722 . #xA76F) + #xA770 + (#xA771 . #xA787) + #xA788 + (#xA78B . #xA78C) + (#xA7FB . #xA801) + (#xA803 . #xA805) + (#xA807 . #xA80A) + (#xA80C . #xA822) + (#xA823 . #xA824) + (#xA825 . #xA826) + #xA827 + (#xA840 . #xA873) + (#xA880 . #xA881) + (#xA882 . #xA8B3) + (#xA8B4 . #xA8C3) + (#xA90A . #xA925) + (#xA926 . #xA92A) + (#xA930 . #xA946) + (#xA947 . #xA951) + #xA952 + (#xAA00 . #xAA28) + (#xAA29 . #xAA2E) + (#xAA2F . #xAA30) + (#xAA31 . #xAA32) + (#xAA33 . #xAA34) + (#xAA35 . #xAA36) + (#xAA40 . #xAA42) + #xAA43 + (#xAA44 . #xAA4B) + #xAA4C + #xAA4D + (#xAC00 . #xD7A3) + (#xF900 . #xFA2D) + (#xFA30 . #xFA6A) + (#xFA70 . #xFAD9) + (#xFB00 . #xFB06) + (#xFB13 . #xFB17) + #xFB1D + #xFB1E + (#xFB1F . #xFB28) + (#xFB2A . #xFB36) + (#xFB38 . #xFB3C) + #xFB3E + (#xFB40 . #xFB41) + (#xFB43 . #xFB44) + (#xFB46 . #xFBB1) + (#xFBD3 . #xFD3D) + (#xFD50 . #xFD8F) + (#xFD92 . #xFDC7) + (#xFDF0 . #xFDFB) + (#xFE70 . #xFE74) + (#xFE76 . #xFEFC) + (#xFF21 . #xFF3A) + (#xFF41 . #xFF5A) + (#xFF66 . #xFF6F) + #xFF70 + (#xFF71 . #xFF9D) + (#xFF9E . #xFF9F) + (#xFFA0 . #xFFBE) + (#xFFC2 . #xFFC7) + (#xFFCA . #xFFCF) + (#xFFD2 . #xFFD7) + (#xFFDA . #xFFDC) + (#x10000 . #x1000B) + (#x1000D . #x10026) + (#x10028 . #x1003A) + (#x1003C . #x1003D) + (#x1003F . #x1004D) + (#x10050 . #x1005D) + (#x10080 . #x100FA) + (#x10140 . #x10174) + (#x10280 . #x1029C) + (#x102A0 . #x102D0) + (#x10300 . #x1031E) + (#x10330 . #x10340) + #x10341 + (#x10342 . #x10349) + #x1034A + (#x10380 . #x1039D) + (#x103A0 . #x103C3) + (#x103C8 . #x103CF) + (#x103D1 . #x103D5) + (#x10400 . #x1044F) + (#x10450 . #x1049D) + (#x10800 . #x10805) + #x10808 + (#x1080A . #x10835) + (#x10837 . #x10838) + #x1083C + #x1083F + (#x10900 . #x10915) + (#x10920 . #x10939) + #x10A00 + (#x10A01 . #x10A03) + (#x10A05 . #x10A06) + (#x10A0C . #x10A0F) + (#x10A10 . #x10A13) + (#x10A15 . #x10A17) + (#x10A19 . #x10A33) + (#x12000 . #x1236E) + (#x12400 . #x12462) + (#x1D400 . #x1D454) + (#x1D456 . #x1D49C) + (#x1D49E . #x1D49F) + #x1D4A2 + (#x1D4A5 . #x1D4A6) + (#x1D4A9 . #x1D4AC) + (#x1D4AE . #x1D4B9) + #x1D4BB + (#x1D4BD . #x1D4C3) + (#x1D4C5 . #x1D505) + (#x1D507 . #x1D50A) + (#x1D50D . #x1D514) + (#x1D516 . #x1D51C) + (#x1D51E . #x1D539) + (#x1D53B . #x1D53E) + (#x1D540 . #x1D544) + #x1D546 + (#x1D54A . #x1D550) + (#x1D552 . #x1D6A5) + (#x1D6A8 . #x1D6C0) + (#x1D6C2 . #x1D6DA) + (#x1D6DC . #x1D6FA) + (#x1D6FC . #x1D714) + (#x1D716 . #x1D734) + (#x1D736 . #x1D74E) + (#x1D750 . #x1D76E) + (#x1D770 . #x1D788) + (#x1D78A . #x1D7A8) + (#x1D7AA . #x1D7C2) + (#x1D7C4 . #x1D7CB) + (#x20000 . #x2A6D6) + (#x2F800 . #x2FA1D)) + bits) + (let* ((low (if (atom range) range (car range))) + (high (1+ (if (atom range) range (cdr range))))) + (do* ((i low (1+ i))) + ((= i high)) + (setf (sbit bits i) 1)))))) + + +(defun alpha-char-p (c) + "The argument must be a character object. ALPHA-CHAR-P returns T if the + argument is an alphabetic character; otherwise NIL." + (let* ((code (char-code c)) + (bits *alpha-char-bits*)) + (declare (type (mod #x110000) code) + (simple-bit-vector bits)) + (and (< code (length bits)) + (not (eql 0 (sbit bits code)))))) + + +;;; def-accessors type-tracking stuff. Used by inspector +(defvar *def-accessor-types* nil) + +(defun add-accessor-types (types names) + (dolist (type types) + (let ((cell (or (assq type *def-accessor-types*) + (car (push (cons type nil) *def-accessor-types*))))) + (setf (cdr cell) (if (vectorp names) names (%list-to-uvector nil names)))))) + + +;;; Some simple explicit storage management for cons cells + +(def-standard-initial-binding *cons-pool* (%cons-pool nil)) + +(defun cheap-cons (car cdr) + (let* ((pool *cons-pool*) + (cons (pool.data pool))) + (if cons + (locally (declare (type cons cons)) + (setf (pool.data pool) (cdr cons) + (car cons) car + (cdr cons) cdr) + cons) + (cons car cdr)))) + +(defun free-cons (cons) + (when (consp cons) + (locally (declare (type cons cons)) + (setf (car cons) nil + (cdr cons) nil) + (let* ((pool *cons-pool*) + (freelist (pool.data pool))) + (setf (pool.data pool) cons + (cdr cons) freelist))))) + +(defun cheap-copy-list (list) + (let ((l list) + res) + (loop + (when (atom l) + (return (nreconc res l))) + (setq res (cheap-cons (pop l) res))))) + +(defun cheap-list (&rest args) + (declare (dynamic-extent args)) + (cheap-copy-list args)) + +;;; Works for dotted lists +(defun cheap-free-list (list) + (let ((l list) + next-l) + (loop + (setq next-l (cdr l)) + (free-cons l) + (when (atom (setq l next-l)) + (return))))) + +(defmacro pop-and-free (place) + (setq place (require-type place 'symbol)) ; all I need for now. + (let ((list (gensym)) + (cdr (gensym))) + `(let* ((,list ,place) + (,cdr (cdr ,list))) + (prog1 + (car ,list) + (setf ,place ,cdr) + (free-cons ,list))))) + +;;; Support for defresource & using-resource macros +(defun make-resource (constructor &key destructor initializer) + (%cons-resource constructor destructor initializer)) + +(defun allocate-resource (resource) + (setq resource (require-type resource 'resource)) + (with-lock-grabbed ((resource.lock resource)) + (let ((pool (resource.pool resource)) + res) + (let ((data (pool.data pool))) + (when data + (setf res (car data) + (pool.data pool) (cdr (the cons data))) + (free-cons data))) + (if res + (let ((initializer (resource.initializer resource))) + (when initializer + (funcall initializer res))) + (setq res (funcall (resource.constructor resource)))) + res))) + +(defun free-resource (resource instance) + (setq resource (require-type resource 'resource)) + (with-lock-grabbed ((resource.lock resource)) + (let ((pool (resource.pool resource)) + (destructor (resource.destructor resource))) + (when destructor + (funcall destructor instance)) + (setf (pool.data pool) + (cheap-cons instance (pool.data pool))))) + resource) + +(defun valid-char-code-p (code) + (and (typep code 'fixnum) + (locally (declare (fixnum code)) + (and + (>= code 0) + (< code #x110000) + (or (< code #xfffe) + (> code #xffff)) + (or (< code #xd800) + (> code #xdfff)))))) + + +(defpackage #.(ftd-interface-package-name + (backend-target-foreign-type-data *target-backend*)) + (:nicknames "OS") + (:use "COMMON-LISP")) + + + Index: /branches/qres/ccl/level-1/l1-boot-1.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-boot-1.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-boot-1.lisp (revision 13564) @@ -0,0 +1,124 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-boot.lisp + +(in-package "CCL") + +(defparameter *gensym-counter* 0 "counter for generating unique GENSYM symbols") + +(defparameter *inhibit-greeting* nil) + +;the below 3 variables are expected to be redefined in the user's init file +(defparameter *short-site-name* nil) +(defparameter *long-site-name* nil) +#| +(defparameter *machine-instance* nil) +|# + +(defun lisp-implementation-type () + #+clozure-common-lisp "Clozure Common Lisp" + #-clozure-common-lisp "OpenMCL") + + +(defparameter *platform-os-names* + `((,platform-os-vxworks . :vxwork) + (,platform-os-linux . :linux) + (,platform-os-solaris . :solaris) + (,platform-os-darwin . :darwin) + (,platform-os-freebsd . :freebsd) + (,platform-os-windows . :windows))) + +(defparameter *platform-cpu-names* + `((,platform-cpu-ppc . :ppc) + (,platform-cpu-sparc . :sparc) + (,platform-cpu-x86 . :x86))) + +(defun host-platform () + (let* ((pf (%get-kernel-global 'host-platform))) + (values + (or (cdr (assoc (logand pf platform-os-mask) + *platform-os-names*)) + :unknown) + (if (logtest pf platform-word-size-mask) + 64 + 32) + (or (cdr (assoc (logand pf platform-cpu-mask) + *platform-cpu-names*)) + :unknown)))) + + +(defun platform-description () + (multiple-value-bind (os bits cpu) (host-platform) + (format nil "~a~a~d" (string-capitalize os) cpu bits))) + +(defun lisp-implementation-version () + (%str-cat "Version " (format nil *openmcl-version* (platform-description)))) + + + + +(defun replace-base-translation (host-dir new-base-dir) + (let* ((host (pathname-host host-dir)) + (device (pathname-device new-base-dir)) + (host-dir (full-pathname host-dir)) + (trans (logical-pathname-translations host)) + (host-wild (merge-pathnames "**/*.*" host-dir))) + (setq host-dir (pathname-directory host-dir)) + (setq new-base-dir (pathname-directory new-base-dir)) + (setf + (logical-pathname-translations host) + (mapcar + #'(lambda (pair) + (let ((rhs (cadr pair))) + (if (and (physical-pathname-p rhs) + (pathname-match-p rhs host-wild)) + (list (car pair) + (merge-pathnames + (make-pathname + :defaults nil + :device device + :directory (append new-base-dir + (nthcdr (length host-dir) + (pathname-directory rhs)))) + rhs)) + pair))) + trans)))) + +(defun set-ccl-directory (path) + (replace-base-translation "ccl:" (translate-logical-pathname path))) + + + + +; only do these if exist +(defun init-logical-directories () + (replace-base-translation "home:" (user-homedir-pathname)) + (replace-base-translation "ccl:" (ccl-directory))) + +(push #'init-logical-directories *lisp-system-pointer-functions*) + + +(catch :toplevel + (init-logical-directories) + ) + + + + + + Index: /branches/qres/ccl/level-1/l1-boot-2.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-boot-2.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-boot-2.lisp (revision 13564) @@ -0,0 +1,334 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; l1-boot-2.lisp +;; Second part of l1-boot + +(in-package "CCL") + +(macrolet ((l1-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./l1-fasls/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(let* ((*loading-file-source-file* *loading-file-source-file*) + (*loading-toplevel-location* *loading-toplevel-location*)) + (%fasload ,namestring)))) + (bin-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./bin/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(let* ((*loading-file-source-file* *loading-file-source-file*) + (*loading-toplevel-location* *loading-toplevel-location*)) + (%fasload ,namestring))))) + + +(catch :toplevel + #+ppc-target + (l1-load "ppc-error-signal") + #+x86-target + (l1-load "x86-error-signal") + (l1-load "l1-error-signal") + (l1-load "l1-sockets") + (setq *LEVEL-1-LOADED* t)) + +#+ppc-target +(defun altivec-available-p () + "Return non-NIL if AltiVec is available." + (not (eql (%get-kernel-global 'ppc::altivec-present) 0))) + +#+ppc-target +(defloadvar *altivec-available* (altivec-available-p) + "This variable is intitialized each time a Clozure CL session starts based +on information provided by the lisp kernel. Its value is true if AltiVec is +present and false otherwise. This variable shouldn't be set by user code.") + + +(defstatic *auto-flush-streams* ()) +(def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil)) +(defstatic *auto-flush-streams-lock* (make-lock)) + + +(defvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0))) +(defloadvar *quiet-flag* nil) +(defvar *terminal-input* ()) +(defvar *terminal-output* ()) +(defvar *stdin* ()) +(defvar *stdout* ()) +(defvar *stderr* ()) + + +(defun set-basic-stream-prototype (class) + (when (subtypep class 'basic-stream) + (setf (%class.prototype class) (or (%class.prototype class) + (allocate-basic-stream class))) + (dolist (subclass (class-direct-subclasses class)) + (set-basic-stream-prototype subclass)))) + +(set-basic-stream-prototype (find-class 'basic-stream)) + + +;;; The hard parts here have to do with setting up *TERMINAL-IO*. +;;; Note that opening /dev/tty can fail, and that failure would +;;; be reported as a negative return value from FD-OPEN. +;;; It's pretty important that nothing signals an error here, +;;; since there may not be any valid streams to write an error +;;; message to. + +(defglobal *interactive-streams-initialized* nil) + +(defun initialize-interactive-streams () + (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*)) + (encoding-name (if encoding (character-encoding-name encoding)))) + (setq *stdin* (make-fd-stream #-windows-target 0 + #+windows-target (%ptr-to-int + (#_GetStdHandle #$STD_INPUT_HANDLE)) + :basic t + :sharing :lock + :direction :input + :interactive (not *batch-flag*) + :encoding encoding-name + #+windows-target :line-termination #+windows-target :cp/m)) + (setq *stdout* (make-fd-stream #-windows-target 1 + #+windows-target (%ptr-to-int + (#_GetStdHandle #$STD_OUTPUT_HANDLE)) + :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :msdos)) + (setq *stderr* (make-fd-stream #-windows-target 2 + #+windows-target (%ptr-to-int + (#_GetStdHandle #$STD_ERROR_HANDLE)) + :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :crlf)) + (if *batch-flag* + (let* ((tty-fd + #-windows-target + (let* ((fd (fd-open "/dev/tty" #$O_RDWR))) + (if (>= fd 0) fd))) + (can-use-tty #-windows-target (and tty-fd (eql (tcgetpgrp tty-fd) (getpid))))) + (if can-use-tty + (setq + *terminal-input* (make-fd-stream tty-fd + :basic t + :direction :input + :interactive t + :sharing :lock + :encoding encoding-name) + *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name) + *terminal-io* (make-echoing-two-way-stream + *terminal-input* *terminal-output*)) + (progn + (when tty-fd (fd-close tty-fd)) + (setq *terminal-input* *stdin* + *terminal-output* *stdout* + *terminal-io* (make-two-way-stream + *terminal-input* *terminal-output*)))) + (setq *standard-input* *stdin* + *standard-output* *stdout*)) + (progn + (setq *terminal-input* *stdin* + *terminal-output* *stdout* + *terminal-io* (make-echoing-two-way-stream + *terminal-input* *terminal-output*)) + (setq *standard-input* (make-synonym-stream '*terminal-io*) + *standard-output* (make-synonym-stream '*terminal-io*)))) + (setq *error-output* (if *batch-flag* + (make-synonym-stream '*stderr*) + (make-synonym-stream '*terminal-io*))) + (setq *query-io* (make-synonym-stream '*terminal-io*)) + (setq *debug-io* *query-io*) + (setq *trace-output* *standard-output*) + (push *stdout* *auto-flush-streams*) + (setf (input-stream-shared-resource *terminal-input*) + (make-shared-resource "Shared Terminal Input"))) + (setq *interactive-streams-initialized* t)) + +(initialize-interactive-streams) + +(def-standard-initial-binding *standard-input*) +(def-standard-initial-binding *standard-output*) +(def-standard-initial-binding *error-output*) +(def-standard-initial-binding *trace-output*) +(def-standard-initial-binding *debug-io*) +(def-standard-initial-binding *query-io*) + + +(defun set-terminal-encoding (encoding-name) + #+windows-target (when (atom encoding-name) + (setq encoding-name `(:character-encoding ,encoding-name + :line-termination :crlf))) + (let* ((exformat (normalize-external-format t encoding-name))) + (setf (stream-external-format *stdin*) exformat + (stream-external-format *stdout*) exformat + (stream-external-format *stderr*) exformat + (stream-external-format *terminal-input*) exformat + (stream-external-format *terminal-output*) exformat)) + encoding-name) + +(catch :toplevel + (macrolet ((l1-load-provide (module path) + `(let* ((*package* *package*)) + (l1-load ,path) + (provide ,module))) + (bin-load-provide (module path) + `(let* ((*package* *package*)) + (bin-load ,path) + (provide ,module)))) + (bin-load-provide "SORT" "sort") + (bin-load-provide "NUMBERS" "numbers") + + (bin-load-provide "SUBPRIMS" "subprims") + #+ppc32-target + (bin-load-provide "PPC32-ARCH" "ppc32-arch") + #+ppc64-target + (bin-load-provide "PPC64-ARCH" "ppc64-arch") + #+x86-target + (bin-load-provide "X8632-ARCH" "x8632-arch") + #+x86-target + (bin-load-provide "X8664-ARCH" "x8664-arch") + (bin-load-provide "VREG" "vreg") + + #+ppc-target + (bin-load-provide "PPC-ASM" "ppc-asm") + + (bin-load-provide "VINSN" "vinsn") + (bin-load-provide "REG" "reg") + + #+ppc-target + (bin-load-provide "PPC-LAP" "ppc-lap") + (bin-load-provide "BACKEND" "backend") + (bin-load-provide "NX2" "nx2") + + #+ppc-target + (provide "PPC2") ; Lie, load the module manually + + #+x86-target + (provide "X862") + + (l1-load-provide "NX" "nx") + + #+ppc-target + (bin-load "ppc2") + + #+x86-target + (bin-load "x862") + + (bin-load-provide "LEVEL-2" "level-2") + (bin-load-provide "MACROS" "macros") + (bin-load-provide "SETF" "setf") + (bin-load-provide "SETF-RUNTIME" "setf-runtime") + (bin-load-provide "FORMAT" "format") + (bin-load-provide "STREAMS" "streams") + (bin-load-provide "OPTIMIZERS" "optimizers") + (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros") + (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds") + (bin-load-provide "NFCOMP" "nfcomp") + (bin-load-provide "BACKQUOTE" "backquote") + (bin-load-provide "BACKTRACE-LDS" "backtrace-lds") + (bin-load-provide "BACKTRACE" "backtrace") + (bin-load-provide "READ" "read") + (bin-load-provide "ARRAYS-FRY" "arrays-fry") + (bin-load-provide "APROPOS" "apropos") + (bin-load-provide "SOURCE-FILES" "source-files") + + #+ppc-target + (progn + (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble") + (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros")) + + #+x86-target + (progn + (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble") + (bin-load-provide "X86-LAPMACROS" "x86-lapmacros") + (bin-load "x86-watch")) + + + (bin-load-provide "FOREIGN-TYPES" "foreign-types") + (install-standard-foreign-types *host-ftd*) + + #+(and ppc32-target linux-target) + (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32") + #+(and ppc32-target darwin-target) + (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32") + #+(and ppc64-target darwin-target) + (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64") + #+(and ppc64-target linux-target) + (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64") + #+(and x8632-target darwin-target) + (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632") + #+(and x8664-target linux-target) + (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664") + #+(and x8664-target darwin-target) + (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664") + #+(and x8664-target freebsd-target) + (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664") + #+(and x8664-target solaris-target) + (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664") + #+win64-target + (bin-load-provide "FFI-WIN64" "ffi-win64") + #+linuxx8632-target + (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632") + #+win32-target + (bin-load-provide "FFI-WIN32" "ffi-win32") + #+solarisx8632-target + (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632") + #+freebsdx8632-target + (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632") + + + ;; Knock wood: all standard reader macros and no non-standard + ;; reader macros are defined at this point. + (setq *readtable* (copy-readtable *readtable*)) + + (bin-load-provide "DB-IO" "db-io") + + (canonicalize-foreign-type-ordinals *host-ftd*) + + (bin-load-provide "CASE-ERROR" "case-error") + (bin-load-provide "ENCAPSULATE" "encapsulate") + (bin-load-provide "METHOD-COMBINATION" "method-combination") + (bin-load-provide "MISC" "misc") + (bin-load-provide "PPRINT" "pprint") + (bin-load-provide "DUMPLISP" "dumplisp") + (bin-load-provide "PATHNAMES" "pathnames") + (bin-load-provide "TIME" "time") + (bin-load-provide "COMPILE-CCL" "compile-ccl") + (bin-load-provide "ARGLIST" "arglist") + (bin-load-provide "EDIT-CALLERS" "edit-callers") + (bin-load-provide "DESCRIBE" "describe") + (bin-load-provide "COVER" "cover") + (bin-load-provide "LEAKS" "leaks") + (bin-load-provide "CORE-FILES" "core-files") + (bin-load-provide "DOMINANCE" "dominance") + (bin-load-provide "MCL-COMPAT" "mcl-compat") + (require "LOOP") + (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms") + (l1-load-provide "VERSION" "version") + (require "JP-ENCODE") + (require "LISPEQU") ; Shouldn't need this at load time ... + ) + (setq *%fasload-verbose* nil) + ) +) + + + + + + Index: /branches/qres/ccl/level-1/l1-boot-3.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-boot-3.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-boot-3.lisp (revision 13564) @@ -0,0 +1,33 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; l1-boot-3.lisp +;;; Third part of l1-boot + +(in-package "CCL") + +(catch :toplevel + (or (find-package "COMMON-LISP-USER") + (make-package "COMMON-LISP-USER" :use '("COMMON-LISP" "CCL") :NICKNAMES '("CL-USER"))) +) + +(set-periodic-task-interval .33) +(setq cmain xcmain) +(setq %err-disp %xerr-disp) + +;;;end of l1-boot-3.lisp + Index: /branches/qres/ccl/level-1/l1-boot-lds.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-boot-lds.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-boot-lds.lisp (revision 13564) @@ -0,0 +1,123 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +; l1-boot-lds.lisp + +(in-package "CCL") + + + + + +(defun command-line-arguments () + *command-line-argument-list*) + +(defun startup-ccl (&optional init-file) + (with-simple-restart (abort "Abort startup.") + (let ((init-files (if (listp init-file) init-file (list init-file)))) + (dolist (init-file init-files) + (with-simple-restart (continue "Skip loading init file.") + (when (load init-file :if-does-not-exist nil :verbose nil) + (return))))) + (flet ((eval-string (s) + (with-simple-restart (continue "Skip evaluation of ~a" s) + (eval (read-from-string s)))) + (load-file (name) + (with-simple-restart (continue "Skip loading ~s" name) + (load name)))) + (dolist (p *lisp-startup-parameters*) + (let* ((param (cdr p))) + (case (car p) + (:gc-threshold + (multiple-value-bind (n last) (parse-integer param :junk-allowed t) + (when n + (if (< last (length param)) + (case (schar param last) + ((#\k #\K) (setq n (ash n 10))) + ((#\m #\M) (setq n (ash n 20))))) + (set-lisp-heap-gc-threshold n) + (use-lisp-heap-gc-threshold)))) + (:eval (eval-string param)) + (:load (load-file param)))))))) + + +(defun listener-function () + (progn + (unless (or *inhibit-greeting* *quiet-flag*) + (format t "~&Welcome to ~A ~A!~%" + (lisp-implementation-type) + (lisp-implementation-version))) + (toplevel-loop))) + + +(defun make-mcl-listener-process (procname + input-stream + output-stream + cleanup-function + &key + (initial-function #'listener-function) + (close-streams t) + (class 'process) + (control-stack-size *default-control-stack-size*) + (auto-flush t) + (value-stack-size *default-value-stack-size*) + (temp-stack-size *default-temp-stack-size*) + (echoing t) + (process)) + (let ((p (if (typep process class) + (progn + (setf (process-thread process) + (new-thread procname control-stack-size value-stack-size temp-stack-size)) + process) + (make-process procname + :class class + :stack-size control-stack-size + :vstack-size value-stack-size + :tstack-size temp-stack-size)))) + (process-preset p #'(lambda () + (let ((*terminal-io* + (if echoing + (make-echoing-two-way-stream + input-stream output-stream) + (make-two-way-stream + input-stream output-stream)))) + (unwind-protect + (progn + (when auto-flush + (add-auto-flush-stream output-stream)) + (let* ((shared-input + (input-stream-shared-resource + input-stream))) + (when shared-input + (setf (shared-resource-primary-owner + shared-input) + *current-process*))) + (application-ui-operation + *application* + :note-current-package *package*) + (funcall initial-function)) + (remove-auto-flush-stream output-stream) + (funcall cleanup-function) + (when close-streams + (close input-stream) + (close output-stream)))))) + (process-enable p) + p)) + + +; End of l1-boot-lds.lisp Index: /branches/qres/ccl/level-1/l1-callbacks.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-callbacks.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-callbacks.lisp (revision 13564) @@ -0,0 +1,154 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; l1-callbacks.lisp + +(in-package "CCL") + +(defstatic *callback-lock* (make-lock)) + + +;;; (defcallback ...) expands into a call to this function. +(defun define-callback-function (lisp-function &optional doc-string (without-interrupts t) info &aux name trampoline) + (unless (functionp lisp-function) + (setq lisp-function (require-type lisp-function 'function))) + (unless (and (symbolp (setq name (function-name lisp-function))) + ;;Might as well err out now before do any _Newptr's... + (not (constant-symbol-p name))) + (report-bad-arg name '(and symbol (not (satisfies constantp))))) + (with-lock-grabbed (*callback-lock*) + (let ((len (length %pascal-functions%))) + (declare (fixnum len)) + (when (and name (boundp name)) + (let ((old-tramp (symbol-value name))) + (dotimes (i len) + (let ((pfe (%svref %pascal-functions% i))) + (when (and (vectorp pfe) + (eql old-tramp (pfe.routine-descriptor pfe))) + + (setf (pfe.without-interrupts pfe) without-interrupts) + (setf (pfe.lisp-function pfe) lisp-function) + (setq trampoline old-tramp)))))) + (unless trampoline + (let ((index (dotimes (i (length %pascal-functions%) + (let* ((new-len (if (zerop len) 32 (* len 2))) + (new-pf (make-array (the fixnum new-len)))) + (declare (fixnum new-len)) + (dotimes (i len) + (setf (%svref new-pf i) (%svref %pascal-functions% i))) + (do ((i len (1+ i))) + ((>= i new-len)) + (declare (fixnum i)) + (setf (%svref new-pf i) nil)) + (setq %pascal-functions% new-pf) + len)) + (unless (%svref %pascal-functions% i) + (return i))))) + (setq trampoline (make-callback-trampoline index info)) + (setf (%svref %pascal-functions% index) + (%cons-pfe trampoline info lisp-function name without-interrupts)))))) + ;;(%proclaim-special name) ; + ;; already done by defpascal expansion + (when name (set name trampoline)) + (record-source-file name 'callback) + (when (and doc-string *save-doc-strings*) + (setf (documentation name 'variable) doc-string)) + (when *fasload-print* (format t "~&~S~%" name)) + (or name trampoline)) + +(defun %lookup-pascal-function (index) + (declare (optimize (speed 3) (safety 0))) + (with-lock-grabbed (*callback-lock*) + (let* ((pfe (svref %pascal-functions% index))) + (values (pfe.lisp-function pfe) + (pfe.without-interrupts pfe) + (pfe.trace-p pfe))))) + + +(defun %callback-function (pointer) + (if (typep pointer 'symbol) + (setq pointer (symbol-value pointer))) + (with-lock-grabbed (*callback-lock*) + (let* ((index (dotimes (i (length %pascal-functions%)) + (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer) + (return i))))) + (when index + (let* ((entry (svref %pascal-functions% index))) + (pfe.lisp-function entry)))))) + + +(defun %delete-pascal-function (pointer) + (with-lock-grabbed (*callback-lock*) + (let* ((index (dotimes (i (length %pascal-functions%)) + (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer) + (return i))))) + (when index + (let* ((entry (svref %pascal-functions% index)) + (sym (pfe.sym entry))) + (setf (svref %pascal-functions% index) nil) + (when (and sym + (boundp sym) + (eql (symbol-value sym) + (pfe.routine-descriptor entry))) + (set (symbol-value sym) nil)) + (free (pfe.routine-descriptor entry)) + t))))) + + +;; The kernel only really knows how to call back to one function, +;; and you're looking at it ... +(defun %pascal-functions% (index args-ptr-fixnum) + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (lisp-function without-interrupts *callback-trace-p*) + (%lookup-pascal-function index) + (declare (special *callback-trace-p*)) + (if without-interrupts + (without-interrupts (funcall lisp-function args-ptr-fixnum)) + (funcall lisp-function args-ptr-fixnum)))) + +(defstatic *callback-alloc-lock* (make-lock)) + +;;; +(defun %make-executable-page () + #-windows-target + (#_mmap (%null-ptr) + (#_getpagesize) + (logior #$PROT_READ #$PROT_WRITE #$PROT_EXEC) + (logior #$MAP_PRIVATE #$MAP_ANON) + -1 + 0) + #+windows-target + (#_VirtualAlloc (%null-ptr) + (ash 1 16) ; should use GetSystemInfo + (logior #$MEM_RESERVE #$MEM_COMMIT) + #$PAGE_EXECUTE_READWRITE) + ) + +(defstatic *available-bytes-for-callbacks* 0) +(defstatic *current-callback-page* nil) + +(defun reset-callback-storage () + (setq *available-bytes-for-callbacks* #-windows-target (#_getpagesize) #+windows-target (ash 1 16) + *current-callback-page* (%make-executable-page))) + +(defun %allocate-callback-pointer (n) + (with-lock-grabbed (*callback-alloc-lock*) + (when (< *available-bytes-for-callbacks* n) + (reset-callback-storage)) + (decf *available-bytes-for-callbacks* n) + (values (%inc-ptr *current-callback-page* *available-bytes-for-callbacks*)))) + Index: /branches/qres/ccl/level-1/l1-cl-package.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-cl-package.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-cl-package.lisp (revision 13564) @@ -0,0 +1,1022 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; l1-cl-package.lisp + +(in-package "CCL") + + +(eval-when (:compile-toplevel :execute) + (defconstant %lisp-symbols% + '("&ALLOW-OTHER-KEYS" + "&AUX" + "&BODY" + "&ENVIRONMENT" + "&KEY" + "&OPTIONAL" + "&REST" + "&WHOLE" + "*" + "**" + "***" + "*BREAK-ON-SIGNALS*" + "*COMPILE-FILE-PATHNAME*" + "*COMPILE-FILE-TRUENAME*" + "*COMPILE-PRINT*" + "*COMPILE-VERBOSE*" + "*DEBUG-IO*" + "*DEBUGGER-HOOK*" + "*DEFAULT-PATHNAME-DEFAULTS*" + "*ERROR-OUTPUT*" + "*FEATURES*" + "*GENSYM-COUNTER*" + "*LOAD-PATHNAME*" + "*LOAD-PRINT*" + "*LOAD-TRUENAME*" + "*LOAD-VERBOSE*" + "*MACROEXPAND-HOOK*" + "*MODULES*" + "*PACKAGE*" + "*PRINT-ARRAY*" + "*PRINT-BASE*" + "*PRINT-CASE*" + "*PRINT-CIRCLE*" + "*PRINT-ESCAPE*" + "*PRINT-GENSYM*" + "*PRINT-LENGTH*" + "*PRINT-LEVEL*" + "*PRINT-LINES*" + "*PRINT-MISER-WIDTH*" + "*PRINT-PPRINT-DISPATCH*" + "*PRINT-PRETTY*" + "*PRINT-RADIX*" + "*PRINT-READABLY*" + "*PRINT-RIGHT-MARGIN*" + "*QUERY-IO*" + "*RANDOM-STATE*" + "*READ-BASE*" + "*READ-DEFAULT-FLOAT-FORMAT*" + "*READ-EVAL*" + "*READ-SUPPRESS*" + "*READTABLE*" + "*STANDARD-INPUT*" + "*STANDARD-OUTPUT*" + "*TERMINAL-IO*" + "*TRACE-OUTPUT*" + "+" + "++" + "+++" + "-" + "/" + "//" + "///" + "/=" + "1+" + "1-" + "<" + "<=" + "=" + ">" + ">=" + "ABORT" + "ABS" + "ACONS" + "ACOS" + "ACOSH" + "ADD-METHOD" + "ADJOIN" + "ADJUST-ARRAY" + "ADJUSTABLE-ARRAY-P" + "ALLOCATE-INSTANCE" + "ALPHA-CHAR-P" + "ALPHANUMERICP" + "AND" + "APPEND" + "APPLY" + "APROPOS" + "APROPOS-LIST" + "AREF" + "ARITHMETIC-ERROR" + "ARITHMETIC-ERROR-OPERANDS" + "ARITHMETIC-ERROR-OPERATION" + "ARRAY" + "ARRAY-DIMENSION" + "ARRAY-DIMENSION-LIMIT" + "ARRAY-DIMENSIONS" + "ARRAY-DISPLACEMENT" + "ARRAY-ELEMENT-TYPE" + "ARRAY-HAS-FILL-POINTER-P" + "ARRAY-IN-BOUNDS-P" + "ARRAY-RANK" + "ARRAY-RANK-LIMIT" + "ARRAY-ROW-MAJOR-INDEX" + "ARRAY-TOTAL-SIZE" + "ARRAY-TOTAL-SIZE-LIMIT" + "ARRAYP" + "ASH" + "ASIN" + "ASINH" + "ASSERT" + "ASSOC" + "ASSOC-IF" + "ASSOC-IF-NOT" + "ATAN" + "ATANH" + "ATOM" + "BASE-CHAR" + "BASE-STRING" + "BIGNUM" + "BIT" + "BIT-AND" + "BIT-ANDC1" + "BIT-ANDC2" + "BIT-EQV" + "BIT-IOR" + "BIT-NAND" + "BIT-NOR" + "BIT-NOT" + "BIT-ORC1" + "BIT-ORC2" + "BIT-VECTOR" + "BIT-VECTOR-P" + "BIT-XOR" + "BLOCK" + "BOOLE" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "BOOLEAN" + "BOTH-CASE-P" + "BOUNDP" + "BREAK" + "BROADCAST-STREAM" + "BROADCAST-STREAM-STREAMS" + "BUILT-IN-CLASS" + "BUTLAST" + "BYTE" + "BYTE-POSITION" + "BYTE-SIZE" + "CAAAAR" + "CAAADR" + "CAAAR" + "CAADAR" + "CAADDR" + "CAADR" + "CAAR" + "CADAAR" + "CADADR" + "CADAR" + "CADDAR" + "CADDDR" + "CADDR" + "CADR" + "CALL-ARGUMENTS-LIMIT" + "CALL-METHOD" + "CALL-NEXT-METHOD" + "CAR" + "CASE" + "CATCH" + "CCASE" + "CDAAAR" + "CDAADR" + "CDAAR" + "CDADAR" + "CDADDR" + "CDADR" + "CDAR" + "CDDAAR" + "CDDADR" + "CDDAR" + "CDDDAR" + "CDDDDR" + "CDDDR" + "CDDR" + "CDR" + "CEILING" + "CELL-ERROR" + "CELL-ERROR-NAME" + "CERROR" + "CHANGE-CLASS" + "CHAR" + "CHAR-CODE" + "CHAR-CODE-LIMIT" + "CHAR-DOWNCASE" + "CHAR-EQUAL" + "CHAR-GREATERP" + "CHAR-INT" + "CHAR-LESSP" + "CHAR-NAME" + "CHAR-NOT-EQUAL" + "CHAR-NOT-GREATERP" + "CHAR-NOT-LESSP" + "CHAR-UPCASE" + "CHAR/=" + "CHAR<" + "CHAR<=" + "CHAR=" + "CHAR>" + "CHAR>=" + "CHARACTER" + "CHARACTERP" + "CHECK-TYPE" + "CIS" + "CLASS" + "CLASS-NAME" + "CLASS-OF" + "CLEAR-INPUT" + "CLEAR-OUTPUT" + "CLOSE" + "CLRHASH" + "CODE-CHAR" + "COERCE" + "COMPILATION-SPEED" + "COMPILE" + "COMPILE-FILE" + "COMPILE-FILE-PATHNAME" + "COMPILED-FUNCTION" + "COMPILED-FUNCTION-P" + "COMPILER-MACRO" + "COMPILER-MACRO-FUNCTION" + "COMPLEMENT" + "COMPLEX" + "COMPLEXP" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-RESTARTS" + "CONCATENATE" + "CONCATENATED-STREAM" + "CONCATENATED-STREAM-STREAMS" + "COND" + "CONDITION" + "CONJUGATE" + "CONS" + "CONSP" + "CONSTANTLY" + "CONSTANTP" + "CONTINUE" + "CONTROL-ERROR" + "COPY-ALIST" + "COPY-LIST" + "COPY-PPRINT-DISPATCH" + "COPY-READTABLE" + "COPY-SEQ" + "COPY-STRUCTURE" + "COPY-SYMBOL" + "COPY-TREE" + "COS" + "COSH" + "COUNT" + "COUNT-IF" + "COUNT-IF-NOT" + "CTYPECASE" + "DEBUG" + "DECF" + "DECLAIM" + "DECLARATION" + "DECLARE" + "DECODE-FLOAT" + "DECODE-UNIVERSAL-TIME" + "DEFCLASS" + "DEFCONSTANT" + "DEFGENERIC" + "DEFINE-COMPILER-MACRO" + "DEFINE-CONDITION" + "DEFINE-METHOD-COMBINATION" + "DEFINE-MODIFY-MACRO" + "DEFINE-SETF-EXPANDER" + "DEFINE-SYMBOL-MACRO" + "DEFMACRO" + "DEFMETHOD" + "DEFPACKAGE" + "DEFPARAMETER" + "DEFSETF" + "DEFSTRUCT" + "DEFTYPE" + "DEFUN" + "DEFVAR" + "DELETE" + "DELETE-DUPLICATES" + "DELETE-FILE" + "DELETE-IF" + "DELETE-IF-NOT" + "DELETE-PACKAGE" + "DENOMINATOR" + "DEPOSIT-FIELD" + "DESCRIBE" + "DESCRIBE-OBJECT" + "DESTRUCTURING-BIND" + "DIGIT-CHAR" + "DIGIT-CHAR-P" + "DIRECTORY" + "DIRECTORY-NAMESTRING" + "DISASSEMBLE" + "DIVISION-BY-ZERO" + "DO" + "DO*" + "DO-ALL-SYMBOLS" + "DO-EXTERNAL-SYMBOLS" + "DO-SYMBOLS" + "DOCUMENTATION" + "DOLIST" + "DOTIMES" + "DOUBLE-FLOAT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "DPB" + "DRIBBLE" + "DYNAMIC-EXTENT" + "ECASE" + "ECHO-STREAM" + "ECHO-STREAM-INPUT-STREAM" + "ECHO-STREAM-OUTPUT-STREAM" + "ED" + "EIGHTH" + "ELT" + "ENCODE-UNIVERSAL-TIME" + "END-OF-FILE" + "ENDP" + "ENOUGH-NAMESTRING" + "ENSURE-DIRECTORIES-EXIST" + "ENSURE-GENERIC-FUNCTION" + "EQ" + "EQL" + "EQUAL" + "EQUALP" + "ERROR" + "ETYPECASE" + "EVAL" + "EVAL-WHEN" + "EVENP" + "EVERY" + "EXP" + "EXPORT" + "EXPT" + "EXTENDED-CHAR" + "FBOUNDP" + "FCEILING" + "FDEFINITION" + "FFLOOR" + "FIFTH" + "FILE-AUTHOR" + "FILE-ERROR" + "FILE-ERROR-PATHNAME" + "FILE-LENGTH" + "FILE-NAMESTRING" + "FILE-POSITION" + "FILE-STREAM" + "FILE-STRING-LENGTH" + "FILE-WRITE-DATE" + "FILL" + "FILL-POINTER" + "FIND" + "FIND-ALL-SYMBOLS" + "FIND-CLASS" + "FIND-IF" + "FIND-IF-NOT" + "FIND-METHOD" + "FIND-PACKAGE" + "FIND-RESTART" + "FIND-SYMBOL" + "FINISH-OUTPUT" + "FIRST" + "FIXNUM" + "FLET" + "FLOAT" + "FLOAT-DIGITS" + "FLOAT-PRECISION" + "FLOAT-RADIX" + "FLOAT-SIGN" + "FLOATING-POINT-INEXACT" + "FLOATING-POINT-INVALID-OPERATION" + "FLOATING-POINT-OVERFLOW" + "FLOATING-POINT-UNDERFLOW" + "FLOATP" + "FLOOR" + "FMAKUNBOUND" + "FORCE-OUTPUT" + "FORMAT" + "FORMATTER" + "FOURTH" + "FRESH-LINE" + "FROUND" + "FTRUNCATE" + "FTYPE" + "FUNCALL" + "FUNCTION" + "FUNCTION-KEYWORDS" + "FUNCTION-LAMBDA-EXPRESSION" + "FUNCTIONP" + "GCD" + "GENERIC-FUNCTION" + "GENSYM" + "GENTEMP" + "GET" + "GET-DECODED-TIME" + "GET-DISPATCH-MACRO-CHARACTER" + "GET-INTERNAL-REAL-TIME" + "GET-INTERNAL-RUN-TIME" + "GET-MACRO-CHARACTER" + "GET-OUTPUT-STREAM-STRING" + "GET-PROPERTIES" + "GET-SETF-EXPANSION" + "GET-UNIVERSAL-TIME" + "GETF" + "GETHASH" + "GO" + "GRAPHIC-CHAR-P" + "HANDLER-BIND" + "HANDLER-CASE" + "HASH-TABLE" + "HASH-TABLE-COUNT" + "HASH-TABLE-P" + "HASH-TABLE-REHASH-SIZE" + "HASH-TABLE-REHASH-THRESHOLD" + "HASH-TABLE-SIZE" + "HASH-TABLE-TEST" + "HOST-NAMESTRING" + "IDENTITY" + "IF" + "IGNORABLE" + "IGNORE" + "IGNORE-ERRORS" + "IMAGPART" + "IMPORT" + "IN-PACKAGE" + "INCF" + "INITIALIZE-INSTANCE" + "INLINE" + "INPUT-STREAM-P" + "INSPECT" + "INTEGER" + "INTEGER-DECODE-FLOAT" + "INTEGER-LENGTH" + "INTEGERP" + "INTERACTIVE-STREAM-P" + "INTERN" + "INTERNAL-TIME-UNITS-PER-SECOND" + "INTERSECTION" + "INVALID-METHOD-ERROR" + "INVOKE-DEBUGGER" + "INVOKE-RESTART" + "INVOKE-RESTART-INTERACTIVELY" + "ISQRT" + "KEYWORD" + "KEYWORDP" + "LABELS" + "LAMBDA" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LAST" + "LCM" + "LDB" + "LDB-TEST" + "LDIFF" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LENGTH" + "LET" + "LET*" + "LISP-IMPLEMENTATION-TYPE" + "LISP-IMPLEMENTATION-VERSION" + "LIST" + "LIST*" + "LIST-ALL-PACKAGES" + "LIST-LENGTH" + "LISTEN" + "LISTP" + "LOAD" + "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" + "LOAD-TIME-VALUE" + "LOCALLY" + "LOG" + "LOGAND" + "LOGANDC1" + "LOGANDC2" + "LOGBITP" + "LOGCOUNT" + "LOGEQV" + "LOGICAL-PATHNAME" + "LOGICAL-PATHNAME-TRANSLATIONS" + "LOGIOR" + "LOGNAND" + "LOGNOR" + "LOGNOT" + "LOGORC1" + "LOGORC2" + "LOGTEST" + "LOGXOR" + "LONG-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "LONG-SITE-NAME" + "LOOP" + "LOOP-FINISH" + "LOWER-CASE-P" + "MACHINE-INSTANCE" + "MACHINE-TYPE" + "MACHINE-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" + "MACROEXPAND-1" + "MACROLET" + "MAKE-ARRAY" + "MAKE-BROADCAST-STREAM" + "MAKE-CONCATENATED-STREAM" + "MAKE-CONDITION" + "MAKE-DISPATCH-MACRO-CHARACTER" + "MAKE-ECHO-STREAM" + "MAKE-HASH-TABLE" + "MAKE-INSTANCE" + "MAKE-INSTANCES-OBSOLETE" + "MAKE-LIST" + "MAKE-LOAD-FORM" + "MAKE-LOAD-FORM-SAVING-SLOTS" + "MAKE-METHOD" + "MAKE-PACKAGE" + "MAKE-PATHNAME" + "MAKE-RANDOM-STATE" + "MAKE-SEQUENCE" + "MAKE-STRING" + "MAKE-STRING-INPUT-STREAM" + "MAKE-STRING-OUTPUT-STREAM" + "MAKE-SYMBOL" + "MAKE-SYNONYM-STREAM" + "MAKE-TWO-WAY-STREAM" + "MAKUNBOUND" + "MAP" + "MAP-INTO" + "MAPC" + "MAPCAN" + "MAPCAR" + "MAPCON" + "MAPHASH" + "MAPL" + "MAPLIST" + "MASK-FIELD" + "MAX" + "MEMBER" + "MEMBER-IF" + "MEMBER-IF-NOT" + "MERGE" + "MERGE-PATHNAMES" + "METHOD" + "METHOD-COMBINATION" + "METHOD-COMBINATION-ERROR" + "METHOD-QUALIFIERS" + "MIN" + "MINUSP" + "MISMATCH" + "MOD" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MUFFLE-WARNING" + "MULTIPLE-VALUE-BIND" + "MULTIPLE-VALUE-CALL" + "MULTIPLE-VALUE-LIST" + "MULTIPLE-VALUE-PROG1" + "MULTIPLE-VALUE-SETQ" + "MULTIPLE-VALUES-LIMIT" + "NAME-CHAR" + "NAMESTRING" + "NBUTLAST" + "NCONC" + "NEXT-METHOD-P" + "NIL" + "NINTERSECTION" + "NINTH" + "NO-APPLICABLE-METHOD" + "NO-NEXT-METHOD" + "NOT" + "NOTANY" + "NOTEVERY" + "NOTINLINE" + "NRECONC" + "NREVERSE" + "NSET-DIFFERENCE" + "NSET-EXCLUSIVE-OR" + "NSTRING-CAPITALIZE" + "NSTRING-DOWNCASE" + "NSTRING-UPCASE" + "NSUBLIS" + "NSUBST" + "NSUBST-IF" + "NSUBST-IF-NOT" + "NSUBSTITUTE" + "NSUBSTITUTE-IF" + "NSUBSTITUTE-IF-NOT" + "NTH" + "NTH-VALUE" + "NTHCDR" + "NULL" + "NUMBER" + "NUMBERP" + "NUMERATOR" + "NUNION" + "ODDP" + "OPEN" + "OPEN-STREAM-P" + "OPTIMIZE" + "OR" + "OTHERWISE" + "OUTPUT-STREAM-P" + "PACKAGE" + "PACKAGE-ERROR" + "PACKAGE-ERROR-PACKAGE" + "PACKAGE-NAME" + "PACKAGE-NICKNAMES" + "PACKAGE-SHADOWING-SYMBOLS" + "PACKAGE-USE-LIST" + "PACKAGE-USED-BY-LIST" + "PACKAGEP" + "PAIRLIS" + "PARSE-ERROR" + "PARSE-INTEGER" + "PARSE-NAMESTRING" + "PATHNAME" + "PATHNAME-DEVICE" + "PATHNAME-DIRECTORY" + "PATHNAME-HOST" + "PATHNAME-MATCH-P" + "PATHNAME-NAME" + "PATHNAME-TYPE" + "PATHNAME-VERSION" + "PATHNAMEP" + "PEEK-CHAR" + "PHASE" + "PI" + "PLUSP" + "POP" + "POSITION" + "POSITION-IF" + "POSITION-IF-NOT" + "PPRINT" + "PPRINT-DISPATCH" + "PPRINT-EXIT-IF-LIST-EXHAUSTED" + "PPRINT-FILL" + "PPRINT-INDENT" + "PPRINT-LINEAR" + "PPRINT-LOGICAL-BLOCK" + "PPRINT-NEWLINE" + "PPRINT-POP" + "PPRINT-TAB" + "PPRINT-TABULAR" + "PRIN1" + "PRIN1-TO-STRING" + "PRINC" + "PRINC-TO-STRING" + "PRINT" + "PRINT-NOT-READABLE" + "PRINT-NOT-READABLE-OBJECT" + "PRINT-OBJECT" + "PRINT-UNREADABLE-OBJECT" + "PROBE-FILE" + "PROCLAIM" + "PROG" + "PROG*" + "PROG1" + "PROG2" + "PROGN" + "PROGRAM-ERROR" + "PROGV" + "PROVIDE" + "PSETF" + "PSETQ" + "PUSH" + "PUSHNEW" + "QUOTE" + "RANDOM" + "RANDOM-STATE" + "RANDOM-STATE-P" + "RASSOC" + "RASSOC-IF" + "RASSOC-IF-NOT" + "RATIO" + "RATIONAL" + "RATIONALIZE" + "RATIONALP" + "READ" + "READ-BYTE" + "READ-CHAR" + "READ-CHAR-NO-HANG" + "READ-DELIMITED-LIST" + "READ-FROM-STRING" + "READ-LINE" + "READ-PRESERVING-WHITESPACE" + "READ-SEQUENCE" + "READER-ERROR" + "READTABLE" + "READTABLE-CASE" + "READTABLEP" + "REAL" + "REALP" + "REALPART" + "REDUCE" + "REINITIALIZE-INSTANCE" + "REM" + "REMF" + "REMHASH" + "REMOVE" + "REMOVE-DUPLICATES" + "REMOVE-IF" + "REMOVE-IF-NOT" + "REMOVE-METHOD" + "REMPROP" + "RENAME-FILE" + "RENAME-PACKAGE" + "REPLACE" + "REQUIRE" + "REST" + "RESTART" + "RESTART-BIND" + "RESTART-CASE" + "RESTART-NAME" + "RETURN" + "RETURN-FROM" + "REVAPPEND" + "REVERSE" + "ROOM" + "ROTATEF" + "ROUND" + "ROW-MAJOR-AREF" + "RPLACA" + "RPLACD" + "SAFETY" + "SATISFIES" + "SBIT" + "SCALE-FLOAT" + "SCHAR" + "SEARCH" + "SECOND" + "SEQUENCE" + "SERIOUS-CONDITION" + "SET" + "SET-DIFFERENCE" + "SET-DISPATCH-MACRO-CHARACTER" + "SET-EXCLUSIVE-OR" + "SET-MACRO-CHARACTER" + "SET-PPRINT-DISPATCH" + "SET-SYNTAX-FROM-CHAR" + "SETF" + "SETQ" + "SEVENTH" + "SHADOW" + "SHADOWING-IMPORT" + "SHARED-INITIALIZE" + "SHIFTF" + "SHORT-FLOAT" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SHORT-SITE-NAME" + "SIGNAL" + "SIGNED-BYTE" + "SIGNUM" + "SIMPLE-ARRAY" + "SIMPLE-BASE-STRING" + "SIMPLE-BIT-VECTOR" + "SIMPLE-BIT-VECTOR-P" + "SIMPLE-CONDITION" + "SIMPLE-CONDITION-FORMAT-ARGUMENTS" + "SIMPLE-CONDITION-FORMAT-CONTROL" + "SIMPLE-ERROR" + "SIMPLE-STRING" + "SIMPLE-STRING-P" + "SIMPLE-TYPE-ERROR" + "SIMPLE-VECTOR" + "SIMPLE-VECTOR-P" + "SIMPLE-WARNING" + "SIN" + "SINGLE-FLOAT" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" + "SINH" + "SIXTH" + "SLEEP" + "SLOT-BOUNDP" + "SLOT-EXISTS-P" + "SLOT-MAKUNBOUND" + "SLOT-MISSING" + "SLOT-UNBOUND" + "SLOT-VALUE" + "SOFTWARE-TYPE" + "SOFTWARE-VERSION" + "SOME" + "SORT" + "SPACE" + "SPECIAL" + "SPECIAL-OPERATOR-P" + "SPEED" + "SQRT" + "STABLE-SORT" + "STANDARD" + "STANDARD-CHAR" + "STANDARD-CHAR-P" + "STANDARD-CLASS" + "STANDARD-GENERIC-FUNCTION" + "STANDARD-METHOD" + "STANDARD-OBJECT" + "STEP" + "STORAGE-CONDITION" + "STORE-VALUE" + "STREAM" + "STREAM-ELEMENT-TYPE" + "STREAM-ERROR" + "STREAM-ERROR-STREAM" + "STREAM-EXTERNAL-FORMAT" + "STREAMP" + "STRING" + "STRING-CAPITALIZE" + "STRING-DOWNCASE" + "STRING-EQUAL" + "STRING-GREATERP" + "STRING-LEFT-TRIM" + "STRING-LESSP" + "STRING-NOT-EQUAL" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP" + "STRING-RIGHT-TRIM" + "STRING-STREAM" + "STRING-TRIM" + "STRING-UPCASE" + "STRING/=" + "STRING<" + "STRING<=" + "STRING=" + "STRING>" + "STRING>=" + "STRINGP" + "STRUCTURE" + "STRUCTURE-CLASS" + "STRUCTURE-OBJECT" + "STYLE-WARNING" + "SUBLIS" + "SUBSEQ" + "SUBSETP" + "SUBST" + "SUBST-IF" + "SUBST-IF-NOT" + "SUBSTITUTE" + "SUBSTITUTE-IF" + "SUBSTITUTE-IF-NOT" + "SUBTYPEP" + "SVREF" + "SXHASH" + "SYMBOL" + "SYMBOL-FUNCTION" + "SYMBOL-MACROLET" + "SYMBOL-NAME" + "SYMBOL-PACKAGE" + "SYMBOL-PLIST" + "SYMBOL-VALUE" + "SYMBOLP" + "SYNONYM-STREAM" + "SYNONYM-STREAM-SYMBOL" + "T" + "TAGBODY" + "TAILP" + "TAN" + "TANH" + "TENTH" + "TERPRI" + "THE" + "THIRD" + "THROW" + "TIME" + "TRACE" + "TRANSLATE-LOGICAL-PATHNAME" + "TRANSLATE-PATHNAME" + "TREE-EQUAL" + "TRUENAME" + "TRUNCATE" + "TWO-WAY-STREAM" + "TWO-WAY-STREAM-INPUT-STREAM" + "TWO-WAY-STREAM-OUTPUT-STREAM" + "TYPE" + "TYPE-ERROR" + "TYPE-ERROR-DATUM" + "TYPE-ERROR-EXPECTED-TYPE" + "TYPE-OF" + "TYPECASE" + "TYPEP" + "UNBOUND-SLOT" + "UNBOUND-SLOT-INSTANCE" + "UNBOUND-VARIABLE" + "UNDEFINED-FUNCTION" + "UNEXPORT" + "UNINTERN" + "UNION" + "UNLESS" + "UNREAD-CHAR" + "UNSIGNED-BYTE" + "UNTRACE" + "UNUSE-PACKAGE" + "UNWIND-PROTECT" + "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" + "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" + "UPGRADED-ARRAY-ELEMENT-TYPE" + "UPGRADED-COMPLEX-PART-TYPE" + "UPPER-CASE-P" + "USE-PACKAGE" + "USE-VALUE" + "USER-HOMEDIR-PATHNAME" + "VALUES" + "VALUES-LIST" + "VARIABLE" + "VECTOR" + "VECTOR-POP" + "VECTOR-PUSH" + "VECTOR-PUSH-EXTEND" + "VECTORP" + "WARN" + "WARNING" + "WHEN" + "WILD-PATHNAME-P" + "WITH-ACCESSORS" + "WITH-COMPILATION-UNIT" + "WITH-CONDITION-RESTARTS" + "WITH-HASH-TABLE-ITERATOR" + "WITH-INPUT-FROM-STRING" + "WITH-OPEN-FILE" + "WITH-OPEN-STREAM" + "WITH-OUTPUT-TO-STRING" + "WITH-PACKAGE-ITERATOR" + "WITH-SIMPLE-RESTART" + "WITH-SLOTS" + "WITH-STANDARD-IO-SYNTAX" + "WRITE" + "WRITE-BYTE" + "WRITE-CHAR" + "WRITE-LINE" + "WRITE-SEQUENCE" + "WRITE-STRING" + "WRITE-TO-STRING" + "Y-OR-N-P" + "YES-OR-NO-P" + "ZEROP" + ) + )) + +(let* ((pkg *common-lisp-package*) + (etab (pkg.etab pkg)) + (itab (pkg.itab pkg))) + (without-interrupts + (dolist (name '#.%lisp-symbols%) + (let* ((namelen (length name))) + (multiple-value-bind (found-int symbol int-offset) + (%get-htab-symbol name namelen itab) + (multiple-value-bind (found-ext ignore ext-offset) + (%get-htab-symbol name namelen etab) + (declare (ignore ignore)) + (if found-int ; This shouldn't happen. + (progn + (setf (%svref (car itab) int-offset) (%unbound-marker-8)) + (%htab-add-symbol symbol etab ext-offset)) + (unless found-ext + (%add-symbol name pkg int-offset ext-offset t))))))))) Index: /branches/qres/ccl/level-1/l1-clos-boot.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-clos-boot.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-clos-boot.lisp (revision 13564) @@ -0,0 +1,3860 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + + +;;; l1-clos-boot.lisp + + +(in-package "CCL") + + +;;; Early accessors. These functions eventually all get replaced with +;;; generic functions with "real", official names. + + +(declaim (inline instance-slots %non-standard-instance-slots)) +(defun %non-standard-instance-slots (instance typecode) + (cond ((eql typecode target::subtag-macptr) (foreign-slots-vector instance)) + ((or (typep instance 'standard-generic-function) + (typep instance 'funcallable-standard-object)) + (gf.slots instance)) + (t (error "Don't know how to find slots of ~s" instance)))) + +(defun instance-slots (instance) + (let* ((typecode (typecode instance))) + (cond ((eql typecode target::subtag-instance) (instance.slots instance)) + (t (%non-standard-instance-slots instance typecode))))) + + +;;; True if X is a class but not a foreign-class. +(defun native-class-p (x) + (if (%standard-instance-p x) + (< (the fixnum (instance.hash x)) max-class-ordinal))) + +(defun %class-name (class) + (if (native-class-p class) + (%class.name class) + (class-name class))) + +(defun %class-info (class) + (if (native-class-p class) + (%class.info class) + (class-info class))) + + +(defun %class-kernel-p (class) + (car (%class-info class))) + +(defun (setf %class-kernel-p) (new class) + (setf (car (%class-info class)) new)) + +(defun %class-proper-name (class) + (cdr (%class-info class))) + +(defun (setf %class-proper-name) (new class) + (setf (cdr (%class-info class)) new)) + + +(defun %class-own-wrapper (class) + (if (native-class-p class) + (%class.own-wrapper class) + (class-own-wrapper class))) + +(defun (setf %class-own-wrapper) (new class) + (setf (%class.own-wrapper class) new)) + +(defun %class-alist (class) + (%class.alist class)) + +(defun (setf %class-alist) (new class) + (if (typep class 'slots-class) + (setf (%class.alist class) new) + new)) + +(defun %class-slots (class) + (if (native-class-p class) + (%class.slots class) + (class-slots class))) + +(defun (setf %class-slots) (new class) + (if (native-class-p class) + (setf (%class.slots class) new) + (setf (class-slots class) new))) + +(defun %class-direct-slots (class) + (if (native-class-p class) + (%class.direct-slots class) + (class-direct-slots class))) + +(defun (setf %class-direct-slots) (new class) + (if (native-class-p class) + (setf (%class.direct-slots class) new) + (setf (class-direct-slots class) new))) + + + + + + +(defun %class-direct-superclasses (class) + (%class.local-supers class)) + +(defun (setf %class-direct-superclasses) (new class) + (setf (%class.local-supers class) new)) + +(defun %class-direct-subclasses (class) + (%class.subclasses class)) + +(defun (setf %class-direct-subclasses) (new class) + (setf (%class.subclasses class) new)) + +(defun %class-direct-default-initargs (class) + (if (typep class 'std-class) + (%class.local-default-initargs class))) + +(defun (setf %class-direct-default-initargs) (new class) + (if (typep class 'std-class) + (setf (%class.local-default-initargs class) new) + new)) + + +(defun %class-default-initargs (class) + (if (typep class 'std-class) + (%class.default-initargs class))) + + +(defun (setf %class-default-initargs) (new class) + (setf (%class.default-initargs class) new)) + +(defun %slot-definition-name (slotd) + (standard-slot-definition.name slotd)) + + +(defun %slot-definition-type (slotd) + (standard-slot-definition.type slotd)) + +(defun %slot-definition-initargs (slotd) + (standard-slot-definition.initargs slotd)) + + +(defun %slot-definition-initform (slotd) + (standard-slot-definition.initform slotd)) + +(defun %slot-definition-initfunction (slotd) + (standard-slot-definition.initfunction slotd)) + +(defun %slot-definition-allocation (slotd) + (standard-slot-definition.allocation slotd)) + +(defun %slot-definition-class (slotd) + (standard-slot-definition.class slotd)) + +;;; Returns (VALUES BOUNDP VALUE). +(defun %slot-definition-documentation (slotd) + (let* ((val (%standard-instance-instance-location-access + slotd + standard-slot-definition.documentation))) + (if (eq val (%slot-unbound-marker)) + (values nil nil) + (values t val)))) + + +(defun %slot-definition-location (slotd) + (standard-effective-slot-definition.location slotd)) + +(defun (setf %slot-definition-location) (new slotd) + (setf (standard-effective-slot-definition.location slotd) new)) + +(defun %slot-definition-readers (slotd) + (standard-direct-slot-definition.readers slotd)) + +(defun (setf %slot-definition-readers) (new slotd) + (setf (standard-direct-slot-definition.readers slotd) new)) + +(defun %slot-definition-writers (slotd) + (standard-direct-slot-definition.writers slotd)) + +(defun (setf %slot-definition-writers) (new slotd) + (setf (standard-direct-slot-definition.writers slotd) new)) + +(defun %generic-function-name (gf) + (sgf.name gf)) + +(defun %generic-function-method-combination (gf) + (sgf.method-combination gf)) + +(defun %generic-function-method-class (gf) + (sgf.method-class gf)) + + +(defun %method-qualifiers (m) + (%method.qualifiers m)) + +(defun %method-specializers (m) + (%method.specializers m)) + +(defun %method-function (m) + (%method.function m)) + +(defun (setf %method-function) (new m) + (setf (%method.function m) new)) + +(defun %method-gf (m) + (%method.gf m)) + +(defun (setf %method-gf) (new m) + (setf (%method.gf m) new)) + +(defun %method-name (m) + (%method.name m)) + +(defun %method-lambda-list (m) + (%method.lambda-list m)) + + + +;;; Map slot-names (symbols) to SLOT-ID objects (which contain unique indices). +(let* ((slot-id-lock (make-lock)) + (next-slot-index 1) ; 0 is never a valid slot-index + (slot-id-hash (make-hash-table :test #'eq :weak t))) + (defun ensure-slot-id (slot-name) + (setq slot-name (require-type slot-name 'symbol)) + (with-lock-grabbed (slot-id-lock) + (or (gethash slot-name slot-id-hash) + (setf (gethash slot-name slot-id-hash) + (%istruct 'slot-id slot-name (prog1 + next-slot-index + (incf next-slot-index))))))) + (defun current-slot-index () (with-lock-grabbed (slot-id-lock) + next-slot-index)) + ) + + + + +(defun %slot-id-lookup-obsolete (instance slot-id) + (update-obsolete-instance instance) + (funcall (%wrapper-slot-id->slotd (instance.class-wrapper instance)) + instance slot-id)) +(defun slot-id-lookup-no-slots (instance slot-id) + (declare (ignore instance slot-id))) + +(defun %slot-id-ref-obsolete (instance slot-id) + (update-obsolete-instance instance) + (funcall (%wrapper-slot-id-value (instance.class-wrapper instance)) + instance slot-id)) +(defun %slot-id-ref-missing (instance slot-id) + (values (slot-missing (class-of instance) instance (slot-id.name slot-id) 'slot-value))) + +(defun %slot-id-set-obsolete (instance slot-id new-value) + (update-obsolete-instance instance) + (funcall (%wrapper-set-slot-id-value (instance.class-wrapper instance)) + instance slot-id new-value)) + +(defun %slot-id-set-missing (instance slot-id new-value) + (slot-missing (class-of instance) instance (slot-id.name slot-id) 'setf new-value) + new-value + ) + + + + +;;; This becomes (apply #'make-instance &rest args). +(fset '%make-method-instance + (nlambda bootstrapping-%make-method-instance (class &key + qualifiers + specializers + function + name + lambda-list + &allow-other-keys) + (let* ((method + (%instance-vector (%class-own-wrapper class) + qualifiers + specializers + function + nil + name + lambda-list))) + (when function + (let* ((inner (closure-function function))) + (unless (eq inner function) + (copy-method-function-bits inner function))) + (lfun-name function method)) + method))) + + + +(defun encode-lambda-list (l &optional return-keys?) + (multiple-value-bind (ok req opttail resttail keytail auxtail) + (verify-lambda-list l) + (when ok + (let* ((bits 0) + (temp nil) + (nreq (length req)) + (num-opt 0) + (rest nil) + (lexpr nil) + (keyp nil) + (key-list nil) + (aokp nil) + (hardopt nil)) + (when (> nreq #.(ldb $lfbits-numreq $lfbits-numreq)) + (return-from encode-lambda-list nil)) + (when (eq (pop opttail) '&optional) + (until (eq opttail resttail) + (when (and (consp (setq temp (pop opttail))) + (%cadr temp)) + (setq hardopt t)) + (setq num-opt (%i+ num-opt 1)))) + (when (eq (%car resttail) '&rest) + (setq rest t)) + (when (eq (%car resttail) '&lexpr) + (setq lexpr t)) + (when (eq (pop keytail) '&key) + (setq keyp t) + (labels ((ensure-symbol (x) + (if (symbolp x) x (return-from encode-lambda-list nil))) + (ensure-keyword (x) + (make-keyword (ensure-symbol x)))) + (declare (dynamic-extent #'ensure-symbol #'ensure-keyword)) + (until (eq keytail auxtail) + (setq temp (pop keytail)) + (if (eq temp '&allow-other-keys) + (progn + (setq aokp t) + (unless (eq keytail auxtail) + (return-from encode-lambda-list nil))) + (when return-keys? + (push (if (consp temp) + (if (consp (setq temp (%car temp))) + (ensure-symbol (%car temp)) + (ensure-keyword temp)) + (ensure-keyword temp)) + key-list)))))) + (when (%i> nreq (ldb $lfbits-numreq -1)) + (setq nreq (ldb $lfbits-numreq -1))) + (setq bits (dpb nreq $lfbits-numreq bits)) + (when (%i> num-opt (ldb $lfbits-numopt -1)) + (setq num-opt (ldb $lfbits-numopt -1))) + (setq bits (dpb num-opt $lfbits-numopt bits)) + (when hardopt (setq bits (%ilogior (%ilsl $lfbits-optinit-bit 1) bits))) + (when rest (setq bits (%ilogior (%ilsl $lfbits-rest-bit 1) bits))) + (when lexpr (setq bits (%ilogior (%ilsl $lfbits-restv-bit 1) bits))) + (when keyp (setq bits (%ilogior (%ilsl $lfbits-keys-bit 1) bits))) + (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits))) + (if return-keys? + (values bits (and keyp (apply #'vector (nreverse key-list)))) + bits))))) + +(defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-nesting-ok) + (or (symbol-arg-p thing lambda-list-ok) ; nil ok in destructuring case + (and (consp thing) + (or (null (%cdr thing)) + (and (consp (%cdr thing)) + (or (null (%cddr thing)) + (and supplied-p-ok + (consp (%cddr thing)) + (null (%cdddr thing)))))) + (if (not keyword-nesting-ok) + (req-arg-p (%car thing) lambda-list-ok) + (or (symbol-arg-p (%car thing) lambda-list-ok) + (and (consp (setq thing (%car thing))) + (consp (%cdr thing)) + (null (%cddr thing)) + (%car thing) + (symbolp (%car thing)) + (req-arg-p (%cadr thing) lambda-list-ok))))))) + +(defun req-arg-p (thing &optional lambda-list-ok) + (or + (symbol-arg-p thing lambda-list-ok) + (lambda-list-arg-p thing lambda-list-ok))) + +(defun symbol-arg-p (thing nil-ok) + (and + (symbolp thing) + (or thing nil-ok) + (not (memq thing lambda-list-keywords)))) + +(defun lambda-list-arg-p (thing lambda-list-ok) + (and + lambda-list-ok + (listp thing) + (if (verify-lambda-list thing t t) + (setq *structured-lambda-list* t)))) + +(defun opt-arg-p (thing &optional lambda-ok) + (pair-arg-p thing lambda-ok t nil)) + +(defun key-arg-p (thing &optional lambda-ok) + (pair-arg-p thing lambda-ok t t)) + +(defun proclaimed-ignore-p (sym) + (cdr (assq sym *nx-proclaimed-ignore*))) + +(defun verify-lambda-list (l &optional destructure-p whole-p env-p) + (let* ((the-keys lambda-list-keywords) + opttail + resttail + keytail + allowothertail + auxtail + safecopy + whole + m + n + req + sym + (*structured-lambda-list* nil)) + (prog () + (multiple-value-setq (safecopy whole) + (normalize-lambda-list l whole-p env-p)) + (unless (or destructure-p (eq l safecopy) (go LOSE))) + (setq l safecopy) + (unless (dolist (key the-keys t) + (when (setq m (cdr (memq key l))) + (if (memq key m) (return)))) + (go LOSE)) + (if (null l) (go WIN)) + (setq opttail (memq '&optional l)) + (setq m (or (memq '&rest l) + (unless destructure-p (memq '&lexpr l)))) + (setq n (if destructure-p (memq '&body l))) + (if (and m n) (go LOSE) (setq resttail (or m n))) + (setq keytail (memq '&key l)) + (if (and (setq allowothertail (memq '&allow-other-keys l)) + (not keytail)) + (go LOSE)) + (if (and (eq (car resttail) '&lexpr) + (or keytail opttail)) + (go lose)) + (setq auxtail (memq '&aux l)) + (loop + (when (null l) (go WIN)) + (when (or (eq l opttail) + (eq l resttail) + (eq l keytail) + (eq l allowothertail) + (eq l auxtail)) + (return)) + (setq sym (pop l)) + (unless (and (req-arg-p sym destructure-p) + (or (proclaimed-ignore-p sym) + (and destructure-p (null sym)) + (not (memq sym req)))) ; duplicate required args + (go LOSE)) + (push sym req)) + (when (eq l opttail) + (setq l (%cdr l)) + (loop + (when (null l) (go WIN)) + (when (or (eq l resttail) + (eq l keytail) + (eq l allowothertail) + (eq l auxtail)) + (return)) + (unless (opt-arg-p (pop l) destructure-p) + (go LOSE)))) + (when (eq l resttail) + (setq l (%cdr l)) + (when (or (null l) + (eq l opttail) + (eq l keytail) + (eq l allowothertail) + (eq l auxtail)) + (go LOSE)) + (unless (req-arg-p (pop l) destructure-p) (go LOSE))) + (unless (or (eq l keytail) ; allowothertail is a sublist of keytail if present + (eq l auxtail)) + (go LOSE)) + (when (eq l keytail) + (pop l) + (loop + (when (null l) (go WIN)) + (when (or (eq l opttail) + (eq l resttail)) + (go LOSE)) + (when (or (eq l auxtail) (setq n (eq l allowothertail))) + (if n (setq l (%cdr l))) + (return)) + (unless (key-arg-p (pop l) destructure-p) (go LOSE)))) + (when (eq l auxtail) + (setq l (%cdr l)) + (loop + (when (null l) (go WIN)) + (when (or (eq l opttail) + (eq l resttail) + (eq l keytail)) + (go LOSE)) + (unless (pair-arg-p (pop l)) (go LOSE)))) + (when l (go LOSE)) + WIN + (return (values + t + (nreverse req) + (or opttail resttail keytail auxtail) + (or resttail keytail auxtail) + (or keytail auxtail) + auxtail + safecopy + whole + *structured-lambda-list*)) + LOSE + (return (values nil nil nil nil nil nil nil nil nil nil))))) + +(defun normalize-lambda-list (x &optional whole-p env-p) + (let* ((y x) whole env envtail head) + (setq + x + (loop + (when (atom y) + (if (or (null y) (eq x y)) (return x)) + (setq x (copy-list x) y x) + (return + (loop + (when (atom (%cdr y)) + (%rplacd y (list '&rest (%cdr y))) + (return x)) + (setq y (%cdr y))))) + (setq y (%cdr y)))) + (when env-p + ;; Trapped in a world it never made ... + (when (setq y (memq '&environment x)) + (setq envtail (%cddr y) + env (%cadr y)) + (cond ((eq y x) + (setq x envtail)) + (t + (dolist (v x) + (if (eq v '&environment) + (return) + (push v head))) + (setq x (nconc (nreverse head) envtail) y (%car envtail)))))) + (when (and whole-p + (eq (%car x) '&whole) + (%cadr x)) + (setq whole (%cadr x) x (%cddr x))) + (values x whole env))) + + + + +(eval-when (eval compile) + (require 'defstruct-macros)) + +(eval-when (:compile-toplevel :execute) + (defmacro make-instance-vector (wrapper len) + (let* ((instance (gensym)) + (slots (gensym))) + `(let* ((,slots (allocate-typed-vector :slot-vector (1+ ,len) (%slot-unbound-marker))) + (,instance (gvector :instance 0 ,wrapper ,slots))) + (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance) + (slot-vector.instance ,slots) ,instance)))) +) + +(eval-when (:compile-toplevel :execute) + (defmacro make-structure-vector (size) + `(%alloc-misc ,size target::subtag-struct nil)) + +) +;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate + (qlfun boot-%move-method-encapsulations-maybe (m1 m2) + (declare (ignore m1 m2)) + nil)) + +(%fhave 'find-unencapsulated-definition ;Redefined in encapsulate + (qlfun bootstrapping-find-unencapsulated-definition (fn) + fn)) + +(%fhave 'function-encapsulated-p ;Redefined in encapsulate + (qlfun bootstrapping-function-encapsulated-p (fn) + (declare (ignore fn)) + nil)) + +(defparameter *uniquify-dcode* #+unique-dcode t #-unique-dcode nil + "If true, each gf will get its own unique copy of its dcode. Not recommended for + real use (for one thing, it's known to break gf tracing), but may be helpful for + profiling") + +(let* ((class-wrapper-random-state (make-random-state)) + (class-wrapper-random-state-lock (make-lock))) + + (defun new-class-wrapper-hash-index () + ;; mustn't be 0 + (with-lock-grabbed (class-wrapper-random-state-lock) + (the fixnum (1+ (the fixnum (random target::target-most-positive-fixnum class-wrapper-random-state))))))) + + +(defun %inner-method-function (method) + (closure-function + (find-unencapsulated-definition + (%method-function method)))) + +(defun copy-method-function-bits (from to) + (let ((new-bits (logior (logand (logior (lsh 1 $lfbits-method-bit) + (ash 1 $lfbits-nextmeth-bit) + (ash 1 $lfbits-nextmeth-with-args-bit) + $lfbits-args-mask) + (lfun-bits from)) + (logand (lognot (logior (lsh 1 $lfbits-method-bit) + (ash 1 $lfbits-nextmeth-bit) + (ash 1 $lfbits-nextmeth-with-args-bit) + $lfbits-args-mask)) + (lfun-bits to))))) + (lfun-bits to new-bits) + new-bits)) + +(defun %ensure-generic-function-using-class (gf function-name &rest keys + &key + &allow-other-keys) + (if gf + (apply #'%ensure-existing-generic-function-using-class gf function-name keys) + (apply #'%ensure-new-generic-function-using-class function-name keys))) + +(defun ensure-generic-function (function-name &rest keys &key &allow-other-keys) + (let* ((def (fboundp function-name))) + (when (and def (not (typep def 'generic-function))) + (cerror "Try to remove any global non-generic function or macro definition." + (make-condition 'simple-program-error :format-control "The function ~s is defined as something other than a generic function." :format-arguments (list function-name))) + (fmakunbound function-name) + (setq def nil)) + (apply #'%ensure-generic-function-using-class def function-name keys))) + + +(defun %ensure-new-generic-function-using-class + (function-name &rest keys &key + (generic-function-class *standard-generic-function-class* gfc-p) + &allow-other-keys) + (declare (dynamic-extent keys)) + (when gfc-p + (if (symbolp generic-function-class) + (setq generic-function-class (find-class generic-function-class))) + (unless (subtypep generic-function-class *standard-generic-function-class*) + (error "~s is not a subtype of ~s" generic-function-class *generic-function-class*)) + (remf keys :generic-function-class)) + (let* ((gf (apply #'%make-gf-instance generic-function-class keys))) + (unless (eq (%gf-method-combination gf) *standard-method-combination*) + (register-gf-method-combination gf (%gf-method-combination gf))) + (setf (sgf.name gf) (getf keys :name function-name)) + (setf (fdefinition function-name) gf))) + +(defun %ensure-existing-generic-function-using-class + (gf function-name &key + (generic-function-class *standard-generic-function-class* gfc-p) + (method-combination *standard-method-combination* mcomb-p) + (method-class *standard-method-class* mclass-p) + (argument-precedence-order nil apo-p) + declarations + (lambda-list nil ll-p) + name) + (when gfc-p + (if (symbolp generic-function-class) + (setq generic-function-class (find-class generic-function-class))) + (unless (subtypep generic-function-class *standard-generic-function-class*) + (error "~s is not a subtype of ~s" generic-function-class *standard-generic-function-class*))) + (when mcomb-p + (unless (typep method-combination 'method-combination) + (report-bad-arg method-combination 'method-combination))) + (when mclass-p + (if (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (subtypep method-class *method-class*) + (error "~s is not a subtype of ~s." method-class *method-class*))) + (when declarations + (unless (list-length declarations) + (error "~s is not a proper list" declarations))) + ;; Fix APO, lambda-list + (if apo-p + (if (not ll-p) + (error "Cannot specify ~s without specifying ~s" :argument-precedence-order + :lambda-list))) + (let* ((old-mc (sgf.method-combination gf))) + (unless (eq old-mc method-combination) + (unless (eq old-mc *standard-method-combination*) + (unregister-gf-method-combination gf method-combination)))) + (setf (sgf.name gf) (or name function-name) + (sgf.decls gf) declarations + (sgf.method-class gf) method-class + (sgf.method-combination gf) method-combination) + (unless (eq method-combination *standard-method-combination*) + (register-gf-method-combination gf method-combination)) + (when ll-p + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + (setf (fdefinition function-name) gf)) + +(defun canonicalize-specializers (specializers &optional (copy t)) + (flet ((canonicalize-specializer (spec) + (if (specializer-p spec) + spec + (if (symbolp spec) + (find-class spec) + (if (and (consp spec) + (eq (car spec) 'eql) + (consp (cdr spec)) + (null (cddr spec))) + (intern-eql-specializer (cadr spec)) + (error "Unknown specializer form ~s" spec)))))) + (if (and (not copy) + (dolist (s specializers t) + (unless (specializer-p s) (return nil)))) + specializers + (mapcar #'canonicalize-specializer specializers)))) + +(defparameter *sealed-clos-world* nil "When true, class and method definition -at least - are disallowed.") + +(defun ensure-method (name specializers &rest keys &key (documentation nil doc-p) qualifiers + &allow-other-keys) + (declare (dynamic-extent keys)) + (if *sealed-clos-world* + (error "Method (re)definition is not allowed in this environment.") + (progn + (setq specializers (canonicalize-specializers specializers)) + (let* ((gf (ensure-generic-function name)) + (method (apply #'%make-method-instance + (%gf-method-class gf) + :name name + :specializers specializers + keys)) + (old-method (when (%gf-methods gf) + (ignore-errors + (find-method gf qualifiers specializers nil))))) + + (%add-method gf method) + (when (and doc-p *save-doc-strings*) + (set-documentation method t documentation)) + (record-source-file method 'method) + (when old-method (%move-method-encapsulations-maybe old-method method)) + method)))) + + +(defun %anonymous-method (function specializers qualifiers lambda-list &optional documentation + &aux name method-class) + (let ((inner-function (closure-function function))) + (unless (%method-function-p inner-function) + (report-bad-arg inner-function 'method-function)) ; Well, I suppose we'll have to shoot you. + (unless (eq inner-function function) ; must be closed over + (copy-method-function-bits inner-function function)) + (setq name (function-name inner-function)) + (if (typep name 'standard-method) ; method-function already installed. + (setq name (%method-name name))) + (setq method-class *standard-method-class*) + (unless (memq *standard-method-class* (or (%class.cpl method-class) + (%class.cpl (update-class method-class t)))) + (%badarg method-class 'standard-method)) + #| + (unless (member qualifiers '(() (:before) (:after) (:around)) :test #'equal) + (report-bad-arg qualifiers)) + ||# + (setq specializers (mapcar #'(lambda (s) + (or (and (consp s) + (eq (%car s) 'eql) + (consp (%cdr s)) + (null (%cddr s)) + (intern-eql-specializer (%cadr s))) + (and (specializer-p s) s) + (find-class s))) + specializers)) + (let ((method (%make-method-instance method-class + :name name + :lambda-list lambda-list + :qualifiers qualifiers + :specializers specializers + :function function))) + (lfun-name inner-function method) + (when documentation + (set-documentation method t documentation)) + method))) + + +(defun check-defmethod-congruency (gf method) + (unless (congruent-lambda-lists-p gf method) + (cerror (format nil + "Remove ~d method~:p from the generic-function and change its lambda list." + (length (%gf-methods gf))) + "Lambda list of method ~S ~%~ +is incompatible with that of the generic function ~S.~%~ +Method's lambda-list : ~s~%~ +Generic-function's : ~s~%" method (or (generic-function-name gf) gf) (flatten-method-lambda-list (%method-lambda-list method)) (generic-function-lambda-list gf)) + (loop + (let ((methods (%gf-methods gf))) + (if methods + (remove-method gf (car methods)) + (return)))) + (%set-defgeneric-keys gf nil) + (inner-lfun-bits gf (%ilogior (%ilsl $lfbits-gfn-bit 1) + (%ilogand $lfbits-args-mask + (lfun-bits (%method-function method)))))) + gf) + + + +(defun %method-function-method (method-function) + (setq method-function + (closure-function + (find-unencapsulated-definition method-function))) + (setq method-function (require-type method-function 'method-function)) + (lfun-name method-function)) + +(defstatic %defgeneric-methods% (make-hash-table :test 'eq :weak t)) + +(defun %defgeneric-methods (gf) + (gethash gf %defgeneric-methods%)) + +(defun %set-defgeneric-methods (gf &rest methods) + (if methods + (setf (gethash gf %defgeneric-methods%) methods) + (remhash gf %defgeneric-methods%))) + +(defun %defgeneric-keys (gf) + (%gf-dispatch-table-keyvect (%gf-dispatch-table gf))) + +(defun %set-defgeneric-keys (gf keyvect) + (setf (%gf-dispatch-table-keyvect (%gf-dispatch-table gf)) keyvect)) + +(defun congruent-lfbits-p (gbits mbits) + (and (eq (ldb $lfbits-numreq gbits) (ldb $lfbits-numreq mbits)) + (eq (ldb $lfbits-numopt gbits) (ldb $lfbits-numopt mbits)) + (eq (or (logbitp $lfbits-rest-bit gbits) + (logbitp $lfbits-restv-bit gbits) + (logbitp $lfbits-keys-bit gbits)) + (or (logbitp $lfbits-rest-bit mbits) + (logbitp $lfbits-restv-bit mbits) + (logbitp $lfbits-keys-bit mbits))))) + +(defun congruent-lambda-lists-p (gf method &optional + error-p gbits mbits gkeys) + (unless gbits (setq gbits (inner-lfun-bits gf))) + (unless mbits (setq mbits (lfun-bits (%method-function method)))) + (and (congruent-lfbits-p gbits mbits) + (or (and (or (logbitp $lfbits-rest-bit mbits) + (logbitp $lfbits-restv-bit mbits)) + (not (logbitp $lfbits-keys-bit mbits))) + (logbitp $lfbits-aok-bit mbits) + (progn + (unless gkeys (setq gkeys (%defgeneric-keys gf))) + (or (null gkeys) + (eql 0 (length gkeys)) + (let ((mkeys (lfun-keyvect + (%inner-method-function method)))) + (dovector (key gkeys t) + (unless (find key mkeys :test 'eq) + (if error-p + (error "~s does not specify keys: ~s" method gkeys)) + (return nil))))))))) + +(defun %add-method (gf method) + (%add-standard-method-to-standard-gf gf method)) + +;; Redefined in l1-clos.lisp +(fset 'maybe-remove-make-instance-optimization + (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method) + (declare (ignore gfn method)) + nil)) + +(defun %add-standard-method-to-standard-gf (gfn method) + (when (%method-gf method) + (error "~s is already a method of ~s." method (%method-gf method))) + (set-gf-arg-info gfn :new-method method) + (let* ((dt (%gf-dispatch-table gfn)) + (methods (sgf.methods gfn)) + (specializers (%method-specializers method)) + (qualifiers (%method-qualifiers method))) + (remove-obsoleted-combined-methods method dt specializers) + (maybe-remove-make-instance-optimization gfn method) + (apply #'invalidate-initargs-vector-for-gf gfn specializers) + (dolist (m methods) + (when (and (equal specializers (%method-specializers m)) + (equal qualifiers (%method-qualifiers m))) + (remove-method gfn m) + ;; There can be at most one match + (return))) + (push method (sgf.methods gfn)) + (setf (%gf-dispatch-table-methods dt) (sgf.methods gfn)) + (setf (%method-gf method) gfn) + (%add-direct-methods method) + (compute-dcode gfn dt) + (when (sgf.dependents gfn) + (map-dependents gfn #'(lambda (d) + (update-dependent gfn d 'add-method method))))) + gfn) + +(defstatic *standard-kernel-method-class* nil) + +(defun redefine-kernel-method (method) + (when (and *warn-if-redefine-kernel* + (or (let ((class *standard-kernel-method-class*)) + (and class (typep method class))) + (and (standard-method-p method) + (kernel-function-p (%method-function method))))) + (cerror "Replace the definition of ~S." + "The method ~S is predefined in Clozure CL." method))) + +;;; Called by the expansion of generic-labels. Which doesn't exist. +(defun %add-methods (gf &rest methods) + (declare (dynamic-extent methods)) + (dolist (m methods) + (add-method gf m))) + +(defun methods-congruent-p (m1 m2) + (when (and (standard-method-p m1)(standard-method-p m2)) + (when (equal (%method-qualifiers m1) (%method-qualifiers m2)) + (let ((specs (%method-specializers m1))) + (dolist (msp (%method-specializers m2) t) + (let ((spec (%pop specs))) + (unless (eq msp spec) + (return nil)))))))) + +(defvar *maintain-class-direct-methods* nil) + + + +;;; CAR is an EQL hash table for objects whose identity is not used by EQL +;;; (numbers and macptrs) +;;; CDR is a weak EQ hash table for other objects. +(defvar *eql-methods-hashes* (cons (make-hash-table :test 'eql) + (make-hash-table :test 'eq :weak :key))) + +(defun eql-methods-cell (object &optional addp) + (let ((hashes *eql-methods-hashes*)) + (without-interrupts + (let* ((hash (cond + ((or (typep object 'number) + (typep object 'macptr)) + (car hashes)) + (t (cdr hashes)))) + (cell (gethash object hash))) + (when (and (null cell) addp) + (setf (gethash object hash) (setq cell (cons nil nil)))) + cell)))) + + + + +(defun map-classes (function) + (with-hash-table-iterator (m %find-classes%) + (loop + (multiple-value-bind (found name cell) (m) + (declare (optimize speed) (type class-cell cell)) + (unless found (return)) + (when cell + (funcall function name (class-cell-class cell))))))) + + + +(defun %class-primary-slot-accessor-info (class accessor-or-slot-name &optional create?) + (let ((info-list (%class-get class '%class-primary-slot-accessor-info))) + (or (car (member accessor-or-slot-name info-list + :key #'(lambda (x) (%slot-accessor-info.accessor x)))) + (and create? + (let ((info (%cons-slot-accessor-info class accessor-or-slot-name))) + (setf (%class-get class '%class-primary-slot-accessor-info) + (cons info info-list)) + info))))) + +;;; Clear the %class.primary-slot-accessor-info for an added or +;;; removed method's specializers +(defun clear-accessor-method-offsets (gf method) + (when (or (typep method 'standard-accessor-method) + (member 'standard-accessor-method + (%gf-methods gf) + :test #'(lambda (sam meth) + (declare (ignore sam)) + (typep meth 'standard-accessor-method)))) + (labels ((clear-class (class) + (when (typep class 'standard-class) + (let ((info (%class-primary-slot-accessor-info class gf))) + (when info + (setf (%slot-accessor-info.offset info) nil))) + (mapc #'clear-class (%class.subclasses class))))) + (declare (dynamic-extent #'clear-class)) + (mapc #'clear-class (%method-specializers method))))) + +;;; Remove methods which specialize on a sub-class of method's +;;; specializers from the generic-function dispatch-table dt. +(defun remove-obsoleted-combined-methods (method &optional dt + (specializers (%method-specializers method))) + (without-interrupts + (unless dt + (let ((gf (%method-gf method))) + (when gf (setq dt (%gf-dispatch-table gf))))) + (when dt + (if specializers + (let* ((argnum (%gf-dispatch-table-argnum dt))) + (when (>= argnum 0) + (let ((class (nth argnum specializers)) + (size (%gf-dispatch-table-size dt)) + (index 0)) + (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method) + (if (typep class 'eql-specializer) + (setq class (class-of (eql-specializer-object class)))) + (while (%i< index size) + (let* ((wrapper (%gf-dispatch-table-ref dt index)) + hash-index-0? + (cpl (and wrapper + (not (setq hash-index-0? + (eql 0 (%wrapper-hash-index wrapper)))) + (%inited-class-cpl + (require-type (%wrapper-class wrapper) 'class))))) + (when (or hash-index-0? (and cpl (cpl-index class cpl))) + (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper* + (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*)) + (setq index (%i+ index 2))))))) + (setf (%gf-dispatch-table-ref dt 1) nil))))) ; clear 0-arg gf cm + +;;; SETQ'd below after the GF's exist. +(defvar *initialization-invalidation-alist* nil) + +;;; Called by %add-method, %remove-method +(defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers) + (declare (ignore other-specializers)) + (when (and first-specializer (typep first-specializer 'class)) ; no eql methods or gfs with no specializers need apply + (let ((indices (cdr (assq gf *initialization-invalidation-alist*)))) + (when indices + (labels ((invalidate (class indices) + (when (std-class-p class) ; catch the class named T + (dolist (index indices) + (setf (standard-instance-instance-location-access class index) nil))) + (dolist (subclass (%class.subclasses class)) + (invalidate subclass indices)))) + (invalidate first-specializer indices)))))) + +;;; Return two values: +;;; 1) the index of the first non-T specializer of method, or NIL if +;;; all the specializers are T or only the first one is T +;;; 2) the index of the first non-T specializer +(defun multi-method-index (method &aux (i 0) index) + (dolist (s (%method.specializers method) (values nil index)) + (unless (eq s *t-class*) + (unless index (setq index i)) + (unless (eql i 0) (return (values index index)))) + (incf i))) + +(defun %remove-standard-method-from-containing-gf (method) + (setq method (require-type method 'standard-method)) + (let ((gf (%method-gf method))) + (when gf + (let* ((dt (%gf-dispatch-table gf)) + (methods (sgf.methods gf))) + (setf (%method-gf method) nil) + (setq methods (nremove method methods)) + (setf (%gf-dispatch-table-methods dt) methods + (sgf.methods gf) methods) + (%remove-direct-methods method) + (remove-obsoleted-combined-methods method dt) + (apply #'invalidate-initargs-vector-for-gf gf (%method-specializers method)) + (compute-dcode gf dt) + (when (sgf.dependents gf) + (map-dependents + gf + #'(lambda (d) + (update-dependent gf d 'remove-method method))))))) + method) + + +(defvar *reader-method-function-proto* + #'(lambda (instance) + (slot-value instance 'x))) + + +(defvar *writer-method-function-proto* + #'(lambda (new instance) + (set-slot-value instance 'x new))) + +(defun dcode-for-gf (gf dcode) + (if *uniquify-dcode* + (let ((new-dcode (%copy-function dcode))) + (lfun-name new-dcode (list (lfun-name dcode) (lfun-name gf))) + new-dcode) + dcode)) + +(defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument. The dcode functions will be caled with all of the incoming arguments.") + +(defun non-dt-dcode-function (gf) + (dolist (f *non-dt-dcode-functions*) + (let* ((dcode (funcall f gf))) + (when dcode (return dcode))))) + +(defun compute-dcode (gf &optional dt) + (setq gf (require-type gf 'standard-generic-function)) + (unless dt (setq dt (%gf-dispatch-table gf))) + (let* ((methods (%gf-dispatch-table-methods dt)) + (bits (inner-lfun-bits gf)) + (nreq (ldb $lfbits-numreq bits)) + (0-args? (eql 0 nreq)) + (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits))) + (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (logbitp $lfbits-aok-bit bits))) + multi-method-index + min-index) + (when methods + (unless 0-args? + (dolist (m methods) + (multiple-value-bind (mm-index index) (multi-method-index m) + (when mm-index + (if (or (null multi-method-index) (< mm-index multi-method-index)) + (setq multi-method-index mm-index))) + (when index + (if (or (null min-index) (< index min-index)) + (setq min-index index)))))) + (let* ((non-dt (non-dt-dcode-function gf)) + (dcode (or non-dt + (if 0-args? + #'%%0-arg-dcode + (or (if multi-method-index + #'%%nth-arg-dcode) + (if (null other-args?) + (if (eql nreq 1) + #'%%one-arg-dcode + (if (eql nreq 2) + #'%%1st-two-arg-dcode + #'%%1st-arg-dcode)) + #'%%1st-arg-dcode)))))) + (setq multi-method-index + (if multi-method-index + (if min-index + (min multi-method-index min-index) + multi-method-index) + 0)) + (let* ((old-dcode (%gf-dcode (find-unencapsulated-definition gf)))) + (when (or non-dt + (neq dcode old-dcode) + (neq multi-method-index (%gf-dispatch-table-argnum dt))) + (clear-gf-dispatch-table dt) + (setf (%gf-dispatch-table-argnum dt) multi-method-index) + (if (function-encapsulated-p gf) + (%set-encapsulated-gf-dcode gf dcode) + (setf (%gf-dcode gf) dcode)))) + (values dcode multi-method-index))))) + +(defun inherits-from-standard-generic-function-p (class) + (memq *standard-generic-function-class* + (%inited-class-cpl (require-type class 'class)))) + +;;;;;;;;;;; The type system needs to get wedged into CLOS fairly early ;;;;;;; + + +;;; Could check for duplicates, but not really worth it. They're all +;;; allocated here +(defun new-type-class (name) + (let* ((class (%istruct + 'type-class + name + #'missing-type-method + nil + nil + #'(lambda (x y) (hierarchical-union2 x y)) + nil + #'(lambda (x y) (hierarchical-intersection2 x y)) + nil + #'missing-type-method + nil + #'missing-type-method))) + (push (cons name class) *type-classes*) + class)) + +;; There are ultimately about a dozen entries on this alist. +(defvar *type-classes* nil) +(declaim (special *wild-type* *empty-type* *universal-type*)) +(defvar *type-kind-info* (make-hash-table :test #'equal)) + +(defun info-type-kind (name) + (gethash name *type-kind-info*)) + +(defun (setf info-type-kind) (val name) + (if val + (setf (gethash name *type-kind-info*) val) + (remhash name *type-kind-info*))) + +(defun missing-type-method (&rest foo) + (error "Missing type method for ~S" foo)) + +(new-type-class 'values) +(new-type-class 'function) +(new-type-class 'constant) +(new-type-class 'wild) +(new-type-class 'bottom) +(new-type-class 'named) +(new-type-class 'hairy) +(new-type-class 'unknown) +(new-type-class 'number) +(new-type-class 'array) +(new-type-class 'member) +(new-type-class 'union) +(new-type-class 'foreign) +(new-type-class 'cons) +(new-type-class 'intersection) +(new-type-class 'negation) +(defparameter *class-type-class* (new-type-class 'class)) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;; Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline non-standard-instance-class-wrapper)) + +(defun non-standard-instance-class-wrapper (instance) + (let* ((typecode (typecode instance))) + (declare (type (unsigned-byte 8) typecode)) + (cond ((eql typecode target::subtag-struct) + (%class.own-wrapper + (class-cell-class (car (%svref instance 0))))) + ((eql typecode target::subtag-istruct) + (istruct-cell-info (%svref instance 0))) + ((eql typecode target::subtag-basic-stream) + (basic-stream.wrapper instance)) + ((typep instance 'funcallable-standard-object) + (gf.instance.class-wrapper instance)) + ((eql typecode target::subtag-macptr) (foreign-instance-class-wrapper instance)) + (t (%class.own-wrapper (class-of instance)))))) + +(defun instance-class-wrapper (instance) + (if (= (typecode instance) target::subtag-instance) + (instance.class-wrapper instance) + (non-standard-instance-class-wrapper instance))) + + +(defun std-instance-class-cell-typep (form class-cell) + (let* ((typecode (typecode form)) + (wrapper (cond ((= typecode target::subtag-instance) + (instance.class-wrapper form)) + ((= typecode target::subtag-basic-stream) + (basic-stream.wrapper form)) + (t nil)))) + (declare (type (unsigned-byte 8) typecode)) + (when wrapper + (loop + (let ((class (class-cell-class class-cell))) + (if class + (let* ((ordinal (%class-ordinal class)) + (bits (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) + (declare (fixnum ordinal)) + (return + (if bits + (locally (declare (simple-bit-vector bits) + (optimize (speed 3) (safety 0))) + (if (< ordinal (length bits)) + (not (eql 0 (sbit bits ordinal)))))))) + (let* ((name (class-cell-name class-cell)) + (new-cell (find-class-cell name nil))) + (unless + (if (and new-cell (not (eq class-cell new-cell))) + (setq class-cell new-cell class (class-cell-class class-cell)) + (return (typep form name))))))))))) + +(defun class-cell-typep (form class-cell) + (locally (declare (type class-cell class-cell)) + (loop + (let ((class (class-cell-class class-cell))) + (if class + (let* ((ordinal (%class-ordinal class)) + (wrapper (instance-class-wrapper form)) + (bits (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) + (declare (fixnum ordinal)) + (return + (if bits + (locally (declare (simple-bit-vector bits) + (optimize (speed 3) (safety 0))) + (if (< ordinal (length bits)) + (not (eql 0 (sbit bits ordinal)))))))) + (let* ((name (class-cell-name class-cell)) + (new-cell (find-class-cell name nil))) + (unless + (if (and new-cell (not (eq class-cell new-cell))) + (setq class-cell new-cell class (class-cell-class class-cell)) + (return (typep form name)))))))))) + + + +(defun %require-type-class-cell (arg class-cell) + (if (class-cell-typep arg class-cell) + arg + (%kernel-restart $xwrongtype arg (car class-cell)))) + + + + +(defun find-class (name &optional (errorp t) environment) + (declare (optimize speed)) + (let* ((cell (find-class-cell name nil))) + (declare (type class-cell cell)) + (or (and cell (class-cell-class cell)) + (let ((defenv (and environment (definition-environment environment)))) + (when defenv + (dolist (class (defenv.classes defenv)) + (when (eq name (%class.name class)) + (return class))))) + (when (or errorp (not (symbolp name))) + (cerror "Try finding the class again" + "Class named ~S not found." name) + (find-class name errorp environment))))) + +(fset 'pessimize-make-instance-for-class-name ;; redefined later + (qlfun bootstrapping-pessimize-make-instance-for-class-name (name) name)) + +(defun update-class-proper-names (name old-class new-class) + (when name + (pessimize-make-instance-for-class-name name)) + (when (and old-class + (not (eq old-class new-class)) + (eq (%class-proper-name old-class) name)) + (setf (%class-proper-name old-class) nil)) + (when (and new-class (eq (%class-name new-class) name)) + (setf (%class-proper-name new-class) name))) + + +(fset 'set-find-class (nfunction bootstrapping-set-find-class ; redefined below + (lambda (name class) + (clear-type-cache) + (let* ((cell (find-class-cell name t)) + (old-class (class-cell-class cell))) + (when class + (if (eq name (%class.name class)) + (setf (info-type-kind name) :instance))) + (setf (class-cell-class cell) class) + (update-class-proper-names name old-class class) + class)))) + + +;;; bootstrapping definition. real one is in "sysutils.lisp" +(fset 'built-in-type-p (nfunction boostrapping-built-in-typep-p + (lambda (name) + (or (type-predicate name) + (memq name '(signed-byte unsigned-byte mod + values satisfies member and or not)) + (typep (find-class name nil) 'built-in-class))))) + + + +(defun %compile-time-defclass (name environment) + (note-type-info name 'class environment) + (unless (find-class name nil environment) + (let ((defenv (definition-environment environment))) + (when defenv + (push (make-instance 'compile-time-class :name name) + (defenv.classes defenv))))) + name) + +(eval-when (:compile-toplevel :execute) +(declaim (inline standard-instance-p)) +) + + + + +(defun standard-instance-p (i) + (eq (typecode i) target::subtag-instance)) + +(defun check-setf-find-class-protected-class (old-class new-class name) + (when (and (standard-instance-p old-class) + (%class-kernel-p old-class) + *warn-if-redefine-kernel* + ;; EQL might be necessary on foreign classes + (not (eq new-class old-class))) + (cerror "Setf (FIND-CLASS ~s) to the new class." + "The class name ~s currently denotes the class ~s that +marked as being a critical part of the system; an attempt is being made +to replace that class with ~s" name old-class new-class) + (setf (%class-kernel-p old-class) nil))) + + +(queue-fixup + (defun set-find-class (name class) + (setq name (require-type name 'symbol)) + (let* ((cell (find-class-cell name t)) + (old-class (class-cell-class cell))) + (declare (type class-cell cell)) + (when old-class + (when (eq (%class.name old-class) name) + (setf (info-type-kind name) nil) + (clear-type-cache)) + (when *warn-if-redefine-kernel* + (check-setf-find-class-protected-class old-class class name))) + (when (null class) + (when cell + (setf (class-cell-class cell) nil)) + (update-class-proper-names name old-class class) + (return-from set-find-class nil)) + (setq class (require-type class 'class)) + (when (built-in-type-p name) + (unless (eq (class-cell-class cell) class) + (error "Cannot redefine built-in type name ~S" name))) + (when (eq (%class.name class) name) + (when (%deftype-expander name) + (cerror "set ~S anyway, removing the ~*~S definition" + "Cannot set ~S because type ~S is already defined by ~S" + `(find-class ',name) name 'deftype) + (%deftype name nil nil)) + (setf (info-type-kind name) :instance)) + (update-class-proper-names name old-class class) + (setf (class-cell-class cell) class))) + ) ; end of queue-fixup + + + +#|| +; This tended to cluster entries in gf dispatch tables too much. +(defvar *class-wrapper-hash-index* 0) +(defun new-class-wrapper-hash-index () + (let ((index *class-wrapper-hash-index*)) + (setq *class-wrapper-hash-index* + (if (< index (- most-positive-fixnum 2)) + ; Increment by two longwords. This is important! + ; The dispatch code will break if you change this. + (%i+ index 3) ; '3 = 24 bytes = 6 longwords in lap. + 1)))) +||# + +(defglobal *next-class-ordinal* 0) + +(defun %next-class-ordinal () + (%atomic-incf-node 1 '*next-class-ordinal* target::symbol.vcell)) + +;;; Initialized after built-in-class is made +(defvar *built-in-class-wrapper* nil) + +(defun make-class-ctype (class) + (%istruct 'class-ctype *class-type-class* nil class nil)) + +(defun %class-ordinal (class &optional no-error) + (if (standard-instance-p class) + (instance.hash class) + (if (typep class 'macptr) + (foreign-class-ordinal class) + (unless no-error + (error "Can't determine ordinal of ~s" class))))) + +(defun (setf %class-ordinal) (new class &optional no-error) + (if (standard-instance-p class) + (setf (instance.hash class) new) + (if (typep class 'macptr) + (setf (foreign-class-ordinal class) new) + (unless no-error + (error "Can't set ordinal of class ~s to ~s" class new))))) + + +(defvar *t-class* (let* ((class (%cons-built-in-class 't))) + (setf (instance.hash class) 0) + (let* ((cpl (list class)) + (wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))) + (setf (%class.cpl class) cpl) + (setf (%wrapper-cpl wrapper) cpl + (%class.own-wrapper class) wrapper + (%wrapper-cpl-bits wrapper) #*1) + (setf (%class.ctype class) (make-class-ctype class)) + (setf (find-class 't) class) + class))) + +(defun compute-cpl (class) + (flet ((%real-class-cpl (class) + (or (%class-cpl class) + (compute-cpl class)))) + (let* ((predecessors (list (list class))) candidates cpl) + (dolist (sup (%class-direct-superclasses class)) + (when (symbolp sup) (report-bad-arg sup 'class)) + (dolist (sup (%real-class-cpl sup)) + (unless (assq sup predecessors) (push (list sup) predecessors)))) + (labels ((compute-predecessors (class table) + (dolist (sup (%class-direct-superclasses class) table) + (compute-predecessors sup table) + ;(push class (cdr (assq sup table))) + (let ((a (assq sup table))) (%rplacd a (cons class (%cdr a)))) + (setq class sup)))) + (compute-predecessors class predecessors)) + (setq candidates (list (assq class predecessors))) + (while predecessors + (dolist (c candidates (error "Inconsistent superclasses for ~d" class)) + (when (null (%cdr c)) + (setq predecessors (nremove c predecessors)) + (dolist (p predecessors) (%rplacd p (nremove (%car c) (%cdr p)))) + (setq candidates (nremove c candidates)) + (setq cpl (%rplacd c cpl)) + (dolist (sup (%class-direct-superclasses (%car c))) + (when (setq c (assq sup predecessors)) (push c candidates))) + (return)))) + (setq cpl (nreverse cpl)) + (do* ((tail cpl (%cdr tail)) + sup-cpl) + ((null (setq sup-cpl (and (cdr tail) (%real-class-cpl (cadr tail)))))) + (when (equal (%cdr tail) sup-cpl) + (setf (%cdr tail) sup-cpl) + (return))) + cpl))) + +(defun make-cpl-bits (cpl) + (declare (optimize speed)) + (when cpl + (let* ((max 0)) + (declare (fixnum max)) + (dolist (class cpl) + (let* ((ordinal (%class-ordinal class))) + (declare (fixnum ordinal)) + (when (> ordinal max) + (setq max ordinal)))) + (let* ((bits (make-array (the fixnum (1+ max)) :element-type 'bit))) + (dolist (class cpl bits) + (let* ((ordinal (%class-ordinal class))) + (setf (sbit bits ordinal) 1))))))) + + +(defun make-built-in-class (name &rest supers) + (if (null supers) + (setq supers (list *t-class*)) + (do ((supers supers (%cdr supers))) + ((null supers)) + (when (symbolp (%car supers)) (%rplaca supers (find-class (%car supers)))))) + (let ((class (find-class name nil))) + (if class + (progn + ;Must be debugging. Give a try at redefinition... + (dolist (sup (%class.local-supers class)) + (setf (%class.subclasses sup) (nremove class (%class.subclasses sup))))) + (progn + (setq class (%cons-built-in-class name)) + (setf (instance.hash class) (%next-class-ordinal)))) + (dolist (sup supers) + (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) + (setf (%class.local-supers class) supers) + (let* ((wrapper (%cons-wrapper class (new-class-wrapper-hash-index))) + (cpl (compute-cpl class))) + (setf (%class.cpl class) cpl) + (setf (%class.own-wrapper class) wrapper) + (setf (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl) + (%wrapper-class-ordinal wrapper) (%class-ordinal class))) + (setf (%class.ctype class) (make-class-ctype class)) + (setf (find-class name) class) + (dolist (sub (%class.subclasses class)) ; Only non-nil if redefining + ;Recompute the cpl. + (apply #'make-built-in-class (%class.name sub) (%class.local-supers sub))) + class)) + +(defun make-istruct-class (name &rest supers) + (let* ((class (apply #'make-built-in-class name supers)) + (cell (register-istruct-cell name))) + (setf (istruct-cell-info cell) (%class.own-wrapper class)) + class)) + +;;; This will be filled in below. Need it defined now as it goes in +;;; the instance.class-wrapper of all the classes that STANDARD-CLASS +;;; inherits from. +(defstatic *standard-class-wrapper* + (%cons-wrapper 'standard-class)) + +(defun make-standard-class (name &rest supers) + (make-class name *standard-class-wrapper* supers)) + +(defun make-class (name metaclass-wrapper supers &optional own-wrapper) + (let ((class (if (find-class name nil) + (error "Attempt to remake standard class ~s" name) + (%cons-standard-class name metaclass-wrapper)))) + (setf (instance.hash class) (%next-class-ordinal)) + (if (null supers) + (setq supers (list *standard-class-class*)) + (do ((supers supers (cdr supers)) + sup) + ((null supers)) + (setq sup (%car supers)) + (if (symbolp sup) (setf (%car supers) (setq sup (find-class (%car supers))))) + #+nil (unless (or (eq sup *t-class*) (std-class-p sup)) + (error "~a is not of type ~a" sup 'std-class)))) + (setf (%class.local-supers class) supers) + (let ((cpl (compute-cpl class)) + (wrapper (if own-wrapper + (progn + (setf (%wrapper-class own-wrapper) class) + own-wrapper) + (%cons-wrapper class)))) + (setf (%class.cpl class) cpl + (%wrapper-instance-slots wrapper) (vector) + (%class.own-wrapper class) wrapper + (%class.ctype class) (make-class-ctype class) + (%class.slots class) nil + (%wrapper-class-ordinal wrapper) (%class-ordinal class) + (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl) + (find-class name) class + ) + (dolist (sup supers) + (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) + class))) + + + + + +(defun standard-object-p (thing) + ;; returns thing's class-wrapper or nil if it isn't a standard-object + (if (standard-instance-p thing) + (instance.class-wrapper thing) + (if (typep thing 'macptr) + (foreign-instance-class-wrapper thing)))) + + +(defun std-class-p (class) + ;; (typep class 'std-class) + ;; but works at bootstrapping time as well + (let ((wrapper (standard-object-p class))) + (and wrapper + (or (eq wrapper *standard-class-wrapper*) + (memq *std-class-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) + +(set-type-predicate 'std-class 'std-class-p) + +(defun slots-class-p (class) + (let ((wrapper (standard-object-p class))) + (and wrapper + (or (eq wrapper *slots-class-wrapper*) + (memq *slots-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) + +(set-type-predicate 'slots-class 'slots-class-p) + +(defun specializer-p (thing) + (memq *specializer-class* (%inited-class-cpl (class-of thing)))) + +(defstatic *standard-object-class* (make-standard-class 'standard-object *t-class*)) + +(defstatic *metaobject-class* (make-standard-class 'metaobject *standard-object-class*)) + +(defstatic *specializer-class* (make-standard-class 'specializer *metaobject-class*)) +(defstatic *eql-specializer-class* (make-standard-class 'eql-specializer *specializer-class*)) + +(defstatic *standard-method-combination* + (make-instance-vector + (%class.own-wrapper + (make-standard-class + 'standard-method-combination + (make-standard-class 'method-combination *metaobject-class*))) + 1)) + + +(defun eql-specializer-p (x) + (memq *eql-specializer-class* (%inited-class-cpl (class-of x)))) + +(setf (type-predicate 'eql-specializer) 'eql-specializer-p) + +;;; The *xxx-class-class* instances get slots near the end of this file. +(defstatic *class-class* (make-standard-class 'class *specializer-class*)) + +(defstatic *slots-class* (make-standard-class 'slots-class *class-class*)) +(defstatic *slots-class-wrapper* (%class.own-wrapper *slots-class*)) + + +;;; an implementation class that exists so that +;;; standard-class & funcallable-standard-class can have a common ancestor not +;;; shared by anybody but their subclasses. + +(defstatic *std-class-class* (make-standard-class 'std-class *slots-class*)) + +;;; The class of all objects whose metaclass is standard-class. Yow. +(defstatic *standard-class-class* (make-standard-class 'standard-class *std-class-class*)) +;;; Replace its wrapper and the circle is closed. +(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper* + (%wrapper-class *standard-class-wrapper*) *standard-class-class* + (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*) + (%wrapper-instance-slots *standard-class-wrapper*) (vector)) + +(defstatic *built-in-class-class* (make-standard-class 'built-in-class *class-class*)) +(setf *built-in-class-wrapper* (%class.own-wrapper *built-in-class-class*) + (instance.class-wrapper *t-class*) *built-in-class-wrapper*) + +(defstatic *structure-class-class* (make-standard-class 'structure-class *slots-class*)) +(defstatic *structure-class-wrapper* (%class.own-wrapper *structure-class-class*)) +(defstatic *structure-object-class* + (make-class 'structure-object *structure-class-wrapper* (list *t-class*))) + +(defstatic *forward-referenced-class-class* + (make-standard-class 'forward-referenced-class *class-class*)) + +(defstatic *function-class* (make-built-in-class 'function)) + +(defun alias-class (name class) + (setf (find-class name) class + (info-type-kind name) :instance) + class) + +;;;Right now, all functions are compiled. + + +(defstatic *compiled-function-class* *function-class*) +(alias-class 'compiled-function *compiled-function-class*) + +(defstatic *compiled-lexical-closure-class* + (make-standard-class 'compiled-lexical-closure *function-class*)) + + + + + +(defstatic *funcallable-standard-class-class* + (make-standard-class 'funcallable-standard-class *std-class-class*)) + +(defstatic *funcallable-standard-object-class* + (make-class 'funcallable-standard-object + (%class.own-wrapper *funcallable-standard-class-class*) + (list *standard-object-class* *function-class*))) + +(defstatic *generic-function-class* + (make-class 'generic-function + (%class.own-wrapper *funcallable-standard-class-class*) + (list *metaobject-class* *funcallable-standard-object-class*))) +(setq *generic-function-class-wrapper* (%class.own-wrapper *generic-function-class*)) + +(defstatic *standard-generic-function-class* + (make-class 'standard-generic-function + (%class.own-wrapper *funcallable-standard-class-class*) + (list *generic-function-class*))) +(setq *standard-generic-function-class-wrapper* + (%class.own-wrapper *standard-generic-function-class*)) + +;;; *standard-method-class* is upgraded to a real class below +(defstatic *method-class* (make-standard-class 'method *metaobject-class*)) +(defstatic *standard-method-class* (make-standard-class 'standard-method *method-class*)) +(defstatic *accessor-method-class* (make-standard-class 'standard-accessor-method *standard-method-class*)) +(defstatic *standard-reader-method-class* (make-standard-class 'standard-reader-method *accessor-method-class*)) +(defstatic *standard-writer-method-class* (make-standard-class 'standard-writer-method *accessor-method-class*)) +(defstatic *method-function-class* (make-standard-class 'method-function *function-class*)) + + +(defstatic *combined-method-class* (make-standard-class 'combined-method *function-class*)) + +(defstatic *slot-definition-class* (make-standard-class 'slot-definition *metaobject-class*)) +(defstatic direct-slot-definition-class (make-standard-class 'direct-slot-definition + *slot-definition-class*)) +(defstatic effective-slot-definition-class (make-standard-class 'effective-slot-definition + *slot-definition-class*)) +(defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition + *slot-definition-class*)) +(defstatic *standard-direct-slot-definition-class* (make-class + 'standard-direct-slot-definition + *standard-class-wrapper* + (list + *standard-slot-definition-class* + direct-slot-definition-class))) + +(defstatic *standard-effective-slot-definition-class* (make-class + 'standard-effective-slot-definition + *standard-class-wrapper* + (list + *standard-slot-definition-class* + effective-slot-definition-class) +)) + +(defstatic *standard-effective-slot-definition-class-wrapper* + (%class.own-wrapper *standard-effective-slot-definition-class*)) + + + + + + + +(let ((*dont-find-class-optimize* t) + (ordinal-type-class-alist ()) + (ordinal-type-class-alist-lock (make-lock))) + + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + +;; The built-in classes. + (defstatic *array-class* (make-built-in-class 'array)) + (defstatic *character-class* (make-built-in-class 'character)) + (make-built-in-class 'number) + (make-built-in-class 'sequence) + (defstatic *symbol-class* (make-built-in-class 'symbol)) + (defstatic *immediate-class* (make-built-in-class 'immediate)) ; Random immediate + ;; Random uvectors - these are NOT class of all things represented by a uvector + ;;type. Just random uvectors which don't fit anywhere else. + (make-built-in-class 'ivector) ; unknown ivector + (make-built-in-class 'gvector) ; unknown gvector + (defstatic *istruct-class* (make-built-in-class 'internal-structure)) ; unknown istruct + + (defstatic *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector))) + + (defstatic *macptr-class* (make-built-in-class 'macptr)) + (defstatic *foreign-standard-object-class* + (make-standard-class 'foreign-standard-object + *standard-object-class* *macptr-class*)) + + (defstatic *foreign-class-class* + (make-standard-class 'foreign-class *foreign-standard-object-class* *slots-class*)) + + (make-built-in-class 'population) + (make-built-in-class 'pool) + (make-built-in-class 'package) + (defstatic *lock-class* (make-built-in-class 'lock)) + (defstatic *recursive-lock-class* (make-built-in-class 'recursive-lock *lock-class*)) + (defstatic *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*)) + + (make-istruct-class 'lock-acquisition *istruct-class*) + (make-istruct-class 'semaphore-notification *istruct-class*) + (make-istruct-class 'class-wrapper *istruct-class*) + ;; Compiler stuff, mostly + (make-istruct-class 'faslapi *istruct-class*) + (make-istruct-class 'faslstate *istruct-class*) + (make-istruct-class 'var *istruct-class*) + (make-istruct-class 'afunc *istruct-class*) + (make-istruct-class 'lexical-environment *istruct-class*) + (make-istruct-class 'definition-environment *istruct-class*) + (make-istruct-class 'compiler-policy *istruct-class*) + (make-istruct-class 'deferred-warnings *istruct-class*) + (make-istruct-class 'ptaskstate *istruct-class*) + (make-istruct-class 'entry *istruct-class*) + (make-istruct-class 'foreign-object-domain *istruct-class*) + + + (make-istruct-class 'slot-id *istruct-class*) + (make-built-in-class 'value-cell) + (make-istruct-class 'restart *istruct-class*) + (make-istruct-class 'hash-table *istruct-class*) + (make-istruct-class 'readtable *istruct-class*) + (make-istruct-class 'pathname *istruct-class*) + (make-istruct-class 'random-state *istruct-class*) + (make-istruct-class 'xp-structure *istruct-class*) + (make-istruct-class 'lisp-thread *istruct-class*) + (make-istruct-class 'resource *istruct-class*) + (make-istruct-class 'periodic-task *istruct-class*) + (make-istruct-class 'semaphore *istruct-class*) + + (make-istruct-class 'type-class *istruct-class*) + + (defstatic *ctype-class* (make-istruct-class 'ctype *istruct-class*)) + (make-istruct-class 'key-info *istruct-class*) + (defstatic *args-ctype* (make-istruct-class 'args-ctype *ctype-class*)) + (make-istruct-class 'values-ctype *args-ctype*) + (make-istruct-class 'function-ctype *args-ctype*) + (make-istruct-class 'constant-ctype *ctype-class*) + (make-istruct-class 'named-ctype *ctype-class*) + (make-istruct-class 'cons-ctype *ctype-class*) + (make-istruct-class 'unknown-ctype (make-istruct-class 'hairy-ctype *ctype-class*)) + (make-istruct-class 'numeric-ctype *ctype-class*) + (make-istruct-class 'array-ctype *ctype-class*) + (make-istruct-class 'member-ctype *ctype-class*) + (make-istruct-class 'union-ctype *ctype-class*) + (make-istruct-class 'foreign-ctype *ctype-class*) + (make-istruct-class 'class-ctype *ctype-class*) + (make-istruct-class 'negation-ctype *ctype-class*) + (make-istruct-class 'intersection-ctype *ctype-class*) + + (make-istruct-class 'class-cell *istruct-class*) + (make-istruct-class 'type-cell *istruct-class*) + (make-istruct-class 'package-ref *istruct-class*) + + (make-istruct-class 'foreign-variable *istruct-class*) + (make-istruct-class 'external-entry-point *istruct-class*) + (make-istruct-class 'shlib *istruct-class*) + + (make-built-in-class 'complex (find-class 'number)) + (make-built-in-class 'real (find-class 'number)) + (defstatic *float-class* (make-built-in-class 'float (find-class 'real))) + (defstatic *double-float-class* (make-built-in-class 'double-float (find-class 'float))) + (defstatic *single-float-class* (make-built-in-class 'single-float (find-class 'float))) + (alias-class 'short-float *single-float-class*) + (alias-class 'long-float *double-float-class*) + + (make-built-in-class 'rational (find-class 'real)) + (make-built-in-class 'ratio (find-class 'rational)) + (make-built-in-class 'integer (find-class 'rational)) + (defstatic *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer))) + + #+x86-target + (defstatic *tagged-return-address-class* (make-built-in-class 'tagged-return-address)) + (make-built-in-class 'bignum (find-class 'integer)) + + (make-built-in-class 'bit *fixnum-class*) + (make-built-in-class 'unsigned-byte (find-class 'integer)) + (make-built-In-class 'signed-byte (find-class 'integer)) + + + (make-istruct-class 'logical-pathname (find-class 'pathname)) + + (make-istruct-class 'destructure-state *istruct-class*) + + (defstatic *base-char-class* (alias-class 'base-char *character-class*)) + (defstatic *standard-char-class* (make-built-in-class 'standard-char *base-char-class*)) + + (defstatic *keyword-class* (make-built-in-class 'keyword *symbol-class*)) + + (make-built-in-class 'list (find-class 'sequence)) + (defstatic *cons-class* (make-built-in-class 'cons (find-class 'list))) + (defstatic *null-class* (make-built-in-class 'null *symbol-class* (find-class 'list))) + + (defstatic *vector-class* (make-built-in-class 'vector *array-class* (find-class 'sequence))) + (defstatic *simple-array-class* (make-built-in-class 'simple-array *array-class*)) + (make-built-in-class 'simple-1d-array *vector-class* *simple-array-class*) + + ;;Maybe should do *float-array-class* etc? + ;;Also, should straighten out the simple-n-dim-array mess... + (make-built-in-class 'unsigned-byte-vector *vector-class*) + (make-built-in-class 'simple-unsigned-byte-vector (find-class 'unsigned-byte-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'unsigned-word-vector *vector-class*) + (make-built-in-class 'simple-unsigned-word-vector (find-class 'unsigned-word-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'fixnum-vector *vector-class*) + (make-built-in-class 'simple-fixnum-vector (find-class 'fixnum-vector) (find-class 'simple-1d-array)) + + + (progn + (make-built-in-class 'double-float-vector *vector-class*) + (make-built-in-class 'short-float-vector *vector-class*) + (alias-class 'long-float-vector (find-class 'double-float-vector)) + (alias-class 'single-float-vector (find-class 'short-float-vector)) + (make-built-in-class 'simple-double-float-vector (find-class 'double-float-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'simple-short-float-vector (find-class 'short-float-vector) (find-class 'simple-1d-array)) + (alias-class 'simple-long-float-vector (find-class 'simple-double-float-vector)) + (alias-class 'simple-single-float-vector (find-class 'simple-short-float-vector)) + ) + + #+x8664-target + (progn + (make-built-in-class 'symbol-vector (find-class 'gvector)) + (make-built-in-class 'function-vector (find-class 'gvector))) + + #+64-bit-target + (progn + (make-built-in-class 'doubleword-vector *vector-class*) + (make-built-in-class 'simple-doubleword-vector (find-class 'doubleword-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'unsigned-doubleword-vector *vector-class*) + (make-built-in-class 'simple-unsigned-doubleword-vector (find-class 'unsigned-doubleword-vector) (find-class 'simple-1d-array)) + ) ; #+64-bit-target + + (make-built-in-class 'long-vector *vector-class*) + (make-built-in-class 'simple-long-vector (find-class 'long-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'unsigned-long-vector *vector-class*) + (make-built-in-class 'simple-unsigned-long-vector (find-class 'unsigned-long-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'byte-vector *vector-class*) + (make-built-in-class 'simple-byte-vector (find-class 'byte-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'bit-vector *vector-class*) + (make-built-in-class 'simple-bit-vector (find-class 'bit-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'word-vector *vector-class*) + (make-built-in-class 'simple-word-vector (find-class 'word-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'string *vector-class*) + (make-built-in-class 'base-string (find-class 'string)) + (make-built-in-class 'simple-string (find-class 'string) (find-class 'simple-1d-array)) + (make-built-in-class 'simple-base-string (find-class 'base-string) (find-class 'simple-string)) + (make-built-in-class 'general-vector *vector-class*) + (make-built-in-class 'simple-vector (find-class 'general-vector) (find-class 'simple-1d-array)) + + (make-built-in-class 'hash-table-vector) + (make-built-in-class 'catch-frame) + (make-built-in-class 'code-vector) + #+ppc32-target + (make-built-in-class 'creole-object) + + (make-built-in-class 'xfunction) + (make-built-in-class 'xcode-vector) + + (defun class-cell-find-class (class-cell errorp) + (unless (istruct-typep class-cell 'class-cell) + (setq class-cell (%kernel-restart $xwrongtype class-cell 'class-cell))) + (locally (declare (type class-cell class-cell)) + (let ((class (class-cell-class class-cell))) + (or class + (and + (setq class (find-class (class-cell-name class-cell) nil)) + (when class + (setf (class-cell-class class-cell) class) + class)) + (if errorp (error "Class ~s not found." (class-cell-name class-cell)) nil))))) + +;;; (%wrapper-class (instance.class-wrapper frob)) + + + + (defstatic *general-vector-class* (find-class 'general-vector)) + + #+ppc32-target + (defparameter *ivector-vector-classes* + (vector (find-class 'short-float-vector) + (find-class 'unsigned-long-vector) + (find-class 'long-vector) + (find-class 'fixnum-vector) + (find-class 'base-string) + (find-class 'unsigned-byte-vector) + (find-class 'byte-vector) + *t-class* ; old base-string + (find-class 'unsigned-word-vector) + (find-class 'word-vector) + (find-class 'double-float-vector) + (find-class 'bit-vector))) + + #+ppc64-target + (defparameter *ivector-vector-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'byte-vector) + (find-class 'word-vector) + (find-class 'long-vector) + (find-class 'doubleword-vector) + (find-class 'unsigned-byte-vector) + (find-class 'unsigned-word-vector) + (find-class 'unsigned-long-vector) + (find-class 'unsigned-doubleword-vector) + *t-class* + *t-class* + (find-class 'short-float-vector) + (find-class 'fixnum-vector) + *t-class* + *t-class* + *t-class* + (find-class 'double-float-vector) + (find-class 'base-string) + *t-class* + (find-class 'base-string) + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'bit-vector) + *t-class* + *t-class*)) + + #+x8632-target + (defparameter *ivector-vector-classes* + (vector (find-class 'short-float-vector) + (find-class 'unsigned-long-vector) + (find-class 'long-vector) + (find-class 'fixnum-vector) + (find-class 'base-string) + (find-class 'unsigned-byte-vector) + (find-class 'byte-vector) + *t-class* + (find-class 'unsigned-word-vector) + (find-class 'word-vector) + (find-class 'double-float-vector) + (find-class 'bit-vector))) + + #+x8664-target + (progn + (defparameter *immheader-0-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'word-vector) + (find-class 'unsigned-word-vector) + (find-class 'base-string) ;old + (find-class 'byte-vector) + (find-class 'unsigned-byte-vector) + (find-class 'bit-vector))) + + (defparameter *immheader-1-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'base-string) + (find-class 'long-vector) + (find-class 'unsigned-long-vector) + (find-class 'short-float-vector))) + + (defparameter *immheader-2-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'fixnum-vector) + (find-class 'doubleword-vector) + (find-class 'unsigned-doubleword-vector) + (find-class 'double-float-vector)))) + + + + (defun make-foreign-object-domain (&key index name recognize class-of classp + instance-class-wrapper + class-own-wrapper + slots-vector class-ordinal + set-class-ordinal) + (%istruct 'foreign-object-domain index name recognize class-of classp + instance-class-wrapper class-own-wrapper slots-vector + class-ordinal set-class-ordinal)) + + (let* ((n-foreign-object-domains 0) + (foreign-object-domains (make-array 10)) + (foreign-object-domain-lock (make-lock))) + (defun register-foreign-object-domain (name + &key + recognize + class-of + classp + instance-class-wrapper + class-own-wrapper + slots-vector + class-ordinal + set-class-ordinal) + (with-lock-grabbed (foreign-object-domain-lock) + (dotimes (i n-foreign-object-domains) + (let* ((already (svref foreign-object-domains i))) + (when (eq name (foreign-object-domain-name already)) + (setf (foreign-object-domain-recognize already) recognize + (foreign-object-domain-class-of already) class-of + (foreign-object-domain-classp already) classp + (foreign-object-domain-instance-class-wrapper already) + instance-class-wrapper + (foreign-object-domain-class-own-wrapper already) + class-own-wrapper + (foreign-object-domain-slots-vector already) slots-vector + (foreign-object-domain-class-ordinal already) class-ordinal + (foreign-object-domain-set-class-ordinal already) + set-class-ordinal) + (return-from register-foreign-object-domain i)))) + (let* ((i n-foreign-object-domains) + (new (make-foreign-object-domain :index i + :name name + :recognize recognize + :class-of class-of + :classp classp + :instance-class-wrapper + instance-class-wrapper + :class-own-wrapper + class-own-wrapper + :slots-vector + slots-vector + :class-ordinal class-ordinal + :set-class-ordinal set-class-ordinal))) + (incf n-foreign-object-domains) + (if (= i (length foreign-object-domains)) + (setq foreign-object-domains (%extend-vector i foreign-object-domains (* i 2)))) + (setf (svref foreign-object-domains i) new) + i))) + (defun foreign-class-of (p) + (funcall (foreign-object-domain-class-of (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-classp (p) + (funcall (foreign-object-domain-classp (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-instance-class-wrapper (p) + (funcall (foreign-object-domain-instance-class-wrapper (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-class-own-wrapper (p) + (funcall (foreign-object-domain-class-own-wrapper (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-slots-vector (p) + (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-class-ordinal (p) + (funcall (foreign-object-domain-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p)) + (defun (setf foreign-class-ordinal) (new p) + (funcall (foreign-object-domain-set-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p new)) + (defun classify-foreign-pointer (p) + (do* ((i (1- n-foreign-object-domains) (1- i))) + ((zerop i) (error "this can't happen")) + (when (funcall (foreign-object-domain-recognize (svref foreign-object-domains i)) p) + (%set-macptr-domain p i) + (return p))))) + + (defun constantly (x) + "Return a function that always returns VALUE." + #'(lambda (&rest ignore) + (declare (dynamic-extent ignore) + (ignore ignore)) + x)) + + (defun %register-type-ordinal-class (foreign-type class-name) + ;; ordinal-type-class shouldn't already exist + (with-lock-grabbed (ordinal-type-class-alist-lock) + (or (let* ((class (cdr (assq foreign-type ordinal-type-class-alist)))) + (if (and class (eq class-name (class-name class))) + class)) + (let* ((class (make-built-in-class class-name 'macptr))) + (push (cons foreign-type class) ordinal-type-class-alist) + class)))) + + (defun %ordinal-type-class-for-macptr (p) + (with-lock-grabbed (ordinal-type-class-alist-lock) + (or (unless (%null-ptr-p p) + (cdr (assoc (%macptr-type p) ordinal-type-class-alist :key #'foreign-type-ordinal))) + *macptr-class*))) + + + (register-foreign-object-domain :unclassified + :recognize #'(lambda (p) + (declare (ignore p)) + (error "Shouldn't happen")) + :class-of #'(lambda (p) + (foreign-class-of + (classify-foreign-pointer p))) + :classp #'(lambda (p) + (foreign-classp + (classify-foreign-pointer p))) + :instance-class-wrapper + #'(lambda (p) + (foreign-instance-class-wrapper + (classify-foreign-pointer p))) + :class-own-wrapper + #'(lambda (p) + (foreign-class-own-wrapper + (classify-foreign-pointer p))) + :slots-vector + #'(lambda (p) + (foreign-slots-vector + (classify-foreign-pointer p)))) + +;;; "Raw" macptrs, that aren't recognized as "standard foreign objects" +;;; in some other domain, should always be recognized as such (and this +;;; pretty much has to be domain #1.) + + (register-foreign-object-domain :raw + :recognize #'true + :class-of #'%ordinal-type-class-for-macptr + :classp #'false + :instance-class-wrapper + (lambda (p) + (%class.own-wrapper (%ordinal-type-class-for-macptr p))) + :class-own-wrapper #'false + :slots-vector #'false) + + (defstatic *class-table* + (let* ((v (make-array 256 :initial-element nil)) + (class-of-function-function + #'(lambda (thing) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + ;; closure + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + *compiled-lexical-closure-class* + (if (logbitp $lfbits-gfn-bit inner-bits) + (%wrapper-class (gf.instance.class-wrapper thing)) + (if (logbitp $lfbits-cm-bit inner-bits) + *combined-method-class* + *compiled-lexical-closure-class*)))) + *compiled-lexical-closure-class*)) + (if (logbitp $lfbits-method-bit bits) + *method-function-class* + (if (logbitp $lfbits-gfn-bit bits) + (%wrapper-class (gf.instance.class-wrapper thing)) + (if (logbitp $lfbits-cm-bit bits) + *combined-method-class* + *compiled-function-class*)))))))) + ;; Make one loop through the vector, initializing fixnum & list + ;; cells. Set all immediates to *immediate-class*, then + ;; special-case characters later. + #+ppc32-target + (do* ((slice 0 (+ 8 slice))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice ppc32::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice ppc32::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice ppc32::fulltag-cons)) *cons-class* + (%svref v (+ slice ppc32::fulltag-nil)) *null-class* + (%svref v (+ slice ppc32::fulltag-imm)) *immediate-class*)) + #+ppc64-target + (do* ((slice 0 (+ 16 slice))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice ppc64::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice ppc64::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice ppc64::fulltag-cons)) *cons-class* + (%svref v (+ slice ppc64::fulltag-imm-0)) *immediate-class* + (%svref v (+ slice ppc64::fulltag-imm-1)) *immediate-class* + (%svref v (+ slice ppc64::fulltag-imm-2)) *immediate-class* + (%svref v (+ slice ppc64::fulltag-imm-3)) *immediate-class*)) + #+x8632-target + (do* ((slice 0 (+ 8 slice)) + (cons-fn #'(lambda (x) (if (null x) *null-class* *cons-class*)))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice x8632::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice x8632::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice x8632::fulltag-cons)) cons-fn + (%svref v (+ slice x8632::fulltag-tra)) *tagged-return-address-class* + (%svref v (+ slice x8632::fulltag-imm)) *immediate-class*)) + #+x8664-target + (do* ((slice 0 (+ 16 slice))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice x8664::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice x8664::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice x8664::fulltag-cons)) *cons-class* + (%svref v (+ slice x8664::fulltag-imm-0)) *immediate-class* + (%svref v (+ slice x8664::fulltag-imm-1)) *immediate-class* + (%svref v (+ slice x8664::fulltag-tra-0)) *tagged-return-address-class* + (%svref v (+ slice x8664::fulltag-tra-1)) *tagged-return-address-class* + (%svref v (+ slice x8664::fulltag-nil)) *null-class*)) + (macrolet ((map-subtag (subtag class-name) + `(setf (%svref v ,subtag) (find-class ',class-name)))) + ;; immheader types map to built-in classes. + (map-subtag target::subtag-bignum bignum) + (map-subtag target::subtag-double-float double-float) + (map-subtag target::subtag-single-float short-float) + (map-subtag target::subtag-dead-macptr ivector) + #-x86-target + (map-subtag target::subtag-code-vector code-vector) + #+ppc32-target + (map-subtag ppc32::subtag-creole-object creole-object) + (map-subtag target::subtag-xcode-vector xcode-vector) + (map-subtag target::subtag-xfunction xfunction) + (map-subtag target::subtag-single-float-vector simple-short-float-vector) + #+64-bit-target + (map-subtag target::subtag-u64-vector simple-unsigned-doubleword-vector) + #+64-bit-target + (map-subtag target::subtag-s64-vector simple-doubleword-vector) + (map-subtag target::subtag-fixnum-vector simple-fixnum-vector) + (map-subtag target::subtag-u32-vector simple-unsigned-long-vector) + (map-subtag target::subtag-s32-vector simple-long-vector) + (map-subtag target::subtag-u8-vector simple-unsigned-byte-vector) + (map-subtag target::subtag-s8-vector simple-byte-vector) + (map-subtag target::subtag-simple-base-string simple-base-string) + (map-subtag target::subtag-u16-vector simple-unsigned-word-vector) + (map-subtag target::subtag-s16-vector simple-word-vector) + (map-subtag target::subtag-double-float-vector simple-double-float-vector) + (map-subtag target::subtag-bit-vector simple-bit-vector) + ;; Some nodeheader types map to built-in-classes; others require + ;; further dispatching. + (map-subtag target::subtag-ratio ratio) + (map-subtag target::subtag-complex complex) + (map-subtag target::subtag-catch-frame catch-frame) + (map-subtag target::subtag-hash-vector hash-table-vector) + (map-subtag target::subtag-value-cell value-cell) + (map-subtag target::subtag-pool pool) + (map-subtag target::subtag-weak population) + (map-subtag target::subtag-package package) + (map-subtag target::subtag-simple-vector simple-vector) + (map-subtag target::subtag-slot-vector slot-vector) + #+x8664-target (map-subtag x8664::subtag-symbol symbol-vector) + #+x8664-target (map-subtag x8664::subtag-function function-vector)) + (setf (%svref v target::subtag-arrayH) + #'(lambda (x) + (if (logbitp $arh_simple_bit + (the fixnum (%svref x target::arrayH.flags-cell))) + *simple-array-class* + *array-class*))) + ;; These need to be special-cased: + (setf (%svref v target::subtag-macptr) #'foreign-class-of) + (setf (%svref v target::subtag-character) + #'(lambda (c) (let* ((code (%char-code c))) + (if (or (eq c #\NewLine) + (and (>= code (char-code #\space)) + (< code (char-code #\rubout)))) + *standard-char-class* + *base-char-class*)))) + (setf (%svref v target::subtag-struct) + #'(lambda (s) (%structure-class-of s))) ; need DEFSTRUCT + (setf (%svref v target::subtag-istruct) + #'(lambda (i) + (let* ((cell (%svref i 0)) + (wrapper (istruct-cell-info cell))) + (if wrapper + (%wrapper-class wrapper) + (or (find-class (istruct-cell-name cell) nil) + *istruct-class*))))) + (setf (%svref v target::subtag-basic-stream) + #'(lambda (b) (%wrapper-class (basic-stream.wrapper b)))) + (setf (%svref v target::subtag-instance) + #'%class-of-instance) + (setf (%svref v #+ppc-target target::subtag-symbol + #+x8632-target target::subtag-symbol + #+x8664-target target::tag-symbol) + #-ppc64-target + #'(lambda (s) (if (eq (symbol-package s) *keyword-package*) + *keyword-class* + *symbol-class*)) + #+ppc64-target + #'(lambda (s) + (if s + (if (eq (symbol-package s) *keyword-package*) + *keyword-class* + *symbol-class*) + *null-class*))) + + (setf (%svref v + #+ppc-target target::subtag-function + #+x8632-target target::subtag-function + #+x8664-target target::tag-function) + class-of-function-function) + (setf (%svref v target::subtag-vectorH) + #'(lambda (v) + (let* ((subtype (%array-header-subtype v))) + (declare (fixnum subtype)) + (if (eql subtype target::subtag-simple-vector) + *general-vector-class* + #-x8664-target + (%svref *ivector-vector-classes* + #+ppc32-target + (ash (the fixnum (- subtype ppc32::min-cl-ivector-subtag)) + (- ppc32::ntagbits)) + #+ppc64-target + (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits)) + #+x8632-target + (ash (the fixnum (- subtype x8632::min-cl-ivector-subtag)) + (- x8632::ntagbits))) + #+x8664-target + (let* ((class (logand x8664::fulltagmask subtype)) + (idx (ash subtype (- x8664::ntagbits)))) + (cond ((= class x8664::fulltag-immheader-0) + (%svref *immheader-0-classes* idx)) + ((= class x8664::fulltag-immheader-1) + (%svref *immheader-1-classes* idx)) + ((= class x8664::fulltag-immheader-2) + (%svref *immheader-2-classes* idx)) + (t *t-class*))) + + )))) + (setf (%svref v target::subtag-lock) + #'(lambda (thing) + (case (%svref thing target::lock.kind-cell) + (recursive-lock *recursive-lock-class*) + (read-write-lock *read-write-lock-class*) + (t *lock-class*)))) + v)) + + + + + + (defun no-class-error (x) + (error "Bug (probably): can't determine class of ~s" x)) + + + ; return frob from table + + + + + ) ; end let + + + +(defun classp (x) + (if (%standard-instance-p x) + (< (the fixnum (instance.hash x)) max-class-ordinal) + (and (typep x 'macptr) (foreign-classp x)))) + +(set-type-predicate 'class 'classp) + +(defun subclassp (c1 c2) + (and (classp c1) + (classp c2) + (not (null (memq c2 (%inited-class-cpl c1 t)))))) + +(defun %class-get (class indicator &optional default) + (let ((cell (assq indicator (%class-alist class)))) + (if cell (cdr cell) default))) + +(defun %class-put (class indicator value) + (let ((cell (assq indicator (%class-alist class)))) + (if cell + (setf (cdr cell) value) + (push (cons indicator value) (%class-alist class)))) + value) + +(defsetf %class-get %class-put) + +(defun %class-remprop (class indicator) + (let* ((handle (cons nil (%class-alist class))) + (last handle)) + (declare (dynamic-extent handle)) + (while (cdr last) + (if (eq indicator (caar (%cdr last))) + (progn + (setf (%cdr last) (%cddr last)) + (setf (%class-alist class) (%cdr handle))) + (setf last (%cdr last)))))) + + +(pushnew :primary-classes *features*) + +(defun %class-primary-p (class) + (if (typep class 'slots-class) + (%class-get class :primary-p) + t)) + +(defun (setf %class-primary-p) (value class) + (if value + (setf (%class-get class :primary-p) value) + (progn + (%class-remprop class :primary-p) + nil))) + +;;; Returns the first element of the CPL that is primary +(defun %class-or-superclass-primary-p (class) + (unless (class-has-a-forward-referenced-superclass-p class) + (dolist (super (%inited-class-cpl class t)) + (when (and (typep super 'standard-class) (%class-primary-p super)) + (return super))))) + + +;;; Bootstrapping version of union +(unless (fboundp 'union) + (fset 'union (nlambda bootstrapping-union (l1 l2) + (dolist (e l1) + (unless (memq e l2) + (push e l2))) + l2)) +) + +(defun %add-direct-methods (method) + (dolist (spec (%method-specializers method)) + (%do-add-direct-method spec method))) + +(defun %do-add-direct-method (spec method) + (pushnew method (specializer.direct-methods spec))) + +(defun %remove-direct-methods (method) + (dolist (spec (%method-specializers method)) + (%do-remove-direct-method spec method))) + +(defun %do-remove-direct-method (spec method) + (setf (specializer.direct-methods spec) + (nremove method (specializer.direct-methods spec)))) + +(ensure-generic-function 'initialize-instance + :lambda-list '(instance &rest initargs &key &allow-other-keys)) + +(defmethod find-method ((generic-function standard-generic-function) + method-qualifiers specializers &optional (errorp t)) + (dolist (m (%gf-methods generic-function) + (when errorp + (cerror "Try finding the method again" + "~s has no method for ~s ~s" + generic-function method-qualifiers specializers) + (find-method generic-function method-qualifiers specializers + errorp))) + (flet ((err () + (error "Wrong number of specializers: ~s" specializers))) + (let ((ss (%method-specializers m)) + (q (%method-qualifiers m)) + s) + (when (equal q method-qualifiers) + (dolist (spec (canonicalize-specializers specializers nil) + (if (null ss) + (return-from find-method m) + (err))) + (unless (setq s (pop ss)) + (err)) + (unless (eq s spec) + (return)))))))) + +(defmethod create-reader-method-function ((class slots-class) + (reader-method-class standard-reader-method) + (dslotd direct-slot-definition)) + #+ppc-target + (gvector :function + (uvref *reader-method-function-proto* 0) + (ensure-slot-id (%slot-definition-name dslotd)) + 'slot-id-value + nil ;method-function name + (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))) + #+x86-target + (%clone-x86-function + *reader-method-function-proto* + (ensure-slot-id (%slot-definition-name dslotd)) + 'slot-id-value + nil ;method-function name + (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit)))) + +(defmethod create-writer-method-function ((class slots-class) + (writer-method-class standard-writer-method) + (dslotd direct-slot-definition)) + #+ppc-target + (gvector :function + (uvref *writer-method-function-proto* 0) + (ensure-slot-id (%slot-definition-name dslotd)) + 'set-slot-id-value + nil + (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))) + #+x86-target + (%clone-x86-function + *writer-method-function-proto* + (ensure-slot-id (%slot-definition-name dslotd)) + 'set-slot-id-value + nil + (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))) + ) + + + + + + +(defun %make-instance (class-cell &rest initargs) + (declare (dynamic-extent initargs)) + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + (apply #'make-instance + (or (class-cell-class class-cell) (class-cell-name (the class-cell class-cell))) + initargs)) + + +(defmethod make-instance ((class symbol) &rest initargs) + (declare (dynamic-extent initargs)) + (apply 'make-instance (find-class class) initargs)) + + +(defmethod make-instance ((class standard-class) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (%make-std-instance class initargs)) + +(defmethod make-instance ((class std-class) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (%make-std-instance class initargs)) + + +(defun %make-std-instance (class initargs) + (setq initargs (default-initargs class initargs)) + (when initargs + (apply #'check-initargs + nil class initargs t + #'initialize-instance #'allocate-instance #'shared-initialize + nil)) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance)) + +(defun default-initargs (class initargs) + (unless (std-class-p class) + (setq class (require-type class 'std-class))) + (when (null (%class.cpl class)) (update-class class t)) + (let ((defaults ())) + (dolist (key.form (%class-default-initargs class)) + (unless (pl-search initargs (%car key.form)) + (setq defaults + (list* (funcall (caddr key.form)) + (%car key.form) + defaults)))) + (when defaults + (setq initargs (append initargs (nreverse defaults)))) + initargs)) + + +(defun %allocate-std-instance (class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((wrapper (%class.own-wrapper class)) + (len (length (%wrapper-instance-slots wrapper)))) + (declare (fixnum len)) + (make-instance-vector wrapper len))) + + + + +(defmethod copy-instance ((instance standard-object)) + (let* ((new-slots (copy-uvector (instance.slots instance))) + (copy (gvector :instance 0 (instance-class-wrapper instance) new-slots))) + (setf (instance.hash copy) (strip-tag-to-fixnum copy) + (slot-vector.instance new-slots) copy))) + +(defmethod initialize-instance ((instance standard-object) &rest initargs) + (declare (dynamic-extent initargs)) + (apply 'shared-initialize instance t initargs)) + + +(defmethod reinitialize-instance ((instance standard-object) &rest initargs) + (declare (dynamic-extent initargs)) + (when initargs + (check-initargs + instance nil initargs t #'reinitialize-instance #'shared-initialize)) + (apply 'shared-initialize instance nil initargs)) + +(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) + (declare (dynamic-extent initargs)) + (%shared-initialize instance slot-names initargs)) + +(defmethod shared-initialize ((instance standard-generic-function) slot-names + &rest initargs) + (declare (dynamic-extent initargs)) + (%shared-initialize instance slot-names initargs)) + + + +;;; Slot-value, slot-boundp, slot-makunbound, etc. +(declaim (inline find-slotd)) +(defun find-slotd (name slots) + (dolist (slotd slots) + (when (eq name (standard-slot-definition.name slotd)) + (return slotd)))) + +(declaim (inline %std-slot-vector-value)) + +(defun %std-slot-vector-value (slot-vector slotd) + (let* ((loc (standard-effective-slot-definition.location slotd))) + (symbol-macrolet ((instance (slot-vector.instance slot-vector))) + (typecase loc + (fixnum + (%slot-ref slot-vector loc)) + (cons + (let* ((val (%cdr loc))) + (if (eq val (%slot-unbound-marker)) + (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd)) + val))) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd))))))) + + +(defmethod slot-value-using-class ((class standard-class) + instance + (slotd standard-effective-slot-definition)) + (ecase (standard-slot-definition.allocation slotd) + ((:instance :class) + (%std-slot-vector-value (instance-slots instance) slotd)))) + +(defun %maybe-std-slot-value-using-class (class instance slotd) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) + (eq *standard-effective-slot-definition-class-wrapper* + (instance.class-wrapper slotd)) + (eq *standard-class-wrapper* (instance.class-wrapper class)) + (let* ((allocation (standard-effective-slot-definition.location slotd))) + (or (eq allocation :instance) (eq allocation :class)))) + (%std-slot-vector-value (instance-slots instance) slotd) + (if (= (the fixnum (typecode instance)) target::subtag-struct) + (struct-ref instance (standard-effective-slot-definition.location slotd)) + (slot-value-using-class class instance slotd)))) + + +(declaim (inline %set-std-slot-vector-value)) + +(defun %set-std-slot-vector-value (slot-vector slotd new) + (let* ((loc (standard-effective-slot-definition.location slotd)) + (type (standard-effective-slot-definition.type slotd)) + (type-predicate (standard-effective-slot-definition.type-predicate slotd))) + (unless (or (eq new (%slot-unbound-marker)) + (null type-predicate) + (funcall type-predicate new)) + (error 'bad-slot-type + :instance (slot-vector.instance slot-vector) + :datum new :expected-type type + :slot-definition slotd)) + (typecase loc + (fixnum + (setf (%svref slot-vector loc) new)) + (cons + (setf (%cdr loc) new)) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + + +(defmethod (setf slot-value-using-class) + (new + (class standard-class) + instance + (slotd standard-effective-slot-definition)) + (ecase (standard-slot-definition.allocation slotd) + ((:instance :class) + (%set-std-slot-vector-value (instance-slots instance) slotd new)))) + + +(defun %maybe-std-setf-slot-value-using-class (class instance slotd new) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) + (eq *standard-effective-slot-definition-class-wrapper* + (instance.class-wrapper slotd)) + (eq *standard-class-wrapper* (instance.class-wrapper class)) + (let* ((allocation (standard-effective-slot-definition.allocation slotd))) + (or (eq allocation :instance) (eq allocation :class)))) + ;; Not safe to use instance.slots here, since the instance is not + ;; definitely of type SUBTAG-INSTANCE. (Anyway, INSTANCE-SLOTS + ;; should be inlined here.) + (%set-std-slot-vector-value (instance-slots instance) slotd new) + (if (structurep instance) + (setf (struct-ref instance (standard-effective-slot-definition.location slotd)) + new) + (setf (slot-value-using-class class instance slotd) new)))) + +(defmethod slot-value-using-class ((class funcallable-standard-class) + instance + (slotd standard-effective-slot-definition)) + (%std-slot-vector-value (gf.slots instance) slotd)) + +(defmethod (setf slot-value-using-class) + (new + (class funcallable-standard-class) + instance + (slotd standard-effective-slot-definition)) + (%set-std-slot-vector-value (gf.slots instance) slotd new)) + +(defun slot-value (instance slot-name) + (let* ((wrapper + (let* ((w (instance-class-wrapper instance))) + (if (eql 0 (%wrapper-hash-index w)) + (instance.class-wrapper (update-obsolete-instance instance)) + w))) + (class (%wrapper-class wrapper)) + (slotd (find-slotd slot-name (if (%standard-instance-p class) + (%class.slots class) + (class-slots class))))) + (if slotd + (%maybe-std-slot-value-using-class class instance slotd) + (if (typep slot-name 'symbol) + (restart-case + (values (slot-missing class instance slot-name 'slot-value)) + (continue () + :report "Try accessing the slot again" + (slot-value instance slot-name)) + (use-value (value) + :report "Return a value" + :interactive (lambda () + (format *query-io* "~&Value to use: ") + (list (read *query-io*))) + value)) + (report-bad-arg slot-name 'symbol))))) + + +(defmethod slot-unbound (class instance slot-name) + (declare (ignore class)) + (restart-case (error 'unbound-slot :name slot-name :instance instance) + (use-value (value) + :report "Return a value" + :interactive (lambda () + (format *query-io* "~&Value to use: ") + (list (read *query-io*))) + value))) + + + +(defmethod slot-makunbound-using-class ((class slots-class) + instance + (slotd standard-effective-slot-definition)) + (setf (slot-value-using-class class instance slotd) (%slot-unbound-marker)) + instance) + +(defmethod slot-missing (class object slot-name operation &optional new-value) + (declare (ignore class operation new-value)) + (error "~s has no slot named ~s." object slot-name)) + + +(defun set-slot-value (instance name value) + (let* ((wrapper + (let* ((w (instance-class-wrapper instance))) + (if (eql 0 (%wrapper-hash-index w)) + (instance.class-wrapper (update-obsolete-instance instance)) + w))) + (class (%wrapper-class wrapper)) + (slotd (find-slotd name (if (%standard-instance-p class) + (%class.slots class) + (class-slots class))))) + (if slotd + (%maybe-std-setf-slot-value-using-class class instance slotd value) + (if (typep name 'symbol) + (progn + (slot-missing class instance name 'setf value) + value) + (report-bad-arg name 'symbol))))) + +(defsetf slot-value set-slot-value) + +(defun slot-makunbound (instance name) + (let* ((class (class-of instance)) + (slotd (find-slotd name (%class-slots class)))) + (if slotd + (slot-makunbound-using-class class instance slotd) + (slot-missing class instance name 'slot-makunbound)) + instance)) + +(defun %std-slot-vector-boundp (slot-vector slotd) + (let* ((loc (standard-effective-slot-definition.location slotd))) + (typecase loc + (fixnum + (not (eq (%svref slot-vector loc) (%slot-unbound-marker)))) + (cons + (not (eq (%cdr loc) (%slot-unbound-marker)))) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + +(defun %maybe-std-slot-boundp-using-class (class instance slotd) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) + (eq *standard-effective-slot-definition-class-wrapper* + (instance.class-wrapper slotd)) + (eq *standard-class-wrapper* (instance.class-wrapper class)) + (let* ((allocation (standard-slot-definition.allocation slotd))) + (or (eq allocation :class) + (eq allocation :instance)))) + (%std-slot-vector-boundp (instance-slots instance) slotd) + (slot-boundp-using-class class instance slotd))) + + +(defmethod slot-boundp-using-class ((class standard-class) + instance + (slotd standard-effective-slot-definition)) + (ecase (standard-slot-definition.allocation slotd) + ((:instance :class) + (%std-slot-vector-boundp (instance-slots instance) slotd)))) + +(defmethod slot-boundp-using-class ((class funcallable-standard-class) + instance + (slotd standard-effective-slot-definition)) + (%std-slot-vector-boundp (gf.slots instance) slotd)) + + + +(defun slot-boundp (instance name) + (let* ((wrapper + (let* ((w (instance-class-wrapper instance))) + (if (eql 0 (%wrapper-hash-index w)) + (instance.class-wrapper (update-obsolete-instance instance)) + w))) + (class (%wrapper-class wrapper)) + (slotd (find-slotd name (if (%standard-instance-p class) + (%class.slots class) + (class-slots class))))) + (if slotd + (%maybe-std-slot-boundp-using-class class instance slotd) + (if (typep name 'symbol) + (values (slot-missing class instance name 'slot-boundp)) + (report-bad-arg name 'symbol))))) + +(defun slot-value-if-bound (instance name &optional default) + (if (slot-boundp instance name) + (slot-value instance name) + default)) + +(defun slot-exists-p (instance name) + (let* ((class (class-of instance)) + (slots (class-slots class))) + (find-slotd name slots))) + + +(defun slot-id-value (instance slot-id) + (let* ((wrapper (instance-class-wrapper instance))) + (funcall (%wrapper-slot-id-value wrapper) instance slot-id))) + +(defun set-slot-id-value (instance slot-id value) + (let* ((wrapper (instance-class-wrapper instance))) + (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value))) + +(defun slot-id-boundp (instance slot-id) + (let* ((wrapper (instance-class-wrapper instance)) + (class (%wrapper-class wrapper)) + (slotd (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id))) + (if slotd + (%maybe-std-slot-boundp-using-class class instance slotd) + (values (slot-missing class instance (slot-id.name slot-id) 'slot-boundp))))) + +;;; returns nil if (apply gf args) wil cause an error because of the +;;; non-existance of a method (or if GF is not a generic function or the name +;;; of a generic function). +(defun method-exists-p (gf &rest args) + (declare (dynamic-extent args)) + (when (symbolp gf) + (setq gf (fboundp gf))) + (when (typep gf 'standard-generic-function) + (or (null args) + (let* ((methods (sgf.methods gf))) + (dolist (m methods) + (when (null (%method-qualifiers m)) + (let ((specializers (%method-specializers m)) + (args args)) + (when (dolist (s specializers t) + (unless (cond ((typep s 'eql-specializer) + (eql (eql-specializer-object s) + (car args))) + (t (memq s (%inited-class-cpl + (class-of (car args)))))) + (return nil)) + (pop args)) + (return-from method-exists-p m))))) + nil)))) + +(defun funcall-if-method-exists (gf &optional default &rest args) + (declare (dynamic-extent args)) + (if (apply #'method-exists-p gf args) + (apply gf args) + (if default (apply default args)))) + + +(defun find-specializer (specializer) + (if (and (listp specializer) (eql (car specializer) 'eql)) + (intern-eql-specializer (cadr specializer)) + (find-class specializer))) + +(defmethod make-instances-obsolete ((class symbol)) + (make-instances-obsolete (find-class class))) + +(defmethod make-instances-obsolete ((class standard-class)) + (let ((wrapper (%class-own-wrapper class))) + (when wrapper + (setf (%class-own-wrapper class) nil) + (make-wrapper-obsolete wrapper))) + class) + +(defmethod make-instances-obsolete ((class funcallable-standard-class)) + (let ((wrapper (%class.own-wrapper class))) + (when wrapper + (setf (%class-own-wrapper class) nil) + (make-wrapper-obsolete wrapper))) + class) + +(defmethod make-instances-obsolete ((class structure-class)) + ;; could maybe warn that instances are obsolete, but there's not + ;; much that we can do about that. + class) + + + +;;; A wrapper is made obsolete by setting the hash-index & instance-slots to 0 +;;; The instance slots are saved for update-obsolete-instance +;;; by consing them onto the class slots. +;;; Method dispatch looks at the hash-index. +;;; slot-value & set-slot-value look at the instance-slots. +;;; Each wrapper may have an associated forwarding wrapper, which must +;;; also be made obsolete. The forwarding-wrapper is stored in the +;;; hash table below keyed on the wrapper-hash-index of the two +;;; wrappers. +(defvar *forwarding-wrapper-hash-table* (make-hash-table :test 'eq)) + + +(defun make-wrapper-obsolete (wrapper) + (without-interrupts + (let ((forwarding-info + (unless (eql 0 (%wrapper-instance-slots wrapper)) ; already forwarded or obsolete? + (%cons-forwarding-info (%wrapper-instance-slots wrapper) + (%wrapper-class-slots wrapper))))) + (when forwarding-info + (setf (%wrapper-hash-index wrapper) 0 + (%wrapper-cpl wrapper) nil + (%wrapper-cpl-bits wrapper) nil + (%wrapper-instance-slots wrapper) 0 + (%wrapper-forwarding-info wrapper) forwarding-info + (%wrapper-slot-id->slotd wrapper) #'%slot-id-lookup-obsolete + (%wrapper-slot-id-value wrapper) #'%slot-id-ref-obsolete + (%wrapper-set-slot-id-value wrapper) #'%slot-id-set-obsolete + )))) + wrapper) + +(defun %clear-class-primary-slot-accessor-offsets (class) + (let ((info-list (%class-get class '%class-primary-slot-accessor-info))) + (dolist (info info-list) + (setf (%slot-accessor-info.offset info) nil)))) + +(defun primary-class-slot-offset (class slot-name) + (dolist (super (%class.cpl class)) + (let* ((pos (and (typep super 'standard-class) + (%class-primary-p super) + (dolist (slot (%class-slots class)) + (when (eq (%slot-definition-allocation slot) + :instance) + (when (eq slot-name (%slot-definition-name slot)) + (return (%slot-definition-location slot)))))))) + (when pos (return pos))))) + +;;; Called by the compiler-macro expansion for slot-value +;;; info is the result of a %class-primary-slot-accessor-info call. +;;; value-form is specified if this is set-slot-value. +;;; Otherwise it's slot-value. +(defun primary-class-slot-value (instance info &optional (value-form nil value-form-p)) + (let ((slot-name (%slot-accessor-info.slot-name info))) + (prog1 + (if value-form-p + (setf (slot-value instance slot-name) value-form) + (slot-value instance slot-name)) + (setf (%slot-accessor-info.offset info) + (primary-class-slot-offset (class-of instance) slot-name))))) + +(defun primary-class-accessor (instance info &optional (value-form nil value-form-p)) + (let ((accessor (%slot-accessor-info.accessor info))) + (prog1 + (if value-form-p + (funcall accessor value-form instance) + (funcall accessor instance)) + (let ((methods (compute-applicable-methods + accessor + (if value-form-p (list value-form instance) (list instance)))) + method) + (when (and (eql (length methods) 1) + (typep (setq method (car methods)) 'standard-accessor-method)) + (let* ((slot-name (method-slot-name method))) + (setf (%slot-accessor-info.offset info) + (primary-class-slot-offset (class-of instance) slot-name)))))))) + +(defun exchange-slot-vectors-and-wrappers (a b) + (if (typep a 'funcallable-standard-object) + (let* ((temp-wrapper (gf.instance.class-wrapper a)) + (orig-a-slots (gf.slots a)) + (orig-b-slots (gf.slots b))) + (setf (gf.instance.class-wrapper a) (gf.instance.class-wrapper b) + (gf.instance.class-wrapper b) temp-wrapper + (gf.slots a) orig-b-slots + (gf.slots b) orig-a-slots + (slot-vector.instance orig-a-slots) b + (slot-vector.instance orig-b-slots) a)) + (let* ((temp-wrapper (instance.class-wrapper a)) + (orig-a-slots (instance.slots a)) + (orig-b-slots (instance.slots b))) + (setf (instance.class-wrapper a) (instance.class-wrapper b) + (instance.class-wrapper b) temp-wrapper + (instance.slots a) orig-b-slots + (instance.slots b) orig-a-slots + (slot-vector.instance orig-a-slots) b + (slot-vector.instance orig-b-slots) a)))) + + + + +;;; How slot values transfer (from PCL): +;;; +;;; local --> local transfer +;;; local --> shared discard +;;; local --> -- discard +;;; shared --> local transfer +;;; shared --> shared discard +;;; shared --> -- discard +;;; -- --> local added +;;; -- --> shared -- +;;; +;;; See make-wrapper-obsolete to see how we got here. +;;; A word about forwarding. When a class is made obsolete, the +;;; %wrapper-instance-slots slot of its wrapper is set to 0. +;;; %wrapper-class-slots = (instance-slots . class-slots) +;;; Note: this should stack-cons the new-instance if we can reuse the +;;; old instance or it's forwarded value. +(defun update-obsolete-instance (instance) + (let* ((added ()) + (discarded ()) + (plist ())) + (without-interrupts ; Not -close- to being correct + (let* ((old-wrapper (standard-object-p instance))) + (unless old-wrapper + (when (typep instance 'funcallable-standard-object) + (setq old-wrapper (gf.instance.class-wrapper instance))) + (unless old-wrapper + (report-bad-arg instance '(or standard-instance funcallable-standard-object)))) + (when (eql 0 (%wrapper-instance-slots old-wrapper)) ; is it really obsolete? + (let* ((class (%wrapper-class old-wrapper)) + (new-wrapper (or (%class.own-wrapper class) + (progn + (update-class class t) + (%class.own-wrapper class)))) + (forwarding-info (%wrapper-forwarding-info old-wrapper)) + (old-class-slots (%forwarding-class-slots forwarding-info)) + (old-instance-slots (%forwarding-instance-slots forwarding-info)) + (new-instance-slots (%wrapper-instance-slots new-wrapper)) + (new-class-slots (%wrapper-class-slots new-wrapper)) + (new-instance (allocate-instance class)) + (old-slot-vector (instance-slots instance)) + (new-slot-vector (instance-slots new-instance))) + ;; Lots to do. Hold onto your hat. + (let* ((old-size (uvsize old-instance-slots)) + (new-size (uvsize new-instance-slots))) + (declare (fixnum old-size new-size)) + (dotimes (i old-size) + (declare (fixnum i)) + (let* ((slot-name (%svref old-instance-slots i)) + (pos (%vector-member slot-name new-instance-slots)) + (val (%svref old-slot-vector (%i+ i 1)))) + (if pos + (setf (%svref new-slot-vector (%i+ pos 1)) val) + (progn + (push slot-name discarded) + (unless (eq val (%slot-unbound-marker)) + (setf (getf plist slot-name) val)))))) + ;; Go through old class slots + (dolist (pair old-class-slots) + (let* ((slot-name (%car pair)) + (val (%cdr pair)) + (pos (%vector-member slot-name new-instance-slots))) + (if pos + (setf (%svref new-slot-vector (%i+ pos 1)) val) + (progn + (push slot-name discarded) + (unless (eq val (%slot-unbound-marker)) + (setf (getf plist slot-name) val)))))) + ; Go through new instance slots + (dotimes (i new-size) + (declare (fixnum i)) + (let* ((slot-name (%svref new-instance-slots i))) + (unless (or (%vector-member slot-name old-instance-slots) + (assoc slot-name old-class-slots)) + (push slot-name added)))) + ;; Go through new class slots + (dolist (pair new-class-slots) + (let ((slot-name (%car pair))) + (unless (or (%vector-member slot-name old-instance-slots) + (assoc slot-name old-class-slots)) + (push slot-name added)))) + (exchange-slot-vectors-and-wrappers new-instance instance)))))) + ;; run user code with interrupts enabled. + (update-instance-for-redefined-class instance added discarded plist)) + instance) + + +(defmethod update-instance-for-redefined-class ((instance standard-object) + added-slots + discarded-slots + property-list + &rest initargs) + (declare (ignore discarded-slots property-list)) + (when initargs + (check-initargs + instance nil initargs t + #'update-instance-for-redefined-class #'shared-initialize)) + (apply #'shared-initialize instance added-slots initargs)) + +(defmethod update-instance-for-redefined-class ((instance standard-generic-function) + added-slots + discarded-slots + property-list + &rest initargs) + (declare (ignore discarded-slots property-list)) + (when initargs + (check-initargs + instance nil initargs t + #'update-instance-for-redefined-class #'shared-initialize)) + (apply #'shared-initialize instance added-slots initargs)) + +(defun check-initargs (instance class initargs errorp &rest functions) + (declare (dynamic-extent functions)) + (declare (list functions)) + (setq class (require-type (or class (class-of instance)) 'std-class)) + (unless (getf initargs :allow-other-keys) + (let ((initvect (initargs-vector instance class functions))) + (when (eq initvect t) (return-from check-initargs nil)) + (do* ((tail initargs (cddr tail)) + (initarg (car tail) (car tail)) + bad-keys? bad-key) + ((null (cdr tail)) + (if bad-keys? + (if errorp + (signal-program-error + "~s is an invalid initarg to ~s for ~s.~%~ + Valid initargs: ~s." + bad-key + (function-name (car functions)) + class (coerce initvect 'list)) + (values bad-keys? bad-key)))) + (if (eq initarg :allow-other-keys) + (if (cadr tail) + (return)) ; (... :allow-other-keys t ...) + (unless (or bad-keys? (%vector-member initarg initvect)) + (setq bad-keys? t + bad-key initarg))))))) + +(defun initargs-vector (instance class functions) + (let ((index (cadr (assq (car functions) *initialization-invalidation-alist*)))) + (unless index + (error "Unknown initialization function: ~s." (car functions))) + (let ((initvect (%svref (instance-slots class) index))) + (unless initvect + (setf (%svref (instance-slots class) index) + (setq initvect (compute-initargs-vector instance class functions)))) + initvect))) + + +;; This is used for compile-time defclass option checking. +(defun class-keyvect (class-arg initargs) + (let* ((class (if (typep class-arg 'class) class-arg (find-class class-arg nil))) + (meta-arg (getf initargs :metaclass (if (and class (not (typep class 'forward-referenced-class))) + (class-of class) + *standard-class-class*))) + (meta-spec (if (quoted-form-p meta-arg) (%cadr meta-arg) meta-arg)) + (meta (if (typep meta-spec 'class) meta-spec (find-class meta-spec nil)))) + (if (and meta (not (typep meta 'forward-referenced-class))) + (compute-initargs-vector class meta (list #'initialize-instance #'allocate-instance #'shared-initialize) t) + t))) + +(defun compute-initargs-vector (instance class functions &optional require-rest) + (let ((initargs (class-slot-initargs class)) + (cpl (%inited-class-cpl class))) + (dolist (f functions) ; for all the functions passed + #+no + (if (logbitp $lfbits-aok-bit (lfun-bits f)) + (return-from compute-initargs-vector t)) + (dolist (method (%gf-methods f)) ; for each applicable method + (let ((spec (car (%method-specializers method)))) + (when (if (typep spec 'eql-specializer) + (eql instance (eql-specializer-object spec)) + (memq spec cpl)) + (let* ((func (%inner-method-function method)) + (keyvect (if (and (logbitp $lfbits-aok-bit (lfun-bits func)) + (or (not require-rest) + (logbitp $lfbits-rest-bit (lfun-bits func)))) + (return-from compute-initargs-vector t) + (lfun-keyvect func)))) + (dovector (key keyvect) + (pushnew key initargs))))))) ; add all of the method's keys + (apply #'vector initargs))) + + + +;;; A useful function +(defun class-make-instance-initargs (class) + (setq class (require-type (if (symbolp class) (find-class class) class) + 'std-class)) + (flet ((iv (class &rest functions) + (declare (dynamic-extent functions)) + (initargs-vector (class-prototype class) class functions))) + (let ((initvect (apply #'iv + class + #'initialize-instance #'allocate-instance #'shared-initialize + nil))) + (if (eq initvect 't) + t + (concatenate 'list initvect))))) + + + +;;; This is part of the MOP +;;; Maybe it was, at one point in the distant past ... +(defmethod class-slot-initargs ((class slots-class)) + (collect ((initargs)) + (dolist (slot (%class-slots class) (initargs)) + (dolist (i (%slot-definition-initargs slot)) + (initargs i))))) + + +(defun maybe-update-obsolete-instance (instance) + (let ((wrapper (standard-object-p instance))) + (unless wrapper + (when (typep instance 'funcallable-standard-object) + (setq wrapper (gf.instance.class-wrapper instance))) + + (unless wrapper + (report-bad-arg instance '(or standard-object funcallable-standard-object)))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance instance))) + instance) + + +;;; If you ever reference one of these through anyone who might call +;;; update-obsolete-instance, you will lose badly. +(defun %maybe-forwarded-instance (instance) + (maybe-update-obsolete-instance instance) + instance) + + + +(defmethod change-class (instance + (new-class symbol) + &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (apply #'change-class instance (find-class new-class) initargs)) + +(defmethod change-class ((instance standard-object) + (new-class standard-class) + &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (%change-class instance new-class initargs)) + + +(defun %change-class (object new-class initargs) + (let* ((old-class (class-of object)) + (old-wrapper (%class.own-wrapper old-class)) + (new-wrapper (or (%class.own-wrapper new-class) + (progn + (update-class new-class t) + (%class.own-wrapper new-class)))) + (old-instance-slots-vector (%wrapper-instance-slots old-wrapper)) + (new-instance-slots-vector (%wrapper-instance-slots new-wrapper)) + (num-new-instance-slots (length new-instance-slots-vector)) + (new-object (allocate-instance new-class))) + (declare (fixnum num-new-instance-slots) + (simple-vector new-instance-slots-vector old-instance-slots-vector)) + ;; Retain local slots shared between the new class and the old. + (do* ((new-pos 0 (1+ new-pos)) + (new-slot-location 1 (1+ new-slot-location))) + ((= new-pos num-new-instance-slots)) + (declare (fixnum new-pos new-slot-location)) + (let* ((old-pos (position (svref new-instance-slots-vector new-pos) + old-instance-slots-vector :test #'eq))) + (when old-pos + (setf (%standard-instance-instance-location-access + new-object + new-slot-location) + (%standard-instance-instance-location-access + object + (the fixnum (1+ (the fixnum old-pos)))))))) + ;; If the new class defines a local slot whos name matches + ;; that of a shared slot in the old class, the shared slot's + ;; value is used to initialize the new instance's local slot. + (dolist (shared-slot (%wrapper-class-slots old-wrapper)) + (destructuring-bind (name . value) shared-slot + (let* ((new-slot-pos (position name new-instance-slots-vector + :test #'eq))) + (if new-slot-pos + (setf (%standard-instance-instance-location-access + new-object + (the fixnum (1+ (the fixnum new-slot-pos)))) + value))))) + (exchange-slot-vectors-and-wrappers object new-object) + (apply #'update-instance-for-different-class new-object object initargs) + object)) + +(defmethod update-instance-for-different-class ((previous standard-object) + (current standard-object) + &rest initargs) + (declare (dynamic-extent initargs)) + (%update-instance-for-different-class previous current initargs)) + +(defun %update-instance-for-different-class (previous current initargs) + (when initargs + (check-initargs + current nil initargs t + #'update-instance-for-different-class #'shared-initialize)) + (let* ((previous-slots (class-slots (class-of previous))) + (current-slots (class-slots (class-of current))) + (added-slot-names ())) + (dolist (s current-slots) + (let* ((name (%slot-definition-name s))) + (unless (find-slotd name previous-slots) + (push name added-slot-names)))) + (apply #'shared-initialize + current + added-slot-names + initargs))) + + + + +;;; Clear all the valid initargs caches. +(defun clear-valid-initargs-caches () + (map-classes #'(lambda (name class) + (declare (ignore name)) + (when (std-class-p class) + (setf (%class.make-instance-initargs class) nil + (%class.reinit-initargs class) nil + (%class.redefined-initargs class) nil + (%class.changed-initargs class) nil))))) + +(defun clear-clos-caches () + (clear-all-gf-caches) + (clear-valid-initargs-caches)) + +(defmethod allocate-instance ((class standard-class) &rest initargs) + (declare (ignore initargs)) + (%allocate-std-instance class)) + +(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) + (declare (ignore initargs)) + (%allocate-gf-instance class)) + +(unless *initialization-invalidation-alist* + (setq *initialization-invalidation-alist* + (list (list #'initialize-instance %class.make-instance-initargs) + (list #'allocate-instance %class.make-instance-initargs) + (list #'reinitialize-instance %class.reinit-initargs) + (list #'shared-initialize + %class.make-instance-initargs %class.reinit-initargs + %class.redefined-initargs %class.changed-initargs) + (list #'update-instance-for-redefined-class + %class.redefined-initargs) + (list #'update-instance-for-different-class + %class.changed-initargs)))) + + +(defstatic *initialization-function-lists* + (list (list #'initialize-instance #'allocate-instance #'shared-initialize) + (list #'reinitialize-instance #'shared-initialize) + (list #'update-instance-for-redefined-class #'shared-initialize) + (list #'update-instance-for-different-class #'shared-initialize))) + + + +(unless *clos-initialization-functions* + (setq *clos-initialization-functions* + (list #'initialize-instance #'allocate-instance #'shared-initialize + #'reinitialize-instance + #'update-instance-for-different-class #'update-instance-for-redefined-class))) + +(defun compute-initialization-functions-alist () + (let ((res nil) + (lists *initialization-function-lists*)) + (dolist (cell *initialization-invalidation-alist*) + (let (res-list) + (dolist (slot-num (cdr cell)) + (push + (ecase slot-num + (#.%class.make-instance-initargs + (assq #'initialize-instance lists)) + (#.%class.reinit-initargs + (assq #'reinitialize-instance lists)) + (#.%class.redefined-initargs + (assq #'update-instance-for-redefined-class lists)) + (#.%class.changed-initargs + (assq #'update-instance-for-different-class lists))) + res-list)) + (push (cons (car cell) (nreverse res-list)) res))) + (setq *initialization-functions-alist* res))) + +(compute-initialization-functions-alist) + + + + + + +;;; Need to define this for all of the BUILT-IN-CLASSes. +(defmethod class-prototype ((class class)) + (%class.prototype class)) + +(defmethod class-prototype ((class std-class)) + (or (%class.prototype class) + (setf (%class.prototype class) (allocate-instance class)))) + + +(defun gf-class-prototype (class) + (%allocate-gf-instance class)) + + + +(defmethod class-prototype ((class structure-class)) + (or (%class.prototype class) + (setf (%class.prototype class) + (let* ((sd (gethash (class-name class) %defstructs%)) + (slots (class-slots class)) + (proto (allocate-typed-vector :struct (1+ (length slots))))) + (setf (uvref proto 0) (sd-superclasses sd)) + (dolist (slot slots proto) + (setf (slot-value-using-class class proto slot) + (funcall (slot-definition-initfunction slot)))))))) + + +(defmethod remove-method ((generic-function standard-generic-function) + (method standard-method)) + (when (eq generic-function (%method-gf method)) + (%remove-standard-method-from-containing-gf method)) + generic-function) + + + +(defmethod function-keywords ((method standard-method)) + (let ((f (%inner-method-function method))) + (values + (concatenate 'list (lfun-keyvect f)) + (%ilogbitp $lfbits-aok-bit (lfun-bits f))))) + +(defmethod no-next-method ((generic-function standard-generic-function) + (method standard-method) + &rest args) + (error "There is no next method for ~s~%args: ~s" method args)) + +(defmethod add-method ((generic-function standard-generic-function) (method standard-method)) + (%add-standard-method-to-standard-gf generic-function method)) + +(defmethod no-applicable-method (gf &rest args) + (cerror "Try calling it again" + "There is no applicable method for the generic function:~% ~s~%when called with arguments:~% ~s" gf args) + (apply gf args)) + + +(defmethod no-applicable-primary-method (gf methods) + (%method-combination-error "No applicable primary methods for ~s~@ + Applicable methods: ~s" gf methods)) + +(defmethod compute-applicable-methods ((gf standard-generic-function) args) + (%compute-applicable-methods* gf args)) + +(defmethod compute-applicable-methods-using-classes ((gf standard-generic-function) args) + (let ((res (%compute-applicable-methods* gf args t))) + (if (eq res :undecidable) + (values nil nil) + (values res t)))) + +(defun %compute-applicable-methods+ (gf &rest args) + (declare (dynamic-extent args)) + (%compute-applicable-methods* gf args)) + +(defun %compute-applicable-methods* (gf args &optional using-classes-p) + (let* ((methods (%gf-methods gf)) + (args-length (length args)) + (bits (inner-lfun-bits gf)) + arg-count res) + (when methods + (setq arg-count (length (%method-specializers (car methods)))) + (unless (<= arg-count args-length) + (error "Too few args to ~s" gf)) + (unless (or (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (<= args-length + (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)))) + (error "Too many args to ~s" gf)) + (let ((cpls (make-list arg-count))) + (declare (dynamic-extent cpls)) + (do* ((args-tail args (cdr args-tail)) + (cpls-tail cpls (cdr cpls-tail))) + ((null cpls-tail)) + (setf (car cpls-tail) + (%class-precedence-list (if using-classes-p + ;; extension for use in source location support + (if (typep (car args-tail) 'eql-specializer) + (class-of (eql-specializer-object (car args-tail))) + (car args-tail)) + (class-of (car args-tail)))))) + (dolist (m methods) + (let ((appp (%method-applicable-p m args cpls using-classes-p))) + (when appp + (when (eq appp :undecidable) ;; can only happen if using-classes-p + (return-from %compute-applicable-methods* appp)) + (push m res)))) + (sort-methods res cpls (%gf-precedence-list gf)))))) + + +(defun %method-applicable-p (method args cpls &optional using-classes-p) + (do* ((specs (%method-specializers method) (%cdr specs)) + (args args (%cdr args)) + (cpls cpls (%cdr cpls))) + ((null specs) t) + (let ((spec (%car specs)) + (arg (%car args))) + (if (typep spec 'eql-specializer) + (if using-classes-p + (if (typep arg 'eql-specializer) ;; extension for use in source location support + (unless (eql (eql-specializer-object arg) (eql-specializer-object spec)) + (return nil)) + (if (typep (eql-specializer-object spec) arg) + ;; Can't tell if going to be applicable or not based on class alone + ;; Except for the special case of NULL which is a singleton + (unless (eq arg *null-class*) + (return :undecidable)) + (return nil))) + (unless (eql arg (eql-specializer-object spec)) + (return nil))) + (unless (memq spec (%car cpls)) + (return nil)))))) + + +;;; Need this so that (compute-applicable-methods +;;; #'class-precedence-list ...) will not recurse. +(defun %class-precedence-list (class) + (if (eq (class-of class) *standard-class-class*) + (%inited-class-cpl class) + (class-precedence-list class))) + +(defmethod class-precedence-list ((class class)) + (%inited-class-cpl class)) + + +(defun make-all-methods-kernel () + (dolist (f (population.data %all-gfs%)) + (let ((smc *standard-method-class*)) + (dolist (method (slot-value-if-bound f 'methods)) + (when (eq (class-of method) smc) + (change-class method *standard-kernel-method-class*)))))) + + +(defun make-all-methods-non-kernel () + (dolist (f (population.data %all-gfs%)) + (let ((skmc *standard-kernel-method-class*)) + (dolist (method (slot-value-if-bound f 'methods)) + (when (eq (class-of method) skmc) + (change-class method *standard-method-class*)))))) + + +(defun required-lambda-list-args (l) + (multiple-value-bind (ok req) (verify-lambda-list l) + (unless ok (error "Malformed lambda-list: ~s" l)) + req)) + + +(defun check-generic-function-lambda-list (ll &optional (errorp t)) + (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail) + (verify-lambda-list ll) + (declare (ignore reqsyms resttail)) + (when ok + (block checkit + (when (eq (car opttail) '&optional) + (dolist (elt (cdr opttail)) + (when (memq elt lambda-list-keywords) (return)) + (unless (or (symbolp elt) + (and (listp elt) + (non-nil-symbol-p (car elt)) + (null (cdr elt)))) + (return-from checkit (setq ok nil))))) + (dolist (elt (cdr keytail)) + (when (memq elt lambda-list-keywords) (return)) + (unless (or (symbolp elt) + (and (listp elt) + (or (non-nil-symbol-p (car elt)) + (and (listp (car elt)) + (non-nil-symbol-p (caar elt)) + (non-nil-symbol-p (cadar elt)) + (null (cddar elt)))) + (null (cdr elt)))) + (return-from checkit (setq ok nil)))) + (when auxtail (setq ok nil)))) + (when (and errorp (not ok)) + (signal-program-error "Bad generic function lambda list: ~s" ll)) + ok)) + + +(defun canonicalize-argument-precedence-order (apo req) + (cond ((equal apo req) nil) + ((not (eql (length apo) (length req))) + (signal-program-error "Lengths of ~S and ~S differ." apo req)) + (t (let ((res nil)) + (dolist (arg apo (nreverse res)) + (let ((index (position arg req))) + (if (or (null index) (memq index res)) + (error "Missing or duplicate arguments in ~s" apo)) + (push index res))))))) + + +(defun %defgeneric (function-name lambda-list method-combination generic-function-class + options) + (setq generic-function-class (find-class generic-function-class)) + (setq method-combination + (find-method-combination + (class-prototype generic-function-class) + (car method-combination) + (cdr method-combination))) + (let ((gf (fboundp function-name))) + (when gf + (dolist (method (%defgeneric-methods gf)) + (remove-method gf method)))) + (record-source-file function-name 'function) + (record-arglist function-name lambda-list) + (apply #'ensure-generic-function + function-name + :lambda-list lambda-list + :method-combination method-combination + :generic-function-class generic-function-class + options)) + + + + +;;; Redefined in lib;method-combination.lisp +(defmethod find-method-combination ((gf standard-generic-function) type options) + (unless (and (eq type 'standard) (null options)) + (error "non-standard method-combination not supported yet.")) + *standard-method-combination*) + + + +(defmethod add-direct-method ((spec specializer) (method method)) + (pushnew method (specializer.direct-methods spec))) + +(setf (fdefinition '%do-add-direct-method) #'add-direct-method) + +(defmethod remove-direct-method ((spec specializer) (method method)) + (setf (specializer.direct-methods spec) + (nremove method (specializer.direct-methods spec)))) + +(setf (fdefinition '%do-remove-direct-method) #'remove-direct-method) + + + + + + + + + +(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq)) + +(defun make-load-form-saving-slots (object &key + (slot-names nil slot-names-p) + environment) + (declare (ignore environment)) + (let* ((class (class-of object)) + (class-name (class-name class)) + (structurep (structurep object)) + (sd (and structurep (require-type (gethash class-name %defstructs%) 'vector)))) + (unless (or structurep + (standard-instance-p object)) + (%badarg object '(or standard-object structure-object))) + (if slot-names-p + (dolist (slot slot-names) + (unless (slot-exists-p object slot) + (error "~s has no slot named ~s" object slot))) + (setq slot-names + (if structurep + (let ((res nil)) + (dolist (slot (sd-slots sd)) + (unless (fixnump (car slot)) + (push (%car slot) res))) + (nreverse res)) + (mapcar '%slot-definition-name + (extract-instance-effective-slotds + (class-of object)))))) + (values + (let* ((form (gethash class-name *make-load-form-saving-slots-hash*))) + (or (and (consp form) + (eq (car form) 'allocate-instance) + form) + (setf (gethash class-name *make-load-form-saving-slots-hash*) + `(allocate-instance (find-class ',class-name))))) + ;; initform is NIL when there are no slots + (when slot-names + `(%set-slot-values + ',object + ',slot-names + ',(let ((temp #'(lambda (slot) + (if (slot-boundp object slot) + (slot-value object slot) + (%slot-unbound-marker))))) + (declare (dynamic-extent temp)) + (mapcar temp slot-names))))))) + + + + +(defmethod allocate-instance ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (let* ((class-name (%class-name class)) + (sd (or (gethash class-name %defstructs%) + (error "Can't find structure named ~s" class-name))) + (res (make-structure-vector (sd-size sd)))) + (setf (%svref res 0) (mapcar (lambda (x) + (find-class-cell x t)) (sd-superclasses sd))) + res)) + + +(defun %set-slot-values (object slots values) + (dolist (slot slots) + (let ((value (pop values))) + (if (eq value (%slot-unbound-marker)) + (slot-makunbound object slot) + (setf (slot-value object slot) value))))) + + +(defun %recache-class-direct-methods () + (let ((*maintain-class-direct-methods* t)) ; in case we get an error + (dolist (f (population-data %all-gfs%)) + (when (standard-generic-function-p f) + (dolist (method (%gf-methods f)) + (%add-direct-methods method))))) + (setq *maintain-class-direct-methods* t)) ; no error, all is well + Index: /branches/qres/ccl/level-1/l1-clos.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-clos.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-clos.lisp (revision 13564) @@ -0,0 +1,2512 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Copyright (C) 2002-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;;; + +;;; At this point in the load sequence, the handful of extant basic classes +;;; exist only in skeletal form (without direct or effective slot-definitions.) + +(in-package "CCL") + +(defun extract-slotds-with-allocation (allocation slotds) + (collect ((right-ones)) + (dolist (s slotds (right-ones)) + (if (eq (%slot-definition-allocation s) allocation) + (right-ones s))))) + +(defun extract-instance-direct-slotds (class) + (extract-slotds-with-allocation :instance (%class-direct-slots class))) + +(defun extract-class-direct-slotds (class) + (extract-slotds-with-allocation :class (%class-direct-slots class))) + +(defun extract-instance-effective-slotds (class) + (extract-slotds-with-allocation :instance (%class-slots class))) + +(defun extract-class-effective-slotds (class) + (extract-slotds-with-allocation :class (%class-slots class))) + +(defun extract-instance-class-and-other-slotds (slotds) + (collect ((instance-slots) + (shared-slots) + (other-slots)) + (dolist (s slotds (values (instance-slots) (shared-slots) (other-slots))) + (case (%slot-definition-allocation s) + (:instance (instance-slots s)) + (:class (shared-slots s)) + (t (other-slots s)))))) + + +(defun %early-shared-initialize (instance slot-names initargs) + (unless (or (listp slot-names) (eq slot-names t)) + (report-bad-arg slot-names '(or list (eql t)))) + ;; Check that initargs contains valid key/value pairs, + ;; signal a PROGRAM-ERROR otherwise. (Yes, this is + ;; an obscure way to do so.) + (destructuring-bind (&key &allow-other-keys) initargs) + (let* ((wrapper (instance-class-wrapper instance)) + (class (%wrapper-class wrapper))) + (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete + (update-obsolete-instance instance) + (setq wrapper (instance-class-wrapper instance))) + (dolist (slotd (%class-slots class)) + (let* ((loc (%slot-definition-location slotd))) + (multiple-value-bind (ignore new-value foundp) + (get-properties initargs + (%slot-definition-initargs slotd)) + (declare (ignore ignore)) + (if foundp + (progn + (unless (funcall (standard-effective-slot-definition.type-predicate slotd) new-value) + (error 'bad-slot-type-from-initarg + :slot-definition slotd + :instance instance + :datum new-value + :expected-type (%slot-definition-type slotd) + :initarg-name (car foundp))) + (if (consp loc) + (rplacd loc new-value) + (setf (standard-instance-instance-location-access instance loc) + new-value))) + (if (or (eq slot-names t) + (member (%slot-definition-name slotd) + slot-names + :test #'eq)) + (let* ((curval (if (consp loc) + (cdr loc) + (%standard-instance-instance-location-access + instance loc)))) + (if (eq curval (%slot-unbound-marker)) + (let* ((initfunction (%slot-definition-initfunction slotd))) + (if initfunction + (let* ((newval (funcall initfunction))) + (unless (funcall (standard-effective-slot-definition.type-predicate slotd) newval) + (error 'bad-slot-type-from-initform + :slot-definition slotd + :expected-type (%slot-definition-type slotd) + :datum newval + :instance instance)) + (if (consp loc) + (rplacd loc newval) + (setf (standard-instance-instance-location-access + instance loc) + newval))))))))))))) + instance) + +(setf (fdefinition '%shared-initialize) #'%early-shared-initialize) + +;;; This is redefined (to call MAKE-INSTANCE) below. +(setf (fdefinition '%make-direct-slotd) + #'(lambda (slotd-class &key + name + initfunction + initform + initargs + (allocation :instance) + class + (type t) + (documentation (%slot-unbound-marker)) + readers + writers) + (declare (ignore slotd-class)) + (%instance-vector + (%class.own-wrapper *standard-direct-slot-definition-class*) + name type initfunction initform initargs allocation + documentation class readers writers))) + +;;; Also redefined below, after MAKE-INSTANCE is possible. +(setf (fdefinition '%make-effective-slotd) + #'(lambda (slotd-class &key + name + initfunction + initform + initargs + allocation + class + type + documentation) + (declare (ignore slotd-class)) + (%instance-vector + (%class.own-wrapper *standard-effective-slot-definition-class*) + name type initfunction initform initargs allocation + documentation class nil (ensure-slot-id name) #'true))) + + +(defmethod compile-time-class-p ((class class)) nil) + +(defmethod direct-slot-definition-class ((class std-class) &key &allow-other-keys) + *standard-direct-slot-definition-class*) + +(defmethod effective-slot-definition-class ((class std-class) &key &allow-other-keys) + *standard-effective-slot-definition-class*) + +(defun make-direct-slot-definition (class initargs) + (apply #'%make-direct-slotd + (apply #'direct-slot-definition-class class initargs) + :class class + initargs)) + +(defun make-effective-slot-definition (class &rest initargs) + (declare (dynamic-extent initargs)) + (apply #'%make-effective-slotd + (apply #'effective-slot-definition-class class initargs) + initargs)) + +;; Bootstrapping version, replaced in l1-typesys +(fset 'standardized-type-specifier + (nlambda bootstrapping-standardized-type-specifier (spec) + (when (and (consp spec) + (memq (%car spec) '(and or)) + (consp (%cdr spec)) + (null (%cddr spec))) + (setq spec (%cadr spec))) + (if (consp spec) + (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec))) + (or (cdr (assoc spec '((string . base-string)))) + spec)))) + +;;; The type of an effective slot definition is the intersection of +;;; the types of the direct slot definitions it's initialized from. +(defun dslotd-type-intersection (direct-slots) + (or (dolist (dslotd direct-slots t) + (unless (eq t (%slot-definition-type dslotd)) + (return))) + (standardized-type-specifier + (if (cdr direct-slots) + `(and ,@(mapcar #'(lambda (d) (or (%slot-definition-type d) t)) + direct-slots)) + (%slot-definition-type (car direct-slots)))))) + +(defmethod compute-effective-slot-definition ((class slots-class) + name + direct-slots) + + (let* ((initer (dolist (s direct-slots) + (when (%slot-definition-initfunction s) + (return s)))) + (documentor (dolist (s direct-slots) + (when (%slot-definition-documentation s) + (return s)))) + (first (car direct-slots)) + (initargs (let* ((initargs nil)) + (dolist (dslot direct-slots initargs) + (dolist (dslot-arg (%slot-definition-initargs dslot)) + (pushnew dslot-arg initargs :test #'eq)))))) + (make-effective-slot-definition + class + :name name + :allocation (%slot-definition-allocation first) + :documentation (when documentor (nth-value + 1 + (%slot-definition-documentation + documentor))) + :class (%slot-definition-class first) + :initargs initargs + :initfunction (if initer (%slot-definition-initfunction initer)) + :initform (if initer (%slot-definition-initform initer)) + :type (dslotd-type-intersection direct-slots)))) + +(defmethod compute-slots ((class slots-class)) + (let* ((slot-name-alist ())) + (labels ((note-direct-slot (dslot) + (let* ((sname (%slot-definition-name dslot)) + (pair (assq sname slot-name-alist))) + (if pair + (push dslot (cdr pair)) + (push (list sname dslot) slot-name-alist)))) + (rwalk (tail) + (when tail + (rwalk (cdr tail)) + (let* ((c (car tail))) + (unless (eq c *t-class*) + (dolist (dslot (%class-direct-slots c)) + (note-direct-slot dslot))))))) + (rwalk (class-precedence-list class))) + (collect ((effective-slotds)) + (dolist (pair (nreverse slot-name-alist) (effective-slotds)) + (effective-slotds (compute-effective-slot-definition class (car pair) (cdr pair))))))) + + +(defmethod compute-slots :around ((class std-class)) + (let* ((cpl (%class.cpl class))) + (multiple-value-bind (instance-slots class-slots other-slots) + (extract-instance-class-and-other-slotds (call-next-method)) + (setq instance-slots (sort-effective-instance-slotds instance-slots class cpl)) + (do* ((loc 1 (1+ loc)) + (islotds instance-slots (cdr islotds))) + ((null islotds)) + (declare (fixnum loc)) + (setf (%slot-definition-location (car islotds)) loc)) + (dolist (eslotd class-slots) + (setf (%slot-definition-location eslotd) + (assoc (%slot-definition-name eslotd) + (%class-get (%slot-definition-class eslotd) + :class-slots) + :test #'eq))) + (append instance-slots class-slots other-slots)))) + +(defmethod compute-slots :around ((class structure-class)) + (let* ((slots (call-next-method)) ) + (do* ((loc 1 (1+ loc)) + (islotds slots (cdr islotds))) + ((null islotds) slots) + (declare (fixnum loc)) + (setf (%slot-definition-location (car islotds)) loc)))) + +;;; Should eventually do something here. +;(defmethod compute-slots ((s structure-class)) +; (call-next-method)) + +(defmethod direct-slot-definition-class ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (find-class 'structure-direct-slot-definition)) + +(defmethod effective-slot-definition-class ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (find-class 'structure-effective-slot-definition)) + + +(defmethod compute-default-initargs ((class slots-class)) + (let* ((initargs ())) + (dolist (c (%class-precedence-list class) (nreverse initargs)) + (if (typep c 'forward-referenced-class) + (error + "Class precedence list of ~s contains FORWARD-REFERENCED-CLASS ~s ." + class c) + (dolist (i (%class-direct-default-initargs c)) + (pushnew i initargs :test #'eq :key #'car)))))) + + + + +(defvar *update-slots-preserve-existing-wrapper* nil) + +(defvar *optimized-dependents* (make-hash-table :test 'eq :weak :key) + "Hash table mapping a class to a list of all objects that have been optimized to + depend in some way on the layout of the class") + +(defun note-class-dependent (class gf) + (pushnew gf (gethash class *optimized-dependents*))) + +(defun unoptimize-dependents (class) + (pessimize-make-instance-for-class-name (%class-name class)) + (loop for obj in (gethash class *optimized-dependents*) + do (etypecase obj + (standard-generic-function + (clear-gf-dispatch-table (%gf-dispatch-table obj)) + (compute-dcode obj))))) + +(defun update-slots (class eslotds) + (let* ((instance-slots (extract-slotds-with-allocation :instance eslotds)) + (new-ordering + (let* ((v (make-array (the fixnum (length instance-slots)))) + (i 0)) + (declare (simple-vector v) (fixnum i)) + (dolist (e instance-slots v) + (setf (svref v i) + (%slot-definition-name e)) + (incf i)))) + (old-wrapper (%class-own-wrapper class)) + (new-wrapper + (cond ((null old-wrapper) + (%cons-wrapper class)) + ((and old-wrapper *update-slots-preserve-existing-wrapper*) + old-wrapper) + (t + (unoptimize-dependents class) + (make-instances-obsolete class) + (%cons-wrapper class))))) + (setf (%class-slots class) eslotds) + (setf (%wrapper-instance-slots new-wrapper) new-ordering + (%wrapper-class-slots new-wrapper) (%class-get class :class-slots) + (%class-own-wrapper class) new-wrapper) + (setup-slot-lookup new-wrapper eslotds))) + + + +(defun setup-slot-lookup (wrapper eslotds) + (when eslotds + (let* ((nslots (length eslotds)) + (total-slot-ids (current-slot-index)) + (small (< nslots 255)) + (map + (if small + (make-array total-slot-ids :element-type '(unsigned-byte 8)) + (make-array total-slot-ids :element-type '(unsigned-byte 32)))) + (table (make-array (the fixnum (1+ nslots)))) + (i 0)) + (declare (fixnum nslots total-slot-ids i) (simple-vector table)) + (setf (svref table 0) nil) + (dolist (slotd eslotds) + (incf i) + (setf (svref table i) slotd) + (if small + (locally (declare (type (simple-array (unsigned-byte 8) (*)) map)) + (setf (aref map + (slot-id.index + (standard-effective-slot-definition.slot-id slotd))) + i)) + (locally (declare (type (simple-array (unsigned-byte 32) (*)) map)) + (setf (aref map + (slot-id.index + (standard-effective-slot-definition.slot-id slotd))) + i)))) + (let* ((lookup-f + #+ppc-target + (gvector :function + (%svref (if small + #'%small-map-slot-id-lookup + #'%large-map-slot-id-lookup) 0) + map + table + (dpb 1 $lfbits-numreq + (ash -1 $lfbits-noname-bit))) + #+x86-target + (%clone-x86-function (if small + #'%small-map-slot-id-lookup + #'%large-map-slot-id-lookup) + map + table + (dpb 1 $lfbits-numreq + (ash -1 $lfbits-noname-bit)))) + (class (%wrapper-class wrapper)) + (get-f + #+ppc-target + (gvector :function + (%svref (if small + #'%small-slot-id-value + #'%large-slot-id-value) 0) + map + table + class + #'%maybe-std-slot-value-using-class + #'%slot-id-ref-missing + (dpb 2 $lfbits-numreq + (ash -1 $lfbits-noname-bit))) + #+x86-target + (%clone-x86-function (if small + #'%small-slot-id-value + #'%large-slot-id-value) + map + table + class + #'%maybe-std-slot-value-using-class + #'%slot-id-ref-missing + (dpb 2 $lfbits-numreq + (ash -1 $lfbits-noname-bit)))) + (set-f + #+ppc-target + (gvector :function + (%svref (if small + #'%small-set-slot-id-value + #'%large-set-slot-id-value) 0) + map + table + class + #'%maybe-std-setf-slot-value-using-class + #'%slot-id-set-missing + (dpb 3 $lfbits-numreq + (ash -1 $lfbits-noname-bit))) + #+x86-target + (%clone-x86-function + (if small + #'%small-set-slot-id-value + #'%large-set-slot-id-value) + map + table + class + #'%maybe-std-setf-slot-value-using-class + #'%slot-id-set-missing + (dpb 3 $lfbits-numreq + (ash -1 $lfbits-noname-bit))))) + (setf (%wrapper-slot-id->slotd wrapper) lookup-f + (%wrapper-slot-id-value wrapper) get-f + (%wrapper-set-slot-id-value wrapper) set-f + (%wrapper-slot-id-map wrapper) map + (%wrapper-slot-definition-table wrapper) table)))) + wrapper) + + + + +(defmethod validate-superclass ((class class) (super class)) + (or (eq super *t-class*) + (let* ((class-of-class (class-of class)) + (class-of-super (class-of super))) + (or (eq class-of-class class-of-super) + (and (eq class-of-class *standard-class-class*) + (eq class-of-super *funcallable-standard-class-class*)) + (and (eq class-of-class *funcallable-standard-class-class*) + (eq class-of-super *standard-class-class*)))))) + +(defmethod validate-superclass ((class foreign-class) (super standard-class)) + t) + +(defmethod validate-superclass ((class std-class) (super forward-referenced-class)) + t) + + +(defmethod add-direct-subclass ((class class) (subclass class)) + (pushnew subclass (%class-direct-subclasses class)) + subclass) + +(defmethod remove-direct-subclass ((class class) (subclass class)) + (setf (%class-direct-subclasses class) + (remove subclass (%class-direct-subclasses class))) + subclass) + +(defun add-direct-subclasses (class new) + (dolist (n new) + (unless (memq class (%class-direct-subclasses class)) + (add-direct-subclass n class)))) + +(defun remove-direct-subclasses (class old-supers new-supers) + (dolist (o old-supers) + (unless (memq o new-supers) + (remove-direct-subclass o class)))) + +;;; Built-in classes are always finalized. +(defmethod class-finalized-p ((class class)) + t) + +;;; Standard classes are finalized if they have a wrapper and that +;;; wrapper has an instance-slots vector; that implies that +;;; both UPDATE-CPL and UPDATE-SLOTS have been called on the class. +(defmethod class-finalized-p ((class std-class)) + (let* ((w (%class-own-wrapper class))) + (and w (typep (%wrapper-instance-slots w) 'vector)))) + +(defmethod finalize-inheritance ((class std-class)) + (update-class class t)) + + +(defmethod finalize-inheritance ((class forward-referenced-class)) + (error "Class ~s can't be finalized." class)) + +(defmethod class-primary-p ((class slots-class)) + (%class-primary-p class)) + +(defmethod (setf class-primary-p) (new (class std-class)) + (setf (%class-primary-p class) new)) + +(defmethod class-primary-p ((class class)) + t) + +(defmethod (setf class-primary-p) (new (class class)) + new) + + +(defun forward-referenced-class-p (class) + (and (%standard-instance-p class) + (eq (%class-of-instance class) *forward-referenced-class-class*))) + +;;; This uses the primary class information to sort the slots of a class. +(defun sort-effective-instance-slotds (slotds class cpl) + (let (primary-slotds + primary-slotds-class + (primary-slotds-length 0)) + (declare (fixnum primary-slotds-length)) + (dolist (sup (cdr cpl)) + (unless (eq sup *t-class*) + (when (class-primary-p sup) + (let ((sup-slotds (extract-instance-effective-slotds sup))) + (if (null primary-slotds-class) + (setf primary-slotds-class sup + primary-slotds sup-slotds + primary-slotds-length (length sup-slotds)) + (let ((sup-slotds-length (length sup-slotds))) + (do* ((i 0 (1+ i)) + (n (min sup-slotds-length primary-slotds-length)) + (sup-slotds sup-slotds (cdr sup-slotds)) + (primary-slotds primary-slotds (cdr primary-slotds))) + ((= i n)) + (unless (eq (%slot-definition-name (car sup-slotds)) + (%slot-definition-name (car primary-slotds))) + (error "While initializing ~s:~%~ + attempt to mix incompatible primary classes:~%~ + ~s and ~s" + class sup primary-slotds-class))) + (when (> sup-slotds-length primary-slotds-length) + (setq primary-slotds-class sup + primary-slotds sup-slotds + primary-slotds-length sup-slotds-length)))))))) + (if (null primary-slotds-class) + slotds + (flet ((slotd-position (slotd) + (let* ((slotd-name (%slot-definition-name slotd))) + (do* ((i 0 (1+ i)) + (primary-slotds primary-slotds (cdr primary-slotds))) + ((= i primary-slotds-length) primary-slotds-length) + (declare (fixnum i)) + (when (eq slotd-name + (%slot-definition-name (car primary-slotds))) + (return i)))))) + (declare (dynamic-extent #'slotd-position)) + (sort-list slotds '< #'slotd-position))))) + + + + +(defun update-cpl (class cpl) + (if (class-finalized-p class) + (unless (equal (%class.cpl class) cpl) + (setf (%class.cpl class) cpl) + #|(force-cache-flushes class)|#) + (setf (%class.cpl class) cpl)) + cpl) + + +(defun class-has-a-forward-referenced-superclass-p (original) + (labels ((scan-forward-refs (class seen) + (unless (memq class seen) + (or (if (forward-referenced-class-p class) class) + (let ((seen (cons class seen))) + (declare (dynamic-extent seen)) + (dolist (s (%class-direct-superclasses class)) + (when (eq s original) + (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class)) + (let* ((fwdref (scan-forward-refs s seen))) + (when fwdref (return fwdref))))))))) + (or (compile-time-class-p original) + (scan-forward-refs original ())))) + +(defun class-forward-referenced-superclasses (original) + (labels ((scan-forward-refs (class seen fwdrefs) + (unless (memq class seen) + (if (forward-referenced-class-p class) + (push class fwdrefs) + (let ((seen (cons class seen))) + (declare (dynamic-extent seen)) + (dolist (s (%class-direct-superclasses class)) + (when (eq s original) + (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class)) + (setq fwdrefs (scan-forward-refs s seen fwdrefs)))))) + fwdrefs)) + (scan-forward-refs original () ()))) + + + +(defmethod compute-class-precedence-list ((class class)) + (let* ((fwdrefs (class-forward-referenced-superclasses class))) + (if fwdrefs + (if (cdr fwdrefs) + (error "Class ~s can't be finalized because superclasses ~s are not defined yet" + class (mapcar #'%class-name fwdrefs)) + (error "Class ~s can't be finalized because superclass ~s is not defined yet" + class (%class-name (car fwdrefs)))) + (compute-cpl class)))) + +;;; Classes that can't be instantiated via MAKE-INSTANCE have no +;;; initargs caches. +(defmethod %flush-initargs-caches ((class class)) + ) + +;;; Classes that have initargs caches should flush them when the +;;; class is finalized. +(defmethod %flush-initargs-caches ((class std-class)) + (setf (%class.make-instance-initargs class) nil + (%class.reinit-initargs class) nil + (%class.redefined-initargs class) nil + (%class.changed-initargs class) nil)) + +(defun update-class (class finalizep) + ;; + ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which + ;; makes the class finalized. When UPDATE-CLASS isn't called from + ;; FINALIZE-INHERITANCE, make sure that this finalization invokes + ;; FINALIZE-INHERITANCE as per AMOP. Note, that we can't simply + ;; delay the finalization when CLASS has no forward referenced + ;; superclasses because that causes bootstrap problems. + (when (and (not (or finalizep (class-finalized-p class))) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (return-from update-class)) + (when (or finalizep (class-finalized-p class)) + (let* ((cpl (update-cpl class (compute-class-precedence-list class)))) + ;; This -should- be made to work for structure classes + (update-slots class (compute-slots class)) + (setf (%class-default-initargs class) (compute-default-initargs class)) + (%flush-initargs-caches class) + (let* ((wrapper (%class-own-wrapper class))) + (when wrapper + (setf (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)))))) + (unless finalizep + (dolist (sub (%class-direct-subclasses class)) + (update-class sub nil)))) + +(defun add-accessor-methods (class dslotds) + (dolist (dslotd dslotds) + (dolist (reader (%slot-definition-readers dslotd)) + (add-reader-method class + (ensure-generic-function reader) + dslotd)) + (dolist (writer (%slot-definition-writers dslotd)) + (add-writer-method class + (ensure-generic-function writer) + dslotd)))) + +(defun remove-accessor-methods (class dslotds) + (dolist (dslotd dslotds) + (dolist (reader (%slot-definition-readers dslotd)) + (remove-reader-method class (ensure-generic-function reader :lambda-list '(x)))) + (dolist (writer (%slot-definition-writers dslotd)) + (remove-writer-method class (ensure-generic-function writer :lambda-list '(x y)))))) + +(defmethod reinitialize-instance :before ((class std-class) &key direct-superclasses) + (remove-accessor-methods class (%class-direct-slots class)) + (remove-direct-subclasses class (%class-direct-superclasses class) direct-superclasses)) + +(defmethod shared-initialize :after + ((class slots-class) + slot-names &key + (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p) + (documentation nil doc-p) + (primary-p nil primary-p-p)) + (if (or direct-superclasses-p (eq slot-names t)) + (progn + (setq direct-superclasses + (or direct-superclasses + (list (if (typep class 'funcallable-standard-class) + *funcallable-standard-object-class* + *standard-object-class*)))) + (dolist (superclass direct-superclasses) + (unless (validate-superclass class superclass) + (error "The class ~S was specified as a~%super-class of the class ~S;~%~ + but the meta-classes ~S and~%~S are incompatible." + superclass class (class-of superclass) (class-of class)))) + (setf (%class-direct-superclasses class) direct-superclasses)) + (setq direct-superclasses (%class-direct-superclasses class))) + (setq direct-slots + (if direct-slots-p + (setf (%class-direct-slots class) + (mapcar #'(lambda (initargs) + (make-direct-slot-definition class initargs)) + direct-slots)) + (%class-direct-slots class))) + (if direct-default-initargs-p + (setf (%class-direct-default-initargs class) direct-default-initargs) + (setq direct-default-initargs (%class-direct-default-initargs class))) + (let* ((new-class-slot-cells ()) + (old-class-slot-cells (%class-get class :class-slots))) + (dolist (slot direct-slots) + (when (eq (%slot-definition-allocation slot) :class) + (let* ((slot-name (%slot-definition-name slot)) + (pair (assq slot-name old-class-slot-cells))) + ;;; If the slot existed as a class slot in the old + ;;; class, retain the definition (even if it's unbound.) + (unless pair + (let* ((initfunction (%slot-definition-initfunction slot))) + (setq pair (cons slot-name + (if initfunction + (funcall initfunction) + (%slot-unbound-marker)))))) + (push pair new-class-slot-cells)))) + (when new-class-slot-cells + (setf (%class-get class :class-slots) new-class-slot-cells))) + (when doc-p + (set-documentation class 'type documentation)) + (when primary-p-p + (setf (class-primary-p class) primary-p)) + + (add-direct-subclasses class direct-superclasses) + (update-class class nil) + (add-accessor-methods class direct-slots)) + +(defmethod initialize-instance :before ((class class) &key &allow-other-keys) + (setf (%class-ordinal class) (%next-class-ordinal)) + (setf (%class.ctype class) (make-class-ctype class))) + +(defun ensure-class-metaclass-and-initargs (class args) + (let* ((initargs (copy-list args)) + (missing (cons nil nil)) + (supplied-meta (getf initargs :metaclass missing)) + (supplied-supers (getf initargs :direct-superclasses missing)) + (supplied-slots (getf initargs :direct-slots missing)) + (metaclass (cond ((not (eq supplied-meta missing)) + (if (typep supplied-meta 'class) + supplied-meta + (find-class supplied-meta))) + ((or (null class) + (typep class 'forward-referenced-class)) + *standard-class-class*) + (t (class-of class))))) + (declare (dynamic-extent missing)) + (flet ((fix-super (s) + (cond ((classp s) s) + ((not (and s (symbolp s))) + (error "~s is not a class or a legal class name." s)) + (t + (or (find-class s nil) + (setf (find-class s) + (make-instance 'forward-referenced-class :name s)))))) + (excise-all (keys) + (dolist (key keys) + (loop (unless (remf initargs key) (return)))))) + (excise-all '(:metaclass :direct-superclasses :direct-slots)) + (values metaclass + `(,@ (unless (eq supplied-supers missing) + `(:direct-superclasses ,(mapcar #'fix-super supplied-supers))) + ,@ (unless (eq supplied-slots missing) + `(:direct-slots ,supplied-slots)) + ,@initargs))))) + + +;;; This defines a new class. +(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys) + (multiple-value-bind (metaclass initargs) + (ensure-class-metaclass-and-initargs class keys) + (let* ((class (apply #'make-instance metaclass :name name initargs))) + (setf (find-class name) class)))) + +(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys) + (multiple-value-bind (metaclass initargs) + (ensure-class-metaclass-and-initargs class keys) + (apply #'change-class class metaclass initargs) + (apply #'reinitialize-instance class initargs) + (setf (find-class name) class))) + +;; Can't go with optimize-make-instance-for-class-name because +;; ensure-class-using-class is called before that is defined. +(defun pessimize-make-instance-for-class-name (class-name) + (let ((cell (find-class-cell class-name nil))) + (when cell + (init-class-cell-instantiator cell)))) + +(defun init-class-cell-instantiator (cell) + (when cell + (setf (class-cell-instantiate cell) '%make-instance) + (setf (class-cell-extra cell) nil))) + +;;; Redefine an existing (not forward-referenced) class. +(defmethod ensure-class-using-class ((class class) name &rest keys &key) + (multiple-value-bind (metaclass initargs) + (ensure-class-metaclass-and-initargs class keys) + (unless (eq (class-of class) metaclass) + (error "Can't change metaclass of ~s to ~s." class metaclass)) + (apply #'reinitialize-instance class initargs) + (setf (find-class name) class))) + + +(defun ensure-class (name &rest keys &key &allow-other-keys) + (declare (dynamic-extent keys)) + (apply #'ensure-class-using-class (find-class name nil) name keys)) + +(defparameter *defclass-redefines-improperly-named-classes-pedantically* + t + "ANSI CL expects DEFCLASS to redefine an existing class only when +the existing class is properly named, the MOP function ENSURE-CLASS +redefines existing classes regardless of their CLASS-NAME. This variable +governs whether DEFCLASS makes that distinction or not.") + +(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys) + (declare (dynamic-extent keys)) + (record-source-file name 'class) + (let* ((existing-class (find-class name nil))) + (when (and *defclass-redefines-improperly-named-classes-pedantically* + existing-class + (not (eq (class-name existing-class) name))) + ;; Class isn't properly named; act like it didn't exist + (setq existing-class nil)) + (apply #'ensure-class-using-class existing-class name keys))) + + + + +(defmethod method-slot-name ((m standard-accessor-method)) + (standard-direct-slot-definition.name (%accessor-method.slot-definition m))) + + +(defun %ensure-class-preserving-wrapper (&rest args) + (declare (dynamic-extent args)) + (let* ((*update-slots-preserve-existing-wrapper* t)) + (apply #'ensure-class args))) + +(defun %find-direct-slotd (class name) + (dolist (dslotd (%class-direct-slots class) + (error "Direct slot definition for ~s not found in ~s" name class)) + (when (eq (%slot-definition-name dslotd) name) + (return dslotd)))) + +(defun %add-slot-readers (class-name pairs) + (let* ((class (find-class class-name))) + (dolist (pair pairs) + (destructuring-bind (slot-name &rest readers) pair + (setf (%slot-definition-readers (%find-direct-slotd class slot-name)) readers))) + (add-accessor-methods class (%class-direct-slots class)))) + +(defun %add-slot-writers (class-name pairs) + (let* ((class (find-class class-name))) + (dolist (pair pairs) + (destructuring-bind (slot-name &rest readers) pair + (setf (%slot-definition-writers (%find-direct-slotd class slot-name)) readers))) + (add-accessor-methods class (%class-direct-slots class)))) + + +(%ensure-class-preserving-wrapper + 'standard-method + :direct-superclasses '(method) + :direct-slots `((:name qualifiers :initargs (:qualifiers) :initfunction ,#'false :initform nil) + (:name specializers :initargs (:specializers) :initfunction ,#'false :initform nil) + (:name function :initargs (:function)) + (:name generic-function :initargs (:generic-function) :initfunction ,#'false :initform nil) + (:name name :initargs (:name) :initfunction ,#'false :initform nil) + (:name lambda-list :initform nil :initfunction ,#'false + :initargs (:lambda-list))) + :primary-p t) + +(defmethod shared-initialize :after ((method standard-method) + slot-names + &key function &allow-other-keys) + (declare (ignore slot-names)) + (when function + (let* ((inner (closure-function function))) + (unless (eq inner function) + (copy-method-function-bits inner function))) + (lfun-name function method))) + +;;; Reader & writer methods classes. +(%ensure-class-preserving-wrapper + 'standard-accessor-method + :direct-superclasses '(standard-method) + :direct-slots '((:name slot-definition :initargs (:slot-definition))) + :primary-p t) + +(%ensure-class-preserving-wrapper + 'standard-reader-method + :direct-superclasses '(standard-accessor-method)) + +(%ensure-class-preserving-wrapper + 'standard-writer-method + :direct-superclasses '(standard-accessor-method)) + +(defmethod reader-method-class ((class standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-reader-method-class*) + +(defmethod reader-method-class ((class funcallable-standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-reader-method-class*) + +(defmethod add-reader-method ((class slots-class) gf dslotd) + (let* ((initargs + `(:qualifiers nil + :specializers ,(list class) + :lambda-list (,(or (%class-name class) 'instance)) + :name ,(function-name gf) + :slot-definition ,dslotd)) + (reader-method-class + (apply #'reader-method-class class dslotd initargs)) + (method-function (create-reader-method-function + class (class-prototype reader-method-class) dslotd)) + (method (apply #'make-instance reader-method-class + :function method-function + initargs))) + (declare (dynamic-extent initargs)) + (record-source-file method 'reader-method) + (add-method gf method))) + +(defmethod remove-reader-method ((class std-class) gf) + (let* ((method (find-method gf () (list class) nil))) + (when method (remove-method gf method)))) + +(defmethod writer-method-class ((class standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-writer-method-class*) + +(defmethod writer-method-class ((class funcallable-standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-writer-method-class*) + + +(defmethod add-writer-method ((class slots-class) gf dslotd) + (let* ((initargs + `(:qualifiers nil + :specializers ,(list *t-class* class) + :lambda-list (new-value ,(or (%class-name class) 'instance)) + :name ,(function-name gf) + :slot-definition ,dslotd)) + (method-class (apply #'writer-method-class class dslotd initargs)) + (method + (apply #'make-instance + method-class + :function (create-writer-method-function + class + (class-prototype method-class) + dslotd) + initargs))) + (declare (dynamic-extent initargs)) + (record-source-file method 'writer-method) + (add-method gf method))) + +(defmethod remove-writer-method ((class std-class) gf) + (let* ((method (find-method gf () (list *t-class* class) nil))) + (when method (remove-method gf method)))) + +;;; We can now define accessors. Fix up the slots in the classes defined +;;; thus far. + +(%add-slot-readers 'standard-method '((qualifiers method-qualifiers) + (specializers method-specializers) + (name method-name) + ;(function method-function) + (generic-function method-generic-function) + (lambda-list method-lambda-list))) + +(%add-slot-writers 'standard-method '((function (setf method-function)) + (generic-function (setf method-generic-function)))) + + +(defmethod method-function ((m standard-method)) + (%method.function m)) + + +(%add-slot-readers 'standard-accessor-method + '((slot-definition accessor-method-slot-definition))) + + +(%ensure-class-preserving-wrapper + 'specializer + :direct-superclasses '(metaobject) + :direct-slots `((:name direct-methods + :readers (specializer-direct-methods) + :initform nil :initfunction ,#'false)) + :primary-p t) + +(%ensure-class-preserving-wrapper + 'eql-specializer + :direct-superclasses '(specializer) + :direct-slots '((:name object :initargs (:object) :readers (eql-specializer-object))) + :primary-p t) + + +(%ensure-class-preserving-wrapper + 'class + :direct-superclasses '(specializer) + :direct-slots + `((:name prototype :initform nil :initfunction ,#'false) + (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name)) + (:name precedence-list :initform nil :initfunction ,#'false) + (:name own-wrapper :initform nil :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper))) + (:name direct-superclasses :initform nil :initfunction ,#'false :readers (class-direct-superclasses)) + (:name direct-subclasses :initform nil :initfunction ,#'false :readers (class-direct-subclasses)) + (:name dependents :initform nil :initfunction ,#'false) + (:name class-ctype :initform nil :initfunction ,#'false) + (:name direct-slots :initform nil :initfunction ,#'false + :readers (class-direct-slots) + :writers ((setf class-direct-slots))) + (:name slots :initform nil :initfunction ,#'false + :readers (class-slots) + :writers ((setf class-slots))) + (:name info :initform (cons nil nil) :initfunction ,(lambda () (cons nil nil)) :readers (class-info)) + (:name direct-default-initargs :initform nil :initfunction ,#'false :readers (class-direct-default-initargs)) + (:name default-initargs :initform nil :initfunction ,#'false :readers (class-default-initargs))) + :primary-p t) + +(%ensure-class-preserving-wrapper + 'forward-referenced-class + :direct-superclasses '(class)) + + + +(%ensure-class-preserving-wrapper + 'built-in-class + :direct-superclasses '(class)) + + +(%ensure-class-preserving-wrapper + 'slots-class + :direct-superclasses '(class) + :direct-slots `((:name alist :initform nil :initfunction ,#'false)) + :primary-p t) + +;;; This class exists only so that standard-class & funcallable-standard-class +;;; can inherit its slots. +(%ensure-class-preserving-wrapper + 'std-class + :direct-superclasses '(slots-class) + :direct-slots `( + (:name make-instance-initargs :initform nil :initfunction ,#'false) + (:name reinit-initargs :initform nil :initfunction ,#'false) + (:name redefined-initargs :initform nil :initfunction ,#'false) + (:name changed-initargs :initform nil :initfunction ,#'false)) + :primary-p t) + + + +(%ensure-class-preserving-wrapper + 'standard-class + :direct-superclasses '(std-class)) + +(%ensure-class-preserving-wrapper + 'funcallable-standard-class + :direct-superclasses '(std-class)) + + +(%ensure-class-preserving-wrapper + 'funcallable-standard-object +#|| + :direct-superclasses '(standard-object function) +||# + :direct-slots `((:name name :initargs (:name) :readers (generic-function-name))) + :metaclass 'funcallable-standard-class) + +(%ensure-class-preserving-wrapper + 'generic-function + :direct-superclasses '(metaobject funcallable-standard-object) + :direct-slots `( + (:name method-combination :initargs (:method-combination) + :initform *standard-method-combination* + :initfunction ,#'(lambda () *standard-method-combination*) + :readers (generic-function-method-combination)) + (:name method-class :initargs (:method-class) + :initform *standard-method-class* + :initfunction ,#'(lambda () *standard-method-class*) + :readers (generic-function-method-class)) + (:name methods :initargs (:methods) + :initform nil :initfunction ,#'false + :readers (generic-function-methods)) + (:name declarations + :initargs (:declarations) + :initform nil :initfunction ,#'false + :readers (generic-function-declarations)) + (:name %lambda-list + :initform :unspecified + :initfunction ,(constantly :unspecified)) + (:name dependents + :initform nil :initfunction ,#'false)) + :metaclass 'funcallable-standard-class) + + + +(%ensure-class-preserving-wrapper + 'standard-generic-function + :direct-superclasses '(generic-function) + + :metaclass 'funcallable-standard-class + :primary-p t) + +(%ensure-class-preserving-wrapper + 'standard-generic-function + :direct-superclasses '(generic-function) + + :metaclass 'funcallable-standard-class) + +(%ensure-class-preserving-wrapper + 'structure-class + :direct-superclasses '(slots-class)) + +(%ensure-class-preserving-wrapper + 'slot-definition + :direct-superclasses '(metaobject) + :direct-slots `((:name name :initargs (:name) :readers (slot-definition-name) + :initform nil :initfunction ,#'false) + (:name type :initargs (:type) :readers (slot-definition-type) + :initform t :initfunction ,#'true) + (:name initfunction :initargs (:initfunction) :readers (slot-definition-initfunction) + :initform nil :initfunction ,#'false) + (:name initform :initargs (:initform) :readers (slot-definition-initform) + :initform nil :initfunction ,#'false) + (:name initargs :initargs (:initargs) :readers (slot-definition-initargs) + :initform nil :initfunction ,#'false) + (:name allocation :initargs (:allocation) :readers (slot-definition-allocation) + :initform :instance :initfunction ,(constantly :instance)) + (:name documentation :initargs (:documentation) :readers (slot-definition-documentation) + :initform nil :initfunction ,#'false) + (:name class :initargs (:class) :readers (slot-definition-class))) + + :primary-p t) + +(%ensure-class-preserving-wrapper + 'direct-slot-definition + :direct-superclasses '(slot-definition) + :direct-slots `((:name readers :initargs (:readers) :initform nil + :initfunction ,#'false :readers (slot-definition-readers)) + (:name writers :initargs (:writers) :initform nil + :initfunction ,#'false :readers (slot-definition-writers)))) + +(%ensure-class-preserving-wrapper + 'effective-slot-definition + :direct-superclasses '(slot-definition) + :direct-slots `((:name location :initform nil :initfunction ,#'false + :readers (slot-definition-location)) + (:name slot-id :initform nil :initfunction ,#'false + :readers (slot-definition-slot-id)) + (:name type-predicate :initform nil + :initfunction ,#'false + :readers (slot-definition-predicate)) + ) + + :primary-p t) + +(%ensure-class-preserving-wrapper + 'standard-slot-definition + :direct-superclasses '(slot-definition) +) + + + + + + + +(%ensure-class-preserving-wrapper + 'standard-direct-slot-definition + :direct-superclasses '(standard-slot-definition direct-slot-definition) +) + +(%ensure-class-preserving-wrapper + 'standard-effective-slot-definition + :direct-superclasses '(standard-slot-definition effective-slot-definition)) + + + + + + + + + +;;; Fake method-combination, redefined in lib;method-combination. +(unless *type-system-initialized* + (defclass method-combination (metaobject) + ((name :initarg :name)))) + + + + +(defclass standard-method-combination (method-combination) ()) + +(initialize-instance *standard-method-combination* :name 'standard) + +(setq *standard-kernel-method-class* + (defclass standard-kernel-method (standard-method) + ())) + +(unless *standard-method-combination* + (setq *standard-method-combination* + (make-instance 'standard-method-combination :name 'standard))) + +;;; For %compile-time-defclass +(defclass compile-time-class (class) ()) + +(defmethod compile-time-class-p ((class compile-time-class)) + t) + +(defmethod class-finalized-p ((class compile-time-class)) + nil) + + +(defclass structure-slot-definition (slot-definition) ()) +(defclass structure-effective-slot-definition (structure-slot-definition + effective-slot-definition) + ()) + +(defclass structure-direct-slot-definition (structure-slot-definition + direct-slot-definition) + ()) + +(defmethod shared-initialize :after ((class structure-class) + slot-names + &key + (direct-superclasses nil direct-superclasses-p) + &allow-other-keys) + (declare (ignore slot-names)) + (labels ((obsolete (class) + (dolist (sub (%class-direct-subclasses class)) (obsolete sub)) + ;;Need to save old class info in wrapper for obsolete + ;;instance access... + (setf (%class.cpl class) nil))) + (obsolete class) + (when direct-superclasses-p + (let* ((old-supers (%class-direct-superclasses class)) + (new-supers direct-superclasses)) + (dolist (c old-supers) + (unless (memq c new-supers) + (remove-direct-subclass c class))) + (dolist (c new-supers) + (unless (memq c old-supers) + (add-direct-subclass c class))) + (setf (%class.local-supers class) new-supers))) + (let* ((wrapper (or (%class-own-wrapper class) + (setf (%class-own-wrapper class) (%cons-wrapper class)))) + (cpl (compute-cpl class))) + (setf (%class.cpl class) cpl) + (setf (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl))))) + + + + +;;; Called from DEFSTRUCT expansion. +(defun %define-structure-class (sd) + (let* ((dslots ())) + (dolist (ssd (cdr (sd-slots sd)) (setq dslots (nreverse dslots))) + (let* ((type (ssd-type ssd)) + (refinfo (ssd-refinfo ssd))) + (unless (logbitp $struct-inherited refinfo) + (let* ((name (ssd-name ssd)) + (initform (cadr ssd)) + (initfunction (constantly initform))) + (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction :initargs ,(list (make-keyword name))) dslots))))) + (ensure-class (sd-name sd) + :metaclass 'structure-class + :direct-superclasses (list (or (cadr (sd-superclasses sd)) 'structure-object)) + :direct-slots dslots + ))) + + +(defun standard-instance-access (instance location) + (etypecase location + (fixnum (%standard-instance-instance-location-access instance location)) + (cons (%cdr location)))) + +(defun (setf standard-instance-access) (new instance location) + (etypecase location + (fixnum (setf (standard-instance-instance-location-access instance location) + new)) + (cons (setf (%cdr location) new)))) + +(defun funcallable-standard-instance-access (instance location) + (etypecase location + (fixnum (%standard-generic-function-instance-location-access instance location)) + (cons (%cdr location)))) + +(defun (setf funcallable-standard-instance-access) (new instance location) + (etypecase location + (fixnum (setf (%standard-generic-function-instance-location-access instance location) new)) + (cons (setf (%cdr location) new)))) + +;;; Handle a trap from %slot-ref +(defun %slot-unbound-trap (slotv idx frame-ptr) + (let* ((instance nil) + (class nil) + (slot nil)) + (if (and (eq (typecode slotv) target::subtag-slot-vector) + (setq instance (slot-vector.instance slotv)) + (setq slot + (find idx (class-slots (setq class (class-of instance))) + :key #'slot-definition-location))) + (slot-unbound class instance (slot-definition-name slot)) + (%error "Unbound slot at index ~d in ~s" (list idx slotv) frame-ptr)))) + + + +;;; +;;; Now that CLOS is nominally bootstrapped, it's possible to redefine some +;;; of the functions that really should have been generic functions ... +(setf (fdefinition '%class-name) #'class-name + (fdefinition '%class-default-initargs) #'class-default-initargs + (fdefinition '%class-direct-default-initargs) #'class-direct-default-initargs + (fdefinition '(setf %class-direct-default-initargs)) + #'(lambda (new class) + (if (typep class 'slots-class) + (setf (slot-value class 'direct-default-initargs) new) + new)) + (fdefinition '%class-direct-slots) #'class-direct-slots + (fdefinition '(setf %class-direct-slots)) + #'(setf class-direct-slots) + (fdefinition '%class-slots) #'class-slots + (fdefinition '%class-direct-superclasses) #'class-direct-superclasses + (fdefinition '(setf %class-direct-superclasses)) + #'(lambda (new class) + (setf (slot-value class 'direct-superclasses) new)) + (fdefinition '%class-direct-subclasses) #'class-direct-subclasses + ;(fdefinition '%class-own-wrapper) #'class-own-wrapper + (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper) +) + + + +(setf (fdefinition '%slot-definition-name) #'slot-definition-name + (fdefinition '%slot-definition-type) #'slot-definition-type + (fdefinition '%slot-definition-initargs) #'slot-definition-initargs + (fdefinition '%slot-definition-allocation) #'slot-definition-allocation + (fdefinition '%slot-definition-location) #'slot-definition-location + (fdefinition '%slot-definition-readers) #'slot-definition-readers + (fdefinition '%slot-definition-writers) #'slot-definition-writers) + + +(setf (fdefinition '%method-qualifiers) #'method-qualifiers + (fdefinition '%method-specializers) #'method-specializers + (fdefinition '%method-function) #'method-function + (fdefinition '(setf %method-function)) #'(setf method-function) + (fdefinition '%method-gf) #'method-generic-function + (fdefinition '(setf %method-gf)) #'(setf method-generic-function) + (fdefinition '%method-name) #'method-name + (fdefinition '%method-lambda-list) #'method-lambda-list + ) + +(setf (fdefinition '%add-method) #'add-method) + + +;;; Make a direct-slot-definition of the appropriate class. +(defun %make-direct-slotd (slotd-class &rest initargs) + (declare (dynamic-extent initargs)) + (apply #'make-instance slotd-class initargs)) + +;;; Likewise, for an effective-slot-definition. +(defun %make-effective-slotd (slotd-class &rest initargs) + (declare (dynamic-extent initargs)) + (apply #'make-instance slotd-class initargs)) + +;;; Likewise, for methods +(defun %make-method-instance (class &rest initargs) + (apply #'make-instance class initargs)) + +(defmethod initialize-instance :after ((slotd effective-slot-definition) &key name) + (setf (standard-effective-slot-definition.slot-id slotd) + (ensure-slot-id name))) + + +(defmethod specializer-direct-generic-functions ((s specializer)) + (let* ((gfs ()) + (methods (specializer-direct-methods s))) + (dolist (m methods gfs) + (let* ((gf (method-generic-function m))) + (when gf (pushnew gf gfs)))))) + +(defmethod generic-function-lambda-list ((gf standard-generic-function)) + (%maybe-compute-gf-lambda-list gf (car (generic-function-methods gf)))) + +(defmethod generic-function-argument-precedence-order + ((gf standard-generic-function)) + (let* ((req (required-lambda-list-args (generic-function-lambda-list gf))) + (apo (%gf-dispatch-table-precedence-list + (%gf-dispatch-table gf)))) + (if (null apo) + req + (mapcar #'(lambda (n) (nth n req)) apo)))) + +(defun normalize-egf-keys (keys gf) + (let* ((missing (cons nil nil)) + (env (getf keys :environment nil))) + (declare (dynamic-extent missing)) + (remf keys :environment) + (let* ((gf-class (getf keys :generic-function-class missing)) + (mcomb (getf keys :method-combination missing)) + (method-class (getf keys :method-class missing))) + (if (eq gf-class missing) + (setf gf-class (if gf (class-of gf) *standard-generic-function-class*)) + (progn + (remf keys :generic-function-class) + (if (typep gf-class 'symbol) + (setq gf-class + (find-class gf-class t env))) + (unless (or (eq gf-class *standard-generic-function-class*) + (subtypep gf-class *generic-function-class*)) + (error "Class ~S is not a subclass of ~S" + gf-class *generic-function-class*)))) + (unless (eq mcomb missing) + (unless (typep mcomb 'method-combination) + (setf (getf keys :method-combination) + (find-method-combination (class-prototype gf-class) + (car mcomb) + (cdr mcomb))))) + (unless (eq method-class missing) + (if (typep method-class 'symbol) + (setq method-class (find-class method-class t env))) + (unless (subtypep method-class *method-class*) + (error "~s is not a subclass of ~s" method-class *method-class*)) + (setf (getf keys :method-class) method-class)) + (values gf-class keys)))) + +(defmethod ensure-generic-function-using-class + ((gf null) + function-name + &rest keys + &key + &allow-other-keys) + (declare (dynamic-extent keys)) + (multiple-value-bind (gf-class initargs) + (normalize-egf-keys keys nil) + (let* ((gf (apply #'make-instance gf-class + :name function-name + initargs))) + (setf (fdefinition function-name) gf)))) + +(defparameter *error-on-gf-class-redefinition* nil + "The MOP spec requires ENSURE-GENERIC-FUNCTION-USING-CLASS of an + existing gf to signal an error if the :GENERIC-FUNCTION-CLASS + argument specifies a class other than the existing gf's class. + ANSI CL allows this kind of redefinition if the classes are + \"compatible\", but doesn't define what compatibility means + in this case. When *ERROR-ON-GF-CLASS-REDEFINITION* is true, + a continuable error is signaled. + + Historically, Clozure CL CERRORed, but didn't offer a useful + CHANGE-CLASS method that would change the GF's class") + +(defmethod ensure-generic-function-using-class + ((gf generic-function) + function-name + &rest keys + &key + &allow-other-keys) + (declare (dynamic-extent keys) (ignorable function-name)) + (multiple-value-bind (gf-class initargs) + (normalize-egf-keys keys gf) + (unless (eq gf-class (class-of gf)) + (when *error-on-gf-class-redefinition* + (cerror (format nil "Change the class of ~s to ~s." gf gf-class) + "The class of the existing generic function ~s is not ~s" + gf gf-class)) + (change-class gf gf-class)) + (apply #'reinitialize-instance gf initargs))) + + +(defmethod initialize-instance :before ((instance generic-function) + &key &allow-other-keys) + (setf (%gf-dcode instance) #'%%0-arg-dcode)) + +(defmethod initialize-instance :after ((gf standard-generic-function) + &key + (lambda-list nil ll-p) + (argument-precedence-order nil apo-p) + &allow-other-keys) + (if (and apo-p (not ll-p)) + (error + "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST")) + (if ll-p + (progn + (unless (verify-lambda-list lambda-list) + (error "~s is not a valid generic function lambda list" lambda-list)) + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + (set-gf-arg-info gf)) + (if (gf-arg-info-valid-p gf) + (compute-dcode gf (%gf-dispatch-table gf))) + gf) + +(defmethod reinitialize-instance :after ((gf standard-generic-function) + &rest args + &key + (lambda-list nil ll-p) + (argument-precedence-order nil apo-p) + &allow-other-keys) + (if (and apo-p (not ll-p)) + (error + "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST")) + (if ll-p + (progn + (unless (verify-lambda-list lambda-list) + (error "~s is not a valid generic function lambda list" lambda-list)) + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + (set-gf-arg-info gf)) + (if (and (gf-arg-info-valid-p gf) + args + (or ll-p (cddr args))) + (compute-dcode gf (%gf-dispatch-table gf))) + (when (sgf.dependents gf) + (map-dependents gf #'(lambda (d) + (apply #'update-dependent gf d args)))) + gf) + + +(defun decode-method-lambda-list (method-lambda-list) + (flet ((bad () + (error "Invalid lambda-list syntax in ~s" method-lambda-list))) + (collect ((specnames) + (required)) + (do* ((tail method-lambda-list (cdr tail)) + (head (car tail) (car tail))) + ((or (null tail) (member head lambda-list-keywords)) + (if (verify-lambda-list tail) + (values (required) tail (specnames)) + (bad))) + (cond ((atom head) + (unless (typep head 'symbol) (bad)) + (required head) + (specnames t)) + (t + (unless (and (typep (car head) 'symbol) + (consp (cdr head)) + (null (cddr head))) + (bad)) + (required (car head)) + (specnames (cadr head)))))))) + +(defun extract-specializer-names (method-lambda-list) + (nth-value 2 (decode-method-lambda-list method-lambda-list))) + +(defun extract-lambda-list (method-lambda-list) + (multiple-value-bind (required tail) + (decode-method-lambda-list method-lambda-list) + (nconc required tail))) + +(setf (fdefinition '%ensure-generic-function-using-class) + #'ensure-generic-function-using-class) + + +(defmethod shared-initialize :after ((gf generic-function) slot-names + &key + (documentation nil doc-p)) + (declare (ignore slot-names)) + (when doc-p + (if documentation (check-type documentation string)) + (set-documentation gf t documentation))) + + + + +(defmethod allocate-instance ((b built-in-class) &rest initargs) + (declare (ignore initargs)) + (error "Can't allocate instances of BUILT-IN-CLASS.")) + +(defmethod reinitialize-instance ((m method) &rest initargs) + (declare (ignore initargs)) + (error "Can't reinitialze ~s ~s" (class-of m) m)) + +(defmethod add-dependent ((class class) dependent) + (pushnew dependent (%class.dependents class))) + +(defmethod add-dependent ((gf standard-generic-function) dependent) + (pushnew dependent (sgf.dependents gf))) + +(defmethod remove-dependent ((class class) dependent) + (setf (%class.dependents class) + (delete dependent (%class.dependents class)))) + +(defmethod remove-dependent ((gf standard-generic-function) dependent) + (setf (sgf.dependents gf) + (delete dependent (sgf.dependents gf)))) + +(defmethod map-dependents ((class class) function) + (dolist (d (%class.dependents class)) + (funcall function d))) + +(defmethod map-dependents ((gf standard-generic-function) function) + (dolist (d (sgf.dependents gf)) + (funcall function d))) + +(defgeneric update-dependent (metaobject dependent &rest initargs)) + +(defmethod reinitialize-instance :after ((class std-class) &rest initargs) + (map-dependents class #'(lambda (d) + (apply #'update-dependent class d initargs)))) + + +(defun %allocate-gf-instance (class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((wrapper (%class.own-wrapper class)) + (gf-p (member *generic-function-class* (%class-cpl class))) + (len (length (%wrapper-instance-slots wrapper))) + (dt (if gf-p (make-gf-dispatch-table))) + (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker))) + (fn + #+ppc-target + (gvector :function + *unset-fin-code* + wrapper + slots + dt + #'false + 0 + (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-aok-bit))) + #+x86-target + (%clone-x86-function #'unset-fin-trampoline + wrapper + slots + dt + #'false + 0 + (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-aok-bit))))) + (setf + (slot-vector.instance slots) fn) + (when dt + (setf (%gf-dispatch-table-gf dt) fn)) + (if gf-p + (push fn (population.data %all-gfs%))) + fn)) + + +(defmethod slot-value-using-class ((class structure-class) + instance + (slotd structure-effective-slot-definition)) + (let* ((loc (standard-effective-slot-definition.location slotd))) + (typecase loc + (fixnum + (struct-ref instance loc)) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + +;;; Some STRUCTURE-CLASS leftovers. +(defmethod (setf slot-value-using-class) + (new + (class structure-class) + instance + (slotd structure-effective-slot-definition)) + (let* ((loc (standard-effective-slot-definition.location slotd)) + (type (standard-effective-slot-definition.type slotd))) + (if (and type (not (eq type t))) + (unless (or (eq new (%slot-unbound-marker)) + (typep new type)) + (setq new (require-type new type)))) + (typecase loc + (fixnum + (setf (struct-ref instance loc) new)) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + +(defmethod slot-boundp-using-class ((class structure-class) + instance + (slotd structure-effective-slot-definition)) + (declare (ignore instance)) + t) + +;;; This has to be somewhere, so it might as well be here. +(defmethod make-load-form ((s slot-id) &optional env) + (declare (ignore env)) + `(ensure-slot-id ,(slot-id.name s))) + +(defmethod make-load-form ((c class-cell) &optional env) + (declare (ignore env)) + `(find-class-cell ',(class-cell-name c) t)) + + + +(defmethod (setf class-name) (new (class class)) + (check-type new symbol) + (when (and (standard-instance-p class) + (%class-kernel-p class) + (not (eq new (%class.name class))) + *warn-if-redefine-kernel*) + (cerror "Change the name of ~s to ~s." + "The class ~s may be a critical part of the system; +changing its name to ~s may have serious consequences." class new)) + (let* ((old-name (class-name class))) + (if (eq (find-class old-name nil) class) + (progn + (setf (info-type-kind old-name) nil) + (clear-type-cache)))) + (when (eq (find-class new nil) class) + (when (%deftype-expander new) + (cerror "Change the name of ~S anyway, removing the DEFTYPE definition." + "Changing the name of ~S to ~S would conflict with the type defined by DEFTYPE." + class new) + (%deftype new nil nil)) + (setf (info-type-kind new) :instance) + (clear-type-cache)) + (reinitialize-instance class :name new) + (setf (%class-proper-name class) + (if (eq (find-class new nil) class) + new)) + new) + + +;;; From Tim Moore, as part of a set of patches to support funcallable +;;; instances. + +;;; Support for objects with metaclass funcallable-instance-class that are not +;;; standard-generic-function. The objects still look a lot like generic +;;; functions, complete with vestigial dispatch +;;; tables. set-funcallable-instance-function will work on generic functions, +;;; though after that it won't be much of a generic function. + + + + + +(defun set-funcallable-instance-function (funcallable-instance function) + (unless (typep funcallable-instance 'funcallable-standard-object) + (error "~S is not a funcallable instance" funcallable-instance)) + (unless (functionp function) + (error "~S is not a function" function)) + (setf (%gf-dcode funcallable-instance) function)) + +(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys) + (error "Can't reinitialize ~s" slotd)) + +(defmethod (setf generic-function-name) (new-name (gf generic-function)) + (reinitialize-instance gf :name new-name)) + +;;; Are we CLOS yet ? + +(defun %shared-initialize (instance slot-names initargs) + (unless (or (listp slot-names) (eq slot-names t)) + (report-bad-arg slot-names '(or list (eql t)))) + ;; Check that initargs contains valid key/value pairs, + ;; signal a PROGRAM-ERROR otherwise. (Yes, this is + ;; an obscure way to do so.) + (destructuring-bind (&key &allow-other-keys) initargs) + ;; I'm not sure if there's a more portable way of detecting + ;; obsolete instances. This'll eventually call + ;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS if it needs to. + (let* ((wrapper (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance) + (instance-class-wrapper instance))) + (class (%wrapper-class wrapper))) + (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete + (update-obsolete-instance instance)) + ;; Now loop over all of the class's effective slot definitions. + (dolist (slotd (class-slots class)) + ;; Anything that inherits from STANDARD-EFFECTIVE-SLOT-DEFINITION + ;; in Clozure CL will have a CCL::TYPE-PREDICATE slot. It's not + ;; well-defined to inherit from EFFECTIVE-SLOT-DEFINITION without + ;; also inheriting from STANDARD-EFFECTIVE-SLOT-DEFINITION, + ;; and I'd rather not check here. If you really want to + ;; create that kind of slot definition, write your own SHARED-INITIALIZE + ;; method for classes that use such slot definitions ... + (let* ((predicate (slot-definition-predicate slotd))) + (multiple-value-bind (ignore new-value foundp) + (get-properties initargs (slot-definition-initargs slotd)) + (declare (ignore ignore)) + (cond (foundp + ;; an initarg for the slot was passed to this function + ;; Typecheck the new-value, then call + ;; (SETF SLOT-VALUE-USING-CLASS) + (unless (or (null predicate) + (funcall predicate new-value)) + (error 'bad-slot-type-from-initarg + :slot-definition slotd + :instance instance + :datum new-value + :expected-type (slot-definition-type slotd) + :initarg-name (car foundp))) + (setf (slot-value-using-class class instance slotd) new-value)) + ((and (or (eq slot-names t) + (member (slot-definition-name slotd) + slot-names + :test #'eq)) + (not (slot-boundp-using-class class instance slotd))) + ;; If the slot name is among the specified slot names, or + ;; we're reinitializing all slots, and the slot is currently + ;; unbound in the instance, set the slot's value based + ;; on the initfunction (which captures the :INITFORM). + (let* ((initfunction (slot-definition-initfunction slotd))) + (if initfunction + (let* ((newval (funcall initfunction))) + (unless (or (null predicate) + (funcall predicate newval)) + (error 'bad-slot-type-from-initform + :slot-definition slotd + :expected-type (slot-definition-type slotd) + :datum newval + :instance instance)) + (setf (slot-value-using-class class instance slotd) + newval)))))))))) + instance) + +(defmethod shared-initialize ((struct structure-object) slot-names &rest initargs) + (unless (eq slot-names t) + (error "Structure instance ~s can't be reinitialized." struct)) + (dolist (slotd (class-slots (class-cell-class (car (%svref struct 0))))) + (let* ((predicate (slot-definition-predicate slotd)) + (location (slot-definition-location slotd))) + (declare (fixnum location)) + (multiple-value-bind (ignore new-value foundp) + (get-properties initargs (slot-definition-initargs slotd)) + (declare (ignore ignore)) + (cond (foundp + ;; an initarg for the slot was passed to this function + ;; Typecheck the new-value, then call + ;; (SETF SLOT-VALUE-USING-CLASS) + (unless (or (null predicate) + (funcall predicate new-value)) + (error 'bad-slot-type-from-initarg + :slot-definition slotd + :instance struct + :datum new-value + :expected-type (slot-definition-type slotd) + :initarg-name (car foundp))) + (setf (struct-ref struct location) new-value)) + (t + ;; If the slot name is among the specified slot names, or + ;; we're reinitializing all slots, and the slot is currently + ;; unbound in the instance, set the slot's value based + ;; on the initfunction (which captures the :INITFORM). + (let* ((initfunction (slot-definition-initfunction slotd))) + (if initfunction + (let* ((newval (funcall initfunction))) + (unless (or (null predicate) + (funcall predicate newval)) + (error 'bad-slot-type-from-initform + :slot-definition slotd + :expected-type (slot-definition-type slotd) + :datum newval + :instance struct)) + (setf (struct-ref struct location) newval))))))))) + struct) + +(defmethod initialize-instance ((struct structure-object) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (apply #'shared-initialize struct t initargs)) + +(defmethod make-instance ((class structure-class) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (let* ((struct (apply #'allocate-instance class initargs))) + (apply #'initialize-instance struct initargs))) + + + +;;; Sometimes you can do a lot better at generic function dispatch than the +;;; default. This supports that for the one-arg-dcode case. +(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t)) + nil) + +(defun optimize-generic-function-dispatching () + (dolist (gf (population.data %all-gfs%)) + (optimize-dispatching-for-gf gf))) + +(defun optimize-dispatching-for-gf (gf) + (let* ((dcode (%gf-dcode gf)) + (name (function-name dcode))) + (when (or (eq name '%%one-arg-dcode) + (eq name '%%nth-arg-dcode)) + (let ((methods (generic-function-methods gf))) + (when (and methods (null (cdr methods))) + (when (or (eq #'%%one-arg-dcode dcode) + (and (eq #'%%nth-arg-dcode dcode) + (let ((spec (method-specializers (car methods))) + (argnum (%gf-dispatch-table-argnum + (%gf-dispatch-table gf)))) + (and (eql 2 (length spec)) + (and (eql argnum 1) (eq (car spec) *t-class*)))))) + (override-one-method-one-arg-dcode gf (car methods)))))))) + +(defparameter *unique-reader-dcode-functions* t) + +;;; dcode for a GF with a single reader method which accesses +;;; a slot in a class that has no subclasses (that restriction +;;; makes typechecking simpler and also ensures that the slot's +;;; location is correct.) +(defun singleton-reader-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((wrapper (%svref dt %gf-dispatch-table-first-data)) + (location (%svref dt (1+ %gf-dispatch-table-first-data)))) + (if (eq (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance)) + wrapper) + (%slot-ref (instance.slots instance) location) + (cond ((and (eq (typecode instance) target::subtag-instance) + (eq 0 (%wrapper-hash-index (instance.class-wrapper instance))) + (progn (update-obsolete-instance instance) + (eq (instance.class-wrapper instance) wrapper))) + (%slot-ref (instance.slots instance) location)) + (t (no-applicable-method (%gf-dispatch-table-gf dt) instance)))))) +(register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +(defun reader-constant-location-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (if (memq (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + (%svref dt %gf-dispatch-table-first-data)) + (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data))) + (no-applicable-method (%gf-dispatch-table-gf dt) instance))) +(register-dcode-proto #'reader-constant-location-dcode *gf-proto-one-arg*) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +;;; The number of classes for which the method is applicable is +;;; potentially large, but all are subclasses of a single class +(defun reader-constant-location-inherited-from-single-class-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((defining-class-ordinal (%svref dt %gf-dispatch-table-first-data)) + (bits (let* ((wrapper + (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance)))) + (when wrapper (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl + (%wrapper-class wrapper)))))))) + (declare (fixnum defining-class-ordinal)) + (if (and bits + (< defining-class-ordinal (the fixnum (uvsize bits))) + (not (eql 0 (sbit bits defining-class-ordinal)))) + (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data))) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) +(register-dcode-proto #'reader-constant-location-inherited-from-single-class-dcode *gf-proto-one-arg*) + +;;; It may be faster to make individual functions that take their +;;; "parameters" (defining class ordinal, slot location) as constants. +;;; It may not be. Use *unique-reader-dcode-functions* to decide +;;; whether or not to do so. +(defun make-reader-constant-location-inherited-from-single-class-dcode + (defining-class-ordinal location gf) + (if *unique-reader-dcode-functions* + (let* ((gf-name (function-name gf))) + (values + (%make-function + `(slot-reader for ,gf-name) + `(lambda (instance) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((bits (let* ((wrapper + (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance)))) + (when wrapper (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl + (%wrapper-class wrapper)))))))) + (if (and bits + (< ,defining-class-ordinal (the fixnum (uvsize bits))) + (not (eql 0 (sbit bits ,defining-class-ordinal)))) + (%slot-ref (instance.slots instance) ,location) + (no-applicable-method (function ,gf-name) instance))))) + nil) + #'funcallable-trampoline)) + (let* ((dt (gf.dispatch-table gf))) + (setf (%svref dt %gf-dispatch-table-first-data) + defining-class-ordinal + (%svref dt (1+ %gf-dispatch-table-first-data)) + location) + (values + (dcode-for-gf gf #'reader-constant-location-inherited-from-single-class-dcode) + (cdr (assq #'reader-constant-location-inherited-from-single-class-dcode dcode-proto-alist)))))) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +;;; The number of classes is for which the method is applicable is +;;; large, but all are subclasses of one of a (small) set of defining classes. +(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((wrapper (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance))) + (bits (if wrapper (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) + (nbits (if bits (uvsize bits) 0))) + (declare (fixnum nbits)) + (if (dolist (ordinal (%svref dt %gf-dispatch-table-first-data)) + (declare (fixnum ordinal)) + (when (and (< ordinal nbits) + (not (eql 0 (sbit bits ordinal)))) + (return t))) + (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data))) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) +(register-dcode-proto #'reader-constant-location-inherited-from-multiple-classes-dcode *gf-proto-one-arg*) + + +;;; Similar to the case above, but we use an alist to map classes +;;; to their non-constant locations. +(defun reader-variable-location-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((alist (%svref dt %gf-dispatch-table-first-data)) + (location (cdr + (assq + (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + alist)))) + (if location + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) +(register-dcode-proto #'reader-variable-location-dcode *gf-proto-one-arg*) + +(defun class-and-slot-location-alist (classes slot-name) + (let* ((alist nil)) + (labels ((add-class (c) + (unless (assq c alist) + (let* ((slots (class-slots c))) + (unless slots + (finalize-inheritance c) + (setq slots (class-slots c))) + (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist)) + (dolist (sub (class-direct-subclasses c)) + (add-class sub))))) + (dolist (class classes) (add-class class)) + ;; Building the alist the way that we have should often approximate + ;; this ordering; the idea is that leaf classes are more likely to + ;; be instantiated than non-leaves. + (sort alist (lambda (c1 c2) + (< (length (class-direct-subclasses c1)) + (length (class-direct-subclasses c2)))) + :key #'car)))) + +;;; Return a list of all classes in CLASS-LIST that aren't subclasses +;;; of any other class in the list. +(defun remove-subclasses-from-class-list (class-list) + (if (null (cdr class-list)) + class-list + (collect ((unique)) + (dolist (class class-list (unique)) + (when (dolist (other class-list t) + (unless (eq class other) + (when (subtypep class other) (return nil)))) + (unique class)))))) + + +;;; Try to replace gf dispatch with something faster in f. +(defun %snap-reader-method (f &key (redefinable t)) + (when (slot-boundp f 'methods) + (let* ((methods (generic-function-methods f))) + (when (and methods + (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods) + (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods) + (every (lambda (m) (null (method-qualifiers m))) methods)) + (let* ((m0 (car methods)) + (name (slot-definition-name (accessor-method-slot-definition m0)))) + (when (every (lambda (m) + (eq name (slot-definition-name (accessor-method-slot-definition m)))) + (cdr methods)) + ;; All methods are *STANDARD-READER-METHODS* that + ;; access the same slot name. Build an alist of + ;; mapping all subclasses of all classes on which those + ;; methods are specialized to the effective slot's + ;; location in that subclass. + (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m))) + methods)) + (alist (class-and-slot-location-alist classes name)) + (loc (cdar alist)) + (dt (gf.dispatch-table f))) + ;; Only try to handle the case where all slots have + ;; :allocation :instance (and all locations - the CDRs + ;; of the alist pairs - are small, positive fixnums. + (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist) + (when redefinable + (loop for (c . nil) in alist + do (note-class-dependent c f))) + (clear-gf-dispatch-table dt) + (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard + (cond ((null (cdr alist)) + ;; Method is only applicable to a single class. + (destructuring-bind (class . location) (car alist) + (setf (%svref dt %gf-dispatch-table-first-data) (%class.own-wrapper class) + (%svref dt (1+ %gf-dispatch-table-first-data)) location + (gf.dcode f) (dcode-for-gf f #'singleton-reader-dcode)))) + ((dolist (other (cdr alist) t) + (unless (eq (cdr other) loc) + (return))) + ;; All classes have the slot in the same location, + ;; by luck or design. + (cond + ((< (length alist) 10) + ;; Only a small number of classes, just do MEMQ + (setf (%svref dt %gf-dispatch-table-first-data) + (mapcar #'car alist) + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) (dcode-for-gf f #'reader-constant-location-dcode))) + ((null (cdr (setq classes (remove-subclasses-from-class-list classes)))) + ;; Lots of classes, all subclasses of a single class + (multiple-value-bind (dcode trampoline) + (make-reader-constant-location-inherited-from-single-class-dcode (%class-ordinal (car classes)) loc f) + (setf (gf.dcode f) dcode) + (replace-function-code f trampoline))) + (t + ;; Multple classes. We should probably check + ;; to see they're disjoint + (setf (%svref dt %gf-dispatch-table-first-data) + (mapcar #'%class-ordinal classes) + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) + (dcode-for-gf f #'reader-constant-location-inherited-from-multiple-classes-dcode))))) + (t + ;; Multiple classes; the slot's location varies. + (setf (%svref dt %gf-dispatch-table-first-data) + alist + + (gf.dcode f) (dcode-for-gf f #'reader-variable-location-dcode)))))))))))) + +;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T) +;;; specializers are all EQL specializers whose objects are symbols. +;;; The effective method applicable for each symbol is stored on the +;;; plist of the symbol under a property EQ to the dispatch table (which +;;; is mostly ignored, otherwise.) +(defun %%1st-arg-eql-method-hack-dcode (dt args) + (let* ((sym (if (listp args) (car args)(%lexpr-ref args (%lexpr-count args) 0))) + (mf (if (symbolp sym) (get sym dt)))) + (if mf + (if (listp args) + (apply mf args) + (%apply-lexpr-tail-wise mf args)) + ;;; Let %%1st-arg-dcode deal with it. + (%%1st-arg-dcode dt args)))) +(register-dcode-proto #'%%1st-arg-eql-method-hack-dcode *gf-proto*) + +(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2) + (let* ((mf (if (typep arg1 'symbol) (get arg1 dt)))) + (if mf + (funcall mf arg1 arg2) + (%%1st-two-arg-dcode dt arg1 arg2)))) +(register-dcode-proto #'%%1st-two-arg-eql-method-hack-dcode *gf-proto-two-arg*) + +(defun %%one-arg-eql-method-hack-dcode (dt arg) + (let* ((mf (if (typep arg 'symbol) (get arg dt)))) + (if mf + (funcall mf arg)))) +(register-dcode-proto #'%%one-arg-eql-method-hack-dcode *gf-proto-one-arg*) + +(defun install-eql-method-hack-dcode (gf) + (let* ((bits (inner-lfun-bits gf)) + (nreq (ldb $lfbits-numreq bits)) + (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits))) + (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (logbitp $lfbits-aok-bit bits)))) + (setf (%gf-dcode gf) + (dcode-for-gf gf + (cond ((and (eql nreq 1) (null other-args?)) + #'%%one-arg-eql-method-hack-dcode) + ((and (eql nreq 2) (null other-args?)) + #'%%1st-two-arg-eql-method-hack-dcode) + (t + #'%%1st-arg-eql-method-hack-dcode)))))) + +(defun maybe-hack-eql-methods (gf) + (let* ((methods (generic-function-methods gf))) + (when (and methods + (every #'(lambda (method) + (let* ((specializers (method-specializers method)) + (first (car specializers))) + (and (typep first 'eql-specializer) + (typep (eql-specializer-object first) 'symbol) + (dolist (s (cdr specializers) t) + (unless (eq s *t-class*) + (return nil))) + (null (cdr (compute-applicable-methods gf (cons (eql-specializer-object first) (make-list (length (cdr specializers)))))))))) + methods)) + (let* ((dt (%gf-dispatch-table gf))) + (dolist (m methods) + (let* ((sym (eql-specializer-object (car (method-specializers m)))) + (f (method-function m))) + (setf (get sym dt) f))) + (install-eql-method-hack-dcode gf) + t)))) + + + + +;;; Return a list of :after methods for INITIALIZE-INSTANCE on the +;;; class's prototype, and a boolean that's true if no other qualified +;;; methods are defined and at most one primary one. +(defun initialize-instance-after-methods (proto class) + (let* ((method-list (compute-method-list (sort-methods + (compute-applicable-methods #'initialize-instance (list proto)) + (list (class-precedence-list class)))))) + (if (atom method-list) + (values nil t) + (if (and (null (car method-list)) + (null (cdddr method-list))) + (values (cadr method-list) t) + ;; :around or :before methods, or more than one primary method, give up + (values nil nil))))) + +(defparameter *typecheck-slots-in-optimized-make-instance* t) + + +;;; Return a lambda form or NIL. +(defun make-instantiate-lambda-for-class-cell (cell) + (let* ((class (class-cell-class cell)) + (after-methods nil)) + (when (and (typep class 'standard-class) + (progn (unless (class-finalized-p class) + (finalize-inheritance class)) + t) + (null (cdr (compute-applicable-methods #'allocate-instance (list class)))) + (let* ((proto (class-prototype class))) + (and (multiple-value-bind (afters ok) + (initialize-instance-after-methods proto class) + (when ok + (setq after-methods afters) + t)) + (null (cdr (compute-applicable-methods #'shared-initialize (list proto t))))))) + (let* ((slotds (sort (copy-list (class-slots class)) + #'(lambda (x y) + (if (consp x) x (if (consp y) y (< x y)))) + :key #'slot-definition-location)) + (default-initargs (class-default-initargs class))) + (collect ((keys) + (binds) + (class-binds) + (ignorable) + (class-slot-inits) + (after-method-forms) + (forms)) + (flet ((generate-type-check (form type &optional spvar) + (if (or (null *typecheck-slots-in-optimized-make-instance*) + (eq type t) + (and (quoted-form-p type) (eq (cadr type) t))) + form + (if spvar + `(if ,spvar + (require-type ,form ',type) + ,form) + `(require-type ,form ',type))))) + (dolist (slot slotds) + (let* ((initargs (slot-definition-initargs slot)) + (initfunction (slot-definition-initfunction slot)) + (initform (slot-definition-initform slot)) + (location (slot-definition-location slot)) + (location-var nil) + (class-init-p nil) + (one-initarg-p (null (cdr initargs))) + (name (slot-definition-name slot)) + (type (slot-definition-type slot))) + (when (consp location) + (setq location-var (gensym "LOCATION"))) + (when initfunction + (setq initform + (if (self-evaluating-p initform) + initform + `(funcall ,initfunction)))) + (cond ((null initargs) + (let ((initial-value-form + (if initfunction + (generate-type-check initform type) + `(%slot-unbound-marker)))) + (if location-var + (when initfunction + (setq class-init-p t) + (class-slot-inits + `(when (eq (%slot-unbound-marker) (cdr ,location-var)) + (setf (cdr ,location-var) ,initial-value-form)))) + (forms initial-value-form)))) + (t (collect ((cond-clauses)) + (let ((last-cond-clause nil)) + (dolist (initarg initargs) + (let* ((spvar nil) + (name (if one-initarg-p + name + (gensym (string name)))) + (initial-value-form + (if (and initfunction + one-initarg-p + (null location-var)) + initform + (progn + (when initarg + (setq spvar (make-symbol + (concatenate + 'string + (string initarg) + "-P")))) + (and one-initarg-p + (null location-var) + (if initfunction + initform + `(%slot-unbound-marker)))))) + (default (assq initarg default-initargs)) + (default-value-form nil)) + (when spvar (ignorable spvar)) + (when default + (destructuring-bind (form function) + (cdr default) + (setq default-value-form + (if (or (quoted-form-p form) + (self-evaluating-p form)) + form + `(funcall ,function))))) + (keys (list* + (list initarg name) + (if (and default one-initarg-p (null location-var)) + default-value-form + initial-value-form) + (if spvar (list spvar)))) + (if one-initarg-p + (if location-var + (progn + (setq class-init-p t) + (class-slot-inits + `(if ,spvar + (setf (cdr ,location-var) + ,(generate-type-check + name type)) + ,(if default + `(setf (cdr ,location-var) + ,(generate-type-check + default type)) + (when initfunction + `(when (eq (%slot-unbound-marker) + (cdr ,location-var)) + (setf (cdr ,location-var) + ,(generate-type-check + initform type)))))))) + (forms `,(generate-type-check name type spvar))) + (progn (cond-clauses `(,spvar ,name)) + (when (and default (null last-cond-clause)) + (setq last-cond-clause + `(t ,default))))))) + (when (cond-clauses) + (when last-cond-clause + (cond-clauses last-cond-clause)) + (cond ((null location-var) + (unless last-cond-clause + (cond-clauses `(t ,initform))) + (forms (generate-type-check + `(cond ,@(cond-clauses)) + type))) + (t + (let ((initform-p-var + (unless last-cond-clause + (make-symbol "INITFORM-P"))) + (value-var (make-symbol "VALUE"))) + (unless last-cond-clause + (cond-clauses + `(t (setq ,initform-p-var t) + ,(if initfunction + initform + `(%slot-unbound-marker))))) + (setq class-init-p t) + (class-slot-inits + `(let* (,@(and initform-p-var + (list `(,initform-p-var nil))) + (,value-var + ,(generate-type-check + `(cond ,@(cond-clauses)) type))) + (when + ,(if initform-p-var + `(or (null ,initform-p-var) + (and (eq (cdr ,location-var) + (%slot-unbound-marker)) + (not (eq ,value-var + (%slot-unbound-marker))))) + t) + (setf (cdr ,location-var) ,value-var)))))))))))) + (when class-init-p + (class-binds `(,location-var + (load-time-value + (slot-definition-location ',slot)))))))) + (let* ((cell (make-symbol "CLASS-CELL")) + (args (make-symbol "ARGS")) + (slots (make-symbol "SLOTS")) + (instance (make-symbol "INSTANCE"))) + (dolist (after after-methods) + (after-method-forms `(apply ,(method-function after) ,instance ,args))) + (when after-methods + (after-method-forms instance)) + (binds `(,slots (gvector :slot-vector nil ,@(forms)))) + (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots))) + `(lambda (,cell ,@(when after-methods `(&rest ,args)) &key ,@(keys) ,@(when after-methods '(&allow-other-keys))) + (declare (ignorable ,@(ignorable))) + ,@(when after-methods `((declare (dynamic-extent ,args)))) + (let (,@(class-binds)) + ,@(class-slot-inits)) + (let* (,@(binds)) + (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance) + (%svref ,slots 0) ,instance) + ,@(after-method-forms))))))))) + +(defun optimize-make-instance-for-class-cell (cell) + (init-class-cell-instantiator cell) + (let* ((lambda (make-instantiate-lambda-for-class-cell cell))) + (when lambda + (setf (class-cell-instantiate cell) (compile nil lambda) + (class-cell-extra cell) (%class.own-wrapper + (class-cell-class cell))) + t))) + +(defun optimize-make-instance-for-class-name (class-name) + (optimize-make-instance-for-class-cell (find-class-cell class-name t))) + +(defun optimize-named-class-make-instance-methods () + (maphash (lambda (class-name class-cell) + (handler-case (optimize-make-instance-for-class-cell class-cell) + (error (c) + (warn "error optimizing make-instance for ~s:~&~a" + class-name c)))) + %find-classes%)) + +;; Redefined from bootstrapping verison in l1-clos-boot.lisp +;; Remove the make-instance optimization if the user is adding +;; a method on initialize-instance, allocate-instance, or shared-initialize +(defun maybe-remove-make-instance-optimization (gfn method) + (when (or (eq gfn #'allocate-instance) + (eq gfn #'initialize-instance) + (eq gfn #'shared-initialize)) + (let ((specializer (car (method-specializers method)))) + (when (typep specializer 'class) + (labels ((clear (class) + (pessimize-make-instance-for-class-name (class-name class)) + (dolist (sub (%class-direct-subclasses class)) + (clear sub)))) + (clear specializer)))))) + +;;; Iterate over all known GFs; try to optimize their dcode in cases +;;; involving reader methods. + +(defun snap-reader-methods (&key known-sealed-world + (check-conflicts t) + (optimize-make-instance t)) + (declare (ignore check-conflicts) + (ignore known-sealed-world)) + (when optimize-make-instance + (optimize-named-class-make-instance-methods)) + (let* ((ngf 0) + (nwin 0)) + (dolist (f (population.data %all-gfs%)) + (incf ngf) + (when (%snap-reader-method f) + (incf nwin))) + (values ngf nwin 0))) + +(defun register-non-dt-dcode-function (f) + (flet ((symbol-or-function-name (x) + (etypecase x + (symbol x) + (function (function-name x))))) + (let* ((already (member (symbol-or-function-name f) *non-dt-dcode-functions* :key #'symbol-or-function-name))) + (if already + (setf (car already) f) + (push f *non-dt-dcode-functions*)) + f))) + +(defun pessimize-clos () + ;; Undo MAKE-INSTANCE optimization + (maphash (lambda (class-name class-cell) + (declare (ignore class-name)) + (init-class-cell-instantiator class-cell)) + %find-classes%) + ;; Un-snap reader methods, undo other GF optimizations. + (dolist (f (population-data %all-gfs%)) + (let* ((dt (%gf-dispatch-table f))) + (clear-gf-dispatch-table dt) + (compute-dcode f)))) + +;;; If there's a single method (with standard method combination) on +;;; GF and all of that method's arguments are specialized to the T +;;; class - and if the method doesn't accept &key or do any +;;; next-method things - we can just have the generic function call +;;; the method-function +(defun dcode-for-universally-applicable-singleton (gf) + (when (eq (generic-function-method-combination gf) + *standard-method-combination*) + (let* ((methods (generic-function-methods gf)) + (method (car methods))) + (when (and method + (null (cdr methods)) + (null (method-qualifiers method)) + (not (logtest (logior (ash 1 $lfbits-keys-bit) + (ash 1 $lfbits-nextmeth-bit)) + (lfun-bits (method-function method)))) + (dolist (spec (method-specializers method) t) + (unless (eq spec *t-class*) + (return nil)))) + (method-function method))))) + +(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton) Index: /branches/qres/ccl/level-1/l1-dcode.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-dcode.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-dcode.lisp (revision 13564) @@ -0,0 +1,1962 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + + + + + +(defun %make-gf-instance (class &key + name + (method-combination *standard-method-combination* mcomb-p) + (method-class *standard-method-class* mclass-p) + declarations + (lambda-list nil ll-p) + (argument-precedence-order nil apo-p) + &allow-other-keys) + (when mcomb-p + (unless (typep method-combination 'method-combination) + (report-bad-arg method-combination 'method-combination))) + (when mclass-p + (if (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (subtypep method-class *method-class*) + (error "~s is not a subtype of ~s." method-class *method-class*))) + (when declarations + (unless (list-length declarations) + (error "~s is not a proper list" declarations))) + ;; Fix APO, lambda-list + (if apo-p + (if (not ll-p) + (error "Cannot specify ~s without specifying ~s" :argument-precedence-order + :lambda-list))) + (let* ((gf (%allocate-gf-instance class))) + (setf (sgf.name gf) name + (sgf.method-combination gf) method-combination + (sgf.methods gf) nil + (sgf.method-class gf) method-class + (sgf.decls gf) declarations + (sgf.%lambda-list gf) :unspecified + (sgf.dependents gf) nil) + (when ll-p + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + gf)) + +(defun gf-arg-info-valid-p (gf) + (let* ((bits (lfun-bits gf))) + (declare (fixnum bits)) + (not (and (logbitp $lfbits-aok-bit bits) + (not (logbitp $lfbits-keys-bit bits)))))) + +;;; Derive a GF lambda list from the method's lambda list. +(defun flatten-method-lambda-list (lambda-list) + (collect ((ll)) + (dolist (x lambda-list (ll)) + (if (atom x) + (if (eq x '&aux) + (return (ll)) + (ll x)) + (ll (car x)))))) + +(defun %maybe-compute-gf-lambda-list (gf method) + (let* ((gf-ll (sgf.%lambda-list gf))) + (if (eq gf-ll :unspecified) + (and method + (let* ((method-lambda-list (%method-lambda-list method)) + (method-has-&key (member '&key method-lambda-list)) + (method-has-&allow-other-keys + (member '&allow-other-keys method-lambda-list))) + (if method-has-&key + (nconc (ldiff method-lambda-list (cdr method-has-&key)) + (if method-has-&allow-other-keys + '(&allow-other-keys))) + (flatten-method-lambda-list method-lambda-list)))) + gf-ll))) + + +;;; Borrowed from PCL, sort of. We can encode required/optional/restp/keyp +;;; information in the gf's lfun-bits +(defun set-gf-arg-info (gf &key new-method (lambda-list nil lambda-list-p) + (argument-precedence-order nil apo-p)) + (let* ((methods (%gf-methods gf)) + (dt (%gf-dispatch-table gf)) + (gf-lfun-bits (lfun-bits gf)) + (first-method-p (and new-method (null methods)))) + (declare (fixnum gf-lfun-bits)) + (unless lambda-list-p + (setq lambda-list + (%maybe-compute-gf-lambda-list gf (or (car (last methods)) + new-method)))) + (when (or lambda-list-p + (and first-method-p + (eq (%gf-%lambda-list gf) :unspecified))) + (multiple-value-bind (newbits keyvect) + (encode-lambda-list lambda-list t) + (declare (fixnum newbits)) + (when (and methods (not first-method-p)) + (unless (and (= (ldb $lfbits-numreq gf-lfun-bits) + (ldb $lfbits-numreq newbits)) + (= (ldb $lfbits-numopt gf-lfun-bits) + (ldb $lfbits-numopt newbits)) + (eq (or (logbitp $lfbits-keys-bit gf-lfun-bits) + (logbitp $lfbits-rest-bit gf-lfun-bits) + (logbitp $lfbits-restv-bit gf-lfun-bits)) + (or (logbitp $lfbits-keys-bit newbits) + (logbitp $lfbits-rest-bit newbits) + (logbitp $lfbits-restv-bit newbits)))) + (cerror (format nil + "Remove ~d method~:p from the generic-function and ~ + change its lambda list." + (length (%gf-methods gf))) + "New lambda list of generic function ~s is not congruent ~ + with lambda lists of existing methods.~%~ + Generic-function's : ~s~%~ + Method's lambda-list : ~s~%" + gf lambda-list (%method-lambda-list (car methods))) + (loop + (let ((methods (%gf-methods gf))) + (if methods + (remove-method gf (car methods)) + (return)))) + (%set-defgeneric-keys gf nil))) + (when lambda-list-p + (setf (%gf-%lambda-list gf) lambda-list + (%gf-dispatch-table-keyvect dt) keyvect)) + (when (and apo-p lambda-list-p) + (let* ((old-precedence-list (%gf-dispatch-table-precedence-list dt))) + (setf (%gf-dispatch-table-precedence-list dt) + (canonicalize-argument-precedence-order + argument-precedence-order + (required-lambda-list-args lambda-list))) + (unless (equal old-precedence-list + (%gf-dispatch-table-precedence-list dt)) + (clear-gf-dispatch-table dt)))) + (lfun-bits gf (logior (ash 1 $lfbits-gfn-bit) + (logand $lfbits-args-mask newbits))))) + (when new-method + (check-defmethod-congruency gf new-method)))) + +(defun %gf-name (gf &optional (new-name nil new-name-p)) + (let* ((old-name (%standard-generic-function-instance-location-access + gf sgf.name))) + (if new-name-p + (setf (sgf.name gf) new-name)) + (unless (eq old-name (%slot-unbound-marker)) + old-name))) + + + + +(defun make-n+1th-arg-combined-method (methods gf argnum) + (let ((table (make-gf-dispatch-table))) + (setf (%gf-dispatch-table-methods table) methods + (%gf-dispatch-table-argnum table) (%i+ 1 argnum)) + (let ((self (%cons-combined-method gf table #'%%nth-arg-dcode))) ; << + (setf (%gf-dispatch-table-gf table) self) + self))) + +;;; Bring the generic function to the smallest possible size by removing +;;; any cached recomputable info. Currently this means clearing out the +;;; combined methods from the dispatch table. + +(defun clear-gf-cache (gf) + #-bccl (unless t (typep gf 'standard-generic-function) + (report-bad-arg gf 'standard-generic-function)) + (let ((dt (%gf-dispatch-table gf))) + (if (eq (%gf-dispatch-table-size dt) *min-gf-dispatch-table-size*) + (clear-gf-dispatch-table dt) + (let ((new (make-gf-dispatch-table))) + (setf (%gf-dispatch-table-methods new) (%gf-dispatch-table-methods dt)) + (setf (%gf-dispatch-table-precedence-list new) + (%gf-dispatch-table-precedence-list dt)) + (setf (%gf-dispatch-table-gf new) gf) + (setf (%gf-dispatch-table-keyvect new) + (%gf-dispatch-table-keyvect dt)) + (setf (%gf-dispatch-table-argnum new) (%gf-dispatch-table-argnum dt)) + (setf (%gf-dispatch-table gf) new))))) + +(defun %gf-dispatch-table-store-conditional (dt index new) + "Returns T if the new value can be stored in DT at INDEX, replacing a NIL. + Returns NIL - without storing anything - if the value already in DT + at INDEX is non-NIL at the time of the store." + (let ((offset (+ (ash (%i+ index %gf-dispatch-table-first-data) + target::word-shift) + target::misc-data-offset))) + (or (%store-node-conditional offset dt nil new) + (%store-node-conditional offset dt *gf-dispatch-bug* new)))) + +(defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p) + ;; Grow the table associated with gf and insert table-entry as the value for + ;; wrapper. Wrapper is a class-wrapper. Assumes that it is not obsolete. + (let* ((dt (if (generic-function-p gf-or-cm) + (%gf-dispatch-table gf-or-cm) + (%combined-method-methods gf-or-cm))) + (size (%gf-dispatch-table-size dt)) + (new-size (if obsolete-wrappers-p + size + (%i+ size size))) + new-dt) + (if (> new-size *max-gf-dispatch-table-size*) + (progn + (setq new-dt (clear-gf-dispatch-table dt) + *gf-dt-ovf-cnt* (%i+ *gf-dt-ovf-cnt* 1))) + (progn + (setq new-dt (make-gf-dispatch-table new-size)) + (setf (%gf-dispatch-table-methods new-dt) (%gf-dispatch-table-methods dt) + (%gf-dispatch-table-precedence-list new-dt) (%gf-dispatch-table-precedence-list dt) + (%gf-dispatch-table-keyvect new-dt) (%gf-dispatch-table-keyvect dt) + (%gf-dispatch-table-gf new-dt) gf-or-cm + (%gf-dispatch-table-argnum new-dt) (%gf-dispatch-table-argnum dt)) + (let ((i 0) index w cm) + (dotimes (j (%ilsr 1 (%gf-dispatch-table-size dt))) + (declare (fixnum j)) + (unless (or (null (setq w (%gf-dispatch-table-ref dt i))) + (eql 0 (%wrapper-hash-index w)) + (no-applicable-method-cm-p + (setq cm (%gf-dispatch-table-ref dt (%i+ i 1))))) + (setq index (find-gf-dispatch-table-index new-dt w t)) + (setf (%gf-dispatch-table-ref new-dt index) w) + (setf (%gf-dispatch-table-ref new-dt (%i+ index 1)) cm)) + (setq i (%i+ i 2)))))) + (let ((index (find-gf-dispatch-table-index new-dt wrapper t))) + (setf (%gf-dispatch-table-ref new-dt index) wrapper) + (setf (%gf-dispatch-table-ref new-dt (%i+ index 1)) table-entry)) + (if (generic-function-p gf-or-cm) + (setf (%gf-dispatch-table gf-or-cm) new-dt) + (setf (%combined-method-methods gf-or-cm) new-dt)))) + + +(defun inner-lfun-bits (function &optional value) + (lfun-bits (closure-function function) value)) + + + +;;; probably want to use alists vs. hash-tables initially + + +;;; only used if error - well not really +(defun collect-lexpr-args (args first &optional last) + (if (listp args) + (subseq args first (or last (length args))) + (let ((res nil)) + (when (not last)(setq last (%lexpr-count args))) + (dotimes (i (- last first)) + (setq res (push (%lexpr-ref args last (+ first i)) res))) + (nreverse res)))) + + + + +(defmacro with-list-from-lexpr ((list lexpr) &body body) + (let ((len (gensym))) + `(let* ((,len (%lexpr-count ,lexpr)) + (,list (make-list ,len))) + (declare (dynamic-extent ,list) (fixnum ,len)) + (do* ((i 0 (1+ i)) + (ls ,list (cdr ls))) + ((= i ,len) ,list) + (declare (fixnum i) (list ls)) + (declare (optimize (speed 3)(safety 0))) + (%rplaca ls (%lexpr-ref ,lexpr ,len i))) + ,@body))) + + + +(defmacro %standard-instance-p (i) + `(eq (typecode ,i) ,(type-keyword-code :instance))) + + + +(declaim (inline %find-1st-arg-combined-method)) +(declaim (inline %find-nth-arg-combined-method)) + + + + +(defun %find-1st-arg-combined-method (dt arg) + (let ((wrapper (instance-class-wrapper arg))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance arg) + (setq wrapper (instance-class-wrapper arg))) + (let* ((mask (%gf-dispatch-table-mask dt)) + (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper)))) + table-wrapper flag) + (declare (fixnum index mask)) + (loop + (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper) + (return (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (progn + (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (if (or (neq table-wrapper (%unbound-marker)) + (eql 0 flag)) + (without-interrupts ; why? + (return (1st-arg-combined-method-trap (%gf-dispatch-table-gf dt) wrapper arg))) ; the only difference? + (setq flag 0 index -2))) + (setq index (+ 2 index)))))))) + +;;; for calls from outside - e.g. stream-reader +(defun find-1st-arg-combined-method (gf arg) + (declare (optimize (speed 3)(safety 0))) + (%find-1st-arg-combined-method (%gf-dispatch-table gf) arg)) + + +;;; more PC - it it possible one needs to go round more than once? - +;;; seems unlikely +(defun %find-nth-arg-combined-method (dt arg args) + (declare (optimize (speed 3)(safety 0))) + (let ((wrapper (instance-class-wrapper arg))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance arg) + (setq wrapper (instance-class-wrapper arg))) + (let* ((mask (%gf-dispatch-table-mask dt)) + (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper)))) + table-wrapper flag) + (declare (fixnum index mask)) + (loop + (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper) + (return (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (progn + (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (if (or (neq table-wrapper (%unbound-marker)) + (eql 0 flag)) + (without-interrupts ; why? + (let ((gf (%gf-dispatch-table-gf dt))) + (if (listp args) + (return (nth-arg-combined-method-trap-0 gf dt wrapper args)) + (with-list-from-lexpr (args-list args) + (return (nth-arg-combined-method-trap-0 gf dt wrapper args-list)))))) + (setq flag 0 index -2))) + (setq index (+ 2 index)))))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;; Generic functions and methods ;;;;;;;;;;;;;;;;;;;; +(defun %class-cpl (class) + (if (%standard-instance-p class) + (%class.cpl class) + (or + (and (typep class 'macptr) + (let* ((slots (foreign-slots-vector class))) + (and slots (%slot-ref slots %class.cpl)))) + (error "Can't determine CPL of class ~s" class)))) + + +(defun standard-method-p (thing) + (when (%standard-instance-p thing) + (let* ((cpl (%class-cpl (%wrapper-class (instance.class-wrapper thing)))) + (smc *standard-method-class*)) + (dolist (c cpl) + (if (eq c smc)(return t)))))) + + + +(defun %method-function-p (thing) + (when (functionp thing) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (logbitp $lfbits-method-bit bits)))) + + + + +(setf (type-predicate 'standard-generic-function) 'standard-generic-function-p) +(setf (type-predicate 'combined-method) 'combined-method-p) + +(setf (type-predicate 'standard-method) 'standard-method-p) + +;; Maybe we shouldn't make this a real type... +(setf (type-predicate 'method-function) '%method-function-p) + + +(defvar %all-gfs% (%cons-population nil)) + + +(eval-when (:compile-toplevel :execute) +(defconstant $lfbits-numinh-mask (logior (dpb -1 $lfbits-numinh 0) + (%ilsl $lfbits-nonnullenv-bit 1))) +) + + +#+ppc-target +(defvar *fi-trampoline-code* (uvref #'funcallable-trampoline 0)) + + +#+ppc-target +(defvar *unset-fin-code* (uvref #'unset-fin-trampoline 0)) + + + +#+ppc-target +(defvar *gf-proto-code* (uvref *gf-proto* 0)) + +;;; The "early" version of %ALLOCATE-GF-INSTANCE. +(setf (fdefinition '%allocate-gf-instance) + #'(lambda (class) + (declare (ignorable class)) + (setq class *standard-generic-function-class*) + (let* ((wrapper (%class.own-wrapper class)) + (len (length #.(%wrapper-instance-slots (class-own-wrapper + *standard-generic-function-class*)))) + (dt (make-gf-dispatch-table)) + (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker))) + (fn #+ppc-target + (gvector :function + *gf-proto-code* + wrapper + slots + dt + #'%%0-arg-dcode + 0 + (%ilogior (%ilsl $lfbits-gfn-bit 1) + (%ilogand $lfbits-args-mask 0))) + #+x86-target + (%clone-x86-function *gf-proto* + wrapper + slots + dt + #'%%0-arg-dcode + 0 + (%ilogior (%ilsl $lfbits-gfn-bit 1) + (%ilogand $lfbits-args-mask 0))))) + (setf ;(gf.hash fn) (strip-tag-to-fixnum fn) + (slot-vector.instance slots) fn + (%gf-dispatch-table-gf dt) fn) + (push fn (population.data %all-gfs%)) + fn))) + + + + + + + + + +(defparameter *gf-proto-one-arg* #'gag-one-arg) +(defparameter *gf-proto-two-arg* #'gag-two-arg) + + + + +#+ppc-target +(defvar *cm-proto-code* (uvref *cm-proto* 0)) + +(defun %cons-combined-method (gf thing dcode) + ;; set bits and name = gf + #+ppc-target + (gvector :function + *cm-proto-code* + thing + dcode + gf + (%ilogior (%ilsl $lfbits-cm-bit 1) + (%ilogand $lfbits-args-mask (lfun-bits gf)))) + #+x86-target + (%clone-x86-function *cm-proto* + thing + dcode + gf + (%ilogior (%ilsl $lfbits-cm-bit 1) + (%ilogand $lfbits-args-mask (lfun-bits gf))))) + +(defun %gf-dispatch-table (gf) + ;(require-type gf 'standard-generic-function) + (gf.dispatch-table gf)) + +(defun %gf-dcode (gf) + ;(require-type gf 'standard-generic-function) + (gf.dcode gf)) + +(defun %set-gf-dcode (gf dcode) + (let ((gf (require-type gf 'funcallable-standard-object)) + (dcode (require-type dcode 'function))) + (replace-function-code gf (or (cdr (assq dcode dcode-proto-alist)) + #'funcallable-trampoline)) + (setf (gf.dcode gf) dcode))) + +(defun %set-gf-dispatch-table (gf val) + (setf (gf.dispatch-table gf) val)) + +(defun %combined-method-methods (cm) + ;(require-type cm 'combined-method) + (combined-method.thing cm)) + +(defun %combined-method-dcode (cm) + ;(require-type cm 'combined-method) + (combined-method.dcode cm)) + +(defun %set-combined-method-methods (cm val) + (setf (combined-method.thing cm) val)) + +(defun %set-combined-method-dcode (cm val) + (setf (combined-method.dcode cm) val)) + +(declaim (inline funcallable-instance-p)) +(defun funcallable-instance-p (thing) + (when (typep thing 'function) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (eq (ash 1 $lfbits-gfn-bit) + (logand bits (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-method-bit))))))) + +(setf (type-predicate 'funcallable-standard-object) 'funcallable-instance-p) + +(defstatic *generic-function-class-wrapper* nil) +(defstatic *standard-generic-function-class-wrapper* nil) + +(defun generic-function-p (thing) + (and (typep thing 'funcallable-standard-object) + (let* ((wrapper (gf.instance.class-wrapper thing))) + ;; In practice, many generic-functions are standard-generic-functions. + (or (eq *standard-generic-function-class-wrapper* wrapper) + (eq *generic-function-class-wrapper* wrapper) + (let* ((bits (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))) + (ordinal (%wrapper-class-ordinal *generic-function-class-wrapper*))) + (and bits ordinal + (locally (declare (simple-bit-vector bits) + (fixnum ordinal) + (optimize (speed 3) (safety 0))) + (and (< ordinal (length bits)) + (eql 1 (sbit bits ordinal)))))))))) + + +(defun standard-generic-function-p (thing) + (and (typep thing 'function) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (eq (ash 1 $lfbits-gfn-bit) + (logand bits (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-method-bit))))) + (or (eq (%class.own-wrapper *standard-generic-function-class*) + (gf.instance.class-wrapper thing)) + (memq *standard-generic-function-class* + (%inited-class-cpl (class-of thing)))))) + + +(defun combined-method-p (thing) + (when (functionp thing) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (eq (ash 1 $lfbits-cm-bit) + (logand bits + (logior (ash 1 $lfbits-cm-bit) + (ash 1 $lfbits-method-bit))))))) + +(setf (type-predicate 'generic-function) 'generic-function-p) + +(setf (type-predicate 'standard-generic-function) 'standard-generic-function-p) +(setf (type-predicate 'funcallable-standard-object) 'funcallable-instance-p) +(setf (type-predicate 'combined-method) 'combined-method-p) + + + +;;; A generic-function looks like: +;;; +;;; header | trampoline | dispatch-table | dcode | name | bits +;;; %svref : 0 1 2 3 4 +;;; +;;; The trampoline is *gf-proto*'s code vector. +;;; The dispatch-table and dcode are sort of settable closed-over variables. + +(defsetf %gf-dispatch-table %set-gf-dispatch-table) + +(defun %gf-methods (gf) + (sgf.methods gf)) + +(defun %gf-precedence-list (gf) + (%gf-dispatch-table-precedence-list (%gf-dispatch-table gf))) + +(defun %gf-%lambda-list (gf) + (sgf.%lambda-list gf)) + +(defun (setf %gf-%lambda-list) (new gf) + (setf (sgf.%lambda-list gf) new)) + +;;; Returns INSTANCE if it is either a standard instance of a +;;; standard gf, else nil. +(defun %maybe-gf-instance (instance) + (if (or (standard-generic-function-p instance) + (%standard-instance-p instance)) + instance)) + +(defsetf %gf-dcode %set-gf-dcode) + +(defun %gf-method-class (gf) + (sgf.method-class gf)) + + +(defun %gf-method-combination (gf) + (sgf.method-combination gf)) + +; need setters too + +(defsetf %combined-method-methods %set-combined-method-methods) + +(defparameter *min-gf-dispatch-table-size* 2 + "The minimum size of a generic-function dispatch table") + +(defun make-gf-dispatch-table (&optional (size *min-gf-dispatch-table-size*)) + (when (<= size 0) (report-bad-arg size '(integer 1))) + (setq size (%imax (%ilsl (%i- (integer-length (%i+ size size -1)) + 1) + 1) ; next power of 2 + *min-gf-dispatch-table-size*)) + (let ((res (%cons-gf-dispatch-table size))) + (declare (optimize (speed 3) (safety 0))) + (setf (%gf-dispatch-table-mask res) (%i- (%ilsr 1 size) 1) + (%gf-dispatch-table-argnum res) 0 + (%gf-dispatch-table-ref res size) (%unbound-marker)) + res)) + +;;; I wanted this to be faster - I didn't +(defun clear-gf-dispatch-table (dt) + (let ((i %gf-dispatch-table-first-data)) + (dotimes (j (%gf-dispatch-table-size dt)) + (declare (fixnum j)) + (setf (%svref dt i) nil + i (%i+ i 1))) + (setf (%svref dt i) (%unbound-marker)) ; paranoia... + (setf (svref dt (%i+ 1 i)) nil)) + dt) + + +; Remove all combined-methods from the world +(defun clear-all-gf-caches () + (dolist (f (population-data %all-gfs%)) + (clear-gf-cache f)) + (clrhash *combined-methods*) + nil) + + +;;; Searches for an empty slot in dt at the hash-index for wrapper. +;;; Returns nil if the table was full. +(defun find-gf-dispatch-table-index (dt wrapper &optional skip-full-check?) + (let ((contains-obsolete-wrappers-p nil) + (mask (%gf-dispatch-table-mask dt))) + (declare (fixnum mask)) + (unless skip-full-check? + (let* ((size (1+ mask)) + (max-count (- size (the fixnum (ash (the fixnum (+ size 3)) -2)))) + (index 0) + (count 0)) + (declare (fixnum size max-count index count)) + (dotimes (i size) + (declare (fixnum i)) + (let ((wrapper (%gf-dispatch-table-ref dt index))) + (if wrapper + (if (eql 0 (%wrapper-hash-index wrapper)) + (setf contains-obsolete-wrappers-p t + (%gf-dispatch-table-ref dt index) *obsolete-wrapper* + (%gf-dispatch-table-ref dt (1+ index)) *gf-dispatch-bug*) + (setq count (%i+ count 1))))) + (setq index (%i+ index 2))) + (when (> count max-count) + (return-from find-gf-dispatch-table-index (values nil contains-obsolete-wrappers-p))))) + (let* ((index (ash (logand mask (%wrapper-hash-index wrapper)) 1)) + (flag nil) + table-wrapper) + (values + (loop + (while (and (neq wrapper + (setq table-wrapper (%gf-dispatch-table-ref dt index))) + (%gf-dispatch-table-ref dt (1+ index)) + (neq 0 (%wrapper-hash-index table-wrapper))) + (setq index (%i+ index 2))) + (if (eq (%unbound-marker) table-wrapper) + (if flag + (return nil) ; table full + (setq flag 1 + index 0)) + (return index))) + contains-obsolete-wrappers-p)))) + + +(defvar *obsolete-wrapper* #(obsolete-wrapper 0)) +(defvar *gf-dispatch-bug* + #'(lambda (&rest rest) + (declare (ignore rest)) + (error "Generic-function dispatch bug!"))) + + +;;; This maximum is necessary because of the 32 bit arithmetic in +;;; find-gf-dispatch-table-index. +(defparameter *max-gf-dispatch-table-size* (expt 2 16)) +(defvar *gf-dt-ovf-cnt* 0) ; overflow count + +(defvar *no-applicable-method-hash* nil) + + +(let* ((eql-specializers-lock (make-lock)) + (eql-specializers-hash (make-hash-table :test #'eql))) + (defun intern-eql-specializer (object) + (with-lock-grabbed (eql-specializers-lock) + (or (gethash object eql-specializers-hash) + (setf (gethash object eql-specializers-hash) + (make-instance 'eql-specializer :object object)))))) + + +(setq *no-applicable-method-hash* (make-hash-table :test 'eq :size 0 :weak :key)) + + +(defun make-no-applicable-method-function (gf) + (if *no-applicable-method-hash* + (progn + (or (gethash gf *no-applicable-method-hash*)) + (setf (gethash gf *no-applicable-method-hash*) + (%cons-no-applicable-method gf))) + (%cons-no-applicable-method gf))) + +(defun %cons-no-applicable-method (gf) + (%cons-combined-method gf gf #'%%no-applicable-method)) + +; Returns true if F is a combined-method that calls no-applicable-method +(defun no-applicable-method-cm-p (f) + (and (typep f 'combined-method) + (eq '%%no-applicable-method + (function-name (%combined-method-dcode f))))) + + +(defun %%no-applicable-method (gf args) + (if (listp args) + (apply #'no-applicable-method gf args) + (%apply-lexpr #'no-applicable-method gf args ))) + +;;; if obsolete-wrappers-p is true, will rehash instead of grow. +;;; It would be better to do the rehash in place, but I'm lazy today. + + +(defun arg-wrapper (arg) + (or (standard-object-p arg) + (%class.own-wrapper (class-of arg)) + (error "~a has no wrapper" arg))) + +;;;;;;;;;;;;;;;;;;;;;;;;; generic-function dcode ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; dcode functions using other than *gf-proto* +(defparameter dcode-proto-alist ()) + +(defun register-dcode-proto (dcode proto) + (let ((a (assoc dcode dcode-proto-alist))) + (if a + (setf (cdr a) proto) + (push (cons dcode proto) dcode-proto-alist)))) + + +;;; Simple case for generic-functions with no specializers +;;; Why anyone would want to do this I can't imagine. + +(defun %%0-arg-dcode (dispatch-table args) ; need to get gf from table + (let ((method (or (%gf-dispatch-table-ref dispatch-table 1) + (0-arg-combined-method-trap + (%gf-dispatch-table-gf dispatch-table))))) + (if (not (listp args)) + (progn + (%apply-lexpr-tail-wise method args)) + (apply method args)))) + +(register-dcode-proto #'%%0-arg-dcode *gf-proto*) + +(defun dcode-too-few-args (arg-count cm-or-gf) + (error (make-condition 'too-few-arguments + :nargs arg-count + :fn (combined-method-gf cm-or-gf)))) + + + +(defun %%1st-arg-dcode (dt args) + ;(declare (dynamic-extent args)) + (if (not (listp args)) + (let* ((args-len (%lexpr-count args))) + (if (neq 0 args-len) + (let ((method (%find-1st-arg-combined-method dt (%lexpr-ref args args-len 0)))) + (%apply-lexpr-tail-wise method args)) + (dcode-too-few-args 0 (%gf-dispatch-table-gf dt)))) + (let* () ; happens if traced + (when (null args) (dcode-too-few-args 0 (%gf-dispatch-table-gf dt))) + (let ((method (%find-1st-arg-combined-method dt (%car args)))) + (apply method args))))) +(register-dcode-proto #'%%1st-arg-dcode *gf-proto*) + +(defun %%one-arg-dcode (dt arg) + (let ((method (%find-1st-arg-combined-method dt arg))) + (funcall method arg))) +(register-dcode-proto #'%%one-arg-dcode *gf-proto-one-arg*) + +;;; two args - specialized on first +(defun %%1st-two-arg-dcode (dt arg1 arg2) + (let ((method (%find-1st-arg-combined-method dt arg1))) + (funcall method arg1 arg2))) +(register-dcode-proto #'%%1st-two-arg-dcode *gf-proto-two-arg*) + + +;;; arg is dispatch-table and argnum is in the dispatch table +(defun %%nth-arg-dcode (dt args) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (%gf-dispatch-table-argnum dt))) + (declare (fixnum args-len argnum)) + (when (>= argnum args-len) (dcode-too-few-args args-len (%gf-dispatch-table-gf dt))) + (let ((method (%find-nth-arg-combined-method dt (nth argnum args) args))) + (apply method args))) + (let* ((args-len (%lexpr-count args)) + (argnum (%gf-dispatch-table-argnum dt))) + (declare (fixnum args-len argnum)) + (when (>= argnum args-len) (dcode-too-few-args args-len (%gf-dispatch-table-gf dt))) + (let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args args-len argnum) args))) + (%apply-lexpr-tail-wise method args))))) +(register-dcode-proto #'%%nth-arg-dcode *gf-proto*) + +(defun 0-arg-combined-method-trap (gf) + (let* ((methods (%gf-methods gf)) + (mc (%gf-method-combination gf)) + (cm (if (eq mc *standard-method-combination*) + (make-standard-combined-method methods nil gf) + (compute-effective-method-function + gf + mc + (sort-methods (copy-list methods) nil))))) + (setf (%gf-dispatch-table-ref (%gf-dispatch-table gf) 1) cm) + cm)) + +(defun compute-effective-method-function (gf mc methods) + (if methods + (compute-effective-method gf mc methods) + (make-no-applicable-method-function gf))) + +(defun 1st-arg-combined-method-trap (gf wrapper arg) + ;; Here when we can't find the method in the dispatch table. + ;; Compute it and add it to the table. This code will remain in Lisp. + (let ((table (%gf-dispatch-table gf)) + (combined-method (compute-1st-arg-combined-method gf arg wrapper))) + (multiple-value-bind (index obsolete-wrappers-p) + (find-gf-dispatch-table-index table wrapper) + (if index + (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method) + (setf (%gf-dispatch-table-ref table index) wrapper)) + (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p))) + combined-method)) + +(defvar *cpl-classes* nil) + +(defun %inited-class-cpl (class &optional initialize-can-fail) + (or (%class-cpl class) + (if (memq class *cpl-classes*) + (compute-cpl class) + (let ((*cpl-classes* (cons class *cpl-classes*))) + (declare (dynamic-extent *cpl-classes*)) + (update-class class initialize-can-fail) + (%class-cpl class))))) + + +(defun compute-1st-arg-combined-method (gf arg &optional + (wrapper (arg-wrapper arg))) + (let* ((methods (%gf-dispatch-table-methods (%gf-dispatch-table gf))) + (cpl (%inited-class-cpl (%wrapper-class wrapper))) + (method-combination (%gf-method-combination gf)) + applicable-methods eql-methods specializer) + (dolist (method methods) + (setq specializer (%car (%method.specializers method))) + (if (typep specializer 'eql-specializer) + (when (cpl-memq (%wrapper-class (arg-wrapper (eql-specializer-object specializer))) cpl) + (push method eql-methods)) + (when (cpl-memq specializer cpl) + (push method applicable-methods)))) + (if (null eql-methods) + (if (eq method-combination *standard-method-combination*) + (make-standard-combined-method applicable-methods (list cpl) gf) + (compute-effective-method-function + gf + method-combination + (sort-methods applicable-methods + (list cpl) + (%gf-precedence-list gf)))) + (make-eql-combined-method + eql-methods applicable-methods (list cpl) gf 0 nil method-combination)))) + + + +(defvar *combined-methods* (make-hash-table :test 'equal :weak :value)) + +(defun gethash-combined-method (key) + (gethash key *combined-methods*)) + +(defun puthash-combined-method (key value) + (setf (gethash key *combined-methods*) value)) + +;;; Some statistics on the hash table above +(defvar *returned-combined-methods* 0) +(defvar *consed-combined-methods* 0) + +;;; Assumes methods are already sorted if cpls is nil +(defun make-standard-combined-method (methods cpls gf &optional + (ok-if-no-primaries (null methods))) + (unless (null cpls) + (setq methods (sort-methods + methods cpls (%gf-precedence-list (combined-method-gf gf))))) + (let* ((keywords (compute-allowable-keywords-vector gf methods)) + (combined-method (make-standard-combined-method-internal + methods gf keywords ok-if-no-primaries))) + (if (and keywords methods) + (make-keyword-checking-combined-method gf combined-method keywords) + combined-method))) + + +;;; Initialized below after the functions exist. +(defvar *clos-initialization-functions* nil) + +;;; Returns NIL if all keywords allowed, or a vector of the allowable ones. +(defun compute-allowable-keywords-vector (gf methods) + (setq gf (combined-method-gf gf)) + (unless (memq gf *clos-initialization-functions*) + (let* ((gbits (inner-lfun-bits gf)) + (&key-mentioned-p (logbitp $lfbits-keys-bit gbits))) + (unless (or (logbitp $lfbits-aok-bit gbits) + (dolist (method methods) + (let ((mbits (lfun-bits (%method.function method)))) + (when (logbitp $lfbits-keys-bit mbits) + (setq &key-mentioned-p t) + (if (logbitp $lfbits-aok-bit mbits) + (return t))))) + (not &key-mentioned-p)) + (let (keys) + (flet ((adjoin-keys (keyvect keys) + (when keyvect + (dovector (key keyvect) (pushnew key keys))) + keys)) + (when (logbitp $lfbits-keys-bit gbits) + (setq keys (adjoin-keys (%defgeneric-keys gf) keys))) + (dolist (method methods) + (let ((f (%inner-method-function method))) + (when (logbitp $lfbits-keys-bit (lfun-bits f)) + (setq keys (adjoin-keys (lfun-keyvect f) keys)))))) + (apply #'vector keys)))))) + + +(defun make-keyword-checking-combined-method (gf combined-method keyvect) + (let* ((bits (inner-lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (key-index (+ numreq (ldb $lfbits-numopt bits)))) + (%cons-combined-method + gf + (vector key-index keyvect combined-method) + #'%%check-keywords))) + + + +(defun odd-keys-error (varg l) + (let ((gf (combined-method-gf (%svref varg 2)))) + (signal-program-error "Odd number of keyword args to ~s~%keyargs: ~s" gf l))) + + +(defun bad-key-error (key varg l) + (let* ((keys (%svref varg 1)) + (gf (combined-method-gf (%svref varg 2))) + (*print-array* t) + (*print-readably* t) + (readable-keys (format nil "~s" keys))) + (signal-program-error "Bad keyword ~s to ~s.~%keyargs: ~s~%allowable keys are ~a." key gf l readable-keys))) + +; vector arg is (vector key-index keyvect combined-method) ; the next combined method + +(defun %%check-keywords (vector-arg args) + (flet ((do-it (vector-arg args) + (let* ((args-len (length args)) + (keyvect (%svref vector-arg 1)) + (keyvect-len (length keyvect)) + (key-index (%svref vector-arg 0))) + ; vector arg is (vector key-index keyvect combined-method) ; the next combined method + (declare (fixnum args-len key-index keyvect-len)) + (when (>= args-len key-index) + (let* ((keys-in (- args-len key-index))) ; actually * 2 + (declare (fixnum key-index keys-in keyvect-len)) + (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len))) + (unless (%cadr (%pl-search (nthcdr key-index args) :allow-other-keys)) + (do ((i key-index (+ i 2)) + (kargs (nthcdr key-index args) (cddr kargs))) + ((eq i args-len)) + (declare (fixnum i)) + (let ((key (car kargs))) + (when (not (or (eq key :allow-other-keys) + (dotimes (i keyvect-len nil) + (if (eq key (%svref keyvect i)) + (return t))))) + (bad-key-error key vector-arg (collect-lexpr-args args key-index args-len)) + )))))) + (let ((method (%svref vector-arg 2))) + ; magic here ?? not needed + (apply method args))))) + (if (listp args) + (do-it vector-arg args) + (with-list-from-lexpr (args-list args) + (do-it vector-arg args-list))))) + + + + + + +;;; called from %%call-next-method-with-args - its the key-or-init-fn +;;; called from call-next-method-with-args - just check the blooming keys +;;; dont invoke any methods - maybe use x%%check-keywords with last vector elt nil +; means dont call any methods - but need the gf or method for error message +(defun x-%%check-keywords (vector-arg ARGS) + ;(declare (dynamic-extent args)) + ; vector arg is (vector key-index keyvect unused) + (let* ((ARGS-LEN (length args)) + (keyvect (%svref vector-arg 1)) + (keyvect-len (length keyvect)) + (key-index (%svref vector-arg 0)) + (keys-in (- args-len key-index)) + aok) ; actually * 2 + (declare (fixnum args-len key-index keys-in keyvect-len)) + + (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len))) + (do ((i key-index (+ i 2)) + (kargs (nthcdr key-index args) (cddr kargs))) + ((eq i args-len)) + (declare (fixnum i)) + (when aok (return)) + (let ((key (car kargs))) + (when (and (eq key :allow-other-keys) + (cadr kargs)) + (return)) + (when (not (dotimes (i keyvect-len nil) + (if (eq key (%svref keyvect i)) + (return t)))) + ; not found - is :allow-other-keys t in rest of user args + (when (not (do ((remargs kargs (cddr remargs))) + ((null remargs) nil) + (when (and (eq (car remargs) :allow-other-keys) + (cadr remargs)) + (setq aok t) + (return t)))) + (bad-key-error key vector-arg + (collect-lexpr-args args key-index args-len)))))))) +#| ; testing +(setq keyvect #(:a :b )) +(setq foo (make-array 3)) +(setf (aref foo 0) keyvect (aref foo 1) 2) +(setf (aref foo 2)(method window-close (window))) +( %%check-keywords 1 2 :a 3 :c 4 foo) +( %%check-keywords 1 2 :a 3 :b 4 :d foo) +|# + + + + + +;;; Map an effective-method to it's generic-function. +;;; This is only used for effective-method's which are not combined-method's +;;; (e.g. those created by non-STANDARD method-combination) +(defvar *effective-method-gfs* (make-hash-table :test 'eq :weak :key)) + + +(defun get-combined-method (method-list gf) + (let ((cm (gethash-combined-method method-list))) + (when cm + (setq gf (combined-method-gf gf)) + (if (combined-method-p cm) + (and (eq (combined-method-gf cm) gf) cm) + (and (eq (gethash cm *effective-method-gfs*) gf) cm))))) + +(defun put-combined-method (method-list cm gf) + (unless (%method-function-p cm) ; don't bother with non-combined methods + (puthash-combined-method method-list cm) + (unless (combined-method-p cm) + (setf (gethash cm *effective-method-gfs*) (combined-method-gf gf)))) + cm) + +(defun make-standard-combined-method-internal (methods gf &optional + keywords + (ok-if-no-primaries + (null methods))) + (let ((method-list (and methods (compute-method-list methods nil)))) + (if method-list ; no applicable primary methods + (if (atom method-list) + (%method.function method-list) ; can jump right to the method-function + (progn + (incf *returned-combined-methods*) ; dont need this + (if (contains-call-next-method-with-args-p method-list) + (make-cnm-combined-method gf methods method-list keywords) + (or (get-combined-method method-list gf) + (progn + (incf *consed-combined-methods*) ; dont need this + (puthash-combined-method + method-list + (%cons-combined-method + gf method-list #'%%standard-combined-method-dcode))))))) + (if ok-if-no-primaries + (make-no-applicable-method-function (combined-method-gf gf)) + (no-applicable-primary-method gf methods))))) + +; Initialized after the initialization (generic) functions exist. +(defvar *initialization-functions-alist* nil) + +;;; This could be in-line above, but I was getting confused. + +;;; ok +(defun make-cnm-combined-method (gf methods method-list keywords) + (setq gf (combined-method-gf gf)) + (let ((key (cons methods method-list))) + (or (get-combined-method key gf) + (let* (key-or-init-arg + key-or-init-fn) + (if keywords + (let* ((bits (inner-lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (key-index (+ numreq (ldb $lfbits-numopt bits)))) + (setq key-or-init-arg (vector key-index keywords gf)) + (setq key-or-init-fn #'x-%%check-keywords)) + (let ((init-cell (assq gf *initialization-functions-alist*))) + (when init-cell + (setq key-or-init-arg init-cell) + (setq key-or-init-fn #'%%cnm-with-args-check-initargs)))) + (incf *consed-combined-methods*) + (let* ((vect (vector gf methods key-or-init-arg key-or-init-fn method-list)) + (self (%cons-combined-method + gf vect #'%%cnm-with-args-combined-method-dcode))) + ;(setf (svref vect 4) self) + (puthash-combined-method ; if testing 1 2 3 dont put in our real table + key + self)))))) + + +(defparameter *check-call-next-method-with-args* t) + +(defun contains-call-next-method-with-args-p (method-list) + (when *check-call-next-method-with-args* + (let ((methods method-list) + method) + (loop + (setq method (pop methods)) + (unless methods (return nil)) + (unless (listp method) + (if (logbitp $lfbits-nextmeth-with-args-bit + (lfun-bits (%method.function method))) + (return t))))))) + +;;; The METHODS arg is a sorted list of applicable methods. Returns +;;; the method-list expected by +;;; %%before-and-after-combined-method-dcode or a single method, or +;;; NIL if there are no applicable primaries +(defun compute-method-list (methods &optional (sub-dispatch? t)) + (let (arounds befores primaries afters qs) + (dolist (m methods) + (setq qs (%method.qualifiers m)) + (if qs + (if (cdr qs) + (%invalid-method-error + m "Multiple method qualifiers not allowed in ~s method combination" + 'standard) + (case (car qs) + (:before (push m befores)) + (:after (push m afters)) + (:around (push m arounds)) + (t (%invalid-method-error m "~s is not one of ~s, ~s, and ~s." + (car qs) :before :after :around)))) + (push m primaries))) + (setq primaries (nreverse primaries) + arounds (nreverse arounds) + befores (nreverse befores)) + (unless sub-dispatch? + (setq primaries (nremove-uncallable-next-methods primaries) + arounds (nremove-uncallable-next-methods arounds))) + (flet ((next-method-bit-p (method) + (logbitp $lfbits-nextmeth-bit + (lfun-bits (%method.function method))))) + (unless (null primaries) ; return NIL if no applicable primary methods + (when (and arounds + (not sub-dispatch?) + (not (next-method-bit-p (car (last arounds))))) + ;; Arounds don't call-next-method, can't get to befores, + ;; afters, or primaries + (setq primaries arounds + arounds nil + befores nil + afters nil)) + (if (and (null befores) (null afters) + (progn + (when arounds + (setq primaries (nconc arounds primaries) + arounds nil) + (unless sub-dispatch? + (setq primaries (nremove-uncallable-next-methods primaries)))) + t) + (null (cdr primaries)) + (not (next-method-bit-p (car primaries)))) + (car primaries) ; single method, no call-next-method + (let ((method-list primaries)) + (if (or befores afters) + (setq method-list (cons befores (cons afters method-list)))) + (nconc arounds method-list))))))) + + + +(defun %invalid-method-error (method format-string &rest format-args) + (error "~s is an invalid method.~%~?" method format-string format-args)) + +(defun %method-combination-error (format-string &rest args) + (apply #'error format-string args)) + + + +(defun combined-method-gf (gf-or-cm) + (let ((gf gf-or-cm)) + (while (combined-method-p gf) + (setq gf (lfun-name gf))) + gf)) + + +(defun nth-arg-combined-method-trap-0 (gf-or-cm table wrapper args) + (let* ((argnum (%gf-dispatch-table-argnum table)) + (arg (nth argnum args))) + (nth-arg-combined-method-trap gf-or-cm table argnum args arg wrapper))) + + +(defun nth-arg-combined-method-trap (gf-or-cm table argnum args &optional + (arg (nth-or-gf-error + argnum args gf-or-cm)) + (wrapper (arg-wrapper arg))) + ;; Here when we can't find the method in the dispatch table. + ;; Compute it and add it to the table. This code will remain in Lisp. + (multiple-value-bind (combined-method sub-dispatch?) + (compute-nth-arg-combined-method + gf-or-cm (%gf-dispatch-table-methods table) argnum args + wrapper) + (multiple-value-bind (index obsolete-wrappers-p) + (find-gf-dispatch-table-index table wrapper) + (if index + (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method) + (setf (%gf-dispatch-table-ref table index) wrapper)) + (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p))) + (if sub-dispatch? + (let ((table (%combined-method-methods combined-method))) + (nth-arg-combined-method-trap + combined-method + table + (%gf-dispatch-table-argnum table) + args)) + combined-method))) + +;;; Returns (values combined-method sub-dispatch?) +;;; If sub-dispatch? is true, need to compute a combined-method on the +;;; next arg. +(defun compute-nth-arg-combined-method (gf methods argnum args &optional + (wrapper (arg-wrapper + (nth-or-gf-error + argnum args gf)))) + (let* ((cpl (%inited-class-cpl (%wrapper-class wrapper))) + (real-gf (combined-method-gf gf)) + (mc (%gf-method-combination real-gf)) + (standard-mc? (eq mc *standard-method-combination*)) + applicable-methods eql-methods specializers specializer sub-dispatch?) + (dolist (method methods) + ;;(require-type method 'standard-method) ; for debugging. + (setq specializers (nthcdr argnum (%method.specializers method)) + specializer (%car specializers)) + (when (if (typep specializer 'eql-specializer) + (when (cpl-memq (%wrapper-class + (arg-wrapper (eql-specializer-object specializer))) cpl) + (push method eql-methods)) + (when (cpl-memq specializer cpl) + (push method applicable-methods))) + (if (contains-non-t-specializer? (%cdr specializers)) + (setq sub-dispatch? t)))) + (if (or eql-methods applicable-methods) + (if (or (not standard-mc?) + (contains-primary-method? applicable-methods) + (contains-primary-method? eql-methods)) + (let ((cpls (args-cpls args))) + (if eql-methods + (make-eql-combined-method + eql-methods applicable-methods cpls gf argnum sub-dispatch? mc) + (if sub-dispatch? + (values (make-n+1th-arg-combined-method applicable-methods gf argnum) + t) + (if standard-mc? + (make-standard-combined-method applicable-methods cpls gf) + (compute-effective-method-function + real-gf mc (sort-methods applicable-methods + (args-cpls args) + (%gf-precedence-list real-gf))))))) + (no-applicable-primary-method + real-gf + (sort-methods (append eql-methods applicable-methods) + (args-cpls args) + (%gf-precedence-list real-gf)))) + (make-no-applicable-method-function real-gf)))) + +(defun nth-or-gf-error (n l gf) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (l l (cdr l))) + ((null l) (dcode-too-few-args i gf)) + (declare (fixnum i)) + (if (= i n) + (return (car l))))) + +(defun contains-non-t-specializer? (specializer-list) + (dolist (s specializer-list nil) + (unless (eq *t-class* s) + (return t)))) + +(defun contains-primary-method? (method-list) + (dolist (m method-list nil) + (if (null (%method.qualifiers m)) + (return t)))) + +(defun args-cpls (args &aux res) + (dolist (arg args) + (push (%inited-class-cpl (%wrapper-class (arg-wrapper arg))) res)) + (nreverse res)) + + +(defun compute-eql-combined-method-hash-table-threshold (&optional (iters 1000000) (max 200)) + (flet ((time-assq (cnt iters) + (let ((alist (loop for i from 1 to cnt collect (cons i i))) + (start-time (get-internal-run-time)) + (j 0) + res) + (declare (fixnum j)) + (dotimes (i iters) + (declare (fixnum i)) + (setq res (cdr (assq j alist))) + (when (>= (incf j) cnt) (setq j 0))) + (values (- (get-internal-run-time) start-time) res))) + (time-hash (cnt iters) + (let ((hash (make-hash-table :test 'eq)) + start-time + (j 0) + res) + (declare (fixnum j)) + (dotimes (i cnt) + (setf (gethash i hash) i)) + (assert-hash-table-readonly hash) + (setq start-time (get-internal-run-time)) + (dotimes (i iters) + (declare (fixnum i)) + (setq res (gethash i hash)) + (when (>= (incf j) cnt) (setq j 0))) + (values (- (get-internal-run-time) start-time) res)))) + (dotimes (i max) + (let ((time-assq (time-assq i iters)) + (time-hash (time-hash i iters))) + (format t "i: ~d, assq: ~d, hash: ~d~%" i time-assq time-hash) + (when (> time-assq time-hash) (return i)))))) + +;; Value computed on a dual-core 2.4 GHz AMD Opteron running FC3 +;; This isn't the result of compute-eql-combined-method-hash-table-threshold, +;; it's the value at which assq takes 3/4 the time of hash, which weights +;; towards the worst case of the eql method, not the average for uniform inputs. +(defparameter *eql-combined-method-hash-table-threshold* 45) + +;;; A vector might be a little faster than an alist, but the hash table case +;;; will speed up large numbers of methods. +(defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional + (method-combination *standard-method-combination*)) + (let ((eql-ms (copy-list eql-methods)) + (precedence-list (%gf-precedence-list (combined-method-gf gf))) + (standard-mc? (eq method-combination *standard-method-combination*)) + (real-gf (combined-method-gf gf)) + eql-method-alist + (can-use-eq? t)) + (unless sub-dispatch? + (setq methods (sort-methods methods cpls precedence-list))) + (while eql-ms + (let ((eql-element (eql-specializer-object (nth argnum (%method.specializers (car eql-ms))))) + (this-element-methods eql-ms) + cell last-cell) + (if (or (and (numberp eql-element) (not (fixnump eql-element))) + (macptrp eql-element)) + (setq can-use-eq? nil)) + (setf eql-ms (%cdr eql-ms) + (%cdr this-element-methods) nil + cell eql-ms) + (while cell + (if (eql eql-element + (eql-specializer-object (nth argnum (%method.specializers (car cell))))) + (let ((cell-save cell)) + (if last-cell + (setf (%cdr last-cell) (cdr cell)) + (setq eql-ms (cdr eql-ms))) + (setf cell (cdr cell) + (%cdr cell-save) this-element-methods + this-element-methods cell-save)) + (setq last-cell cell + cell (cdr cell)))) + (let* ((sorted-methods + (sort-methods (nreconc (copy-list this-element-methods) + (copy-list methods)) + cpls + precedence-list)) + (method-list (and standard-mc? (compute-method-list sorted-methods sub-dispatch?)))) + (when (or (not standard-mc?) + (memq method-list this-element-methods) + (and (consp method-list) + (labels ((member-anywhere (tem mlist) + (member tem mlist + :test #'(lambda (tem el) + (if (listp el) + (member-anywhere tem el) + (member el tem)))))) + (member-anywhere this-element-methods method-list)))) + ; Do EQL comparison only if the EQL methods can run + ; (e.g. does not come after a primary method that does not call-next-method) + (push (cons eql-element + (if sub-dispatch? + (make-n+1th-arg-combined-method + sorted-methods gf argnum) + (if standard-mc? + (make-standard-combined-method sorted-methods nil gf) + (compute-effective-method-function + real-gf method-combination sorted-methods)))) + eql-method-alist))))) + ;;eql-method-alist has (element . combined-method) pairs. + ;;for now, we're going to use assq or assoc + (let ((default-method (if sub-dispatch? + (make-n+1th-arg-combined-method + methods gf argnum) + (if standard-mc? + (make-standard-combined-method methods nil gf t) + (compute-effective-method-function + real-gf method-combination methods))))) + (if eql-method-alist + (if (> (length eql-method-alist) *eql-combined-method-hash-table-threshold*) + (let ((hash (make-hash-table :test (if can-use-eq? 'eq 'eql)))) + (dolist (pair eql-method-alist) + (setf (gethash (car pair) hash) (cdr pair))) + (assert-hash-table-readonly hash) + (%cons-combined-method + gf (cons argnum (cons hash default-method)) + #'%%hash-table-combined-method-dcode)) + (%cons-combined-method + gf (cons argnum (cons eql-method-alist default-method)) + (if can-use-eq? + #'%%assq-combined-method-dcode + #'%%assoc-combined-method-dcode))) + default-method)))) + + +(defun %%assq-combined-method-dcode (stuff args) + ;; stuff is (argnum eql-method-list . default-method) + ;(declare (dynamic-extent args)) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (nth argnum args)) + (thing (assq arg (cadr stuff)))) ; are these things methods or method-functions? - fns + (if thing + (apply (cdr thing) args) + (apply (cddr stuff) args)))) + (let* ((args-len (%lexpr-count args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (%lexpr-ref args args-len argnum)) + (thing (assq arg (cadr stuff)))) + (if thing + (%apply-lexpr (cdr thing) args) + (%apply-lexpr (cddr stuff) args)))))) + + +(DEFun %%assoc-combined-method-dcode (stuff args) + ;; stuff is (argnum eql-method-list . default-method) + ;(declare (dynamic-extent args)) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (nth argnum args)) + (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions? + (if thing + (apply (cdr thing) args) + (apply (cddr stuff) args)))) + (let* ((args-len (%lexpr-count args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (%lexpr-ref args args-len argnum)) + (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions? + (if thing + (%apply-lexpr (cdr thing) args) + (%apply-lexpr (cddr stuff) args)))))) + + + +(defun %%hash-table-combined-method-dcode (stuff args) + ;; stuff is (argnum eql-hash-table . default-method) + ;(declare (dynamic-extent args)) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (nth argnum args))) + (apply (gethash arg (cadr stuff) (cddr stuff)) args))) + (let* ((args-len (%lexpr-count args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (%lexpr-ref args args-len argnum))) + (%apply-lexpr (gethash arg (cadr stuff) (cddr stuff)) args))))) + + +;;; Assumes the two methods have the same number of specializers and +;;; that each specializer of each method is in the corresponding +;;; element of cpls (e.g. cpls is a list of the cpl's for the classes +;;; of args for which both method1 & method2 are applicable. +(defun %method< (method1 method2 cpls) + (let ((s1s (%method.specializers method1)) + (s2s (%method.specializers method2)) + s1 s2 cpl) + (loop + (if (null s1s) + (return (method-qualifiers< method1 method2))) + (setq s1 (%pop s1s) + s2 (%pop s2s) + cpl (%pop cpls)) + (cond ((typep s1 'eql-specializer) + (unless (eq s1 s2) + (return t))) + ((typep s2 'eql-specializer) (return nil)) + ((eq s1 s2)) + (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl)))))))) + +(defun %simple-method< (method1 method2 cpl) + (let ((s1 (%car (%method.specializers method1))) + (s2 (%car (%method.specializers method2)))) + (cond ((typep s1 'eql-specializer) + (if (eq s1 s2) + (method-qualifiers< method1 method2) + t)) + ((typep s2 'eql-specializer) nil) + ((eq s1 s2) (method-qualifiers< method1 method2)) + (t (%i< (cpl-index s1 cpl) (cpl-index s2 cpl)))))) + +; Sort methods with argument-precedence-order +(defun %hairy-method< (method1 method2 cpls apo) + (let ((s1s (%method.specializers method1)) + (s2s (%method.specializers method2)) + s1 s2 cpl index) + (loop + (if (null apo) + (return (method-qualifiers< method1 method2))) + (setq index (pop apo)) + (setq s1 (nth index s1s) + s2 (nth index s2s) + cpl (nth index cpls)) + (cond ((typep s1 'eql-specializer) + (unless (eq s1 s2) + (return t))) + ((typep s2 'eql-specializer) (return nil)) + ((eq s1 s2)) + (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl)))))))) + +; This can matter if the user removes & reinstalls methods between +; invoking a generic-function and doing call-next-method with args. +; Hence, we need a truly canonical sort order for the methods +; (or a smarter comparison than EQUAL in %%cnm-with-args-check-methods). +(defun method-qualifiers< (method1 method2) + (labels ((qualifier-list< (ql1 ql2 &aux q1 q2) + (cond ((null ql1) (not (null ql2))) + ((null ql2) nil) + ((eq (setq q1 (car ql1)) (setq q2 (car ql2))) + (qualifier-list< (cdr ql1) (cdr ql2))) + ((string-lessp q1 q2) t) + ; This isn't entirely correct. + ; two qualifiers with the same pname in different packages + ; are not comparable here. + ; Unfortunately, users can change package names, hence, + ; comparing the package names doesn't work either. + (t nil)))) + (qualifier-list< (%method.qualifiers method1) (%method.qualifiers method2)))) + +(defun sort-methods (methods cpls &optional apo) + (cond ((null cpls) methods) + ((null (%cdr cpls)) + (setq cpls (%car cpls)) + (flet ((simple-sort-fn (m1 m2) + (%simple-method< m1 m2 cpls))) + (declare (dynamic-extent #'simple-sort-fn)) + (%sort-list-no-key methods #'simple-sort-fn))) + ((null apo) ; no unusual argument-precedence-order + (flet ((sort-fn (m1 m2) + (%method< m1 m2 cpls))) + (declare (dynamic-extent #'sort-fn)) + (%sort-list-no-key methods #'sort-fn))) + (t ; I guess some people are just plain rude + (flet ((hairy-sort-fn (m1 m2) + (%hairy-method< m1 m2 cpls apo))) + (declare (dynamic-extent #'hairy-sort-fn)) + (%sort-list-no-key methods #'hairy-sort-fn))))) + +(defun nremove-uncallable-next-methods (methods) + (do ((m methods (%cdr m)) + mbits) + ((null m)) + (setq mbits (lfun-bits (%method.function (%car m)))) + (unless (logbitp $lfbits-nextmeth-bit mbits) + (setf (%cdr m) nil) + (return))) + methods) + + +(defun cpl-index (superclass cpl) + ;; This will be table lookup later. Also we'll prelookup the tables + ;; in compute-1st-arg-combined-methods above. + (locally (declare (optimize (speed 3)(safety 0))) + (do ((i 0 (%i+ i 1)) + (cpl cpl (%cdr cpl))) + ((null cpl) nil) + (if (eq superclass (%car cpl)) + (return i))))) + +(defun cpl-memq (superclass cpl) + (locally (declare (optimize (speed 3)(safety 0))) + (do ((cpl cpl (%cdr cpl))) + ((null cpl) nil) + (if (eq superclass (%car cpl)) + (return cpl))))) + +;;; Combined method interpretation + + +;;; magic is a list of (cnm-cm (methods) . args) cnm-cm is the +;;; argument checker for call-next-method-with-args or nil could make +;;; it be a cons as a flag that magic has been heap consed - done +;;; could also switch car and cadr if we do &lexpr business then if +;;; cddr is lexpr-p (aka (not listp)) thats the clue also would need +;;; to do lexpr-apply or apply depending on the state. + + +(defun %%standard-combined-method-dcode (methods args) + ;; combined-methods as made by make-combined-method are in methods + ;; args are as put there by the caller of the gf. + (let* ((car-meths (car methods)) + (cell-2 (cons methods args)) + (magic (cons nil cell-2))) + ;; i.e. magic is nil methods . args + (declare (dynamic-extent magic) + (dynamic-extent cell-2)) + (if (listp car-meths) + (%%before-and-after-combined-method-dcode magic) + (progn + (if (not (cdr methods)) + (%rplaca (cdr magic) car-meths) + (%rplaca (cdr magic) (cdr methods))) + ; so maybe its a combined-method ?? - no + (apply-with-method-context magic (%method.function car-meths) args))))) + +;;; args is list, old-args may be lexpr +(defun cmp-args-old-args (args old-args numreq) + (declare (optimize (speed 3)(safety 0))) + (if (listp old-args) + (do ((newl args (cdr newl)) + (oldl old-args (cdr oldl)) + (i 0 (1+ i))) + ((eql i numreq) t) + (when (neq (car newl)(car oldl))(return nil))) + (let ((len (%lexpr-count old-args))) + (do ((newl args (cdr newl)) + (i 0 (1+ i))) + ((eql i numreq) t) + (when (neq (car newl)(%lexpr-ref old-args len i))(return nil)))))) + + +; called from call-next-method-with-args with magic supplied and 1st time around with not +(defun %%cnm-with-args-combined-method-dcode (thing args &optional magic) ; was &rest args + ;(declare (dynamic-extent args)) + ; now thing is vector of gf orig methods, arg for key or initarg check, key or initarg fnction + ; and our job is to do all the arg checking + (let () + ;; THING is nil in next-method calls for non-standard method combination. To enable + ;; checking in that case, would need to change %%call-method* to store a vector in (car magic). + (when (and magic thing) + (flet ((do-it (thing args) + (let* ((args-len (length args)) + (gf (svref thing 0)) ; could get this from a method + (numreq (ldb $lfbits-numreq (inner-lfun-bits gf))) + (next-methods (cadr magic))) + ;(when (null self)(error "Next method with args context error")) + (when (neq 0 numreq) + ; oh screw it - old-args may be lexpr too + (let ((old-args (cddr magic))) + (when (< args-len numreq) (signal-program-error "Too few args to ~S" gf)) + (when (null (cmp-args-old-args args old-args numreq)) + ; required args not eq - usually true, we expect + (let ((new-methods (%compute-applicable-methods* gf args)) + (old-methods (svref thing 1))) + (when (not (equal new-methods old-methods)) + (error '"Applicable-methods changed in call-next-method.~%~ + Should be: ~s~%Was: ~s~%Next-methods: ~s" + old-methods new-methods next-methods)))))) + (let ((key-or-init-fn (svref thing 3))) + (when key-or-init-fn + ; was apply + (funcall key-or-init-fn (svref thing 2) args)))))) + (if (listp args) + (do-it thing args) + (with-list-from-lexpr (args-list args) + (do-it thing args-list))))) + ; ok done checking - lets do it + (let* ((methods (if magic (cadr magic)(svref thing 4))) ;<< was 5 this is nil unless cnm with args + ; was if magic + (car-meths (car methods)) + (cell-2 (cons methods args)) + (magic (cons thing cell-2))) + (declare (dynamic-extent magic cell-2)) + ; i.e. magic is thing methods . args + ;(%rplaca magic thing) + ;(setf (cadr magic) methods) + ;(%rplaca (cdr magic) methods) + ;(setf (cddr magic) args) + ;(%rplacd (cdr magic) args) + (if (listp car-meths) + (progn + (%%before-and-after-combined-method-dcode magic)) + (progn + (if (not (cdr methods)) + (%rplaca (cdr magic) car-meths) + (%rplaca (cdr magic) (cdr methods))) + ; so maybe its a combined-method ?? - no + (apply-with-method-context magic (%method.function car-meths) args)))))) + + + +;;; here if car of methods is listp. methods = (befores afters . primaries) +(defun %%before-and-after-combined-method-dcode (magic) + (declare (list magic)) + (let* ((methods (cadr magic)) + (befores (car methods)) + (cdr-meths (cdr methods)) + (primaries (cdr cdr-meths)) + (afters (car cdr-meths)) + (args (cddr magic))) + (declare (list befores afters primaries)) + (when befores + (dolist (method befores) + (rplaca (cdr magic) method) + (apply-with-method-context magic (%method.function method) args))) + (let* ((cdr (cdr primaries)) + (method-function (%method.function (car primaries)))) ; guaranteed non nil? + (rplaca (cdr magic) (if (null cdr)(car primaries) cdr)) + (if (null afters) + (apply-with-method-context magic method-function args) ; tail call if possible + (multiple-value-prog1 + (apply-with-method-context magic method-function args) + (dolist (method afters) + (rplaca (cdr magic) method) + (apply-with-method-context magic (%method.function method) args))))))) + + +; This is called by the compiler expansion of next-method-p +; I think there's a bug going around... LAP fever! I'm immune +(defun %next-method-p (magic) + (let ((methods (%cadr magic))) + (consp methods))) + + +(defun %call-next-method (magic &rest args) ; if args supplied they are new ones + (declare (dynamic-extent args)) + (if args + (apply #'%call-next-method-with-args magic args) + (let* ((next-methods (%cadr magic))) ; don't get this closed magic stuff + (if (not (consp next-methods)) + ( %no-next-method magic) + (let ((args (%cddr magic))) ; get original args + ;The unwind-protect is needed in case some hacker in his/her wisdom decides to: + ; (defmethod foo (x) (catch 'foo (call-next-method)) (call-next-method)) + ; where the next-method throws to 'foo. + ; The alternative is to make a new magic var with args + ; actually not that fancy (call-next-method)(call-next-method) is same problem + (let () + (unwind-protect + (if (listp (car next-methods)) + ( %%before-and-after-combined-method-dcode magic) + (let ((cdr (cdr next-methods))) + (rplaca (cdr magic)(if (not cdr)(car next-methods) cdr)) + (let ((method-function (%method.function (car next-methods)))) + (apply-with-method-context magic method-function args)))) + (rplaca (cdr magic) next-methods)))))))) + +;; Note: we need to change the compiler to call this when it can prove that +;; call-next-method cannot be called a second time. I believe thats done. + + +(defun %tail-call-next-method (magic) + (let* ((next-methods (%cadr magic)) ; or make it car + (args (%cddr magic))) ; get original args + (if (not (consp next-methods)) ; or consp? + ( %no-next-method magic) + (if (listp (car next-methods)) + ( %%before-and-after-combined-method-dcode magic) + (let ((cdr (cdr next-methods))) + (rplaca (cdr magic) (if (not cdr)(car next-methods) cdr)) + (apply-with-method-context magic (%method.function (car next-methods)) args)))))) + +;;; may be simpler to blow another cell so magic looks like +;;; (cnm-cm/nil next-methods . args) - done +;;; and also use first cell to mean heap-consed if itsa cons + +(defun %call-next-method-with-args (magic &rest args) + (declare (dynamic-extent args)) + (if (null args) + (%call-next-method magic) + (let* ((methods (%cadr magic))) + (if (not (consp methods)) + (%no-next-method magic) + (let* ((cnm-cm (car magic))) + ; a combined method + (when (consp cnm-cm)(setq cnm-cm (car cnm-cm))) + ; could just put the vector in car magic & no self needed in vector? + (let ((the-vect cnm-cm)) ; << + (funcall #'%%cnm-with-args-combined-method-dcode ;(%combined-method-dcode cnm-cm) + the-vect + args + magic))))))) + + + +; called from x%%call-next-method-with-args - its the key-or-init-fn +(defun %%cnm-with-args-check-initargs (init-cell args) + ; here we forget the lexpr idea because it wants to cdr + ;(declare (dynamic-extent args)) + (let* ((rest (cdr args)) + (first-arg (car args))) + (declare (list rest)) + (let* ((initargs rest) + (init-function (car init-cell)) + (instance (cond ((eq init-function #'update-instance-for-different-class) + (setq initargs (cdr rest)) + (car rest)) + ((eq init-function #'shared-initialize) + (setq initargs (cdr rest)) + first-arg) + ((eq init-function #'update-instance-for-redefined-class) + (setq initargs (%cdddr rest)) + first-arg) + (t first-arg))) + (class (class-of instance)) + bad-initarg) + (dolist (functions (cdr init-cell) + (error "Bad initarg: ~s to call-next-method for ~s~%on ~s" + bad-initarg instance (car init-cell))) + (multiple-value-bind + (errorp bad-key) + (if (eq (car functions) #'initialize-instance) + (apply #'check-initargs instance class initargs nil + #'initialize-instance #'allocate-instance #'shared-initialize + nil) + (apply #'check-initargs instance class initargs nil functions)) + (if errorp + (unless bad-initarg (setq bad-initarg bad-key)) + (return t))))))) + + + +(defun %no-next-method (magic) + (let* ((method (%cadr magic))) + (if (consp method) (setq method (car method))) + (unless (typep method 'standard-method) + (error "call-next-method called outside of generic-function dispatch context.~@ + Usually indicates an error in a define-method-combination form.")) + (let ((args (cddr magic)) + (gf (%method.gf method))) + (if (listp args) + (apply #'no-next-method gf method args) + (%apply-lexpr #'no-next-method gf method args))))) + + + + +;;; This makes a consed version of the magic first arg to a method. +;;; Called when someone closes over the magic arg. (i.e. does (george +;;; #'call-next-method)) + +(defun %cons-magic-next-method-arg (magic) + ; car is a cons as a flag that its already heap-consed! - else cnm-cm or nil + (if (consp (car magic)) + magic + (list* (list (car magic)) + (if (consp (%cadr magic)) + (copy-list (%cadr magic)) ; is this copy needed - probably not + (cadr magic)) + (let ((args (%cddr magic))) + (if (listp args) + (copy-list args) + (let* ((len (%lexpr-count args)) + (l (make-list len))) + (do ((i 0 (1+ i)) + (list l (cdr list))) + ((null list)) + (%rplaca list (%lexpr-ref args len i))) + l)))))) + + +; Support CALL-METHOD in DEFINE-METHOD-COMBINATION +(defun %%call-method* (method next-methods args) + (let* ((method-function (%method.function method)) + (bits (lfun-bits method-function))) + (declare (fixnum bits)) + (if (not (and (logbitp $lfbits-nextmeth-bit bits) + (logbitp $lfbits-method-bit bits))) + (if (listp args) + (apply method-function args) + (%apply-lexpr method-function args)) + (let* ((cell-2 (cons next-methods args)) + (magic (cons nil cell-2))) + (declare (dynamic-extent magic) + (dynamic-extent cell-2)) + (if (null next-methods) + (%rplaca (cdr magic) method)) + (apply-with-method-context magic method-function args))))) + +; Error checking version for user's to call +(defun %call-method* (method next-methods args) + (let* ((method-function (%method.function method)) + (bits (lfun-bits method-function))) + (declare (fixnum bits)) + (if (not (and (logbitp $lfbits-nextmeth-bit bits) + (logbitp $lfbits-method-bit bits))) + (progn + (require-type method 'standard-method) + (if (listp args) + (apply method-function args) + (%apply-lexpr method-function args))) + (progn + (do* ((list next-methods (cdr list))) + ((null list)) + (when (not (listp list)) + (%err-disp $XIMPROPERLIST next-methods)) + (when (not (standard-method-p (car list))) + (report-bad-arg (car list) 'standard-method))) + (let* ((cell-2 (cons next-methods args)) + (magic (cons nil cell-2))) + (declare (dynamic-extent magic) + (dynamic-extent cell-2)) + (if (null next-methods) + (%rplaca (cdr magic) method)) + (apply-with-method-context magic method-function args)))))) + + + Index: /branches/qres/ccl/level-1/l1-error-signal.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-error-signal.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-error-signal.lisp (revision 13564) @@ -0,0 +1,158 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun %kernel-restart (error-type &rest args) + (%kernel-restart-internal error-type args (%get-frame-ptr))) + +(defun %kernel-restart-internal (error-type args frame-ptr) + ;(declare (dynamic-extent args)) + (dolist (f *kernel-restarts* (%err-disp-internal error-type args frame-ptr)) + (when (eq (car f) error-type) + (return (apply (cdr f) frame-ptr args))))) + +;;; this is the def of %err-disp. +;;; Yup. That was my first guess. +(defun %err-disp (err-num &rest errargs) + (%err-disp-internal err-num errargs (%get-frame-ptr))) + +(defun %errno-disp (errno &rest errargs) + (%errno-disp-internal errno errargs (%get-frame-ptr))) + +#+windows-target +(defun %windows-error-disp (errno &rest errargs) + (%err-disp-common errno 0 (%windows-error-string errno) errargs (%get-frame-ptr))) + +(defun %errno-disp-internal (errno errargs frame-ptr) + (declare (fixnum errno)) + (let* ((err-type (max (ash errno -16) 0)) + (errno (%word-to-int errno)) + (error-string (%strerror errno)) + (format-string (if errargs + (format nil "~a : ~a" error-string "~s") + error-string))) + (%err-disp-common nil err-type format-string errargs frame-ptr))) + + +(defun %err-disp-internal (err-num errargs frame-ptr) + (declare (fixnum err-num)) + ;;; The compiler (finally !) won't tail-apply error. But we kind of + ;;; expect it to ... + (let* ((err-typ (max (ash err-num -16) 0)) + (err-num (%word-to-int err-num)) + (format-string (%rsc-string err-num))) + (%err-disp-common err-num err-typ format-string errargs frame-ptr))) + +(defparameter *foreign-error-condition-recognizers* ()) + + +(defun %err-disp-common (err-num err-typ format-string errargs frame-ptr) + (let* ((condition-name (or (uvref *simple-error-types* err-typ) + (%cdr (assq err-num *kernel-simple-error-classes*))))) + ;;(dbg format-string) + (if condition-name + (funcall '%error + (case condition-name + (type-error + (if (cdr errargs) + (make-condition condition-name + :format-control format-string + :datum (car errargs) + :expected-type (%type-error-type (cadr errargs))) + (make-condition condition-name + :format-control format-string + :datum (car errargs)))) + (improper-list (make-condition condition-name + :datum (car errargs))) + (simple-file-error (make-condition condition-name + :pathname (car errargs) + :error-type format-string + :format-arguments (cdr errargs))) + (undefined-function (make-condition condition-name + :name (car errargs))) + (call-special-operator-or-macro + (make-condition condition-name + :name (car errargs) + :function-arguments (cadr errargs))) + (sequence-index-type-error + (make-sequence-index-type-error (car errargs) (cadr errargs))) + (cant-construct-arglist + (make-condition condition-name + :datum (car errargs) + :format-control format-string)) + (array-element-type-error + (let* ((array (cadr errargs))) + (make-condition condition-name + :format-control format-string + :datum (car errargs) + :expected-type (array-element-type array) + :array array))) + + (t (make-condition condition-name + :format-control format-string + :format-arguments errargs))) + nil + frame-ptr) + (let* ((cond nil)) + (if (and (eql err-num $XFOREIGNEXCEPTION) + (dolist (recog *foreign-error-condition-recognizers*) + (let* ((c (funcall recog (car errargs)))) + (when c (return (setq cond c)))))) + (funcall '%error cond nil frame-ptr) + (funcall '%error format-string errargs frame-ptr)))))) + +(defun error (condition &rest args) + "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS. + If the condition is not handled, the debugger is invoked." + #| + #+ppc-target + (with-pstrs ((pstr (if (stringp condition) condition "Error"))) + (#_DebugStr pstr)) + |# + (%error condition args (%get-frame-ptr))) + +(defun cerror (cont-string condition &rest args) + (let* ((fp (%get-frame-ptr))) + (restart-case (%error condition (if (condition-p condition) nil args) fp) + (continue () + :report (lambda (stream) + (apply #'format stream cont-string args)) + nil)))) + +(defun %error (condition args error-pointer) + (setq *error-reentry-count* 0) + (setq condition (condition-arg condition args 'simple-error)) + (signal condition) + (unless *interactive-streams-initialized* + (bug (format nil "Error during early application initialization:~% +~a" condition)) + (#_exit #-windows-target #$EX_SOFTWARE #+windows-target #$EXIT_FAILURE)) + (application-error *application* condition error-pointer) + (application-error + *application* + (condition-arg "~s returned. It shouldn't.~%If it returns again, I'll throw to toplevel." + '(application-error) 'simple-error) + error-pointer) + (toplevel)) + +(defun make-sequence-index-type-error (idx sequence) + (let* ((upper (length sequence))) + (make-condition 'sequence-index-type-error + :datum idx + :sequence sequence + :expected-type `(integer 0 (,upper))))) Index: /branches/qres/ccl/level-1/l1-error-system.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-error-system.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-error-system.lisp (revision 13564) @@ -0,0 +1,1329 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;; This file contains the error/condition system. Functions that +;;; signal/handle errors are defined later. + +(in-package "CCL") + +;;;*********************************** +;;; Error System +;;;*********************************** + +(defclass condition () ()) +(defclass warning (condition) ()) +(defclass serious-condition (condition) ()) +(defclass error (serious-condition) ()) + +(define-condition simple-condition (condition) + ((format-control :initarg :format-control + :reader simple-condition-format-control) + (format-arguments :initarg :format-arguments + :initform nil + :reader simple-condition-format-arguments)) + (:report (lambda (c stream) ;; If this were a method, slot value might be faster someday. Accessors always faster ? + ;; And of course it's terribly important that this be as fast as humanly possible... + ;Use accessors because they're documented and users can specialize them. + (apply #'format stream (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + + +(define-condition storage-condition (serious-condition) ()) + +(define-condition thread-condition (serious-condition) ()) + +(define-condition process-reset (thread-condition) + ((kill :initarg :kill :initform nil :reader process-reset-kill))) + + +(define-condition print-not-readable (error) + ((object :initarg :object :reader print-not-readable-object) + (stream :initarg :stream :reader print-not-readable-stream)) + (:report (lambda (c stream) + (let* ((*print-readably* nil)) + (format stream "Attempt to print object ~S on stream ~S ." + (print-not-readable-object c) + (print-not-readable-stream c)))))) + +(define-condition simple-warning (simple-condition warning) ()) + +(define-condition compiler-warning (warning) + ((function-name :initarg :function-name :initform nil :accessor compiler-warning-function-name) + (source-note :initarg :source-note :initform nil :accessor compiler-warning-source-note) + (warning-type :initarg :warning-type :reader compiler-warning-warning-type) + (args :initarg :args :reader compiler-warning-args) + (nrefs :initform () :accessor compiler-warning-nrefs)) + (:report report-compiler-warning)) + +;; Backward compatibility +(defmethod compiler-warning-file-name ((w compiler-warning)) + (source-note-filename (compiler-warning-source-note w))) + +(define-condition style-warning (compiler-warning) + ((warning-type :initform :unsure) + (args :initform nil))) +(define-condition undefined-reference (style-warning) ()) +(define-condition undefined-type-reference (undefined-reference) ()) +(define-condition undefined-function-reference (undefined-reference) ()) +(define-condition macro-used-before-definition (compiler-warning) ()) +(define-condition invalid-type-warning (style-warning) ()) +(define-condition invalid-arguments (style-warning) ()) +(define-condition invalid-arguments-global (style-warning) ()) +(define-condition undefined-keyword-reference (undefined-reference invalid-arguments) ()) + +(define-condition simple-error (simple-condition error) ()) + +(define-condition simple-storage-condition (simple-condition storage-condition) ()) +(define-condition stack-overflow-condition (simple-storage-condition) ()) + +(define-condition invalid-memory-access (storage-condition) + ((address :initarg :address) + (write-p :initform nil :initarg :write-p)) + (:report (lambda (c s) + (with-slots (address write-p) c + (format s "Fault during ~a memory address #x~x" (if write-p "write to" "read of") address))))) + +(define-condition invalid-memory-operation (storage-condition) + () + (:report (lambda (c s) + (declare (ignore c)) + (format s "Invalid memory operation.")))) + +(define-condition write-to-watched-object (storage-condition) + ((object :initform nil :initarg :object + :reader write-to-watched-object-object) + (offset :initarg :offset + :reader write-to-watched-object-offset) + (instruction :initarg :instruction + :reader write-to-watched-object-instruction)) + (:report report-write-to-watched-object)) + +(defun report-write-to-watched-object (c s) + (with-slots (object offset instruction) c + (cond + ((uvectorp object) + (let* ((count (uvsize object)) + (nbytes (if (ivectorp object) + (subtag-bytes (typecode object) count) + (* count target::node-size))) + (bytes-per-element (/ nbytes count)) + (offset (- offset target::misc-data-offset)) + (index (/ offset bytes-per-element))) + (format s "Write to watched uvector ~s at " object) + (if (fixnump index) + (format s "index ~s" index) + (format s "an apparently unaligned byte offset ~s" offset)))) + ((consp object) + (format s "Write to ~a watched cons cell ~s" + (cond + ((= offset target::cons.cdr) "the CDR of") + ((= offset target::cons.car) "the CAR of") + (t + (format nil "an apparently unaligned byte offset (~s) into" + offset))) + object)) + (t + (format s "Write to a strange object ~s at byte offset ~s" + object offset))) + (when instruction + (format s "~&Faulting instruction: ~s" instruction)))) + +(define-condition type-error (error) + ((datum :initarg :datum) + (expected-type :initarg :expected-type :reader type-error-expected-type) + (format-control :initarg :format-control :initform (%rsc-string $xwrongtype) :reader type-error-format-control)) + (:report (lambda (c s) + (format s (type-error-format-control c) + (type-error-datum c) + (type-error-expected-type c))))) + +(define-condition bad-slot-type (type-error) + ((slot-definition :initform nil :initarg :slot-definition) + (instance :initform nil :initarg :instance)) + (:report (lambda (c s) + (format s "The value ~s can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " + (type-error-datum c) + (slot-definition-name (slot-value c 'slot-definition)) + (slot-value c 'instance) + (type-error-expected-type c))))) + +(define-condition bad-slot-type-from-initform (bad-slot-type) + () + (:report (lambda (c s) + (let* ((slotd (slot-value c 'slot-definition))) + (format s "The value ~s, derived from the initform ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " + (type-error-datum c) + (slot-definition-initform slotd) + (slot-definition-name slotd) + (slot-value c 'instance) + (type-error-expected-type c)))))) + +(define-condition bad-slot-type-from-initarg (bad-slot-type) + ((initarg-name :initarg :initarg-name)) + (:report (lambda (c s) + (let* ((slotd (slot-value c 'slot-definition))) + (format s "The value ~s, derived from the initarg ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " + (type-error-datum c) + (slot-value c 'initarg-name) + (slot-definition-name slotd) + (slot-value c 'instance) + (type-error-expected-type c)))))) + + +(define-condition improper-list (type-error) + ((expected-type :initform '(satisfies proper-list-p) :reader type-error-expected-type))) + +(define-condition cant-construct-arglist (improper-list) + ()) + + +(let* ((magic-token '("Unbound"))) + (defmethod type-error-datum ((c type-error)) + (let* ((datum-slot (slot-value c 'datum))) + (if (eq magic-token datum-slot) + (%unbound-marker-8) + datum-slot))) + +; do we need this + (defun signal-type-error (datum expected &optional (format-string (%rsc-string $xwrongtype))) + (let ((error #'error)) + (funcall error (make-condition 'type-error + :format-control format-string + :datum (if (eq datum (%unbound-marker-8)) magic-token datum) + :expected-type (%type-error-type expected))))) +) + + +(define-condition sequence-index-type-error (type-error) + ((sequence :initarg :sequence)) + (:report (lambda (c s) + (format s "~s is not a valid sequence index for ~s" + (type-error-datum c) + (slot-value c 'sequence))))) + + +;;; This is admittedly sleazy; ANSI CL requires TYPE-ERRORs to be +;;; signalled in cases where a type-specifier is not of an appropriate +;;; subtype. The sleazy part is whether it's right to overload TYPE-ERROR +;;; like this. + +(define-condition invalid-subtype-error (type-error) + () + (:report (lambda (c s) + (format s "The type specifier ~S is not determinably a subtype of the type ~S" + (type-error-datum c) + (type-error-expected-type c))))) + +(define-condition simple-type-error (simple-condition type-error) ()) + +(define-condition array-element-type-error (simple-type-error) + ((array :initarg :array :reader array-element-type-error-array)) + (:report (lambda (c s) + (format s (simple-condition-format-control c) + (type-error-datum c) + (array-element-type-error-array c))))) + + + + + +(define-condition program-error (error) ()) +(define-condition simple-program-error (simple-condition program-error) + ((context :initarg :context :reader simple-program-error-context :initform nil))) + +(define-condition invalid-type-specifier (program-error) + ((typespec :initarg :typespec :reader invalid-type-specifier-typespec)) + (:report (lambda (c s) + (with-slots (typespec) c + (format s "Invalid type specifier: ~s ." typespec))))) + +(defun signal-program-error (string &rest args) + (let* ((e #'error)) + (funcall e + (make-condition 'simple-program-error + :format-control (if (fixnump string) (%rsc-string string) string) + :format-arguments args)))) + +(define-condition simple-destructuring-error (simple-program-error) ()) + +(define-condition wrong-number-of-arguments (program-error) + ((nargs :initform nil + :initarg :nargs :reader wrong-number-of-arguments-nargs) + (fn :initform nil :initarg :fn :reader wrong-number-of-arguments-fn)) + (:report report-argument-mismatch)) + +(define-condition too-many-arguments (wrong-number-of-arguments) ()) + +(define-condition too-few-arguments (wrong-number-of-arguments) ()) + +(defun report-argument-mismatch (c s) + (let* ((nargs-provided (wrong-number-of-arguments-nargs c)) + (fn (wrong-number-of-arguments-fn c)) + (too-many (typep c 'too-many-arguments))) + (multiple-value-bind (min max scaled-nargs) + (min-max-actual-args fn nargs-provided) + (if (not min) + (progn + (format s "Function ~s called with too ~a arguments. " + fn + (if too-many + "many" + "few"))) + (if too-many + (format s "Too many arguments in call to ~s:~&~d argument~:p provided, at most ~d accepted. " fn scaled-nargs max) + (format s "Too few arguments in call to ~s:~&~d argument~:p provided, at least ~d required. " fn scaled-nargs min)))))) + + + +(define-condition compile-time-program-error (simple-program-error) + nil ;((context :initarg :context :reader compile-time-program-error-context)) + (:report + (lambda (c s) + (format s "While compiling ~a :~%~a" + (simple-program-error-context c) + (apply #'format nil (simple-condition-format-control c) (simple-condition-format-arguments c)))))) + + + +;;; Miscellaneous error during compilation (caused by macroexpansion, transforms, compile-time evaluation, etc.) +;;; NOT program-errors. +(define-condition compile-time-error (simple-error) + ((context :initarg :context :reader compile-time-error-context)) + (:report + (lambda (c s) + (format s "While compiling ~a :~%~a" + (compile-time-error-context c) + (format nil "~a" c))))) + +(define-condition control-error (error) ()) + +(define-condition cant-throw-error (control-error) + ((tag :initarg :tag)) + (:report (lambda (c s) + (format s "Can't throw to tag ~s" (slot-value c 'tag))))) + +(define-condition inactive-restart (control-error) + ((restart-name :initarg :restart-name)) + (:report (lambda (c s) + (format s "Restart ~s is not active" (slot-value c 'restart-name))))) + +(define-condition lock-protocol-error (control-error) + ((lock :initarg :lock))) + +(define-condition not-lock-owner (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Current process ~s does not own lock ~s" + *current-process* (slot-value c 'lock))))) + +(define-condition not-locked (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Lock ~s isn't locked." (slot-value c 'lock))))) + +(define-condition deadlock (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Requested operation on ~s would cause deadlock." (slot-value c 'lock))))) + +(define-condition package-error (error) + ((package :initarg :package :reader package-error-package))) +(define-condition no-such-package (package-error) + () + (:report (lambda (c s) (format s (%rsc-string $xnopkg) (package-error-package c))))) +(define-condition unintern-conflict-error (package-error) + ((sym-to-unintern :initarg :sym) + (conflicting-syms :initarg :conflicts)) + (:report (lambda (c s) + (format s (%rsc-string $xunintc) (slot-value c 'sym-to-unintern) (package-error-package c) (slot-value c 'conflicting-syms))))) + +(define-condition import-conflict-error (package-error) + ((imported-sym :initarg :imported-sym) + (conflicting-sym :initarg :conflicting-sym) + (conflict-external-p :initarg :conflict-external)) + (:report (lambda (c s) + (format s (%rsc-string (if (slot-value c 'conflict-external-p) $ximprtcx $ximprtc)) + (slot-value c 'imported-sym) + (package-error-package c) + (slot-value c 'conflicting-sym))))) + +(define-condition use-package-conflict-error (package-error) + ((package-to-use :initarg :package-to-use) + (conflicts :initarg :conflicts) + (external-p :initarg :external-p)) + (:report (lambda (c s) + (format s (%rsc-string (if (slot-value c 'external-p) $xusecX $xusec)) + (slot-value c 'package-to-use) + (package-error-package c) + (slot-value c 'conflicts))))) + +(define-condition export-conflict-error (package-error) + ((conflicts :initarg :conflicts)) + (:report + (lambda (c s) + (format s "Name conflict~p detected by ~A :" (length (slot-value c 'conflicts)) 'export) + (let* ((package (package-error-package c))) + (dolist (conflict (slot-value c 'conflicts)) + (destructuring-bind (inherited-p sym-to-export using-package conflicting-sym) conflict + (format s "~&~A'ing ~S from ~S would cause a name conflict with ~&~ + the ~a symbol ~S in the package ~s, which uses ~S." + 'export + sym-to-export + package + (if inherited-p "inherited" "present") + conflicting-sym + using-package + package))))))) + +(define-condition export-requires-import (package-error) + ((to-be-imported :initarg :to-be-imported)) + (:report + (lambda (c s) + (let* ((p (package-error-package c))) + (format s "The following symbols need to be imported to ~S before they can be exported ~& from that package:~%~s:" p (slot-value c 'to-be-imported)))))) + + +(define-condition package-name-conflict-error (package-error simple-error) ()) + +(define-condition package-is-used-by (package-error) + ((using-packages :initarg :using-packages)) + (:report (lambda (c s) + (format s "~S is used by ~S" (package-error-package c) + (slot-value c 'using-packages))))) + +(define-condition symbol-name-not-accessible (package-error) + ((symbol-name :initarg :symbol-name)) + (:report (lambda (c s) + (format s "No aymbol named ~S is accessible in package ~s" + (slot-value c 'symbol-name) + (package-error-package c))))) + +(define-condition stream-error (error) + ((stream :initarg :stream :reader stream-error-stream))) + +(defun stream-error-context (condition) + (let* ((stream (stream-error-stream condition))) + (with-output-to-string (s) + (format s "on ~s" stream) + (let* ((pos (ignore-errors (stream-position stream)))) + (when pos + (format s ", near position ~d" pos))) + (let* ((surrounding (stream-surrounding-characters stream))) + (when surrounding + (format s ", within ~s" surrounding)))))) + +(define-condition parse-error (error) ()) +(define-condition parse-integer-not-integer-string (parse-error) + ((string :initarg :string)) + (:report (lambda (c s) + (format s "Not an integer string: ~s" (slot-value c 'string))))) + +(define-condition reader-error (parse-error stream-error) ()) +(define-condition end-of-file (stream-error) () + (:report (lambda (c s) + (format s "Unexpected end of file ~a" (stream-error-context c))))) + +(define-condition io-timeout (stream-error) + ()) + +(define-condition input-timeout (io-timeout) + () + (:report (lambda (c s) + (format s "Input timeout on ~s" (stream-error-stream c))))) +(define-condition output-timeout (io-timeout) + () + (:report (lambda (c s) + (format s "Output timeout on ~s" (stream-error-stream c))))) +(define-condition communication-deadline-expired (io-timeout) + () + (:report (lambda (c s) + (format s "Communication deadline timeout on ~s" (stream-error-stream c))))) + + + + +(define-condition impossible-number (reader-error) + ((token :initarg :token :reader impossible-number-token) + (condition :initarg :condition :reader impossible-number-condition)) + (:report (lambda (c s) + (format s "Condition of type ~s raised ~&while trying to parse numeric token ~s ~&~s" + (type-of (impossible-number-condition c)) + (impossible-number-token c) + (stream-error-context c))))) + + + +(define-condition simple-stream-error (stream-error simple-condition) () + (:report (lambda (c s) + (format s "~a : ~&~a" (stream-error-context c) + (apply #'format + nil + (simple-condition-format-control c) + (simple-condition-format-arguments c)))))) + + + + +(define-condition file-error (error) + ((pathname :initarg :pathname :initform "" :reader file-error-pathname) + (error-type :initarg :error-type :initform "File error on file ~S")) + (:report (lambda (c s) + (format s (slot-value c 'error-type) + (file-error-pathname c))))) + +(define-condition simple-file-error (simple-condition file-error) + () + (:report (lambda (c s) + (apply #'format s (slot-value c 'error-type) + (file-error-pathname c) + (simple-condition-format-arguments c))))) + + +(define-condition namestring-parse-error (error) + ((complaint :reader namestring-parse-error-complaint :initarg :complaint) + (arguments :reader namestring-parse-error-arguments :initarg :arguments + :initform nil) + (namestring :reader namestring-parse-error-namestring :initarg :namestring) + (offset :reader namestring-parse-error-offset :initarg :offset)) + (:report (lambda (condition stream) + (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^" + (namestring-parse-error-complaint condition) + (namestring-parse-error-arguments condition) + (namestring-parse-error-namestring condition) + (namestring-parse-error-offset condition))))) + +(define-condition cell-error (error) + ((name :initarg :name :reader cell-error-name) + (error-type :initarg :error-type :initform "Cell error" :reader cell-error-type)) + (:report (lambda (c s) (format s "~A: ~S" (cell-error-type c) (cell-error-name c))))) + +(define-condition unbound-variable (cell-error) + ((error-type :initform "Unbound variable"))) + +(define-condition undefined-function (cell-error) + ((error-type :initform "Undefined function"))) +(define-condition undefined-function-call (control-error undefined-function) + ((function-arguments :initarg :function-arguments :reader undefined-function-call-arguments)) + (:report (lambda (c s) (format s "Undefined function ~S called with arguments ~:S ." + (cell-error-name c) + (undefined-function-call-arguments c))))) + +(define-condition call-special-operator-or-macro (undefined-function-call) + () + (:report (lambda (c s) (format s "Special operator or global macro-function ~s can't be FUNCALLed or APPLYed" (cell-error-name c))))) + + +(define-condition unbound-slot (cell-error) + ((instance :initarg :instance :accessor unbound-slot-instance)) + (:report (lambda (c s) (format s "Slot ~s is unbound in ~s" + (cell-error-name c) + (unbound-slot-instance c))))) + + +(define-condition arithmetic-error (error) + ((operation :initform nil :initarg :operation :reader arithmetic-error-operation) + (operands :initform nil :initarg :operands :reader arithmetic-error-operands) + (status :initform nil :initarg :status :reader arithmetic-error-status)) + (:report (lambda (c s) + (format s "~S detected" (type-of c)) + (let* ((operands (arithmetic-error-operands c))) + (when operands + (format s "~&performing ~A on ~:S" + (arithmetic-error-operation c) + operands)))))) + +(define-condition division-by-zero (arithmetic-error) ()) + +(define-condition floating-point-underflow (arithmetic-error) ()) +(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition floating-point-inexact (arithmetic-error) ()) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) + +(define-condition compiler-bug (simple-error) + () + (:report (lambda (c stream) + (format stream "Compiler bug or inconsistency:~%") + (apply #'format stream (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(define-condition external-process-creation-failure (serious-condition) + ((proc :initarg :proc)) + (:report (lambda (c stream) + (with-slots (proc) c + (let* ((code (external-process-%exit-code proc))) + (format stream "Fork failed in ~s: ~a. " proc (if (eql code -1) "random lisp error" (%strerror code)))))))) + + +(defun restartp (thing) + (istruct-typep thing 'restart)) +(setf (type-predicate 'restart) 'restartp) + +(defmethod print-object ((restart restart) stream) + (let ((report (%restart-report restart))) + (cond ((or *print-escape* (null report)) + (print-unreadable-object (restart stream :identity t) + (format stream "~S ~S" + 'restart (%restart-name restart)))) + ((stringp report) + (write-string report stream)) + (t + (funcall report stream))))) + +(defun %make-restart (name action report interactive test) + (%cons-restart name action report interactive test)) + +(defun make-restart (vector name action-function &key report-function interactive-function test-function) + (unless vector (setq vector (%cons-restart nil nil nil nil nil))) + (setf (%restart-name vector) name + (%restart-action vector) (require-type action-function 'function) + (%restart-report vector) (if report-function (require-type report-function 'function)) + (%restart-interactive vector) (if interactive-function (require-type interactive-function 'function)) + (%restart-test vector) (if test-function (require-type test-function 'function))) + vector) + +(defun restart-name (restart) + "Return the name of the given restart object." + (%restart-name (require-type restart 'restart))) + +(defun applicable-restart-p (restart condition) + (let* ((pair (if condition (assq restart *condition-restarts*))) + (test (%restart-test restart))) + (and (or (null pair) (eq (%cdr pair) condition)) + (or (null test) (funcall test condition))))) + +(defun compute-restarts (&optional condition &aux restarts) + "Return a list of all the currently active restarts ordered from most + recently established to less recently established. If CONDITION is + specified, then only restarts associated with CONDITION (or with no + condition) will be returned." + (dolist (cluster %restarts% (nreverse restarts)) + (dolist (restart cluster) + (when (applicable-restart-p restart condition) + (push restart restarts))))) + +(defun find-restart (name &optional condition) + "Return the first active restart named NAME. If NAME names a + restart, the restart is returned if it is currently active. If no such + restart is found, NIL is returned. It is an error to supply NIL as a + name. If CONDITION is specified and not NIL, then only restarts + associated with that condition (or with no condition) will be + returned." + (dolist (cluster %restarts%) + (dolist (restart cluster) + (when (and (or (eq restart name) (eq (restart-name restart) name)) + (applicable-restart-p restart condition)) + (return-from find-restart restart))))) + +(defun %active-restart (name) + (dolist (cluster %restarts%) + (dolist (restart cluster) + (let* ((rname (%restart-name restart)) + (rtest (%restart-test restart))) + (when (and (or (eq restart name) (eq rname name)) + (or (null rtest) (funcall rtest nil))) + (return-from %active-restart (values restart cluster)))))) + (error 'inactive-restart :restart-name name)) + +(defun invoke-restart (restart &rest values) + "Calls the function associated with the given restart, passing any given + arguments. If the argument restart is not a restart or a currently active + non-nil restart name, then a CONTROL-ERROR is signalled." + (multiple-value-bind (restart tag) (%active-restart restart) + (let ((fn (%restart-action restart))) + (cond ((null fn) ; simple restart + (unless (null values) (%err-disp $xtminps)) + (throw tag nil)) + ((fixnump fn) ; restart case + (throw tag (cons fn values))) + ((functionp fn) ; restart bind + (apply fn values)) + (t ; with-simple-restart + (throw tag (values nil t))))))) + +(defun invoke-restart-no-return (restart) + (invoke-restart restart) + (error 'restart-failure :restart restart)) + +(defun invoke-restart-interactively (restart) + "Calls the function associated with the given restart, prompting for any + necessary arguments. If the argument restart is not a restart or a + currently active non-NIL restart name, then a CONTROL-ERROR is signalled." + (let* ((restart (find-restart restart))) + (format *error-output* "~&Invoking restart: ~a~&" restart) + (let* ((argfn (%restart-interactive restart)) + (values (when argfn (funcall argfn)))) + (apply #'invoke-restart restart values)))) + + + +(defun maybe-invoke-restart (restart value condition) + (let ((restart (find-restart restart condition))) + (when restart (invoke-restart restart value)))) + +(defun use-value (value &optional condition) + "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if + none exists." + (maybe-invoke-restart 'use-value value condition)) + +(defun store-value (value &optional condition) + "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if + none exists." + (maybe-invoke-restart 'store-value value condition)) + +(defun condition-arg (thing args type) + (cond ((condition-p thing) (if args (%err-disp $xtminps) thing)) + ((symbolp thing) (apply #'make-condition thing args)) + (t (make-condition type :format-control thing :format-arguments args)))) + +(defun make-condition (name &rest init-list) + "Make an instance of a condition object using the specified initargs." + (declare (dynamic-extent init-list)) + (if (subtypep name 'condition) + (apply #'make-instance name init-list) + (let ((class (if (classp name) + name + (find-class name)))) ;; elicit an error if no such class + (unless (class-finalized-p class) + (finalize-inheritance class)) ;; elicit an error if forward refs. + (error "~S is not a condition class" class)))) + +(defmethod print-object ((c condition) stream) + (if *print-escape* + (call-next-method) + (report-condition c stream))) + +(defmethod report-condition ((c condition) stream) + (princ (cond ((typep c 'error) "Error ") + ((typep c 'warning) "Warning ") + (t "Condition ")) + stream) + ;Here should dump all slots or something. For now... + (let ((*print-escape* t)) + (print-object c stream))) + +(defun signal-simple-condition (class-name format-string &rest args) + (let ((e #'error)) ; Never-tail-call. + (funcall e (make-condition class-name :format-control format-string :format-arguments args)))) + +(defun signal-simple-program-error (format-string &rest args) + (apply #'signal-simple-condition 'simple-program-error format-string args)) + +;;getting the function name for error functions. + + +(defun %last-fn-on-stack (&optional (number 0) (s (%get-frame-ptr))) + (let* ((fn nil)) + (let ((p s)) + (dotimes (i number) + (declare (fixnum i)) + (unless (setq p (parent-frame p nil)) + (return))) + (do* ((i number (1+ i))) + ((null p)) + (if (setq fn (cfp-lfun p)) + (return (values fn i)) + (setq p (parent-frame p nil))))))) + +(defun %err-fn-name (lfun) + "given an lfun returns the name or the string \"Unknown\"" + (if (lfunp lfun) (or (lfun-name lfun) lfun) + (or lfun "Unknown"))) + +(defun %real-err-fn-name (error-pointer) + (multiple-value-bind (fn p) (%last-fn-on-stack 0 error-pointer) + (let ((name (%err-fn-name fn))) + (if (and (memq name '( call-check-regs)) p) + (%err-fn-name (%last-fn-on-stack (1+ p) error-pointer)) + name)))) + + +;; Some simple restarts for simple error conditions. Callable from the kernel. + +(defun find-unique-homonyms (name &optional (test (constantly t))) + (delete-duplicates + (loop + with symbol = (if (consp name) (second name) name) + with pname = (symbol-name symbol) + for package in (list-all-packages) + for other-package-symbol = (find-symbol pname package) + for canditate = (and other-package-symbol + (neq other-package-symbol symbol) + (if (consp name) + (list (first name) other-package-symbol) + other-package-symbol)) + when (and canditate + (funcall test canditate)) + collect canditate) + :test #'equal)) + +(def-kernel-restart $xvunbnd %default-unbound-variable-restarts (frame-ptr cell-name) + (unless *level-1-loaded* + (dbg cell-name)) ; user should never see this. + (let ((condition (make-condition 'unbound-variable :name cell-name)) + (other-variables (find-unique-homonyms cell-name (lambda (name) + (and (not (keywordp name)) + (boundp name)))))) + (flet ((new-value () + (catch-cancel + (return-from new-value + (list (read-from-string + (get-string-from-user + (format nil "New value for ~s : " cell-name)))))) + (continue condition))) ; force error again if cancelled, var still not set. + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Retry getting the value of ~S." cell-name)) + (symbol-value cell-name)) + (use-homonym (homonym) + :test (lambda (c) (and (or (null c) (eq c condition)) other-variables)) + :report (lambda (s) + (if (= 1 (length other-variables)) + (format s "Use the value of ~s this time." (first other-variables)) + (format s "Use one of the homonyms ~{~S or ~} this time." other-variables))) + :interactive (lambda () + (if (= 1 (length other-variables)) + other-variables + (select-item-from-list other-variables :window-title "Select homonym to use"))) + (symbol-value homonym)) + (use-value (value) + :interactive new-value + :report (lambda (s) (format s "Specify a value of ~S to use this time." cell-name)) + value) + (store-value (value) + :interactive new-value + :report (lambda (s) (format s "Specify a value of ~S to store and use." cell-name)) + (setf (symbol-value cell-name) value)))))) + +(def-kernel-restart $xnopkg %default-no-package-restart (frame-ptr package-name) + (or (and *autoload-lisp-package* + (or (string-equal package-name "LISP") + (string-equal package-name "USER")) + (progn + (require "LISP-PACKAGE") + (find-package package-name))) + (let* ((alias (or (%cdr (assoc package-name '(("LISP" . "COMMON-LISP") + ("USER" . "CL-USER")) + :test #'string-equal)) + (if (packagep *package*) (package-name *package*)))) + (condition (make-condition 'no-such-package :package package-name))) + (flet ((try-again (p) + (or (find-package p) (%kernel-restart $xnopkg p)))) + (restart-case + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Retry finding package with name ~S." package-name)) + (try-again package-name)) + (use-value (value) + :interactive (lambda () (block nil + (catch-cancel + (return (list (get-string-from-user + "Find package named : ")))) + (continue condition))) + :report (lambda (s) (format s "Find specified package instead of ~S ." package-name)) + (try-again value)) + (make-nickname () + :report (lambda (s) (format s "Make ~S be a nickname for package ~S." package-name alias)) + (let ((p (try-again alias))) + (push package-name (cdr (pkg.names p))) + p))) + (require-lisp-package () + :test (lambda (c) + (and (eq c condition) + (or (string-equal package-name "LISP") (string-equal package-name "USER")))) + :report (lambda (s) + (format s "(require :lisp-package) and retry finding package ~s" + package-name)) + (require "LISP-PACKAGE") + (try-again package-name))))))) + +(def-kernel-restart $xunintc unintern-conflict-restarts (frame-ptr sym package conflicts) + (let ((condition (make-condition 'unintern-conflict-error :package package :sym sym :conflicts conflicts))) + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Try again to unintern ~s from ~s" sym package)) + (unintern sym package)) + (do-shadowing-import (ssym) + :report (lambda (s) (format s "SHADOWING-IMPORT one of ~S in ~S." conflicts package)) + :interactive (lambda () + (block nil + (catch-cancel + (return (select-item-from-list conflicts + :window-title + (format nil "Shadowing-import one of the following in ~s" package) + :table-print-function #'prin1))) + (continue condition))) + (shadowing-import (list ssym) package))))) + + +(def-kernel-restart $xusec blub (frame-ptr package-to-use using-package conflicts) + (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts nil)) + +(def-kernel-restart $xusecX blub (frame-ptr package-to-use using-package conflicts) + (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts t)) + +(defun resolve-use-package-conflict-error (frame-ptr package-to-use using-package conflicts external-p) + (let ((condition (make-condition 'use-package-conflict-error + :package using-package + :package-to-use package-to-use + :conflicts conflicts + :external-p external-p))) + (flet ((external-test (&rest ignore) (declare (ignore ignore)) external-p) + (present-test (&rest ignore) (declare (ignore ignore)) (not external-p))) + (declare (dynamic-extent #'present-test #'external-test)) + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Try again to use ~s in ~s" package-to-use using-package))) + (resolve-by-shadowing-import (&rest shadowing-imports) + :test external-test + :interactive (lambda () + (mapcar #'(lambda (pair) + (block nil + (catch-cancel + (return (car (select-item-from-list pair + :window-title + (format nil "Shadowing-import one of the following in ~s" using-package) + :table-print-function #'prin1)))) + (continue condition))) + conflicts)) + :report (lambda (s) (format s "SHADOWING-IMPORT one of each pair of conflicting symbols.")) + (shadowing-import shadowing-imports using-package)) + (unintern-all () + :test present-test + :report (lambda (s) (format s "UNINTERN all conflicting symbols from ~S" using-package)) + (dolist (c conflicts) + (unintern (car c) using-package))) + (shadow-all () + :test present-test + :report (lambda (s) (format s "SHADOW all conflicting symbols in ~S" using-package)) + (dolist (c conflicts) + (shadow-1 using-package (car c)))) + (resolve-by-unintern-or-shadow (&rest dispositions) + :test present-test + :interactive (lambda () + (mapcar #'(lambda (pair) + (let* ((present-sym (car pair))) + (block nil + (catch-cancel + (return (car (select-item-from-list (list 'shadow 'unintern) + :window-title + (format nil "SHADOW ~S in, or UNINTERN ~S from ~S" + present-sym + present-sym + using-package) + :table-print-function #'prin1))) + (continue condition))))) + conflicts)) + :report (lambda (s) (format s "SHADOW or UNINTERN the conflicting symbols in ~S." using-package)) + (dolist (d dispositions) + (let* ((sym (car (pop conflicts)))) + (if (eq d 'shadow) + (shadow-1 using-package sym) + (unintern sym using-package))))))))) + + +(defun resolve-export-conflicts (conflicts package) + (let* ((first-inherited (caar conflicts)) + (all-same (dolist (conflict (cdr conflicts) t) + (unless (eq (car conflict) first-inherited) (return nil)))) + (all-inherited (and all-same first-inherited)) + (all-present (and all-same (not first-inherited))) + (condition (make-condition 'export-conflict-error + :conflicts conflicts + :package package))) + (flet ((check-again () + (let* ((remaining-conflicts (check-export-conflicts (mapcar #'cadr conflicts) package))) + (if remaining-conflicts (resolve-export-conflicts remaining-conflicts package))))) + (restart-case (%error condition nil (%get-frame-ptr)) + (resolve-all-by-shadowing-import-inherited + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited) + :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting inherited symbol(s) in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (using-package inherited-sym) (cddr conflict) + (shadowing-import-1 using-package inherited-sym)))) + (resolve-all-by-shadowing-import-exported + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited) + :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting symbol(s) to be exported in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (exported-sym using-package ignore) (cdr conflict) + (declare (ignore ignore)) + (shadowing-import-1 using-package exported-sym)))) + (resolve-all-by-uninterning-present + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-present) + :report (lambda (s) (format s "UNINTERN all present conflicting symbol(s) in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (using-package inherited-sym) (cddr conflict) + (unintern inherited-sym using-package)))) + (resolve-all-by-shadowing-present + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-present) + :report (lambda (s) (format s "SHADOW all present conflicting symbol(s) in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (using-package inherited-sym) (cddr conflict) + (shadow-1 using-package inherited-sym)))) + (review-and-resolve + (dispositions) + :report (lambda (s) (format s "Review each name conflict and resolve individually.")) + :interactive (lambda () + (let* ((disp nil)) + (block b + (catch-cancel + (dolist (conflict conflicts (return-from b (list disp))) + (destructuring-bind (inherited-p exported-sym using-package conflicting-sym) conflict + (let* ((syms (list exported-sym conflicting-sym))) + (if inherited-p + (push (list 'shadowing-import + (select-item-from-list syms + :window-title + (format nil "Shadowing-import one of the following in ~s" using-package) + :table-print-function #'prin1) + using-package) + disp) + (let* ((selection (car (select-item-from-list syms + :window-title + (format nil "Shadow ~S or unintern ~s in ~s" + exported-sym + conflicting-sym using-package) + :table-print-function #'prin1)))) + (push (if (eq selection 'exported-sym) + (list 'shadow (list exported-sym) using-package) + (list 'unintern conflicting-sym using-package)) + disp))))))) + nil))) + (dolist (disp dispositions (check-again)) + (apply (car disp) (cdr disp)))))))) + + +(def-kernel-restart $xwrongtype default-require-type-restarts (frame-ptr value typespec) + (setq typespec (%type-error-type typespec)) + (let ((condition (make-condition 'type-error + :datum value + :expected-type typespec))) + (restart-case (%error condition nil frame-ptr) + (use-value (newval) + :report (lambda (s) + (format s "Use a new value of type ~s instead of ~s." typespec value)) + :interactive (lambda () + (format *query-io* "~&New value of type ~S :" typespec) + (list (read *query-io*))) + (require-type newval typespec))))) + +(def-kernel-restart $xudfcall default-undefined-function-call-restarts (frame-ptr function-name args) + (unless *level-1-loaded* + (dbg function-name)) ; user should never see this + (let ((condition (make-condition 'undefined-function-call + :name function-name + :function-arguments args)) + (other-functions (find-unique-homonyms function-name #'fboundp))) + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args)) + (apply function-name args)) + (use-homonym (function-name) + :test (lambda (c) (and (or (null c) (eq c condition)) other-functions)) + :report (lambda (s) + (if (= 1 (length other-functions)) + (format s "Apply ~s to ~S this time." (first other-functions) args) + (format s "Apply one of ~{~S or ~} to ~S this time." + other-functions args))) + :interactive (lambda () + (if (= 1 (length other-functions)) + other-functions + (select-item-from-list other-functions :window-title "Select homonym to use"))) + (apply (fdefinition function-name) args)) + (use-value (function) + :interactive (lambda () + (format *query-io* "Function to apply instead of ~s :" function-name) + (let ((f (read *query-io*))) + (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm) + (list (coerce f 'function)))) + :report (lambda (s) (format s "Apply specified function to ~S this time." args)) + (apply function args)) + (store-value (function) + :interactive (lambda () + (format *query-io* "Function to apply as new definition of ~s :" function-name) + (let ((f (read *query-io*))) + (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm) + (list (coerce f 'function)))) + :report (lambda (s) (format s "Specify a function to use as the definition of ~S." function-name)) + (apply (setf (symbol-function function-name) function) args))))) + + + +(defun %check-type (value typespec placename typename) + (let ((condition (make-condition 'type-error + :datum value + :expected-type typespec))) + (if typename + (setf (slot-value condition 'format-control) + (format nil "value ~~S is not ~A (~~S)." typename))) + (restart-case (%error condition nil (%get-frame-ptr)) + (store-value (newval) + :report (lambda (s) + (format s "Assign a new value of type ~a to ~s" typespec placename)) + :interactive (lambda () + (format *query-io* "~&New value for ~S :" placename) + (list (eval (read)))) + newval)))) + + +; This has to be defined fairly early (assuming, of course, that it "has" to be defined at all ... + +(defun ensure-value-of-type (value typespec placename &optional typename) + (tagbody + again + (unless (typep value typespec) + (let ((condition (make-condition 'type-error + :datum value + :expected-type typespec))) + (if typename + (setf (slot-value condition 'format-control) + (format nil "value ~~S is not ~A (~~S)." typename))) + (restart-case (%error condition nil (%get-frame-ptr)) + (store-value (newval) + :report (lambda (s) + (format s "Assign a new value of type ~a to ~s" typespec placename)) + :interactive (lambda () + (format *query-io* "~&New value for ~S :" placename) + (list (eval (read)))) + (setq value newval) + (go again)))))) + value) + +;;;The Error Function + +(defparameter *kernel-simple-error-classes* + (list (cons $xcalltoofew 'simple-destructuring-error) + (cons $xcalltoomany 'simple-destructuring-error) + (cons $xstkover 'stack-overflow-condition) + (cons $xmemfull 'simple-storage-condition) + (cons $xwrongtype 'type-error) ; this one needs 2 args + (cons $xdivzro 'division-by-zero) + (cons $xflovfl 'floating-point-overflow) + (cons $xfunbnd 'undefined-function) + (cons $xbadkeys 'simple-program-error) + (cons $xcallnomatch 'simple-program-error) + (cons $xnotfun 'call-special-operator-or-macro) + (cons $xaccessnth 'sequence-index-type-error) + (cons $ximproperlist 'improper-list) + (cons $xnospread 'cant-construct-arglist) + (cons $xnotelt 'array-element-type-error) + )) + + +(defparameter *simple-error-types* + (vector nil 'simple-program-error 'simple-file-error)) + +(defconstant $pgm-err #x10000) + + + + +(defparameter %type-error-typespecs% + #(array + bignum + fixnum + character + integer + list + number + sequence + simple-string + simple-vector + string + symbol + macptr + real + cons + unsigned-byte + (integer 2 36) + float + rational + ratio + short-float + double-float + complex + vector + simple-base-string + function + (unsigned-byte 16) + (unsigned-byte 8) + (unsigned-byte 32) + (signed-byte 32) + (signed-byte 16) + (signed-byte 8) + base-char + bit + (unsigned-byte 24) ; (integer 0 (array-total-size-limit)) + (unsigned-byte 64) + (signed-byte 64) + (unsigned-byte 56) + (simple-array double-float (* *)) + (simple-array single-float (* *)) + (mod #x110000) + (array * (* *)) ;2d array + (array * (* * *)) ;3d array + (array t) + (array bit) + (array (signed-byte 8)) + (array (unsigned-byte 8)) + (array (signed-byte 16)) + (array (unsigned-byte 16)) + (array (signed-byte 32)) + (array (unsigned-byte 32)) + (array (signed-byte 64)) + (array (unsigned-byte 64)) + (array fixnum) + (array single-float) + (array double-float) + (array character) + (array t (* *)) + (array bit (* *)) + (array (signed-byte 8) (* *)) + (array (unsigned-byte 8) (* *)) + (array (signed-byte 16) (* *)) + (array (unsigned-byte 16) (* *)) + (array (signed-byte 32) (* *)) + (array (unsigned-byte 32) (* *)) + (array (signed-byte 64) (* *)) + (array (unsigned-byte 64) (* *)) + (array fixnum (* *)) + (array single-float (* *)) + (array double-float (* *)) + (array character (* *)) + (simple-array t (* *)) + (simple-array bit (* *)) + (simple-array (signed-byte 8) (* *)) + (simple-array (unsigned-byte 8) (* *)) + (simple-array (signed-byte 16) (* *)) + (simple-array (unsigned-byte 16) (* *)) + (simple-array (signed-byte 32) (* *)) + (simple-array (unsigned-byte 32) (* *)) + (simple-array (signed-byte 64) (* *)) + (simple-array (unsigned-byte 64) (* *)) + (simple-array fixnum (* *)) + (simple-array character (* *)) + (array t (* * *)) + (array bit (* * *)) + (array (signed-byte 8) (* * *)) + (array (unsigned-byte 8) (* * *)) + (array (signed-byte 16) (* * *)) + (array (unsigned-byte 16) (* * *)) + (array (signed-byte 32) (* * *)) + (array (unsigned-byte 32) (* * *)) + (array (signed-byte 64) (* * *)) + (array (unsigned-byte 64) (* * *)) + (array fixnum (* * *)) + (array single-float (* * *)) + (array double-float (* * *)) + (array character (* * *)) + (simple-array t (* * *)) + (simple-array bit (* * *)) + (simple-array (signed-byte 8) (* * *)) + (simple-array (unsigned-byte 8) (* * *)) + (simple-array (signed-byte 16) (* * *)) + (simple-array (unsigned-byte 16) (* * *)) + (simple-array (signed-byte 32) (* * *)) + (simple-array (unsigned-byte 32) (* * *)) + (simple-array (signed-byte 64) (* * *)) + (simple-array (unsigned-byte 64) (* * *)) + (simple-array fixnum (* * *)) + (simple-array single-float (* * *)) + (simple-array double-float (* * *)) + (simple-array character (* * *)) + + (vector t) + bit-vector + (vector (signed-byte 8)) + (vector (unsigned-byte 8)) + (vector (signed-byte 16)) + (vector (unsigned-byte 16)) + (vector (signed-byte 32)) + (vector (unsigned-byte 32)) + (vector (signed-byte 64)) + (vector (unsigned-byte 64)) + (vector fixnum) + (vector single-float) + (vector double-float) + + )) + + +(defun %type-error-type (type) + (if (fixnump type) + (svref %type-error-typespecs% type) + type)) + +(defun %typespec-id (typespec) + (flet ((type-equivalent (t1 t2) (ignore-errors (and (subtypep t1 t2) (subtypep t2 t1))))) + (position typespec %type-error-typespecs% :test #'type-equivalent))) + + +(defmethod condition-p ((x t)) nil) +(defmethod condition-p ((x condition)) t) + + + +(let* ((globals ())) + + (defun %check-error-globals () + (let ((vars ()) + (valfs ()) + (oldvals ())) + (dolist (g globals (values vars valfs oldvals)) + (destructuring-bind (sym predicate newvalf) g + (let* ((boundp (boundp sym)) + (oldval (if boundp (symbol-value sym) (%unbound-marker-8)))) + (unless (and boundp (funcall predicate oldval)) + (push sym vars) + (push oldval oldvals) + (push newvalf valfs))))))) + + (defun check-error-global (sym checkfn newvalfn) + (setq sym (require-type sym 'symbol) + checkfn (require-type checkfn 'function) + newvalfn (require-type newvalfn 'function)) + (let ((found (assq sym globals))) + (if found + (setf (cadr found) checkfn (caddr found) newvalfn) + (push (list sym checkfn newvalfn) globals)) + sym)) +) + +(check-error-global '*package* #'packagep #'(lambda () (find-package "CL-USER"))) + + +(flet ((io-stream-p (x) (and (streamp x) (eq (stream-direction x) :io))) + (input-stream-p (x) (and (streamp x) (input-stream-p x))) + (output-stream-p (x) (and (streamp x) (output-stream-p x))) + (default-terminal-io () (make-echoing-two-way-stream *stdin* *stdout*)) + (terminal-io () *terminal-io*) + (standard-output () *standard-output*)) + + ;; Note that order matters. These need to come out of %check-error-globals with + ;; *terminal-io* first and *trace-output* last + (check-error-global '*terminal-io* #'io-stream-p #'default-terminal-io) + (check-error-global '*query-io* #'io-stream-p #'terminal-io) + (check-error-global '*debug-io* #'io-stream-p #'terminal-io) + (check-error-global '*standard-input* #'input-stream-p #'terminal-io) + (check-error-global '*standard-output* #'output-stream-p #'terminal-io) + (check-error-global '*error-output* #'output-stream-p #'standard-output) + (check-error-global '*trace-output* #'output-stream-p #'standard-output)) + Index: /branches/qres/ccl/level-1/l1-events.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-events.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-events.lisp (revision 13564) @@ -0,0 +1,268 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defvar *inhibit-abort* nil) + +;;; If any bits in the *periodic-task-mask* are set in the +;;; ptaskstate.flags word of a periodic task, it will not be run +(defvar *periodic-task-mask* 0) + +(defmethod print-object ((p periodic-task) stream) + (print-unreadable-object (p stream :type t :identity t) + (format stream "~s ~d" + (ptask.name p) + (ptaskstate.interval (ptask.state p))))) + +(defvar *periodic-task-lock* (make-lock)) + +(defun find-named-periodic-task (name) + (dolist (task *%periodic-tasks%*) + (when (eq name (ptask.name task)) + (return task)))) + +(defun %install-periodic-task (name function interval &optional + (flags 0) + (privatedata (%null-ptr))) + (with-lock-grabbed (*periodic-task-lock*) + (let* ((already (find-named-periodic-task name)) + (state (if already (ptask.state already) + (%istruct 'ptaskstate 0 0 0 0))) + (task (or already (%istruct 'periodic-task state name nil)))) + (setf (ptask.function task) function) + (setf (ptaskstate.interval state) interval + (ptaskstate.flags state ) flags + (ptaskstate.privatedata state) privatedata + (ptaskstate.nexttick state) (+ (get-tick-count) interval)) + (unless already (push task *%periodic-tasks%*)) + (let* ((interval-in-seconds (/ interval (float *ticks-per-second*)))) + (if (< interval-in-seconds *periodic-task-interval*) + (set-periodic-task-interval interval-in-seconds))) + task))) + +(defmacro with-periodic-task-mask ((mask) &body body) + (let ((thunk (gensym))) + `(let ((,thunk #'(lambda () ,@body))) + (funcall-with-periodic-task-mask ,mask ,thunk)))) + +(defvar *periodic-task-masks* nil) + +; All this hair is so that multiple processes can vote on the *periodic-task-mask* +(defun funcall-with-periodic-task-mask (mask thunk) + (let* ((cell (list mask))) + (declare (dynamic-extent cell)) + (flet ((logior-list (list) + (declare (type list list)) + (let ((res 0)) + (declare (fixnum res)) + (loop + (when (null list) (return res)) + (setq res (%ilogior res (pop list))))))) + (declare (inline logior-list)) + (unwind-protect + (progn + (without-interrupts + (setf (cdr cell) *periodic-task-masks* + *periodic-task-masks* cell) + (setq *periodic-task-mask* (logior-list *periodic-task-masks*)) +) + (funcall thunk)) + (without-interrupts + (let* ((first *periodic-task-masks*) + (this first) + (last nil)) + (declare (type cons first this last)) + (loop + (when (eq this cell) + (if last + (setf (cdr last) (cdr this)) + (pop first)) + (return (setq *periodic-task-masks* first))) + (setq last this + this (cdr this)))) + (setq *periodic-task-mask* (logior-list *periodic-task-masks*))))))) + +(defparameter *invoke-debugger-hook-on-interrupt* nil) + +(define-condition interrupt-signal-condition (condition) () + (:report "interrupt signal")) + +(defun force-break-in-listener (p) + (process-interrupt p + #'(lambda () + (multiple-value-bind (vars inits old-vals) (%check-error-globals) + (progv vars old-vals + (mapcar (lambda (v f) (set v (funcall f))) vars inits) + (let ((condition (make-condition 'interrupt-signal-condition)) + (*top-error-frame* (%current-exception-frame))) + (ignoring-without-interrupts + (when *invoke-debugger-hook-on-interrupt* + (let* ((hook *debugger-hook*) + (*debugger-hook* nil)) + (when hook + (funcall hook condition hook)))) + (%break-in-frame *top-error-frame* condition) + (clear-input *terminal-io*)))))))) + +(defglobal *quit-interrupt-hook* nil) + +(defun force-async-quit (signum) + (when *quit-interrupt-hook* + (multiple-value-bind (req opt restp) (function-args *quit-interrupt-hook*) + (if (and (= req 0) (= opt 0) (not restp)) + (funcall *quit-interrupt-hook*) + (funcall *quit-interrupt-hook* signum)))) + ;; Exit by resignalling, as per http://www.cons.org/cracauer/sigint.html + (quit #'(lambda () + (ff-call (%kernel-import target::kernel-import-lisp-sigexit) :signed signum) + ;; Shouldn't get here + (#__exit 143)))) + +(defstatic *running-periodic-tasks* nil) + +(defun cmain () + (thread-handle-interrupts)) + + +(defvar *select-interactive-process-hook* nil) + +(defun select-interactive-abort-process () + (flet ((maybe-proc (proc) (and proc (process-active-p proc) proc))) + (or (maybe-proc (and *select-interactive-process-hook* + (funcall *select-interactive-process-hook*))) + (maybe-proc *interactive-abort-process*) + (let* ((sr (input-stream-shared-resource *terminal-input*))) + (when sr + (or (maybe-proc (shared-resource-current-owner sr)) + (maybe-proc (shared-resource-primary-owner sr)))))))) + +(defun handle-gc-hooks () + (let ((bits *gc-event-status-bits*)) + (declare (fixnum bits)) + (cond ((logbitp $gc-postgc-pending-bit bits) + (setq *gc-event-status-bits* + (logand (lognot (ash 1 $gc-postgc-pending-bit)) + bits)) + (let ((f *post-gc-hook*)) + (when (functionp f) (funcall f))))))) + +(defconstant $user-interrupt-break 1) +(defconstant $user-interrupt-quit 2) + +(defun housekeeping () + (progn + (handle-gc-hooks) + (unless *inhibit-abort* + (let* ((id (pending-user-interrupt)) + (kind (logand #xFF id))) + (cond ((eql kind $user-interrupt-quit) + ;; Try to use a process that has a shot at reporting any problems + ;; in case of bugs in user hook. + (let* ((proc (or (select-interactive-abort-process) + *initial-process*)) + (signum (ash id -8))) + (process-interrupt proc #'force-async-quit signum))) + ((eql kind $user-interrupt-break) + (let* ((proc (select-interactive-abort-process))) + (if proc + (force-break-in-listener proc))))))) + (flet ((maybe-run-periodic-task (task) + (let ((now (get-tick-count)) + (state (ptask.state task))) + (when (and (>= (- now (ptaskstate.nexttick state)) + 0) + (eql 0 (logand (the fixnum (ptaskstate.flags state)) + (the fixnum *periodic-task-mask*)))) + (setf (ptaskstate.nexttick state) + (+ now (ptaskstate.interval state))) + (funcall (ptask.function task)))))) + (let ((event-dispatch-task *event-dispatch-task*)) + (maybe-run-periodic-task event-dispatch-task) + (with-lock-grabbed (*periodic-task-lock*) + (bitclrf $gc-allow-stack-overflows-bit *gc-event-status-bits*) + (unless *running-periodic-tasks* + (let-globally ((*running-periodic-tasks* t)) + (dolist (task *%periodic-tasks%*) + (unless (eq task event-dispatch-task) + (maybe-run-periodic-task task)))))))))) + + +(defun %remove-periodic-task (name) + (with-lock-grabbed (*periodic-task-lock*) + (let ((task (find-named-periodic-task name))) + (when task + (if (setq *%periodic-tasks%* (delete task *%periodic-tasks%*)) + (let* ((min-ticks target::target-most-positive-fixnum)) + (dolist (other *%periodic-tasks%* + (set-periodic-task-interval (/ min-ticks (float *ticks-per-second*)))) + (let* ((other-ticks + (ptaskstate.interval (ptask.state other)))) + (if (< other-ticks min-ticks) + (setq min-ticks other-ticks))))) + (set-periodic-task-interval 1))) + task))) + + +(defun auto-flush-interactive-streams () + (with-lock-grabbed (*auto-flush-streams-lock*) + (dolist (s *auto-flush-streams*) + (when (open-stream-p s) + (if (or (typep s 'basic-stream) + (typep s 'buffered-io-stream-mixin)) + (if (ioblock-outbuf-lock (stream-ioblock s t)) + (force-output s))) + (force-output s))))) + +(defun add-auto-flush-stream (s) + (with-lock-grabbed (*auto-flush-streams-lock*) + (when (typep s 'output-stream) + (pushnew s *auto-flush-streams*)))) + +(defun remove-auto-flush-stream (s) + (with-lock-grabbed (*auto-flush-streams-lock*) + (setq *auto-flush-streams* (delete s *auto-flush-streams*)))) + +; Is it really necessary to keep this guy in a special variable ? +(defloadvar *event-dispatch-task* + (%install-periodic-task + 'auto-flush-interactive-streams + 'auto-flush-interactive-streams + 33 + (+ $ptask_draw-flag $ptask_event-dispatch-flag))) + + +(defun event-ticks () + (let ((task *event-dispatch-task*)) + (when task (ptaskstate.interval (ptask.state task))))) + +(defun set-event-ticks (n) + (setq n (require-type n '(integer 0 32767))) ; Why this weird limit ? + (let ((task *event-dispatch-task*)) + (when task (setf (ptaskstate.interval (ptask.state task)) n)))) + +;; Making the *initial-process* quit will cause an exit(), +;; though it might be nicer if all processes were shut down +;; in an orderly manner first. This is the not-so-nice way +;; of quitting ... +(defun %quit () + (quit)) + + + +; end of L1-events.lisp + Index: /branches/qres/ccl/level-1/l1-files.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-files.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-files.lisp (revision 13564) @@ -0,0 +1,1481 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-files.lisp - Object oriented file stuff + +(in-package "CCL") + +(defconstant $paramErr -50) ; put this with the rest when we find the rest + +(defconstant pathname-case-type '(member :common :local :studly)) +(defconstant pathname-arg-type '(or string pathname stream)) + +(defmacro signal-file-error (err-num &optional pathname &rest args) + `(%signal-file-error ,err-num + ,@(if pathname (list pathname)) + ,@(if args args))) + +(defun %signal-file-error (err-num &optional pathname args) + (declare (fixnum err-num)) + (let* ((err-code (logior (ash 2 16) (the fixnum (logand #xffff (the fixnum err-num)))))) + (funcall (if (< err-num 0) '%errno-disp '%err-disp) + err-code + pathname + args))) + + +(defvar %logical-host-translations% '()) +(defvar *load-pathname* nil + "the defaulted pathname that LOAD is currently loading") +(defvar *load-truename* nil + "the TRUENAME of the file that LOAD is currently loading") + + +(defparameter *default-pathname-defaults* + (let* ((hide-from-compile-file (%cons-pathname nil nil nil))) + hide-from-compile-file)) + +;Right now, the only way it's used is that an explicit ";" expands into it. +;Used to merge with it before going to ROM. Might be worth to bring that back, +;it doesn't hurt anything if you don't set it. +;(defparameter *working-directory* (%cons-pathname nil nil nil)) + +;These come in useful... We should use them consistently and then document them, +;thereby earning the eternal gratitude of any users who find themselves with a +;ton of "foo.CL" files... +(defparameter *.fasl-pathname* + (%cons-pathname nil nil + #.(pathname-type + (backend-target-fasl-pathname *target-backend*)))) + +(defparameter *.lisp-pathname* (%cons-pathname nil nil "lisp")) + +(defun if-exists (if-exists filename &optional (prompt "Create ...")) + (case if-exists + (:error (signal-file-error (- #$EEXIST) filename)) + ((:dialog) (overwrite-dialog filename prompt)) + ((nil) nil) + ((:ignored :overwrite :append :supersede :rename-and-delete :new-version :rename) filename) + (t (report-bad-arg if-exists '(member :error :dialog nil :ignored :overwrite :append :supersede :rename-and-delete))))) + +(defun if-does-not-exist (if-does-not-exist filename) + (case if-does-not-exist + (:error (signal-file-error (- #$ENOENT) filename)) ; (%err-disp $err-no-file filename)) + (:create filename) + ((nil) (return-from if-does-not-exist nil)) + (t (report-bad-arg if-does-not-exist '(member :error :create nil))))) + + +(defun native-translated-namestring (path) + (let ((name (translated-namestring path))) + ;; Check that no quoted /'s + (when (%path-mem-last-quoted "/" name) + (signal-file-error $xbadfilenamechar name #\/)) + ;; Check that no unquoted wildcards. + (when (%path-mem-last "*" name) + (signal-file-error $xillwild name)) + (namestring-unquote name))) + +(defun native-untranslated-namestring (path) + (let ((name (namestring (translate-logical-pathname path)))) + ;; Check that no quoted /'s + (when (%path-mem-last-quoted "/" name) + (signal-file-error $xbadfilenamechar name #\/)) + ;; Check that no unquoted wildcards. + (when (%path-mem-last "*" name) + (signal-file-error $xillwild name)) + (namestring-unquote name))) + +;; Reverse of above, take native namestring and make a Lisp pathname. +(defun native-to-pathname (name) + (pathname (%path-std-quotes name nil + #+windows-target "*;" + #-windows-target "*;:"))) + +(defun native-to-directory-pathname (name) + #+windows-target + (let* ((len (length name))) + (when (and (> len 1) (not (or (eql (schar name (1- len)) #\/) + (eql (schar name (1- len)) #\\)))) + (setq name (%str-cat name "/"))) + (string-to-pathname name)) + #-windows-target + (make-directory-pathname :device nil :directory (%path-std-quotes name nil "*;:"))) + +;;; Make a pathname which names the specified directory; use +;;; explict :NAME, :TYPE, and :VERSION components of NIL. +(defun make-directory-pathname (&key host device directory) + (make-pathname :host host + :device device + :directory directory + :name nil + :type nil + :version nil)) + + +(defun namestring-unquote (name) + #+(and windows-target bogus) + (when (and (> (length name) 1) + (eql (schar name 1) #\|)) + (setq name (subseq name 0)) + (setf (schar name 1) #\:)) + (let ((esc *pathname-escape-character*)) + (if (position esc name) + (multiple-value-bind (sstr start end) (get-sstring name) + (let ((result (make-string (%i- end start) :element-type 'base-char)) + (dest 0)) + (loop + (let ((pos (or (position esc sstr :start start :end end) end))) + (while (%i< start pos) + (setf (%schar result dest) (%schar sstr start) + start (%i+ start 1) + dest (%i+ dest 1))) + (when (eq pos end) + (return nil)) + (setq start (%i+ pos 1)))) + (shrink-vector result dest))) + name))) + +(defun translated-namestring (path) + (namestring (translate-logical-pathname (merge-pathnames path)))) + + +(defun truename (path) + "Return the pathname for the actual file described by PATHNAME. + An error of type FILE-ERROR is signalled if no such file exists, + or the pathname is wild. + + Under Unix, the TRUENAME of a broken symlink is considered to be + the name of the broken symlink itself." + (or (probe-file path) + (signal-file-error $err-no-file path))) + +(defun check-pathname-not-wild (path) + (when (wild-pathname-p path) + (error 'file-error :error-type "Inappropriate use of wild pathname ~s" + :pathname path)) + path) + +(defun probe-file (path) + "Return a pathname which is the truename of the file if it exists, or NIL + otherwise. An error of type FILE-ERROR is signaled if pathname is wild." + (check-pathname-not-wild path) + (let* ((native (native-translated-namestring path)) + (realpath (%realpath native)) + (kind (if realpath (%unix-file-kind realpath)))) + ;; Darwin's #_realpath will happily return non-nil for + ;; files that don't exist. I don't think that + ;; %UNIX-FILE-KIND would do so. + (when kind + (if (eq kind :directory) + (unless (eq (aref realpath (1- (length realpath))) #\/) + (setq realpath (%str-cat realpath "/")))) + (if realpath + (native-to-pathname realpath) + nil)))) + +(defun cwd (path) + (multiple-value-bind (realpath kind) (%probe-file-x (native-translated-namestring path)) + (if kind + (if (eq kind :directory) + (let* ((error (%chdir realpath))) + (if (eql error 0) + (mac-default-directory) + (signal-file-error error path))) + (error "~S is not a directory pathname." path)) + (error "Invalid pathname : ~s." path)))) + +(defun create-file (path &key (if-exists :error) (create-directory t)) + (let* ((p (%create-file path :if-exists if-exists + :create-directory create-directory))) + (and p + (native-to-pathname p)))) + +(defun %create-file (path &key + (if-exists :error) + (create-directory t)) + (when create-directory + (create-directory path)) + (when (directory-pathname-p path) + (return-from %create-file (probe-file-x path))) + (assert (or (eql if-exists :overwrite) + (null if-exists) + (eq if-exists :error) + (not (probe-file path))) () + "~s ~s not implemented yet" :if-exists if-exists) + (let* ((unix-name (native-translated-namestring path)) + (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC + (if (or (null if-exists) + (eq if-exists :error)) + #$O_EXCL + 0))))) + (if (< fd 0) + (if (and (null if-exists) + (or (eql fd (- #$EEXIST)) + #+windows-target + (and (eql fd (- #$EPERM)) + (probe-file path)))) + (return-from %create-file nil) + (signal-file-error fd path)) + (fd-close fd)) + (%realpath unix-name))) + + +;; The following assumptions are deeply embedded in all our pathname code: +;; (1) Non-logical pathname host is always :unspecific. +;; (2) Logical pathname host is never :unspecific. +;; (3) Logical pathname host can however be NIL, e.g. "foo;bar;baz". + +(defun %pathname-host (pathname) + (if (logical-pathname-p pathname) + (%logical-pathname-host pathname) + :unspecific)) + +(defun %pathname-version (pathname) + (if (logical-pathname-p pathname) + (%logical-pathname-version pathname) + (%physical-pathname-version pathname))) + + + +(fset 'pathname-host (nfunction bootstrapping-pathname-host ; redefined later in this file + (lambda (thing) + (declare (ignore thing)) + :unspecific))) + +(fset 'pathname-version (nfunction bootstrapping-pathname-version ; redefined later in this file + (lambda (thing) + (declare (ignore thing)) + nil))) + +(defmethod print-object ((pathname pathname) stream) + (let ((flags (if (logical-pathname-p pathname) 4 + (%i+ (if (eq (%pathname-type pathname) ':unspecific) 1 0) + (if (equal (%pathname-name pathname) "") 2 0)))) + (name (namestring pathname))) + (if (and (not *print-readably*) (not *print-escape*)) + (write-string name stream) + (progn + (format stream (if (or *print-escape* (eql flags 0)) "#P" "#~DP") flags) + (write-escaped-string name stream #\"))))) + + +(defun mac-default-directory () + (let* ((native-name (current-directory-name)) + (len (length native-name))) + (declare (fixnum len)) + (when (and (> len 1) + (not (eq #\/ (schar native-name (1- len))))) + (setq native-name (%str-cat native-name "/"))) + (native-to-pathname native-name))) + + + + +;;; I thought I wanted to call this from elsewhere but perhaps not +(defun absolute-directory-list (dirlist) + ; just make relative absolute and remove ups where possible + (when (or (null dirlist) (eq (car dirlist) :relative)) + (let ((default (mac-default-directory)) default-dir) + (when default + (setq default-dir (%pathname-directory default)) + (when default-dir + (setq dirlist (append default-dir (cdr dirlist))))))) + (when (memq :up dirlist) + (setq dirlist (remove-up (copy-list dirlist)))) + dirlist) + +; destructively mungs dir +(defun remove-up (dir) + (setq dir (delete "." dir :test #'string=)) + (let ((n 0) + (last nil) + (sub dir) + has-abs kept-up) + ;; from %std-directory-component we get dir with :relative/:absolute stripped + (when (memq :up dir) + (when (memq (car dir) '(:relative :absolute)) + (setq sub (cdr dir) n 1 has-abs t)) + (do () ((null sub)) + (cond ((eq (car sub) :up) + (cond ((or (eq n 0) + (and (stringp last)(string= last "**")) + (eq last :wild-inferiors) + kept-up + (and has-abs (eq n 1))) + ;; up after "**" stays, initial :up stays, how bout 2 :ups + (setq kept-up t) + ) + ((eq n 1) (setq dir (cddr dir) kept-up nil n -1)) + (t (rplacd (nthcdr (- n 2) dir) (cdr sub)) + (setq n (- n 2) kept-up nil)))) + (t (setq kept-up nil))) + (setq last (car sub) + n (1+ n) + sub (cdr sub)))) + dir)) + +(defun namestring (path) + "Construct the full (name)string form of the pathname." + (%str-cat (device-namestring path) + (host-namestring path) + (directory-namestring path) + (file-namestring path))) + +(defun device-namestring (path) + (let* ((device (pathname-device path))) + (if (and device (not (eq device :unspecific))) + (%str-cat device ":") + ""))) + +(defun host-namestring (path) + "Return a string representation of the name of the host in the pathname." + (let ((host (pathname-host path))) + (if (and host (neq host :unspecific)) (%str-cat host ":") ""))) + +(defun directory-namestring (path) + "Return a string representation of the directories used in the pathname." + (%directory-list-namestring (pathname-directory path) + (neq (pathname-host path) :unspecific))) + +(defun ensure-directory-namestring (string) + (namestring (ensure-directory-pathname string))) + +(defun ensure-directory-pathname (pathname) + (let ((path (pathname pathname))) + (if (directory-pathname-p path) + path + (cons-pathname (append (or (pathname-directory path) + ;; This makes sure "ccl:foo" maps to "ccl:foo;" (not + ;; "ccl:;foo;"), but "foo" maps to "foo/" (not "/foo/"). + (if (eq (pathname-host path) :unspecific) + '(:relative) + '(:absolute))) + ;; Don't use file-namestring, because that + ;; includes the version for logical names. + (list (file-namestring-from-parts + (pathname-name path) + (pathname-type path) + nil))) + nil nil (pathname-host path))))) + +(defun %directory-list-namestring (list &optional logical-p) + (if (null list) + "" + (let ((len (if (eq (car list) (if logical-p :relative :absolute)) 1 0)) + + result) + (declare (fixnum len)(optimize (speed 3)(safety 0))) + (dolist (s (%cdr list)) + (case s + (:wild (setq len (+ len 2))) + (:wild-inferiors (setq len (+ len 3))) + (:up (setq len (+ len 3))) + (t ;This assumes that special chars in dir components are escaped, + ;otherwise would have to pre-scan for escapes here. + (setq len (+ len 1 (length s)))))) + (setq result + (make-string len)) + (let ((i 0) + (sep (if logical-p #\; #\/))) + (declare (fixnum i)) + (when (eq (%car list) (if logical-p :relative :absolute)) + (setf (%schar result 0) sep) + (setq i 1)) + (dolist (s (%cdr list)) + (case s + (:wild (setq s "*")) + (:wild-inferiors (setq s "**")) + ;; There is no :up in logical pathnames, so this must be native + (:up (setq s ".."))) + (let ((len (length s))) + (declare (fixnum len)) + (move-string-bytes s result 0 i len) + (setq i (+ i len))) + (setf (%schar result i) sep) + (setq i (1+ i)))) + result))) + +(defun file-namestring (path) + "Return a string representation of the name used in the pathname." + (let* ((path (pathname path)) + (name (pathname-name path)) + (type (pathname-type path)) + (version (if (typep path 'logical-pathname) (pathname-version path)))) + (file-namestring-from-parts name type version))) + +(defun file-namestring-from-parts (name type version) + (when (eq version :unspecific) (setq version nil)) + (when (eq type :unspecific) (setq type nil)) + (%str-cat (case name + ((nil :unspecific) "") + (:wild "*") + (t (%path-std-quotes name "*;:" "."))) + (if (or type version) + (%str-cat (case type + ((nil) ".") + (:wild ".*") + (t (%str-cat "." (%path-std-quotes type "*;:" ".")))) + (case version + ((nil) "") + (:newest ".newest") + (:wild ".*") + (t (%str-cat "." (if (fixnump version) + (%integer-to-string version) + version))))) + ""))) + +(defun enough-namestring (path &optional (defaults *default-pathname-defaults*)) + "Return an abbreviated pathname sufficent to identify the pathname relative + to the defaults." + (if (null defaults) + (namestring path) + (let* ((dir (pathname-directory path)) + (nam (pathname-name path)) + (typ (pathname-type path)) + (ver (pathname-version path)) + (host (pathname-host path)) + (logical-p (neq host :unspecific)) + (default-dir (pathname-directory defaults))) + ;; enough-host-namestring + (setq host (if (and host + (neq host :unspecific) + (not (equalp host (pathname-host defaults)))) + (%str-cat host ":") + "")) + ;; enough-directory-namestring + (cond ((equalp dir default-dir) + (setq dir '(:relative))) + ((and dir default-dir + (eq (car dir) :absolute) (eq (car default-dir) :absolute)) + ;; maybe make it relative to defaults + (do ((p1 (cdr dir) (cdr p1)) + (p2 (cdr default-dir) (cdr p2))) + ((or (null p2) (null p1) (not (equalp (car p1) (car p2)))) + (when (and (null p2) (or t (neq p1 (cdr dir)))) + (setq dir (cons :relative p1))))))) + (setq dir (%directory-list-namestring dir logical-p)) + ;; enough-file-namestring + (when (or (equalp ver (pathname-version defaults)) + (not logical-p)) + (setq ver nil)) + (when (and (null ver) (equalp typ (pathname-type defaults))) + (setq typ nil)) + (when (and (null typ) (equalp nam (pathname-name defaults))) + (setq nam nil)) + (setq nam (file-namestring-from-parts nam typ ver)) + (%str-cat host dir nam)))) + +(defun cons-pathname (dir name type &optional host version device) + (if (neq host :unspecific) + (%cons-logical-pathname dir name type host version) + (%cons-pathname dir name type version device))) + +(defun pathname (path) + "Convert thing (a pathname, string or stream) into a pathname." + (etypecase path + (pathname path) + (stream (%path-from-stream path)) + (string (string-to-pathname path)))) + +(defun %path-from-stream (stream) + (or (pathname (stream-filename stream)) + (error "Can't determine pathname of ~S ." stream))) ; ??? + +;Like (pathname stream) except returns NIL rather than error when there's no +;filename associated with the stream. +(defun stream-pathname (stream &aux (path (stream-filename stream))) + (when path (pathname path))) + +(defun get-pathname-sstring (string &optional (start 0) (end (length string))) + #-windows-target + (get-sstring string start end) + #+windows-target + (multiple-value-bind (sstr start end) + (get-sstring string start end) + (declare (fixnum start end) + (simple-string sstr)) + (if (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (when (eql (schar sstr i) #\\) + (return t))) + (let* ((len (- end start)) + (new (make-string len))) + (declare (fixnum len) (simple-string new)) + (dotimes (i len) + (let* ((ch (schar sstr start))) + (if (eql ch #\\) + (setf (schar new i) #\/) + (setf (schar new i) ch))) + (incf start)) + (values new 0 len)) + (values sstr start end)))) + +(defun string-to-pathname (string &optional (start 0) (end (length string)) + (reference-host nil) + (defaults *default-pathname-defaults*)) + (require-type reference-host '(or null string)) + (multiple-value-bind (sstr start end) (get-pathname-sstring string start end) + #-windows-target + (if (and (> end start) + (eql (schar sstr start) #\~)) + (setq sstr (tilde-expand (subseq sstr start end)) + start 0 + end (length sstr))) + (let (directory name type host version device (start-pos start) (end-pos end) has-slashes) + (multiple-value-setq (host start-pos has-slashes) (pathname-host-sstr sstr start-pos end-pos)) + (cond ((and host (neq host :unspecific)) + (when (and reference-host (not (string-equal reference-host host))) + (error "Host in ~S does not match requested host ~S" + (%substr sstr start end) reference-host))) + ((or reference-host + (and defaults + (neq (setq reference-host (pathname-host defaults)) :unspecific))) + ;;If either a reference-host is specified or defaults is a logical pathname + ;; then the string must be interpreted as a logical pathname. + (when has-slashes + (error "Illegal logical namestring ~S" (%substr sstr start end))) + (setq host reference-host))) + #+windows-target + (when (and (eq host :unspecific) + (eql start-pos 0) + (eql (position #\: sstr) 1)) + (let* ((ch (schar sstr 0))) + (when (and (alpha-char-p ch) + (standard-char-p ch)) + (setq device (make-string 1 :initial-element ch) + start-pos 2)))) + (multiple-value-setq (directory start-pos) (pathname-directory-sstr sstr start-pos end-pos host)) + (unless (eq host :unspecific) + (multiple-value-setq (version end-pos) (pathname-version-sstr sstr start-pos end-pos))) + (multiple-value-setq (type end-pos) (pathname-type-sstr sstr start-pos end-pos)) + ;; now everything else is the name + (unless (eq start-pos end-pos) + (setq name (%std-name-component (%substr sstr start-pos end-pos)))) + (if (eq host :unspecific) + (%cons-pathname directory name type (if name :newest) device) + (%cons-logical-pathname directory name type host version))))) + +(defun parse-namestring (thing &optional host (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed) + (declare (ignore junk-allowed)) + (unless (typep thing 'string) + (let* ((path (pathname thing)) + (pathname-host (pathname-host path))) + (when (and host pathname-host + (or (eq pathname-host :unspecific) ;physical + (not (string-equal host pathname-host)))) + (error "Host in ~S does not match requested host ~S" path host)) + (return-from parse-namestring (values path start)))) + (when host + (verify-logical-host-name host)) + (setq end (check-sequence-bounds thing start end)) + (values (string-to-pathname thing start end host defaults) end)) + + + +(defun %std-device-component (device host) + (when (and (or (null host) (eq host :unspecific)) + (and device (not (eq device :unspecific)))) + #+windows-target + (unless (and (typep device 'string) + (eql (length device) 1) + (alpha-char-p (char device 0)) + (standard-char-p (char device 0))) + (error "Invalid pathname device ~s" device)) + device)) + +(defun make-pathname (&key (host nil host-p) + (device nil device-p) + (directory nil directory-p) + (name nil name-p) + (type nil type-p) + (version nil version-p) + (defaults nil defaults-p) case + &aux path) + "Makes a new pathname from the component arguments. Note that host is +a host-structure or string." + (when case (setq case (require-type case pathname-case-type))) + (if (null host-p) + (let ((defaulted-defaults (if defaults-p defaults *default-pathname-defaults*))) + (setq host (if defaulted-defaults + (pathname-host defaulted-defaults) + :unspecific))) + (unless host (setq host :unspecific))) + (if directory-p + (setq directory (%std-directory-component directory host))) + (if (and defaults (not directory-p)) + (setq directory (pathname-directory defaults))) + (if (and defaults (not device-p)) + (setq device (pathname-device defaults))) + (setq device (%std-device-component device host)) + (setq name + (if name-p + (%std-name-component name) + (and defaults (pathname-name defaults)))) + (setq type + (if type-p + (%std-type-component type) + (and defaults (pathname-type defaults)))) + (setq version (if version-p + (%logical-version-component version) + (if name-p + nil + (and defaults (pathname-version defaults))))) + (setq path + (if (eq host :unspecific) + (%cons-pathname directory name type version device) + (%cons-logical-pathname + (or directory + (unless directory-p '(:absolute))) + name type host version))) + (when (and (eq (car directory) :absolute) + (member (cadr directory) '(:up :back))) + (error 'simple-file-error :pathname path :error-type "Second element of absolute directory component in ~s is ~s" :format-arguments (list (cadr directory)))) + (let* ((after-wif (cadr (member :wild-inferiors directory)))) + (when (member after-wif '(:up :back)) + (error 'simple-file-error :pathname path :error-type "Directory component in ~s contains :WILD-INFERIORS followed by ~s" :format-arguments (list after-wif)))) + + (when (and case (neq case :local)) + (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case) + (%pathname-name path) (%reverse-component-case (%pathname-name path) case) + (%pathname-type path) (%reverse-component-case (%pathname-type path) case))) + path) + +;;; In portable CL, if the :directory argument to make pathname is a +;;; string, it should be the name of a top-level directory and should +;;; not contain any punctuation characters such as "/" or ";". In +;;; MCL a string :directory argument with slashes or semi-colons will +;;; be parsed as a directory in the obvious way. +(defun %std-directory-component (directory host) + (cond ((null directory) nil) + ((eq directory :wild) '(:absolute :wild-inferiors)) + ((stringp directory) (%directory-string-list directory 0 (length directory) host)) + ((listp directory) + ;Standardize the directory list, taking care not to cons if nothing + ;needs to be changed. + (let ((names (%cdr directory)) (new-names ())) + (do ((nn names (%cdr nn))) + ((null nn) (setq new-names (if new-names (nreverse new-names) names))) + (let* ((name (car nn)) + (new-name (%std-directory-part name))) + (unless (eq name new-name) + (unless new-names + (do ((new-nn names (%cdr new-nn))) + ((eq new-nn nn)) + (push (%car new-nn) new-names)))) + (when (or new-names (neq name new-name)) + (push new-name new-names)))) + (when (memq :up (or new-names names)) + (setq new-names (remove-up (copy-list (or new-names names))))) + (ecase (%car directory) + (:relative + (cond (new-names ; Just (:relative) is the same as NIL. - no it isnt + (if (eq new-names names) + directory + (cons ':relative new-names))) + (t directory))) + (:absolute + (cond ((null new-names) directory) ; But just (:absolute) IS the same as NIL + ((eq new-names names) directory) + (t (cons ':absolute new-names))))))) + (t (report-bad-arg directory '(or string list (member :wild)))))) + +(defun %std-directory-part (name) + (case name + ((:wild :wild-inferiors :up) name) + (:back :up) + (t (cond ((string= name "*") :wild) + ((string= name "**") :wild-inferiors) + ((string= name "..") :up) + (t (%path-std-quotes name "/:;*" "/:;")))))) + +; this will allow creation of garbage pathname "foo:bar;bas:" do we care? +(defun merge-pathnames (path &optional (defaults *default-pathname-defaults*) + (default-version :newest)) + "Construct a filled in pathname by completing the unspecified components + from the defaults." + ;(declare (ignore default-version)) + (when (not (pathnamep path))(setq path (pathname path))) + (when (and defaults (not (pathnamep defaults)))(setq defaults (pathname defaults))) + (let* ((path-dir (pathname-directory path)) + (path-host (pathname-host path)) + (path-name (pathname-name path)) + (path-type (pathname-type path)) + (path-device (pathname-device path)) + (default-dir (and defaults (pathname-directory defaults))) + (default-host (and defaults (pathname-host defaults))) + (default-device (and defaults (pathname-device defaults))) + ; take host from defaults iff path-dir is logical or absent - huh? + (host (cond ((or (null path-host) ; added 7/96 + (and (eq path-host :unspecific) + (or (null path-dir) + (null (cdr path-dir)) + (and (eq :relative (car path-dir)) + (not (memq default-host '(nil :unspecific))))))) + + default-host) + (t path-host))) + (dir (cond ((null path-dir) default-dir) + ((null default-dir) path-dir) + ((eq (car path-dir) ':relative) + (let ((the-dir (append default-dir (%cdr path-dir)))) + (when (memq ':up the-dir)(setq the-dir (remove-up (copy-list the-dir)))) + the-dir)) + (t path-dir))) + (nam (or path-name + (and defaults (pathname-name defaults)))) + (typ (or path-type + (and defaults (pathname-type defaults)))) + (version (or (pathname-version path) + (cond ((not path-name) + (or (and defaults (pathname-version defaults)) + default-version)) + (t default-version)))) + (device (or path-device default-device))) + (if (and (pathnamep path) + (eq dir (%pathname-directory path)) + (eq nam path-name) + (eq typ (%pathname-type path)) + (eq host path-host) + (eq device path-device) + (eq version (pathname-version path))) + path + (cons-pathname dir nam typ host version device)))) + +(defun directory-pathname-p (path) + (let ((name (pathname-name path))(type (pathname-type path))) + (and (or (null name) (eq name :unspecific) (%izerop (length name))) + (or (null type) (eq type :unspecific))))) + +;In CCL, a pathname is logical if and only if pathname-host is not :unspecific. +(defun pathname-host (thing &key case) + "Return PATHNAME's host." + (when (streamp thing)(setq thing (%path-from-stream thing))) + (when case (setq case (require-type case pathname-case-type))) + (let ((name + (typecase thing + (logical-pathname (%logical-pathname-host thing)) + (pathname :unspecific) + (string (multiple-value-bind (sstr start end) (get-pathname-sstring thing) + (pathname-host-sstr sstr start end))) + (t (report-bad-arg thing pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) (neq name :unspecific)) (setq case :logical)) + (%reverse-component-case name case)) + name))) + +(defun pathname-host-sstr (sstr start end &optional no-check) + ;; A pathname with any (unescaped) /'s is always a physical pathname. + ;; Otherwise, if the pathname has either a : or a ;, then it's always logical. + ;; Otherwise, it's probably physical. + ;; Return :unspecific for physical, host string or nil for a logical. + (let* ((slash (%path-mem "/" sstr start end)) + (pos (and (not slash) (%path-mem ":;" sstr start end))) + (pos-char (and pos (%schar sstr pos))) + (host (and (eql pos-char #\:) (%substr sstr start pos)))) + (cond (host + (unless (or no-check (logical-host-p host)) + (error "~S is not a defined logical host" host)) + (values host (%i+ pos 1) nil)) + ((eql pos-char #\;) ; logical pathname with missing host + (values nil start nil)) + (t ;else a physical pathname. + (values :unspecific start slash))))) + + +(defun pathname-device (thing &key case) + "Return PATHNAME's device." + (declare (ignore case)) + (let* ((p (pathname thing))) + (etypecase p + (logical-pathname :unspecific) + (pathname (%physical-pathname-device p))))) + + + +;A directory is either NIL or a (possibly wildcarded) string ending in "/" or ";" +;Quoted /'s are allowed at this stage, though will get an error when go to the +;filesystem. +(defun pathname-directory (path &key case) + "Return PATHNAME's directory." + (when (streamp path) (setq path (%path-from-stream path))) + (when case (setq case (require-type case pathname-case-type))) + (let* ((logical-p nil) + (names (typecase path + (logical-pathname (setq logical-p t) (%pathname-directory path)) + (pathname (%pathname-directory path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end) + (unless (eq host :unspecific) (setq logical-p t)) + #+windows-target + (unless logical-p + (if (and (> end 1) + (eql (schar sstr 1) #\:)) + (setq pos2 2))) + (pathname-directory-sstr sstr pos2 end host)))) + (t (report-bad-arg path pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) logical-p) (setq case :logical)) + (%reverse-component-case names case)) + names))) + +;; Must match pathname-directory-end below +(defun pathname-directory-sstr (sstr start end host) + (if (and (eq host :unspecific) + (> end start) + (eql (schar sstr start) #\~)) + (setq sstr (tilde-expand (subseq sstr start end)) + start 0 + end (length sstr))) + (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr start end))) + (if pos + (values + (%directory-string-list sstr start (setq pos (%i+ pos 1)) host) + pos) + (values (and (neq host :unspecific) + (neq start end) + '(:absolute)) + start)))) + +;; Must match pathname-directory-sstr above +(defun pathname-directory-end (sstr start end) + (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end) + (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr pos2 end))) + (if pos + (values (%i+ pos 1) host) + (values pos2 host))))) + +(defun %directory-string-list (sstr start &optional (end (length sstr)) host) + ;; Should use host to split by / vs. ; but for now suport both for either host, + ;; like the mac version. It means that ';' has to be quoted in unix pathnames. + (declare (ignore host)) + ;This must cons up a fresh list, %expand-logical-directory rplacd's it. + (labels ((std-part (sstr start end) + (%std-directory-part (if (and (eq start 0) (eq end (length sstr))) + sstr (%substr sstr start end)))) + (split (sstr start end) + (unless (eql start end) + (let ((pos (%path-mem "/;" sstr start end))) + (if (eq pos start) + (split sstr (%i+ start 1) end) ;; treat multiple ////'s as one. + (cons (std-part sstr start (or pos end)) + (when pos + (split sstr (%i+ pos 1) end)))))))) + (unless (eq start end) + (let* ((slash-pos (%path-mem "/" sstr start end)) + (semi-pos (%path-mem ";" sstr start end)) + (pos (or slash-pos semi-pos))) + ; this never did anything sensible but did not signal an error + (when (and slash-pos semi-pos) + (error "Illegal directory string ~s" (%substr sstr start end))) + (if (null pos) + (list :relative (std-part sstr start end)) + (let ((pos-char (%schar sstr pos))) + (cons (if (eq pos start) + (if (eq pos-char #\/) ':absolute ':relative) + (if (eq pos-char #\/) ':relative ':absolute)) + (split sstr start end)))))))) + +(defun pathname-version (path) + "Return PATHNAME's version." + (when (streamp path) (setq path (%path-from-stream path))) + (typecase path + (logical-pathname (%logical-pathname-version path)) + (pathname (%physical-pathname-version path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (newstart host) (pathname-directory-end sstr start end) + (if (eq host :unspecific) + nil + (values (pathname-version-sstr sstr newstart end)))))) + (t (report-bad-arg path pathname-arg-type)))) + +(defun pathname-version-sstr (sstr start end) + (declare (fixnum start end)) + (let ((pos (%path-mem-last "." sstr start end))) + (if (and pos (%i> pos start) (%path-mem "." sstr start (%i- pos 1))) + (values (%std-version-component (%substr sstr (%i+ pos 1) end)) pos) + (values nil end)))) + +(defun %std-version-component (v) + (cond ((or (null v) (eq v :unspecific)) v) + ((eq v :wild) "*") + ((string= v "") :unspecific) + ((string-equal v "newest") :newest) + ((every #'digit-char-p v) (parse-integer v)) + (t (%path-std-quotes v "./:;*" "./:;")))) + + +;A name is either NIL or a (possibly wildcarded, possibly empty) string. +;Quoted /'s are allowed at this stage, though will get an error if go to the +;filesystem. +(defun pathname-name (path &key case) + "Return PATHNAME's name." + (when (streamp path) (setq path (%path-from-stream path))) + (when case (setq case (require-type case pathname-case-type))) + (let* ((logical-p nil) + (name (typecase path + (logical-pathname (setq logical-p t) (%pathname-name path)) + (pathname (%pathname-name path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (newstart host) (pathname-directory-end sstr start end) + (setq start newstart) + (unless (eq host :unspecific) + (setq logical-p t) + (setq end (nth-value 1 (pathname-version-sstr sstr start end)))) + ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type. + ;; -->> Need to make an exception so that foo/.. is a directory pathname, + ;; for native. + (setq end (or (%path-mem-last "." sstr start end) end));; strip off type + (unless (eq start end) + (%std-name-component (%substr sstr start end)))))) + (t (report-bad-arg path pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) logical-p) (setq case :logical)) + (%reverse-component-case name case)) + name))) + +(defun %std-name-component (name) + (cond ((or (null name) (eq name :unspecific) (eq name :wild)) name) + ((equal name "*") :wild) + (t (%path-std-quotes name "/:;*" "/:;")))) + +;A type is either NIL or a (possibly wildcarded, possibly empty) string. +;Quoted :'s are allowed at this stage, though will get an error if go to the +;filesystem. +(defun pathname-type (path &key case) + "Return PATHNAME's type." + (when (streamp path) (setq path (%path-from-stream path))) + (when case (setq case (require-type case pathname-case-type))) + (let* ((logical-p nil) + (name (typecase path + (logical-pathname (setq logical-p t) (%pathname-type path)) + (pathname (%pathname-type path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (newstart host) (pathname-directory-end sstr start end) + (setq start newstart) + (unless (eq host :unspecific) + (setq logical-p t) + (setq end (nth-value 1 (pathname-version-sstr sstr start end)))) + ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type. + ;; -->> Need to make an exception so that foo/.. is a directory pathname, + ;; for native. + (pathname-type-sstr sstr start end)))) + (t (report-bad-arg path pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) logical-p) (setq case :logical)) + (%reverse-component-case name case)) + name))) + +; assumes dir & version if any has been stripped away +(defun pathname-type-sstr (sstr start end) + (let ((pos (%path-mem-last "." sstr start end))) + (if pos + (values (%std-type-component (%substr sstr (%i+ 1 pos) end)) pos) + (values nil end)))) + +(defun %std-type-component (type) + (cond ((or (null type) (eq type :unspecific) (eq type :wild)) type) + ((equal type "*") :wild) + (t (%path-std-quotes type "./:;*" "./:;")))) + +(defun %std-name-and-type (native) + (let* ((end (length native)) + (pos (position #\. native :from-end t)) + (type (and pos + (%path-std-quotes (%substr native (%i+ 1 pos) end) + nil "/:;*"))) + (name (unless (eq (or pos end) 0) + (%path-std-quotes (if pos (%substr native 0 pos) native) + nil "/:;*")))) + (values name type))) + +(defun %reverse-component-case (name case) + (cond ((not (stringp name)) + (if (listp name) + (mapcar #'(lambda (name) (%reverse-component-case name case)) name) + name)) + #+advanced-studlification-feature + ((eq case :studly) (string-studlify name)) + ((eq case :logical) + (if (every #'(lambda (ch) (not (lower-case-p ch))) name) + name + (string-upcase name))) + (t ; like %read-idiocy but non-destructive - need it be? + (let ((which nil) + (len (length name))) + (dotimes (i len) + (let ((c (%schar name i))) + (if (alpha-char-p c) + (if (upper-case-p c) + (progn + (when (eq which :lower)(return-from %reverse-component-case name)) + (setq which :upper)) + (progn + (when (eq which :upper)(return-from %reverse-component-case name)) + (setq which :lower)))))) + (case which + (:lower (string-upcase name)) + (:upper (string-downcase name)) + (t name)))))) + +;;;;;;; String-with-quotes utilities +(defun %path-mem-last-quoted (chars sstr &optional (start 0) (end (length sstr))) + (while (%i< start end) + (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars) + (%path-quoted-p sstr end start)) + (return-from %path-mem-last-quoted end)))) + +(defun %path-mem-last (chars sstr &optional (start 0) (end (length sstr))) + (while (%i< start end) + (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars) + (not (%path-quoted-p sstr end start))) + (return-from %path-mem-last end)))) + +(defun %path-mem (chars sstr &optional (start 0) (end (length sstr))) + (let ((one-char (when (eq (length chars) 1) (%schar chars 0)))) + (while (%i< start end) + (let ((char (%schar sstr start))) + (when (if one-char (eq char one-char)(%%str-member char chars)) + (return-from %path-mem start)) + (when (eq char *pathname-escape-character*) + (setq start (%i+ start 1))) + (setq start (%i+ start 1)))))) + +; these for \: meaning this aint a logical host. Only legal for top level dir + +(defun %path-unquote-one-quoted (chars sstr &optional (start 0)(end (length sstr))) + (let ((pos (%path-mem-last-quoted chars sstr start end))) + (when (and pos (neq pos 1)) + (cond ((or (%path-mem chars sstr start (1- pos)) + (%path-mem-last-quoted chars sstr start (1- pos))) + nil) + (t (%str-cat (%substr sstr start (1- pos))(%substr sstr pos end))))))) + +(defun %path-one-quoted-p (chars sstr &optional (start 0)(end (length sstr))) + (let ((pos (%path-mem-last-quoted chars sstr start end))) + (when (and pos (neq pos 1)) + (not (or (%path-mem-last-quoted chars sstr start (1- pos)) + (%path-mem chars sstr start (1- pos))))))) + +(defun %path-quoted-p (sstr pos start &aux (esc *pathname-escape-character*) (q nil)) + (while (and (%i> pos start) (eq (%schar sstr (setq pos (%i- pos 1))) esc)) + (setq q (not q))) + q) + + + +;Standardize pathname quoting, so can do EQUAL. +;; Subtle point: when keep-quoted is NIL, arg is assumed native, +;; and therefore escape characters are made quoted. +;; if keep-quoted is not NIL, e.g. if it's "", arg is assumed +;; to be escaped already, so escape chars are interpreted as quotes. +;; Note that this can't be used to remove quotes because it +;; always keeps the escape character quoted. +(defun %path-std-quotes (arg keep-quoted make-quoted) + (when (symbolp arg) + (error "Invalid pathname component ~S" arg)) + (let* ((str arg) + (esc *pathname-escape-character*) + (end (length str)) + res-str char) + (multiple-value-bind (sstr start)(array-data-and-offset str) + (setq end (+ start end)) + (let ((i start)) + (until (eq i end) + (setq char (%schar sstr i)) + (cond ((or (%%str-member char make-quoted) + (and (null keep-quoted) (eq char esc))) + (unless res-str + (setq res-str (make-array (%i- end start) + :element-type (array-element-type sstr) + :adjustable t :fill-pointer 0)) + (do ((j start (%i+ j 1))) ((eq j i)) + (vector-push-extend (%schar sstr j) res-str))) + (vector-push-extend esc res-str)) + ((neq char esc) nil) + ((eq (setq i (%i+ i 1)) end) + (error "Malformed pathname component string ~S" str)) + ((or (eq (setq char (%schar sstr i)) esc) + (%%str-member char keep-quoted)) + (when res-str (vector-push-extend esc res-str))) + (t + (unless res-str + (setq res-str (make-array (%i- end start) + :element-type (array-element-type sstr) + :adjustable t :fill-pointer 0)) + (do ((j start (%i+ j 1)) (end (%i- i 1))) ((eq j end)) + (vector-push-extend (%schar sstr j) res-str))))) + (when res-str (vector-push-extend char res-str)) + (setq i (%i+ i 1))) + (ensure-simple-string (or res-str str)))))) + + + +(defun %%str-member (char string) + (locally (declare (optimize (speed 3)(safety 0))) + (dotimes (i (the fixnum (length string))) + (when (eq (%schar string i) char) + (return i))))) + + +(defun file-write-date (path) + "Return file's creation date, or NIL if it doesn't exist. + An error of type file-error is signaled if file is a wild pathname" + (%file-write-date (native-translated-namestring path))) + +(defun file-author (path) + "Return the file author as a string, or NIL if the author cannot be + determined. Signal an error of type FILE-ERROR if FILE doesn't exist, + or FILE is a wild pathname." + (%file-author (native-translated-namestring path))) + +(defun touch (path) + (if (not (probe-file path)) + (progn + (ensure-directories-exist path) + (if (or (pathname-name path) + (pathname-type path)) + (create-file path))) + (%utimes (native-translated-namestring path))) + t) + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +; load, require, provide + +(defun find-load-file (file-name) + (let ((full-name (full-pathname file-name :no-error nil)) + (kind nil)) + (when full-name + (let ((file-type (pathname-type full-name)) + (merged (pathname (merge-pathnames file-name)))) + (if (and file-type (neq file-type :unspecific)) + (values (probe-file full-name) merged (if (eq (pathname-host file-name) :unspecific) full-name file-name)) + (let* ((source (merge-pathnames file-name *.lisp-pathname*)) + (fasl (merge-pathnames file-name *.fasl-pathname*)) + (true-source (probe-file source)) + (true-fasl (probe-file fasl))) + (cond (true-source + (if (and true-fasl + (> (file-write-date true-fasl) + (file-write-date true-source))) + (values true-fasl merged source) + (values true-source merged source))) + (true-fasl + (values true-fasl merged fasl)) + ((and (multiple-value-setq (full-name kind) + (let* ((realpath (%realpath (native-translated-namestring full-name)))) + (if realpath + (%probe-file-x realpath )))) + (eq kind :file)) + (values full-name merged file-name))))))))) + + + + + +(defun load (file-name &key (verbose *load-verbose*) + (print *load-print*) + (if-does-not-exist :error) + (external-format :default)) + "Load the file given by FILESPEC into the Lisp environment, returning + T on success. + + Extension: :PRINT :SOURCE means print source as well as value" + (loop + (restart-case + (return (%load file-name verbose print if-does-not-exist external-format)) + (retry-load () + :report (lambda (stream) (format stream "Retry loading ~s" file-name))) + (skip-load () + :report (lambda (stream) (format stream "Skip loading ~s" file-name)) + (return nil)) + (load-other () + :report (lambda (stream) (format stream "Load other file instead of ~s" file-name)) + (return + (load (choose-file-dialog) + :verbose verbose + :print print + :if-does-not-exist if-does-not-exist)))))) + + +(defun %load (file-name verbose print if-does-not-exist external-format) + (let ((*load-pathname* file-name) + (*load-truename* file-name) + (source-file file-name) + ;; Don't bind these: let OPTIMIZE proclamations/declamations + ;; persist, unless debugging. + #| + (*nx-speed* *nx-speed*) + (*nx-space* *nx-space*) + (*nx-safety* *nx-safety*) + (*nx-debug* *nx-debug*) + (*nx-cspeed* *nx-cspeed*) + |# + ) + (declare (special *load-pathname* *load-truename*)) + (when (typep file-name 'string-input-stream) + (when verbose + (format t "~&;Loading from stream ~S..." file-name) + (force-output)) + (let ((*package* *package*) + (*readtable* *readtable*)) + (load-from-stream file-name print)) + (return-from %load file-name)) + (unless (streamp file-name) + (multiple-value-setq (*load-truename* *load-pathname* source-file) + (find-load-file (merge-pathnames file-name))) + (when (not *load-truename*) + (return-from %load (if if-does-not-exist + (signal-file-error $err-no-file file-name)))) + (setq file-name *load-truename*)) + (let* ((*package* *package*) + (*readtable* *readtable*) + (*loading-files* (cons file-name (specialv *loading-files*))) + ;;reset by fasload to logical name stored in the file + (*loading-file-source-file* (namestring source-file)) + (*loading-toplevel-location* nil)) + (declare (special *loading-files* *loading-file-source-file*)) + (when verbose + (format t "~&;Loading ~S..." *load-pathname*) + (force-output)) + (cond ((fasl-file-p file-name) + (let ((*fasload-print* print) + (restart-setup nil) + (restart-source nil) + (restart-fasl nil)) + (declare (special *fasload-print*)) + (flet ((restart-test (c) + (unless restart-setup + (setq restart-setup t) + (let ((source *loading-file-source-file*) + (fasl *load-pathname*)) + (when (and (not (typep c 'file-error)) + source + fasl + (setq source (probe-file source)) + (setq fasl (probe-file fasl)) + (not (equalp source fasl))) + (setq restart-fasl (namestring *load-pathname*) + restart-source *loading-file-source-file*)))) + (not (null restart-fasl))) + (fname (p) + #-versioned-file-system + (namestring (make-pathname :version :unspecific :defaults p)) + #+versioned-file-system + (namestring p))) + (restart-case (multiple-value-bind (winp err) + (%fasload (native-translated-namestring file-name)) + (if (not winp) + (%err-disp err))) + (load-source + () + :test restart-test + :report (lambda (s) + (format s "Load ~s instead of ~s" + (fname restart-source) (fname restart-fasl))) + (%load source-file verbose print if-does-not-exist external-format)) + (recompile + () + :test restart-test + :report (lambda (s) + (let ((*print-circle* NIL)) + (format s + (if (equalp + restart-source + (make-pathname :type (pathname-type *.lisp-pathname*) + :defaults restart-fasl)) + "Compile ~s and then load ~s again" + "Compile ~s into ~s then load ~:*~s again") + (fname restart-source) (fname restart-fasl)))) + (compile-file restart-source :output-file restart-fasl) + (%load restart-fasl verbose print if-does-not-exist external-format)))))) + (t + (with-open-file (stream file-name + :element-type 'base-char + :external-format external-format) + (load-from-stream stream print)))))) + file-name) + +(defun load-from-stream (stream print &aux (eof-val (list ())) val) + (with-compilation-unit (:override nil) ; try this for included files + (let ((env (new-lexical-environment (new-definition-environment 'eval))) + ;; source note map to use with any compilations. + (*nx-source-note-map* (and *save-source-locations* + (make-hash-table :test #'eq :shared nil))) + (*loading-toplevel-location* nil)) + (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*) + (loop + (multiple-value-setq (val *loading-toplevel-location*) + (read-recording-source stream + :eofval eof-val + :file-name *loading-file-source-file* + :map *nx-source-note-map* + :save-source-text (neq *save-source-locations* :no-text))) + (when (eq eof-val val) + (return)) + (when (eq print :source) (format t "~&Source: ~S~%" val)) + (setq val (cheap-eval-in-environment val env)) + (when print + (format t "~&~A~S~%" (if (eq print :source) "Value: " "") val)))))) + +(defun include (filename) + (load + (if (null *loading-files*) + filename + (merge-pathnames filename (directory-namestring (car *loading-files*)))))) + +(%fhave '%include #'include) + +(defun delete-file (path) + "Delete the specified FILE." + (let* ((namestring (native-translated-namestring path))) + (when (%realpath namestring) + (let* ((err (%delete-file namestring))) + (or (eql 0 err) (signal-file-error err path)))))) + +(defvar *known-backends* ()) + +(defun fasl-file-p (pathname) + (let* ((type (pathname-type pathname))) + (or (and (null *known-backends*) + (equal type (pathname-type *.fasl-pathname*))) + (dolist (b *known-backends*) + (when (equal type (pathname-type (backend-target-fasl-pathname b))) + (return t))) + (ignore-errors + (with-open-file (f pathname + :direction :input + :element-type '(unsigned-byte 8)) + ;; Assume that (potential) FASL files start with #xFF00 (big-endian), + ;; and that source files don't. + (and (eql (read-byte f nil nil) #xff) + (eql (read-byte f nil nil) #x00))))))) + +(defun provide (module) + "Adds a new module name to *MODULES* indicating that it has been loaded. + Module-name is a string designator" + (pushnew (string module) *modules* :test #'string=) + module) + +(defparameter *loading-modules* () "Internal. Prevents circularity") +(defparameter *module-provider-functions* '(module-provide-search-path module-provide-asdf) + "A list of functions called by REQUIRE to satisfy an unmet dependency. +Each function receives a module name as a single argument; if the function knows how to load that module, it should do so, add the module's name as a string to *MODULES* (perhaps by calling PROVIDE) and return non-NIL." + ) + +(defun module-provide-search-path (module) + ;; (format *debug-io* "trying module-provide-search-path~%") + (let* ((module-name (string module)) + (pathname (find-module-pathnames module-name))) + (when pathname + (if (consp pathname) + (dolist (path pathname) (load path)) + (load pathname)) + (provide module)))) + +(defun require (module &optional pathname) + "Loads a module, unless it already has been loaded. PATHNAMES, if supplied, + is a designator for a list of pathnames to be loaded if the module + needs to be. If PATHNAMES is not supplied, functions from the list + *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME + as an argument, until one of them returns non-NIL. User code is + responsible for calling PROVIDE to indicate a successful load of the + module." + (let* ((str (string module)) + (original-modules (copy-list *modules*))) + (unless (or (member str *modules* :test #'string=) + (member str *loading-modules* :test #'string=)) + ;; The check of (and binding of) *LOADING-MODULES* is a + ;; traditional defense against circularity. (Another + ;; defense is not having circularity, of course.) The + ;; effect is that if something's in the process of being + ;; REQUIREd and it's REQUIREd again (transitively), + ;; the inner REQUIRE is a no-op. + (let ((*loading-modules* (cons str *loading-modules*))) + (if pathname + (dolist (path (if (atom pathname) (list pathname) pathname)) + (load path)) + (unless (some (lambda (p) (funcall p module)) + *module-provider-functions*) + (error "Module ~A was not provided by any function on ~S." module '*module-provider-functions*))))) + (values module + (set-difference *modules* original-modules)))) + +(defun find-module-pathnames (module) + "Returns the file or list of files making up the module" + (let ((mod-path (make-pathname :name (string-downcase module) :defaults nil)) path) + (dolist (path-cand *module-search-path* nil) + (let ((mod-cand (merge-pathnames mod-path path-cand))) + (if (wild-pathname-p path-cand) + (let* ((untyped-p (member (pathname-type mod-cand) '(nil :unspecific))) + (matches (if untyped-p + (or (directory (merge-pathnames mod-cand *.lisp-pathname*)) + (directory (merge-pathnames mod-cand *.fasl-pathname*))) + (directory mod-cand)))) + (when (and matches (null (cdr matches))) + (return (if untyped-p + (make-pathname :type nil :defaults (car matches)) + (car matches))))) + (when (setq path (find-load-file (merge-pathnames mod-path path-cand))) + (return path))))))) + +(defun module-provide-asdf (module) + (let* ((asdf-package (find-package "ASDF"))) + (when asdf-package + (let* ((verbose-out (find-symbol "*VERBOSE-OUT*" asdf-package)) + (find-system (find-symbol "FIND-SYSTEM" asdf-package)) + (operate (find-symbol "OPERATE" asdf-package)) + (load-op (find-symbol "LOAD-OP" asdf-package))) + (when (and verbose-out find-system operate load-op) + (progv (list verbose-out) (list (make-broadcast-stream)) + (let* ((system (funcall find-system module nil))) + (when system + (funcall operate load-op module) + t)))))))) + +(defun wild-pathname-p (pathname &optional field-key) + "Predicate for determining whether pathname contains any wildcards." + (flet ((wild-p (name) (or (eq name :wild) + (eq name :wild-inferiors) + (and (stringp name) (%path-mem "*" name))))) + (case field-key + ((nil) + (or (some #'wild-p (pathname-directory pathname)) + (wild-p (pathname-name pathname)) + (wild-p (pathname-type pathname)) + (wild-p (pathname-version pathname)))) + (:host nil) + (:device nil) + (:directory (some #'wild-p (pathname-directory pathname))) + (:name (wild-p (pathname-name pathname))) + (:type (wild-p (pathname-type pathname))) + (:version (wild-p (pathname-version pathname))) + (t (wild-pathname-p pathname + (require-type field-key + '(member nil :host :device + :directory :name :type :version))))))) Index: /branches/qres/ccl/level-1/l1-format.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-format.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-format.lisp (revision 13564) @@ -0,0 +1,444 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-format.lisp +; +; This file contains the definition for SUB-FORMAT, the dispatching part +; of FORMAT. It also contains an interim definition for FORMAT and a few +; incompletely implemented directives. + +(in-package "CCL") + +(eval-when (eval compile #-bccl load) ;Load-time as well so CCL can use it. + (defmacro defformat (char name &rest def) + `(progn + (add-format-char ,char (nfunction ,name (lambda . ,def))) + ',name)) + ) + +(defparameter *format-char-table* (let* ((x (make-array 128 :initial-element nil))) x)) + +(defun add-format-char (char def) + (unless (and (characterp char) (%i< (%char-code char) 128)) + (report-bad-arg char 'standard-char)) + (setf (svref *format-char-table* (%char-code (char-upcase char))) def)) + +(proclaim '(special *format-original-arguments* ;For ~* + *format-arguments* ;For pop-format-arg + *format-control-string* ;For ~?, ~{ + *format-index* + *format-length* + *format-pprint* ;~I,~W,~_,~:T seen? + *format-justification-semi* ;~<..~:;..~> seen? + )) + +(defun pop-format-arg (&aux (args *format-arguments*)) + (if (null args) + (format-error "Missing argument")) + (progn + (setq *format-arguments* (cdr args)) + (%car args))) + +;SUB-FORMAT parses (a range of) the control string, finding the directives +;and applying them to their parameters. +;Implicit arguments to SUB-FORMAT: *format-control-string*, *format-arguments*, +;*format-original-arguments*, *standard-output*, *format-char-table* +;*format-control-string* must be a simple string. +;Directive functions' arglist should be (colon-p atsign-p &rest params) +;In addition when the directive is called, *format-index* and *format-length* +;are bound to start and end pos (in *format-control-string*) of the rest of the +; control string. The directive may modify *format-index*, but not +; *format-control-string* and *format-length*, before returning. + +(defun sub-format (stream *format-index* *format-length* &aux char) + (prog* ((string (require-type *format-control-string* 'simple-string)) + (length *format-length*) + (i *format-index*) + (lastpos i)) + (declare (fixnum i length lastpos) (type simple-string string)) + (go START) + EOF-ERROR + (setq *format-index* *format-length*) + (format-error "Premature end of control string") + START + (do* () + ((= i length) (unless (= i lastpos) + (write-string string stream :start lastpos :end i))) + (setq char (schar string i) i (1+ i)) + (when (eq char #\~) + (let* ((limit (the fixnum (1- i)))) + (unless (= limit lastpos) + (write-simple-string string stream lastpos limit))) + (let ((params nil) (fn) (colon nil) (atsign nil)) + (block nil + (tagbody + NEXT + (if (= i length) (go EOF-ERROR)) + (setq char (schar string i) i (1+ i)) + (cond ((eq char #\#) + (push (list-length *format-arguments*) params)) + ((eq char #\') + (if (= i length) (go EOF-ERROR)) + (push (schar string i) params) + (incf i)) + ((eq char #\,) + (push nil params) + (go NEXT)) + ((or (eq char #\V) (eq char #\v)) + (push (pop-format-arg) params)) + ((or (eq char #\-) (eq char #\+) (digit-char-p char)) + (let ((start (%i- i 1)) n) + (loop + (when (= i length) (go EOF-ERROR)) + (unless (digit-char-p (schar string i)) (return)) + (incf i)) + (when (null (setq n (%parse-number-token string start i))) + (setq *format-index* i) + (format-error "Illegal parameter")) + (push n params))) + (t (return))) + (if (= i length) (go EOF-ERROR)) + (setq char (schar string i) i (1+ i)) + (when (neq char #\,) (return)) + (go NEXT))) + (cond ((eq char #\:) + (if (= i length) (go EOF-ERROR)) + (setq colon t char (schar string i) i (1+ i)) + (when (eq char #\@) + (if (= i length) (go EOF-ERROR)) + (setq atsign t char (schar string i) i (1+ i)))) + ((eq char #\@) + (if (= i length) (go EOF-ERROR)) + (setq atsign t char (schar string i) i (1+ i)) + (when (eq char #\:) + (if (= i length) (go EOF-ERROR)) + (setq colon t char (schar string i) i (1+ i))))) + (setq *format-index* (%i- i 1)) + (if (setq fn (svref *format-char-table* (%char-code (char-upcase char)))) + (apply fn stream colon atsign (nreverse params)) + (format-error "Unknown directive")) + (setq i (%i+ *format-index* 1) + lastpos i)))))) + + +#|| +(eval-when (load) + ;The non-consing version. +(defun sub-format (stream *format-index* *format-length*) + (declare (special *format-index* *format-length*)) + (old-lap-inline (stream) + (preserve_regs #(asave0 asave1 dsave0 dsave1 dsave2)) + (defreg Control-string asave0 Index dsave0 Length dsave1 NumParams dsave2 Stream asave1) + (move.l acc Stream) + (move.l (special *format-index*) Index) ; *format-index* + (move.l (special *format-length*) Length) ; *format-length* + (specref *format-control-string*) + (move.l acc Control-string) + + ;Make sure everything is in bounds, so don't have to worry about + ;boxing, bounds checking, etc. +start + (movereg Control-string arg_z) + (jsr_subprim $sp-length) + (ccall <= '0 Index Length acc) + (cmp.l nilreg acc) + (beq done) + (move.l Index db) + (loop# + (if# (eq Length Index) + (cmp.l db Index) + (beq done) + (ccall 'stream-write-string Stream Control-string db Index) + (bra done)) + (move.l Index da) + (getint da) + (move.l ($ $t_imm_char 0) acc) + (move.b (Control-string da.l $v_data) acc) + (add.l (fixnum 1) Index) + (cmp.b ($ #\~) acc) + (beq tilde)) + +nextchar + (if# (eq Length Index) + (move.l '"Premature end of format control string" arg_z) + (add.w ($ 4) sp) ; flush internal bsr. + (bra error)) + (move.l Index da) + (getint da) + (move.b (Control-string da.l $v_data) acc) + (add.l (fixnum 1) Index) + (if# (and (ge (cmp.b ($ #\a) acc)) (le (cmp.b ($ #\z) acc))) + (sub.b ($ 32) acc)) + (rts) + +tilde + (move.l Index da) + (sub.l (fixnum 1) da) + (if# (not (eq da db)) + (ccall 'stream-write-string Stream Control-string db da)) + (vpush Stream) + (vpush nilreg) ;assume no : + (vpush nilreg) ;assume no @ + (move.l (fixnum 3) NumParams) +do-param + (bsr nextchar) + (if# (or (eq (cmp.b ($ #\+) acc)) + (eq (cmp.b ($ #\-) acc)) + (and (ge (cmp.b ($ #\0) acc)) (le (cmp.b ($ #\9) acc)))) + (move.l Index da) + (sub.l (fixnum 1) da) + (vpush da) + (prog# + (bsr nextchar) + (until# (or (lt (cmp.b ($ #\0) acc)) (gt (cmp.b ($ #\9) acc))))) + (sub.l (fixnum 1) Index) ;unread the non-digit char + (ccall %parse-number-token Control-string vsp@+ Index) + (cmp.l nilreg acc) + (bne push-param) + (move.l '"Illegal format parameter" arg_z) + (bra error)) + + (if# (eq (cmp.b ($ #\#) acc)) + (move.l (special *format-arguments*) acc) + (jsr_subprim $sp-length) + (bra push-param)) + + (if# (eq (cmp.b ($ #\') acc)) + (bsr nextchar) + (move.l ($ $t_imm_char 0) acc) + (move.b (Control-string da.l $v_data) acc) ;Get the non-uppercased version... + (swap acc) + (bra push-param)) + + (if# (eq (cmp.b ($ #\,) acc)) + (sub.l (fixnum 1) Index) ;Re-read the comma. + (move.l nilreg acc) + (bra push-param)) + + (if# (eq (cmp.b ($ #\V) acc)) + (ccall 'pop-format-arg) + ;(bra push-param) + push-param + (vpush acc) + (add.l (fixnum 1) NumParams) + (bsr nextchar) + (cmp.b ($ #\,) acc) + (beq do-param)) + + (move.l NumParams nargs) + (vscale.l nargs) + (cmp.b ($ #\:) acc) + (if# eq + (bsr nextchar) + (cmp.b ($ #\@) acc) + (bne @a) + (move.l (a5 $t) (vsp nargs.w -12)) + else# + (cmp.b ($ #\@) acc) + (bne @b) + (move.l (a5 $t) (vsp nargs.w -12)) + (bsr nextchar) + (cmp.b ($ #\:) acc) + (bne @b)) + (bsr nextchar) +@a (move.l (a5 $t) (vsp nargs.w -8)) +@b (moveq 127 da) + (and.w acc da) + (bif (ne (cmp.b da acc)) nofun) + (lsl.w 2 da) + (move.l (special *format-char-table*) atemp0) + (move.l (atemp0 da.w $v_data) atemp0) + (cmp.l atemp0 nilreg) + (beq nofun) + (move.l Index da) + (sub.l (fixnum 1) da) + (move.l da (special *format-index*)) + (move.l NumParams nargs) + (vscale.l nargs) ; at least 3 args. + (movem.l vsp@+ #(arg_z arg_y arg_x)) + (jsr_subprim $sp-funcall) + (specref '*format-index*) + (add.l (fixnum 1) acc) + (move.l acc Index) + (bra start) + +nofun + (move.l '"Unknown format directive" acc) +error + (move.l Index (special *format-index*)) + (fsymevalapply 'format-error 1) + +done + (restore_regs) + )) +) ;end of eval-when (load) + +||# + +;;;Interim definitions + +;;;This function is shadowed by CCL in order to use ~{ to print error messages. +(fset 'format + (nlambda bootstrapping-format (stream control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (block format + (when (null stream) + (return-from format + (with-output-to-string (x) + (apply #'format x control-string format-arguments)))) + (if (eq stream t) + (setq stream *standard-output*) + (unless (streamp stream) (report-bad-arg stream 'stream))) + (if (functionp control-string) + (apply control-string stream format-arguments) + (progn + (setq control-string (ensure-simple-string control-string)) + (let* ((*format-original-arguments* format-arguments) + (*format-arguments* format-arguments) + (*format-control-string* control-string)) + (catch 'format-escape + (sub-format stream 0 (length control-string))) + nil)))))) + +(fset 'format-error + (nlambda bootstrapping-format-error (&rest args) + (format t "~&FORMAT error at position ~A in control string ~S " + *format-index* *format-control-string*) + (apply #'error args))) + +(defun format-no-flags (colon atsign) + (cond ((and colon atsign) + (format-error "Flags not allowed")) + (colon + (format-error ": flag not allowed")) + (atsign + (format-error "@ flag not allowed")))) + +;Redefined later +(defformat #\A format-a (stream colon atsign) + (declare (ignore colon atsign)) + (princ (pop-format-arg) stream)) + +;Redefined later +(defformat #\S format-s (stream colon atsign) + (declare (ignore colon atsign)) + (prin1 (pop-format-arg) stream)) + +;Redefined later +(defformat #\^ format-escape (stream colon atsign) + (declare (ignore stream colon atsign)) + (throw 'format-escape t)) + +;Final version +(defformat #\% format-% (stream colon atsign &optional repeat-count) + (format-no-flags colon atsign) + (cond ((or (not repeat-count) + (and (fixnump repeat-count) + (> repeat-count -1))) + (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (terpri stream))) + (t (format-error "Bad repeat-count.")))) + +;Final version +(defformat #\& format-& (stream colon atsign &optional repeat-count) + (format-no-flags colon atsign) + (cond ((or (not repeat-count) + (and (fixnump repeat-count) + (> repeat-count -1))) + (unless (eq repeat-count 0) + (fresh-line stream) + (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream)))) + (t (format-error "Bad repeat-count.")))) + +;Final version +(defformat #\~ format-~ (stream colon atsign &optional repeat-count) + (format-no-flags colon atsign) + (cond ((or (not repeat-count) + (and (fixnump repeat-count) + (> repeat-count -1))) + (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream))) + (t (format-error "Bad repeat-count.")))) + +;Final version +(defformat #\P format-p (stream colon atsign) + (when colon + (let ((end *format-arguments*) (list *format-original-arguments*)) + (tagbody loop + (if list + (when (neq (cdr list) end) + (setq list (%cdr list)) + (go loop)) + (format-error "No previous argument"))) + (setq *format-arguments* list))) + (%write-string (if (eq (pop-format-arg) 1) + (if atsign "y" "") + (if atsign "ies" "s")) + stream)) + +;Final version +(defformat #\* format-* (stream colon atsign &optional count) + (declare (ignore stream)(special *circularity-hash-table*)) + (let* ((orig *format-original-arguments*) + (where (- (list-length orig) ; will error if args circular + (list-length *format-arguments*))) + (to (if atsign + (progn + (format-no-flags colon nil) + (or count 0)) ; absolute + (progn + (when (null count)(setq count 1)) + (when colon (setq count (- count))) + (%i+ where count)))) + (args (nthcdr-no-overflow to orig))) + ; avoid bogus circularity indication + (when (and nil (consp args) (<= to where) *circularity-hash-table*) + ; copy only from to thru where in case some real shared structure + (let ((l args) new) + (dotimes (i (1+ (- where to))) + (declare (fixnum i)) + (push (car l) new) + (setq l (cdr l))) + (setq args (nreconc new (nthcdr (1+ where) orig))))) ;(copy-list args))) + (setq *format-arguments* args))) + +; Redefined later. +(defformat #\Newline format-newline (&rest ignore) + (declare (ignore ignore)) + (do* ((i *format-index* (1+ i)) + (s *format-control-string*) + (n *format-length*)) + ((or (= i n) + (not (whitespacep (schar s i)))) + (setq *format-index* (1- i))))) + +(defun nthcdr-no-overflow (count list) + (if (or (> count (list-length list)) (< count 0)) + (format-error "non-existent target for ~*") + (nthcdr count list))) + +;Redefined later +(defformat #\X format-x (stream colon atsign) + (declare (ignore colon atsign)) + (let* ((*print-base* 16.) + (*print-radix* nil)) + (prin1 (pop-format-arg) stream))) + +;Redefined later +(defformat #\D format-d (stream colon atsign &rest ignore) + (declare (ignore colon atsign ignore)) + (let* ((*print-base* 10.) + (*print-radix* nil)) + (prin1 (pop-format-arg) stream))) Index: /branches/qres/ccl/level-1/l1-init.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-init.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-init.lisp (revision 13564) @@ -0,0 +1,333 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute :load-toplevel) + +(defconstant most-positive-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0)) +(defconstant most-negative-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1)) +(defconstant most-positive-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0)) +(defconstant most-negative-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1)) + + +(defconstant least-positive-short-float (make-short-float-from-fixnums 1 0 0)) +(defconstant least-negative-short-float (make-short-float-from-fixnums 1 0 -1)) +(defconstant least-positive-single-float (make-short-float-from-fixnums 1 0 0)) +(defconstant least-negative-single-float (make-short-float-from-fixnums 1 0 -1)) + +(defconstant short-float-epsilon (make-short-float-from-fixnums 1 103 0)) +(defconstant short-float-negative-epsilon (make-short-float-from-fixnums 1 102 0)) +(defconstant single-float-epsilon (make-short-float-from-fixnums 1 103 0)) +(defconstant single-float-negative-epsilon (make-short-float-from-fixnums 1 102 0)) + +(defconstant least-positive-normalized-short-float (make-short-float-from-fixnums 1 1 0)) +(defconstant least-negative-normalized-short-float (make-short-float-from-fixnums 1 1 -1)) +(defconstant least-positive-normalized-single-float (make-short-float-from-fixnums 1 1 0)) +(defconstant least-negative-normalized-single-float (make-short-float-from-fixnums 1 1 -1)) + +(let ((bigfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe 0))) + ; do it this way if you want to be able to compile before reading floats works + (defconstant most-positive-double-float bigfloat) + (defconstant most-positive-long-float bigfloat) + ) + +(let ((littleposfloat (make-float-from-fixnums 0 1 0 0 ))) + (defconstant least-positive-double-float littleposfloat) + (defconstant least-positive-long-float littleposfloat) + ) + +(let ((littlenegfloat (make-float-from-fixnums 0 1 0 -1))) + (defconstant least-negative-double-float littlenegfloat) + (defconstant least-negative-long-float littlenegfloat) + ) + +(let ((bignegfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe -1))) + (defconstant most-negative-double-float bignegfloat) + (defconstant most-negative-long-float bignegfloat) + ) + +(let ((eps (make-float-from-fixnums #x1000000 1 #x3ca 0))) ;was wrong + (defconstant double-float-epsilon eps) + (defconstant long-float-epsilon eps) + ) + +(let ((eps- (make-float-from-fixnums #x1000000 1 #x3c9 1))) + (defconstant double-float-negative-epsilon eps-) + (defconstant long-float-negative-epsilon eps-) + ) + +(let ((norm (make-float-from-fixnums 0 0 1 0))) + (defconstant least-positive-normalized-double-float norm) + (defconstant least-positive-normalized-long-float norm) + ) + +(let ((norm- (make-float-from-fixnums 0 0 1 -1))) + (defconstant least-negative-normalized-double-float norm-) + (defconstant least-negative-normalized-long-float norm-) + ) + +(defconstant pi (make-float-from-fixnums #x921fb5 #x4442d18 #x400 0)) + +) + + + +(defconstant boole-clr 0 + "Boole function op, makes BOOLE return 0.") +(defconstant boole-set 1 + "Boole function op, makes BOOLE return -1.") +(defconstant boole-1 2 + "Boole function op, makes BOOLE return integer1.") +(defconstant boole-2 3 + "Boole function op, makes BOOLE return integer2.") +(defconstant boole-c1 4 + "Boole function op, makes BOOLE return complement of integer1.") +(defconstant boole-c2 5 + "Boole function op, makes BOOLE return complement of integer2.") +(defconstant boole-and 6 + "Boole function op, makes BOOLE return logand of integer1 and integer2.") +(defconstant boole-ior 7 + "Boole function op, makes BOOLE return logior of integer1 and integer2.") +(defconstant boole-xor 8 + "Boole function op, makes BOOLE return logxor of integer1 and integer2.") +(defconstant boole-eqv 9 + "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") +(defconstant boole-nand 10 + "Boole function op, makes BOOLE return log nand of integer1 and integer2.") +(defconstant boole-nor 11 + "Boole function op, makes BOOLE return lognor of integer1 and integer2.") +(defconstant boole-andc1 12 + "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") +(defconstant boole-andc2 13 + "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") +(defconstant boole-orc1 14 + "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") +(defconstant boole-orc2 15 + "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") + + + +(defconstant internal-time-units-per-second #+64-bit-target 1000000 #-64-bit-target 1000 + "The number of internal time units that fit into a second. See + GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") + +(defconstant char-code-limit #.(arch::target-char-code-limit + (backend-target-arch *target-backend*)) + "the upper exclusive bound on values produced by CHAR-CODE") + +(defconstant array-rank-limit (floor #x8000 target::node-size) + "the exclusive upper bound on the rank of an array") +(defconstant multiple-values-limit 200 + "The exclusive upper bound on the number of multiple VALUES that you can + return.") +(defconstant lambda-parameters-limit (floor #x8000 target::node-size) + "The exclusive upper bound on the number of parameters which may be specifed + in a given lambda list. This is actually the limit on required and &OPTIONAL + parameters. With &KEY and &AUX you can get more.") +(defconstant call-arguments-limit #+ppc-target (floor #x8000 target::node-size) + #-ppc-target #x10000 + "The exclusive upper bound on the number of arguments which may be passed + to a function, including &REST args." +) + +; Currently, vectors can be at most (expt 2 22) bytes, and +; the largest element (double-float or long-float) is 8 bytes: +#| to get largest element size... +(apply #'max (mapcar #'(lambda (type) + (%vect-byte-size (make-array 1 :element-type type))) + *cl-types*)) +|# + +(defconstant array-dimension-limit array-total-size-limit + "the exclusive upper bound on any given dimension of an array") + +(defconstant most-positive-fixnum target::target-most-positive-fixnum + "the fixnum closest in value to positive infinity") +(defconstant most-negative-fixnum target::target-most-negative-fixnum + "the fixnum closest in value to negative infinity") + +(defstatic *least-positive-bignum* (1+ target::target-most-positive-fixnum) + "used internally; value should be treated as a constant") + + +(defconstant lambda-list-keywords + '(&OPTIONAL &REST &AUX &KEY &ALLOW-OTHER-KEYS &BODY &ENVIRONMENT &WHOLE) + "symbols which are magical in a lambda list") + +(defstatic *type-system-initialized* nil) + +(defparameter %toplevel-catch% ':toplevel) + +(defvar *read-default-float-format* 'single-float) + +(defvar *read-suppress* nil + "Suppress most interpreting in the reader when T.") + +(defvar *read-base* 10. + "the radix that Lisp reads numbers in") + + +(defparameter *warn-if-redefine-kernel* nil + "When true, attempts to redefine (via DEFUN or DEFMETHOD) functions and +methods that are marked as being predefined signal continuable errors.") + +(defvar *next-screen-context-lines* 2 "Number of lines to show of old screen + after a scroll-up or scroll-down.") + +(defparameter *compiling-file* nil + "Name of outermost file being compiled or NIL if not compiling a file.") + +(defvar *eval-fn-name* nil) + + +(defvar *compile-definitions* t + "When non-NIL and the evaluator's lexical environment contains no + lexical entities, causes FUNCTION and NFUNCTION forms to be compiled.") +#| +(defvar *fast-eval* () + "If non-nil, compile-and-call any forms which would be expensive to evaluate.") +|# +(defvar *declaration-handlers* ()) + + +(defvar *lisp-system-pointer-functions* nil) +(defvar *lisp-user-pointer-functions* nil) +(defvar *lisp-cleanup-functions* nil) ; list of (0-arg) functions to call before quitting Lisp +(defvar *lisp-startup-functions* nil) ; list of funs to call after startup. +(defvar %lisp-system-fixups% nil) + + +(setf (*%saved-method-var%*) nil) + +; The GC expects these to be NIL or a function of no args +(defvar *pre-gc-hook* nil) +(defvar *post-gc-hook* nil) + +; These are used by add-gc-hook, delete-gc-hook +(defvar *pre-gc-hook-list* nil) +(defvar *post-gc-hook-list* nil) + +(defvar *backtrace-dialogs* nil) +;(defvar *stepper-running* nil) +(defparameter *last-mouse-down-time* 0) +(defparameter *last-mouse-down-position* 0) + +(defvar %handlers% ()) + + +#| +(defvar %restarts% (list (list (%cons-restart 'abort + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (throw :toplevel nil)) + "Restart the toplevel loop." + nil + nil)))) +|# + +(defvar %restarts% nil) + +(defvar ccl::*kernel-restarts* nil) +(defvar *condition-restarts* nil "explicit mapping between c & r") +(declaim (list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*)) + + + + +(defparameter *%periodic-tasks%* nil) +(defparameter *dribble-stream* nil) + +(defconstant *keyword-package* *keyword-package*) +(defconstant *common-lisp-package* *common-lisp-package*) +(defconstant *ccl-package* *ccl-package*) + +(defparameter *load-print* nil "the default for the :PRINT argument to LOAD") +(defparameter *loading-files* nil) +(defparameter *break-level* 0) +(defparameter *last-break-level* 0) +(defparameter *warn-if-redefine* nil) +(defvar *record-source-file*) ; set in l1-utils. +(defparameter *level-1-loaded* nil) ; set t by l1-boot +(defparameter *save-definitions* nil) +(defparameter *save-local-symbols* t) +(defparameter *save-source-locations* T + "Controls whether source location information is saved, both for definitions (names) and +in function objects. + +If NIL we don't store any source locations (other than the filename if *record-source-file* is non-NIL). + +If T we store as much source location information as we have available. + +If :NO-TEXT we don't store a copy of the original source text. This is a space optimization useful +for compiling files that are not expected to change.") + +(defparameter *record-pc-mapping* t "True to record pc -> source mapping (but only if +*save-source-locations* is also true)") + +(defvar *modules* nil + "This is a list of module names that have been loaded into Lisp so far. + The names are case sensitive strings. It is used by PROVIDE and REQUIRE.") + + + + + +(defparameter *eof-value* (cons nil nil)) + +(defvar *gc-event-status-bits*) ; also initialized by kernel + +(defparameter *top-listener* nil) + + + + + + + +(defvar *listener-indent* nil) + +(defparameter *autoload-lisp-package* nil) ; Make 'em suffer +(defparameter *apropos-case-sensitive-p* nil) + +(defloadvar *total-gc-microseconds* (let* ((timeval-size + #.(%foreign-type-or-record-size + :timeval :bytes)) + (p (malloc (* 5 timeval-size)))) + (#_memset p 0 (* 5 timeval-size)) + p)) + + +(defloadvar *total-bytes-freed* (let* ((p (malloc 8))) + (setf (%get-long p 0) 0 + (%get-long p 4) 0) + p)) + + + +(defvar *terminal-character-encoding-name* nil + "NIL (implying :ISO-8859-1), or a keyword which names a defined +character encoding to be used for *TERMINAL-IO* and other predefined +initial streams. The value of *TERMINAL-CHARACTER-ENCODING-NAME* +persists across calls to SAVE-APPLICATION; it can be specified via +the command-line argument --terminal-encoding (-K)") + + +(defconstant +null-ptr+ (%null-ptr)) + +;;; end of L1-init.lisp + Index: /branches/qres/ccl/level-1/l1-io.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-io.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-io.lisp (revision 13564) @@ -0,0 +1,1968 @@ +;;; -*- Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-io.lisp + +(in-package "CCL") + +(setf (fdefinition '%new-ptr) (fdefinition '%new-gcable-ptr)) + + +;;;; ====================================================================== +;;;; Standard CL IO frobs + + +(declaim (inline %real-print-stream)) +(defun %real-print-stream (&optional (stream nil)) + (cond ((null stream) + *standard-output*) + ((eq stream t) + *terminal-io*) + (t stream))) + +;;; OK, EOFP isn't CL ... +(defun eofp (&optional (stream *standard-input*)) + (stream-eofp stream)) + +(defun force-output (&optional stream) + (stream-force-output (%real-print-stream stream)) + nil) + +(defun listen (&optional (stream *standard-input*)) + (let* ((stream (designated-input-stream stream))) + (stream-listen stream))) + +(defun fresh-line (&optional (output-stream *standard-output*)) + "Output #\Newline only if the OUTPUT-STREAM is not already at the +start of a line. Return T if #\Newline needed." + (stream-fresh-line (%real-print-stream output-stream))) + +(defun column (&optional stream) + (let* ((stream (%real-print-stream stream))) + (stream-line-column stream))) + +(defun clear-input (&optional input-stream) + "Clear any available input from INPUT-STREAM." + (stream-clear-input (designated-input-stream input-stream)) + nil) + +(defun write-char (char &optional (output-stream nil)) + "Output CHAR to OUTPUT-STREAM." + (let* ((stream (%real-print-stream output-stream))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-char-function ioblock) ioblock char)) + (stream-write-char stream char)) + char)) + +(defun write-string (string &optional output-stream &key (start 0 start-p) + (end nil end-p)) + "Write the characters of the subsequence of STRING bounded by START +and END to OUTPUT-STREAM." + (let* ((stream (%real-print-stream output-stream))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (if (and (typep string 'simple-string) + (not start-p) (not end-p)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string)) + (progn + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (arr offset) + (if (typep string 'simple-string) + (values string 0) + (array-data-and-offset (require-type string 'string))) + (unless (eql 0 offset) + (incf start offset) + (incf end offset)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock arr start (the fixnum (- end start))))))))) + (if (and (not start-p) (not end-p)) + (stream-write-string stream string) + (stream-write-string stream string start end))) + string)) + +(defun write-simple-string (string output-stream start end) + "Write the characters of the subsequence of simple-string STRING bounded by START +and END to OUTPUT-STREAM." + (let* ((stream (%real-print-stream output-stream)) + (string (the simple-string string))) ;; typecheck at high safety. + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream)) + (start (or start 0))) + (with-ioblock-output-locked (ioblock) + (if (and (eq start 0) (null end)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string)) + (let* ((end (check-sequence-bounds string start end))) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string start (%i- end start)))))) + (if (and (not start) (not end)) + (stream-write-string stream string) + (stream-write-string stream string start (or end (length string))))) + string)) + +(defun write-line (string &optional output-stream + &key (start 0) (end (length string))) + "Write the characters of the subsequence of STRING bounded by START +and END to OUTPUT-STREAM then output a #\Newline at end." + (write-string string output-stream :start start :end end) + (terpri output-stream) + string) + +(defun terpri (&optional (stream *standard-output*)) + (let* ((stream (%real-print-stream stream))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-char-function ioblock) ioblock #\newline)) + (stream-write-char stream #\newline)) + nil)) + +;;;; ---------------------------------------------------------------------- + + + +;;;; ====================================================================== +;;;; The Lisp Printer + + +;; coral extensions +(defvar *print-abbreviate-quote* t + "Non-NIL means that the normal lisp printer -- +not just the pretty-printer -- should print +lists whose first element is QUOTE or FUNCTION specially. +This variable is not part of standard Common Lisp.") + +(defvar *print-structure* t + "Non-NIL means that lisp structures should be printed using +\"#S(...)\" syntax. if nil, structures are printed using \"#<...>\". +This variable is not part of standard Common Lisp.") + +;; things Richard Mlynarik likes. +(defvar *print-simple-vector* nil + "Non-NIL means that simple-vectors whose length is less than +the value of this variable are printed even if *PRINT-ARRAY* is false. +this variable is not part of standard Common Lisp.") + +(defvar *print-simple-bit-vector* nil + "Non-NIL means that simple-bit-vectors whose length is less than +the value of this variable are printed even if *PRINT-ARRAY* is false. +This variable is not part of standard Common Lisp.") + +(defvar *print-string-length* nil + "Non-NIL means that strings longer than this are printed +using abbreviated # syntax. +This variable is not part of standard Common Lisp.") + +(defvar *print-escape* t + "Non-NIL means that the lisp printer should -attempt- to output +expressions `readably.' When NIL the attempts to produce output +which is a little more human-readable (for example, pathnames +are represented by the characters of their namestring.)") + +(defvar *print-pretty* nil + "Non-NIL means that the lisp printer should insert extra +indentation and newlines to make output more readable and `prettier.'") + +(defvar *print-base* 10. + "The output base for integers and rationals. +Must be an integer between 2 and 36.") + +(defvar *print-radix* nil + "Non-NIL means that the lisp printer will explicitly indicate +the output radix (see *PRINT-BASE*) which is used to print +integers and rational numbers.") + +(defvar *print-level* nil + "Specifies the depth at which printing of lisp expressions +should be truncated. NIL means that no such truncation should occur. +Truncation is indicated by printing \"#\" instead of the +representation of the too-deeply-nested structure. +See also *PRINT-LENGTH*") + +(defvar *print-length* nil + "Specifies the length at which printing of lisp expressions +should be truncated. NIL means that no such truncation should occur. +truncation is indicated by printing \"...\" instead of the +rest of the overly-long list or vector. +See also *PRINT-LEVEL*") + +(defvar *print-circle* nil + "Non-NIL means that the lisp printer should attempt to detect +circular structures, indicating them by using \"#n=\" and \"#n#\" syntax. +If this variable is false then an attempt to +output circular structure may cause unbounded output.") + +(defvar *print-case* ':upcase + "Specifies the alphabetic case in which symbols should +be printed. Possible values include :UPCASE, :DOWNCASE and :CAPITALIZE") ; and :StuDLy + +(defvar *print-array* t + "Non-NIL means that arrays should be printed using \"#(...)\" or +\"=#nA(...)\" syntax to show their contents. +If NIL, arrays other than strings are printed using \"#<...>\". +See also the (non-Common Lisp) variables *PRINT-SIMPLE-VECTOR* +and *PRINT-SIMPLE-BIT-VECTOR*") + +(defvar *print-gensym* t + "Non-NIL means that symbols with no home package should be +printed using \"#:\" syntax. NIL means no prefix is printed.") + +(defvar *print-readably* nil + "Non-NIL means that attempts to print unreadable objects + signal PRINT-NOT-READABLE errors. NIL doesn't.") + +(defvar *PRINT-RIGHT-MARGIN* nil + "+#/NIL the right margin for pretty printing") + +(defvar *PRINT-MISER-WIDTH* 40. + "+#/NIL miser format starts when there is less than this width left") + +(defvar *PRINT-LINES* nil + "+#/NIL truncates printing after # lines") + +(defvar *DEFAULT-RIGHT-MARGIN* 70 + "Controls default line length; Must be a non-negative integer") + +(defvar *PRINT-PPRINT-DISPATCH* nil) ; We have to support this. + +(defvar *xp-current-object* nil) ; from xp + +(defvar *circularity-hash-table* nil) ; ditto + +(defvar *current-level* nil) + +(defvar *current-length* nil) ; must be nil at top level + +(defvar *print-catch-errors* nil) + +;;;; ====================================================================== + +(defclass xp-stream (output-stream) + (xp-structure)) + +(defun %write-string (string stream) + (if (characterp string) + (stream-write-char stream string) + (stream-write-entire-string stream string))) + + +;; *print-simple-vector* +;; *print-simple-bit-vector* +;; *print-string-length* +;; for things like *print-level* which must [no longer] be integers > 0 +(defun get-*print-frob* (symbol + &optional (nil-means target::target-most-positive-fixnum) + (t-means nil)) + (declare (type symbol symbol)) + (let ((value (symbol-value symbol))) + (when *print-readably* + (case symbol + ((*print-length* *print-level* *print-lines* *print-string-length*) + (setq value nil)) + ((*print-escape* *print-gensym* *print-array* *print-simple-vector* + *print-simple-bit-vector*) + (setq value t)) + (t nil))) + (cond ((null value) + nil-means) + ((and (integerp value)) ; (> value 0)) + (min (max value -1) value target::target-most-positive-fixnum)) + ((and t-means (eq value 't)) + t-means) + (t + (setf (symbol-value symbol) nil) + (error "~s had illegal value ~s. reset to ~s" + symbol value 'nil))))) + + +(defun pp-newline (stream kind) + (case kind + ((:newline) + (fresh-line stream)) + ((:unconditional :mandatory) + (stream-write-char stream #\Newline)) + (t nil))) + + +(defun pp-space (stream &optional (newline-kind ':fill)) + (stream-write-char stream #\space) + (pp-newline stream newline-kind)) + +(defun pp-start-block (stream &optional prefix) + (cond ((null prefix)) + ((characterp prefix) + (stream-write-char stream prefix)) + ((stringp prefix) + (%write-string prefix stream)) + (t (report-bad-arg prefix '(or character string (eql nil)))))) + + +(defun pp-end-block (stream &optional suffix) + (cond ((null suffix)) + ((characterp suffix) + (stream-write-char stream suffix)) + ((stringp suffix) + (%write-string suffix stream)) + (t (report-bad-arg suffix '(or character string (eql nil)))))) + + +#| +(defmethod pp-set-indentation ((stream stream) kind n) + (declare (ignore kind n)) + nil) +|# + + +;;;; ====================================================================== +;; list-kludge is so that we can simultaneously detect shared list tails +;; and avoid printing lists as (foo . (bar . (baz . nil))) +;; if non-nil, it is the remaining *print-length* and object is +;; a list tail + + + +(defmethod write-internal-1 ((stream t) object level list-kludge) + (declare (type fixnum level) (type (or null fixnum) list-kludge)) + ;;>> Anybody passing in list-kludge had better be internal to the lisp printer. + ;(if list-kludge (error "Internal printer error")) + (let ((circle *print-circle*) + (pretty *print-pretty*)) + (cond ((or pretty circle) + ; what about this level stuff?? + ; most peculiar + (maybe-initiate-xp-printing + #'(lambda (s o) (write+ o s)) stream object)) + ((not list-kludge) + (write-a-frob object stream level list-kludge)) + ((null object)) + (t + (stream-write-char stream #\space) + (when (not (consp object)) + (stream-write-char stream #\.) + (stream-write-char stream #\space)) + (write-a-frob object stream level list-kludge))))) + + + +(defmethod write-internal-1 ((stream xp-stream) object level list-kludge) + (when level + (setq *current-level* (if (and *print-level* (not *print-readably*)) + (- *print-level* level) + 0))) + (write+ object (slot-value stream 'xp-structure) list-kludge)) + + +(defvar *inside-printer-error* nil) + +(defvar *signal-printing-errors* nil) +(queue-fixup (setq *signal-printing-errors* t)) + +(defun write-internal (stream object level list-kludge) + (if (bogus-thing-p object) + (print-unreadable-object + (object stream) + (princ (%str-cat "BOGUS object @ #x" (%integer-to-string (%address-of object) 16.)) + stream)) + (progn + (flet ((handler (condition) + (declare (ignore condition)) + (unless *signal-printing-errors* + (return-from write-internal + (let ((*print-pretty* nil) + (*print-circle* nil)) + (if *inside-printer-error* + (when (eql 1 (incf *inside-printer-error*)) + (%write-string "#)) + (let ((*inside-printer-error* 0)) + ; using format here considered harmful. + (%write-string "#)))))))) + (declare (dynamic-extent #'handler)) + (handler-bind + ((error #'handler)) + (write-internal-1 stream object level list-kludge))) + object))) + + +;;;; ====================================================================== +;;;; internals of write-internal + +;; bd common-lisp (and lisp machine) printer depth counts +;; count from 0 upto *print-level* instead of from +;; *print-level* down to 0 (which this printer sensibly does.) +(defun backtranslate-level (level) + (let ((print-level (get-*print-frob* '*print-level*))) + (if (not (and level print-level)) + target::target-most-positive-fixnum + (if (> level print-level) + ;; wtf! + 1 + (- print-level level))))) + +; so we can print-circle for print-object methods. +(defvar %current-write-level% nil) +(defvar %current-write-stream% nil) +(defun %current-write-level% (stream &optional decrement?) + (if (eq stream %current-write-stream%) + (if decrement? (1- %current-write-level%) %current-write-level%) + (get-*print-frob* '*print-level*))) + +;;>> Some notes: +;;>> CL defining print-object to be a multmethod dispatching on +;;>> both the object and the stream just can't work +;;>> There are a couple of reasons: +;;>> - CL wants *print-circle* structure to be automatically detected +;;>> This means that there must be a printing pre-pass to some stream +;;>> other than the one specified by the user, which means that any +;;>> print-object method which specialises on its second argument is +;;>> going to lose big. + +;;>> - CL wants *print-level* truncation to happen automatically +;;>> and doesn't pass a level argument to print-object (as it should) +;;>> This means that the current level must be associated with the +;;>> stream in some fashion. The quicky kludge Bill uses here +;;>> (binding a special variable) loses for +;;>> + Entering a break loop whilst printing to a stream +;;>> (Should start level from (get-*print-level*) again) +;;>> + Performing output to more than one stream in an interleaved fashion +;;>> (Say a print-object method which writes to *trace-output*) +;;>> The solution, again, is to actually call the print-object methods +;;>> on a write-aux-stream, where that stream is responsible for +;;>> doing *print-level* truncation. +;;>> - BTW The select-method-order should be (stream object) to even have +;;>> a chance of winning. Not that it could win in any case, for the above reasons. +;;>> It isn't that much work to change the printer to always use an +;;>> automatically-level-truncating write-aux-stream +;;>> It is a pity that CL is so BD. +;;>> + +(defun write-a-frob (object stream level list-kludge) + (declare (type stream stream) (type fixnum level) + (type (or null fixnum) list-kludge)) + (cond ((not list-kludge) + (let ((%current-write-stream% stream) ;>> SIGH + (%current-write-level% level)) + (print-object object stream))) + ((%i< list-kludge 1) + ;; *print-length* truncation + (stream-write-entire-string stream "...")) + ((not (consp object)) + (write-a-frob object stream level nil)) + (t + (write-internal stream (%car object) level nil) + ;;>> must do a tail-call!! + (write-internal-1 stream (%cdr object) level (if (consp (%cdr object)) + (%i- list-kludge 1) + list-kludge))))) + +(defmethod print-object :around ((object t) stream) + (if *print-catch-errors* + (handler-case (call-next-method) + (error () (write-string "#" stream))) + (call-next-method))) + +(defmethod print-object ((object t) stream) + (let ((level (%current-write-level% stream)) ; what an abortion. This should be an ARGUMENT! + (%type (%type-of object))) + (declare (type symbol %type) + (type fixnum level)) + (flet ((depth (stream v) + (declare (type fixnum v) (type stream stream)) + (when (%i<= v 0) + ;; *print-level* truncation + (stream-write-entire-string stream "#") + t))) + (cond + ((eq %type 'cons) + (unless (depth stream level) + (write-a-cons object stream level))) + ;; Don't do *print-level* truncation for anything between + ;; here and the (depth ...) case. + ((or (eq %type 'symbol) + (null object)) + (write-a-symbol object stream)) + ((or (stringp object) + (bit-vector-p object)) + (cond ((or (not (stringp object)) + (%i> (length (the string object)) + (get-*print-frob* '*print-string-length*))) + (write-an-array object stream level)) + ((or *print-escape* *print-readably*) + (write-escaped-string object stream)) + (t + (%write-string object stream)))) + ((and (eq %type 'structure) + (not (null (ccl::struct-def object))) + (null (cdr (sd-slots (ccl::struct-def object))))) + ;; else fall through to write-a-uvector + (write-a-structure object stream level)) + ((depth stream level)) + ((eq %type 'package) + (write-a-package object stream)) + ((eq %type 'macptr) + (write-a-macptr object stream)) + ((eq %type 'dead-macptr) + (write-a-dead-macptr object stream)) + ((eq %type 'internal-structure) + (write-an-istruct object stream level)) + ((and (eq %type 'structure) + (not (null (ccl::struct-def object)))) + ;; else fall through to write-a-uvector + (if (and *print-pretty* *print-structure*) + (let ((*current-level* (if (and *print-level* (not *print-readably*)) + (- *print-level* level) + 0))) + (pretty-structure stream object)) + (write-a-structure object stream level))) + ((functionp object) + (write-a-function object stream level)) + ((arrayp object) + (cond ((or (not (stringp object)) + (%i> (length (the string object)) + (get-*print-frob* '*print-string-length*))) + (write-an-array object stream level)) + ((or *print-escape* *print-readably*) + (write-escaped-string object stream)) + (t + (%write-string object stream)))) + + ; whazzat + ((uvectorp object) + (write-a-uvector object stream level)) + (t + (print-unreadable-object (object stream) + (let* ((address (%address-of object))) + (cond ((eq object (%unbound-marker-8)) + (%write-string "Unbound" stream)) + ((eq object (%slot-unbound-marker)) + (%write-string "Slot-Unbound" stream)) + (t + (cond + (t + (%write-string "Unprintable " stream) + (write-a-symbol %type stream) + (%write-string " : " stream))) + (%write-address address stream)))))))) + nil)) + +(defun write-a-dead-macptr (macptr stream) + (print-unreadable-object (macptr stream) + (%write-string "A Dead Mac Pointer" stream))) + + +;;;; ====================================================================== +;;;; Powerful, wonderful tools for printing unreadable objects. + +(defun print-not-readable-error (object stream) + (error (make-condition 'print-not-readable :object object :stream stream))) + +; Start writing an unreadable OBJECT on STREAM, error out if *PRINT-READABLY* is true. +(defun write-unreadable-start (object stream) + (if *print-readably* + (print-not-readable-error object stream) + (pp-start-block stream "#<"))) + +(defun %print-unreadable-object (object stream type id thunk) + (cond ((null stream) (setq stream *standard-output*)) + ((eq stream t) (setq stream *terminal-io*))) + (write-unreadable-start object stream) + (when type + (princ (type-of object) stream)) + (when thunk + (when type (stream-write-char stream #\space)) + (funcall thunk)) + (if id + (%write-address object stream #\>) + (pp-end-block stream ">")) + nil) + +;;;; ====================================================================== +;;;; internals of internals of write-internal + +(defmethod print-object ((char character) stream &aux name) + (cond ((or *print-escape* *print-readably*) ;print #\ for read-ability + (stream-write-char stream #\#) + (stream-write-char stream #\\) + (if (and (or (eql char #\newline) + (not (standard-char-p char))) + (setq name (char-name char))) + (%write-string name stream) + (stream-write-char stream char))) + (t + (stream-write-char stream char)))) + +(defun get-*print-base* () + (let ((base *print-base*)) + (unless (and (fixnump base) + (%i< 1 base) (%i< base 37.)) + (setq *print-base* 10.) + (error "~S had illegal value ~S. Reset to ~S" + '*print-base* base 10)) + base)) + +(defun write-radix (base stream) + (stream-write-char stream #\#) + (case base + (2 (stream-write-char stream #\b)) + (8 (stream-write-char stream #\o)) + (16 (stream-write-char stream #\x)) + (t (%pr-integer base 10. stream) + (stream-write-char stream #\r)))) + +(defun write-an-integer (num stream + &optional (base (get-*print-base*)) + (print-radix *print-radix*)) + (when (and print-radix (not (eq base 10))) + (write-radix base stream)) + (%pr-integer num base stream) + (when (and print-radix (eq base 10)) + (stream-write-char stream #\.))) + +(defmethod print-object ((num integer) stream) + (write-an-integer num stream)) + +(defun %write-address (object stream &optional foo) + (if foo (pp-space stream)) + (write-an-integer (if (integerp object) object (%address-of object)) stream 16. t) + (if foo (pp-end-block stream foo))) + +(defmethod print-object ((num ratio) stream) + (let ((base (get-*print-base*))) + ;;>> What to do when for *print-radix* and *print-base* = 10? + (when (and *print-radix* (not (eq base 10))) + (write-radix base stream)) + (%pr-integer (numerator num) base stream) + (stream-write-char stream #\/) + (%pr-integer (denominator num) base stream))) + +;;>> Doesn't do *print-level* truncation +(defmethod print-object ((c complex) stream) + (pp-start-block stream "#C(") + (print-object (realpart c) stream) + (pp-space stream) + (print-object (imagpart c) stream) + (pp-end-block stream #\))) + +(defmethod print-object ((float float) stream) + (print-a-float float stream)) + +(defun float-exponent-char (float) + (if (case *read-default-float-format* + (single-float (typep float 'single-float)) + (double-float (typep float 'double-float)) + (t (typep float *read-default-float-format*))) + #\E + (if (typep float 'double-float) + #\D + #\S))) + +(defun default-float-p (float) + (case *read-default-float-format* + (single-float (typep float 'single-float)) + (double-float (typep float 'double-float)) + (t (typep float *read-default-float-format*)))) + + +(defun print-a-nan (float stream) + (if (infinity-p float) + (output-float-infinity float stream) + (output-float-nan float stream))) + +(defun output-float-infinity (x stream) + (declare (float x) (stream stream)) + (format stream "~:[-~;~]1~c++0" + (plusp x) + (if (typep x *read-default-float-format*) + #\E + (typecase x + (double-float #\D) + (single-float #\S))))) + +(defun output-float-nan (x stream) + (declare (float x) (stream stream)) + (format stream "1~c+-0 #| not-a-number |#" + (if (typep x *read-default-float-format*) + #\E + (etypecase x + (double-float #\D) + (single-float #\S))))) + + +;; nanning => recursive from print-a-nan - don't check again +(defun print-a-float (float stream &optional exp-p nanning) + (let ((strlen 0) (exponent-char (float-exponent-char float))) + (declare (fixnum strlen)) + (setq stream (%real-print-stream stream)) + (if (and (not nanning)(nan-or-infinity-p float)) + (print-a-nan float stream) + (multiple-value-bind (string before-pt #|after-pt|#) + (flonum-to-string float) + (declare (fixnum before-pt #|after-pt|#)) + (setq strlen (length string)) + (when (minusp (float-sign float)) + (stream-write-char stream #\-)) + (cond + ((and (not exp-p) (zerop strlen)) + (stream-write-entire-string stream "0.0")) + ((and (> before-pt 0)(<= before-pt 7)(not exp-p)) + (cond ((> strlen before-pt) + (write-string string stream :start 0 :end before-pt) + (stream-write-char stream #\.) + (write-string string stream :start before-pt :end strlen)) + (t ; 0's after + (stream-write-entire-string stream string) + (dotimes (i (- before-pt strlen)) + (stream-write-char stream #\0)) + (stream-write-entire-string stream ".0")))) + ((and (> before-pt -3)(<= before-pt 0)(not exp-p)) + (stream-write-entire-string stream "0.") + (dotimes (i (- before-pt)) + (stream-write-char stream #\0)) + (stream-write-entire-string stream string)) + (t + (setq exp-p t) + (stream-write-char stream (if (> strlen 0)(char string 0) #\0)) + (stream-write-char stream #\.) + (if (> strlen 1) + (write-string string stream :start 1 :end strlen) + (stream-write-char stream #\0)) + (stream-write-char stream exponent-char) + (when (and exp-p (not (minusp (1- before-pt)))) + (stream-write-char stream #\+)) + (let ((*print-base* 10) + (*print-radix* nil)) + (princ (1- before-pt) stream)))) + (when (and (not exp-p) + (not (default-float-p float))) + (stream-write-char stream exponent-char) + (stream-write-char stream #\0)))))) + +;;>> Doesn't do *print-level* truncation +(defmethod print-object ((class class) stream) + (print-unreadable-object (class stream) + (print-object (class-name (class-of class)) stream) + (pp-space stream) + (print-object (class-name class) stream))) + + +(defmethod print-object ((value-cell value-cell) stream) + (print-unreadable-object (value-cell stream :type t :identity t) + (prin1 (uvref value-cell target::value-cell.value-cell) stream))) + +;(defun symbol-begins-with-vowel-p (sym) +; (and (symbolp sym) +; (not (%izerop (%str-length (setq sym (symbol-name sym))))) +; (%str-member (schar sym 0) "AEIOU"))) + +;;;; ---------------------------------------------------------------------- +;;;; CLOSsage + +(defmethod print-object ((instance standard-object) stream) + (if (%i<= %current-write-level% 0) ; *print-level* truncation + (stream-write-entire-string stream "#") + (print-unreadable-object (instance stream :identity t) + (let* ((class (class-of instance)) + (class-name (class-name class))) + (cond ((not (and (symbolp class-name) + (eq class (find-class class-name nil)))) + (%write-string "An instance of" stream) + (pp-space stream) + (print-object class stream)) + (t + (write-a-symbol class-name stream))))))) + +(defmethod print-object ((method standard-method) stream) + (print-method method stream (%class.name (class-of method)))) + +(defmethod print-object ((method-function method-function) stream) + (let ((method (%method-function-method method-function))) + (if (typep method 'standard-method) + (print-method (%method-function-method method-function) + stream + (%class.name (class-of method-function))) + (call-next-method)))) + + + +(defun print-method (method stream type-string) + (print-unreadable-object (method stream) + (let ((name (%method-name method)) + (qualifiers (%method-qualifiers method)) + (specializers (mapcar #'(lambda (specializer) + (if (typep specializer 'eql-specializer) + (list 'eql + (eql-specializer-object specializer)) + (or (class-name specializer) + specializer))) + (%method-specializers method))) + (level-1 (%i- %current-write-level% 1))) + (cond + ((< level-1 0) + ;; *print-level* truncation + (stream-write-entire-string stream "#")) + (t + (prin1 type-string stream) + (pp-space stream) + (write-internal stream name level-1 nil) + (pp-space stream) + (when qualifiers + (write-internal stream (if (cdr qualifiers) qualifiers (car qualifiers)) + level-1 nil) + (pp-space stream)) + (write-internal stream specializers level-1 nil)))))) + +;; Need this stub or we'll get the standard-object method +(defmethod print-object ((gf standard-generic-function) stream) + (write-a-function gf stream (%current-write-level% stream))) + +;; This shouldn't ever happen, but if it does, don't want the standard-object method +(defmethod print-object ((mo metaobject) stream) + (print-unreadable-object (mo stream :type t :identity t))) + +(defmethod print-object ((cm combined-method) stream) + (print-unreadable-object (cm stream :identity t) + (%write-string "Combined-Method" stream) + (pp-space stream) + (let ((name (function-name cm))) + (if (and (functionp name) (function-is-current-definition? name)) + (setq name (function-name name))) + (write-internal stream name (%current-write-level% stream) nil)))) + +(defun print-specializer-names (specializers stream) + (flet ((print-specializer (spec stream) + (write-1 (if (typep spec 'class) (%class.name spec) spec) stream))) + (pp-start-block stream #\() + (if (atom specializers) + (print-specializer specializers stream) + (progn (print-specializer (car specializers) stream) + (dolist (spec (cdr specializers)) + (pp-space stream) + (print-specializer spec stream)))) + (pp-end-block stream #\)))) + + +;;;; ---------------------------------------------------------------------- + +(defun write-a-cons (cons stream level) + (declare (type cons cons) (type stream stream) (type fixnum level)) + (let ((print-length (get-*print-frob* '*print-length*)) + (level-1 (%i- level 1)) + (head (%car cons)) + (tail (%cdr cons))) + (declare (type fixnum print-length) (type fixnum level-1)) + (unless (and *print-abbreviate-quote* + (write-abbreviate-quote head tail stream level-1)) + (progn + (pp-start-block stream #\() + (if (= print-length 0) + (%write-string "..." stream) + (progn + (write-internal stream head level-1 nil) + (write-internal stream tail level-1 + (if (atom tail) + print-length + (%i- print-length 1))))) + (pp-end-block stream #\)))))) + +;;;; hack for quote and backquote + +;; for debugging +;(setq *backquote-expand* nil) + +(defvar *backquote-hack* (list '*backquote-hack*)) ;uid +(defun write-abbreviate-quote (head tail stream level-1) + (declare (type stream stream) (type fixnum level-1)) + (when (symbolp head) + (cond ((or (eq head 'quote) (eq head 'function)) + (when (and (consp tail) + (null (%cdr tail))) + (%write-string (if (eq head 'function) "#'" "'") stream) + (write-internal stream (%car tail) level-1 nil) + t)) + ((eq head 'backquote-expander) + (when (and (consp tail) + (consp (cdr tail)) + (consp (cddr tail)) + (consp (cdddr tail)) + (null (cddddr tail))) + (let ((tail tail)) + (set (%car tail) + *backquote-hack*) ;, + (set (%car (setq tail (%cdr tail))) + *backquote-hack*) ;,. + (set (%car (setq tail (%cdr tail))) + *backquote-hack*) ;,@ + (stream-write-char stream #\`) + (write-internal stream (%cadr tail) level-1 nil) + t))) + ((and (boundp head) + (eq (symbol-value head) *backquote-hack*)) + ;;",foo" = (#:|,| . foo) + (stream-write-char stream #\,) + (let* ((n (symbol-name head)) + (l (length n))) + (declare (type simple-string n) (type fixnum l)) + ;; possibilities are #:|`,| #:|,.| and #:|,@| + (if (eql l 3) + (stream-write-char stream (schar n 2))) + (write-internal stream tail level-1 nil) + t)) + (t nil)))) + +(eval-when (compile eval) +(defmacro %char-needs-escape-p (char escape &rest losers) + (setq losers (remove-duplicates (cons escape losers))) + (setq char (require-type char 'symbol)) + (dolist (c losers) + (unless (or (characterp c) (symbolp c)) (report-bad-arg c '(or character symbol)))) + (cond ((null (cdr losers)) + `(eq ,char ,escape)) + ((and (every #'characterp losers) + ;(every #'string-char-p losers) + (%i> (length losers) 2)) + `(%str-member ,char ,(concatenate 'string losers))) + (t + `(or ,@(mapcar #'(lambda (e) `(eq ,char ,e)) + losers))))) + +(defmacro %write-escaped-char (stream char escape &rest losers) + `(progn + (when (%char-needs-escape-p ,char ,escape ,@losers) + (stream-write-char ,stream ,escape)) + (stream-write-char ,stream ,char))) +) + +(defun write-escaped-string (string stream &optional (delim #\")) + (declare (type string string) (type character delim) + (type stream stream)) + (write-char delim stream) + (do* ((limit (length string)) + (i 0 (1+ i))) + ((= i limit)) + (declare (type fixnum limit) (type fixnum i)) + (let* ((char (char string i)) + (needs-escape? (%char-needs-escape-p char #\\ delim))) + (if needs-escape? + (write-char #\\ stream)) + (write-char char stream))) + (write-char delim stream)) + + +;;;; ---------------------------------------------------------------------- +;;;; printing symbols + +(defun get-*print-case* () + (let ((case *print-case*)) + (unless (or (eq case ':upcase) (eq case ':downcase) + (eq case ':capitalize) (eq case ':studly)) + (setq *print-case* ':upcase) + (error "~S had illegal value ~S. Reset to ~S" + '*print-case* case ':upcase)) + case)) + +(defun write-a-symbol (symbol stream) + (declare (type symbol symbol) (type stream stream)) + (let ((case (get-*print-case*)) + (name (symbol-name symbol)) + (package (symbol-package symbol))) + (declare (type simple-string name)) + (when (or *print-readably* *print-escape*) + (cond ((keywordp symbol) + (stream-write-char stream #\:)) + ((null package) + (when (or *print-readably* *print-gensym*) + (stream-write-char stream #\#) + (stream-write-char stream #\:))) + (t + (multiple-value-bind (s flag) + (find-symbol name *package*) + (unless (and flag (eq s symbol)) + (multiple-value-setq (s flag) + (find-symbol name package)) + (unless (and flag (eq s symbol)) + (%write-string "#|symbol not found in home package!!|#" + stream)) + (write-pname (package-name package) case stream) + (stream-write-char stream #\:) + (unless (eq flag ':external) + (stream-write-char stream #\:))))))) + (write-pname name case stream))) + + + +(defun write-pname (name case stream) + (declare (type simple-string name) (stream stream) + (optimize (speed 3)(safety 0))) + (let* ((readtable *readtable*) + (readcase (readtable-case (if *print-readably* + %initial-readtable% + readtable))) + (escape? (or *print-readably* *print-escape*))) + (flet ((slashify? (char) + (declare (type character char)) + (and escape? + (if (alpha-char-p char) + (if (eq readcase :upcase) + (lower-case-p char) ; _tolower + (if (eq readcase :downcase) + (upper-case-p char))) + ; should be using readtable here - but (get-macro-character #\|) is nil + (not (%str-member + char + "!$%&*0123456789.<=>?@[]^_{}~+-/"))))) + (single-case-p (name) + (let ((sofar nil)) + (dotimes (i (length name) sofar) + (declare (type fixnum i)) + (declare (type simple-string name)) + (let* ((c (schar name i)) + (c-case (if (upper-case-p c) + :upcase + (if (lower-case-p c) + :downcase)))) + (when c-case + (if sofar + (if (neq sofar c-case) + (return nil)) + (setq sofar c-case)))))))) + (declare (dynamic-extent #'slashify? #'single-case-p)) + (block alice + (let ((len (length name)) + (slash-count 0) + (last-slash-pos 0)) + (declare (type fixnum len) + (type fixnum slash-count last-slash-pos)) + (when escape? + (when (or (%izerop len) + ;; if more than a few \, just use |...| + (and (not (memq readcase '(:invert :preserve))) ; these never slashify alpha-p + (let ((m (max (floor len 4) 2))) + (dotimes (i (the fixnum len) nil) + (declare (type fixnum i)) + (when (slashify? (schar name i)) + (setq slash-count (%i+ slash-count 1)) + (when (or (eql slash-count m) + (eq i (1+ last-slash-pos))) + (return t)) + (setq last-slash-pos i))))) + ;; or could be read as a number + (%parse-number-token name 0 len *print-base*) + ;; or symbol consisting entirely of .'s + (dotimes (i len t) + (declare (fixnum i)) + (unless (eql (schar name i) #\.) + (return nil)))) + (return-from alice + (write-escaped-string name stream #\|)))) + (case readcase + (:preserve (return-from alice (write-string name stream :start 0 :end len))) + (:invert (return-from alice + (cond ((single-case-p name)(write-perverted-string name stream len :invert)) + (t (write-string name stream :start 0 :end len))))) + (t + (when (eql slash-count 0) + (return-from alice + (cond ((eq readcase case) + (write-string name stream :start 0 :end len)) + (t (write-perverted-string name stream len case))))))) + (let* ((outbuf-len (+ len len)) + (outbuf-ptr -1) + (outbuf (make-string outbuf-len))) + (declare (fixnum outbuf-ptr outbuf-len) + (dynamic-extent outbuf) + (simple-string outbuf)) + (dotimes (pos (the fixnum len)) + (declare (type fixnum pos)) + (let* ((char (schar name pos)) + (slashify? (cond ((eql slash-count 0) + nil) + ((eql slash-count 1) + (eql pos last-slash-pos)) + (t + (slashify? char))))) + (declare (type character char)) + (when slashify? + (setq slash-count (%i- slash-count 1)) + (setf (schar outbuf (incf outbuf-ptr)) #\\)) + (setf (schar outbuf (incf outbuf-ptr)) char))) + (write-string outbuf stream :start 0 :end (1+ outbuf-ptr)))))))) + +#| +(defun write-studly-string (string stream) + (declare (type string string) (stream stream)) + (let* ((offset 0) + (end (length string)) + (pool *pname-buffer*) + (outbuf-ptr -1) + (outbuf (pool.data pool))) + (declare (fixnum offset end outbuf-ptr)) + (setf (pool.data pool) nil) + (unless (and outbuf (>= (length outbuf) end)) + (setq outbuf (make-array end :element-type 'character))) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (setq offset (%i+ offset (char-int (char string i))))) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (let ((c (char string i))) + (declare (type character c)) + (cond ((not (and (%i< (%ilogand2 + (%i+ (char-int c) offset) + 15.) + 6.) + (alpha-char-p c)))) + ((upper-case-p c) + (setq c (char-downcase c))) + (t + (setq c (char-upcase c)))) + (setf (schar outbuf (incf outbuf-ptr)) c))) + (write-string outbuf stream :start 0 :end end) + (setf (pool.data pool) outbuf))) +|# + +(defun write-perverted-string (string stream end type) + ; type :invert :upcase :downcase :capitalize or :studly + (declare (fixnum end)) + (let* ((readtable *readtable*) + (readcase (readtable-case readtable)) + (outbuf-ptr -1) + (outbuf (make-string end)) + (word-start t) + (offset 0)) + (declare (fixnum offset outbuf-ptr) + (dynamic-extent outbuf)) + (when (eq type :studly) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (setq offset (%i+ offset (char-int (char string i)))))) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (let ((c (char string i))) + (declare (type character c)) + (cond ((alpha-char-p c) + (case type + (:studly + (cond ((not (%i< (%ilogand2 + (%i+ (char-int c) offset) + 15.) + 6.))) + ((upper-case-p c) + (setq c (char-downcase c))) + (t + (setq c (char-upcase c))))) + (:invert + (setq c (if (upper-case-p c)(char-downcase c)(char-upcase c)))) + (:upcase + (setq c (char-upcase c))) + (:downcase + (setq c (char-downcase c))) + (:capitalize (setq c (cond (word-start + (setq word-start nil) + (if (eq readcase :upcase) + c + (char-upcase c))) + (t + (if (eq readcase :upcase) + (char-downcase c) + c))))))) + ((digit-char-p c)(setq word-start nil)) + (t (setq word-start t))) + (setf (schar outbuf (incf outbuf-ptr)) c))) + (write-string outbuf stream :start 0 :end end))) + + +;;;; ---------------------------------------------------------------------- +;;;; printing arrays + +;; *print-array* +;; *print-simple-vector* +;; *print-simple-bit-vector* +;; *print-string-length* + +(defun array-readably-printable-p (array) + (let ((dims (array-dimensions array))) + (and (eq (array-element-type array) t) + (let ((zero (position 0 dims)) + (number (position 0 dims + :test (complement #'eql) + :from-end t))) + (or (null zero) (null number) (> zero number)))))) + +(defun write-an-array (array stream level) + (declare (type array array) (type stream stream) (type fixnum level)) + (let* ((rank (array-rank array)) + (vector? (eql rank 1)) + (simple? (simple-array-p array)) + (simple-vector? (simple-vector-p array)) + ;; non-*print-string-length*-truncated strings are printed by + ;; write-a-frob + (string? (stringp array)) + (bit-vector? (bit-vector-p array)) + (fill-pointer? (array-has-fill-pointer-p array)) + (adjustable? (adjustable-array-p array)) + (displaced? (displaced-array-p array)) + (total-size (array-total-size array)) + (length (and vector? (length array))) + (print-length (get-*print-frob* '*print-length*)) + (print-array (get-*print-frob* '*print-array* nil t))) + (declare (type fixnum rank) (type fixnum total-size) + (type fixnum print-length)) + (unless + (cond (string? + nil) + ((and bit-vector? print-array) + (stream-write-char stream #\#) (stream-write-char stream #\*) + (do ((i 0 (%i+ i 1)) + (l print-length (%i- l 1))) + (nil) + (declare (type fixnum i) (type fixnum l)) + (cond ((eql i length) + (return)) + (t + (stream-write-char stream (if (eql (bit array i) 0) #\0 #\1))))) + t) + ((and *print-readably* + (not (array-readably-printable-p array))) + nil) + ((and *print-pretty* print-array) + (let ((*current-level* (if (and *print-level* (not *print-readably*)) + (- *print-level* level) + 0))) + (pretty-array stream array)) + t) + (vector? + (when (or print-array + (and simple-vector? + (%i<= length (get-*print-frob* + '*print-simple-vector* + 0 + target::target-most-positive-fixnum)))) + (pp-start-block stream "#(") + (do ((i 0 (%i+ i 1)) + (l print-length (%i- l 1))) + (nil) + (declare (type fixnum i) (type fixnum l)) + (cond ((eql i length) + (return)) + ((eql l 0) + ;; can't use write-abbreviation since there is + ;; no `object' for the abbreviation to represent + (unless (eql i 0) (pp-space stream)) + (%write-string "..." stream) + (return)) + (t (unless (eql i 0) (pp-space stream)) + (write-internal stream (aref array i) (%i- level 1) nil)))) + (pp-end-block stream #\)) + t)) + ((and print-array (not fill-pointer?)) + (let ((rank (array-rank array))) + (stream-write-char stream #\#) + (%pr-integer rank 10. stream) + (stream-write-char stream #\A) + (if (eql rank 0) + (write-internal stream (aref array) (%i- level 1) nil) + (multiple-value-bind (array-data offset) + (array-data-and-offset array) + (write-array-elements-1 + stream level + array-data offset + (array-dimensions array))))) + t) + (t + ;; fall through -- print randomly + nil)) + ;; print array using #<...> + (print-unreadable-object (array stream) + (if vector? + (progn + (write-a-symbol (cond (simple-vector? + 'simple-vector) + (string? + (if simple? 'simple-string 'string)) + (bit-vector? + (if simple? 'simple-bit-vector 'bit-vector)) + (t 'vector)) + stream) + (pp-space stream) + (%pr-integer total-size 10. stream) + (when fill-pointer? + (let ((fill-pointer (fill-pointer array))) + (declare (fixnum fill-pointer)) + (pp-space stream) + (%write-string "fill-pointer" stream) + (unless (eql fill-pointer total-size) + (stream-write-char stream #\space) + (%pr-integer fill-pointer 10. stream))))) + (progn + (write-a-symbol 'array stream) + (pp-space stream) + (if (eql rank 0) (%write-string "0-dimensional" stream)) + (dotimes (i (the fixnum rank)) + (unless (eql i 0) (stream-write-char stream #\x)) + (%pr-integer (array-dimension array i) 10. stream)))) + (let ((type (array-element-type array))) + (unless (or simple-vector? string? bit-vector? ; already written "#" + level nil))) + (cond (simple? + (unless (or simple-vector? string? bit-vector?) + ;; already written "# length 20)) + (flet ((foo (stream string start end) + (declare (type fixnum start) (type fixnum end) + (type string string)) + (do ((i start (%i+ i 1))) + ((%i>= i end)) + (let ((c (char string i))) + (declare (type character c)) + (if (not (graphic-char-p c)) + (return) + (%write-escaped-char stream c #\\ #\")))))) + #|(%write-string " \"" stream)|# (pp-space stream) + (foo stream array 0 12) + (%write-string "..." stream) + (foo stream array (%i- length 6) length) + #|(stream-write-char stream #\")|#)))))) + +(defun write-array-elements-1 (stream level + array-data offset + dimensions) + (declare (type stream stream) (type fixnum level) + (type vector array-data) (type fixnum offset) + (type list dimensions)) + (block written + (let ((tail (%cdr dimensions)) + (print-length (get-*print-frob* '*print-length*)) + (level-1 (%i- level 1)) + (limit (%car dimensions)) + (step 1)) + (when (and (null tail) + (%i> level-1 0) + (or (bit-vector-p array-data) + (and (stringp array-data) + (%i<= limit print-length)))) + (return-from written + ;;>> cons cons. I was lazy. + ;;>> Should code a loop to write the elements instead + (write-an-array (%make-displaced-array + ;; dimensions displaced-to + limit array-data + ;; fill-pointer adjustable + nil nil + ;; displaced-index-offset + offset) + stream level-1))) + (pp-start-block stream #\() + (dolist (e tail) (setq step (%i* e step))) + (do* ((o offset (%i+ o step)) + (i 0 (1+ i))) + (nil) + (declare (type fixnum o) (type fixnum i) (type fixnum limit) + (type fixnum step) (type fixnum print-length) + (type fixnum level-1)) + (cond ((eql i print-length) + (%write-string " ..." stream) + (return)) + ((eql i limit) + (return)) + ((= i 0)) + (t + (pp-space stream (if (null tail) ':fill ':linear)))) + (cond ((null tail) + (write-internal stream (aref array-data o) level-1 nil)) + ((eql level-1 0) + ;; can't use write-abbreviation since this doesn't really + ;; abbreviate a single object + (stream-write-char stream #\#)) + (t + (write-array-elements-1 stream level-1 + array-data o tail)))) + (pp-end-block stream #\))))) + +;;;; ---------------------------------------------------------------------- + +; A "0" in the sd-print-function => inherit from superclass. +(defun structure-print-function (class) + (let* ((pf (ccl::sd-print-function class)) + (supers (cdr (sd-superclasses class)))) + (do* () + ((neq pf 0) pf) + (if supers + (setq pf (sd-print-function (gethash (pop supers) %defstructs%))) + (return))))) + +(defun write-a-structure (object stream level) + (declare (type stream stream) (type fixnum level)) + (let* ((class (ccl::struct-def object)) ;;guaranteed non-NIL if this function is called + (pf (structure-print-function class))) + (cond (pf + (if (consp pf) + (funcall (%car pf) object stream) + (funcall pf + object stream (backtranslate-level level)))) + ((and (not *print-structure*) (not *print-readably*)) + (print-unreadable-object (object stream :identity t) + (write-a-symbol (ccl::sd-name class) stream))) + (t + (let ((level-1 (ccl::%i- level 1)) + (slots (cdr (ccl::sd-slots class))) + (print-length (get-*print-frob* '*print-length*))) + (declare (type fixnum level-1) (type list slots)) + (%write-string "#S(" stream) + (if (%i> print-length 0) + (write-a-symbol (ccl::sd-name class) stream) + (progn (%write-string "...)" stream) + (return-from write-a-structure))) + (when (and slots (%i> print-length 1)) + (pp-start-block stream #\Space)) + (do ((l (%i- print-length 1) (%i- l 2)) + (first? t) + (print-case (get-*print-case*))) + (nil) + (declare (type fixnum l)) + (cond ((null slots) + (return)) + ((%i< l 1) + ;; Note write-abbreviation since it isn't abbreviating an object + (%write-string " ..." stream) + (return))) + (let* ((slot (prog1 (%car slots) + (setq slots (%cdr slots)))) + (symbol (ccl::ssd-name slot))) + (when (symbolp symbol) + (if first? + (setq first? nil) + (pp-space stream ':linear)) + (stream-write-char stream #\:) + (write-pname (symbol-name symbol) print-case stream) + (cond ((%i> l 1) + (pp-space stream) + (write-internal stream (uvref object (ccl::ssd-offset slot)) + level-1 nil)) + (t (%write-string " ..." stream) + (return))))))) + (pp-end-block stream #\)))))) + +(%fhave 'encapsulated-function-name ;(fn) ;Redefined in encapsulate + (qlfun bootstrapping-encapsulated-function-name (fn) + (declare (ignore fn)) + nil)) + + +(%fhave '%traced-p ;(fn) ;Redefined in encapsulate + (qlfun bootstrapping-%traced-p (fn) + (declare (ignore fn)) + nil)) + +(%fhave '%advised-p ;(fn) ;Redefined in encapsulate + (qlfun bootstrapping-%advised-p (fn) + (declare (ignore fn)) + nil)) + + + +(defun write-a-function (lfun stream level) ; screwed up + (print-unreadable-object (lfun stream :identity t) + (let* ((name (function-name lfun)) + ; actually combined-method has its oun print-object method and doesn't get here. + ; standard-generic-function has a print-object method that just calls this. + (gf-or-cm (or (standard-generic-function-p lfun) (combined-method-p lfun)))) + (cond ((and (not (compiled-function-p lfun)) + (not gf-or-cm)) + ; i.e. closures + (write-internal stream (%type-of lfun) level nil) + (when name + (pp-space stream) + (write-internal stream name (%i- level 1) nil))) + ((not name) + (%lfun-name-string lfun stream t)) + (t + (if gf-or-cm + (write-internal stream (class-name (class-of lfun)) level nil) + (%write-string (cond ((typep lfun 'method-function) + "Compiled Method-function") + (t "Compiled-function")) + stream)) + (stream-write-char stream #\space) + (write-internal stream name (%i- level 1) nil) + (cond ((and (symbolp name) (eq lfun (macro-function name))) + (%write-string " Macroexpander" stream)) ;What better? + ((not (function-is-current-definition? lfun)) + ;;>> Nice if it could print (Traced), (Internal), (Superseded), etc + (cond ((%traced-p name) + (%write-string " (Traced Original) " stream)) + ((%advised-p name) + (%write-string " (Advised Original) " stream)) + (t (%write-string " (Non-Global) " stream)))))))))) + + +(defun function-is-current-definition? (function) + (let ((name (function-name function))) + (and name + (valid-function-name-p name) + (eq function (fboundp name))))) + +;; outputs to stream or returns a string. Barf! +;; Making not matters not worse ... +(defun %lfun-name-string (lfun &optional stream suppress-address) + (unless (functionp lfun) (report-bad-arg lfun 'function)) + (if (null stream) + (with-output-to-string (s) (%lfun-name-string lfun s)) + (let ((name (function-name lfun))) + (if name + (prin1 name stream) + (let* ((fnaddr (%address-of lfun)) + (kernel-function-p (kernel-function-p lfun))) + (%write-string (if kernel-function-p + "Internal " "Anonymous ") + stream) + (if (standard-generic-function-p lfun) + (prin1 (class-name (class-of lfun)) stream) + (%write-string "Function" stream)) + (unless suppress-address + (stream-write-char stream #\ ) + (write-an-integer fnaddr + stream 16. t))))))) + + +;;;; ---------------------------------------------------------------------- + +(defun write-a-package (pkg stream) + (print-unreadable-object (pkg stream) + (if (null (pkg.names pkg)) + (%write-string "Deleted Package" stream) + (progn + (%write-string "Package " stream) + (write-escaped-string (package-name pkg) stream))))) + + + +(defun write-a-macptr (macptr stream) + (let* ((null (%null-ptr-p macptr))) + (print-unreadable-object (macptr stream) + (if null + (progn + (%write-string "A Null Foreign Pointer" stream)) + (progn + (pp-start-block stream "A Foreign Pointer") + (%write-macptr-allocation-info macptr stream) + (stream-write-char stream #\ ) + (%write-macptr-type-info macptr stream) + (write-an-integer (%ptr-to-int macptr) stream 16. t)))))) + +(defun %macptr-allocation-string (macptr) + (if (or (on-any-csp-stack macptr) + (on-any-tsp-stack macptr)) + "[stack-allocated]" + (if (eql (uvsize macptr) target::xmacptr.element-count) + "[gcable]"))) + +(defun %write-macptr-allocation-info (macptr stream) + (let* ((s (%macptr-allocation-string macptr))) + (if s (format stream " ~a" s)))) + +(defun %write-macptr-type-info (macptr stream) + (let* ((ordinal (%macptr-type macptr))) + (unless (eql 0 ordinal) + (let* ((type (gethash ordinal (ftd-ordinal-types *target-ftd*))) + (form + (if (typep type 'foreign-record-type) + `(:* (,(foreign-record-type-kind type) + ,(foreign-record-type-name type))) + `(:* ,(unparse-foreign-type type))))) + (when form (format stream "~s " form)))))) + + + +; This special-casing for wrappers is cheaper than consing a class +(defun write-an-istruct (istruct stream level) + (let* ((type (istruct-cell-name (uvref istruct 0))) + (wrapper-p (eq type 'class-wrapper))) + (print-unreadable-object (istruct stream :identity t) + (write-internal stream type (%i- level 1) nil) + (when wrapper-p + (pp-space stream) + (print-object (class-name (%wrapper-class istruct)) stream))))) + +(defun write-a-uvector (uvec stream level) + (declare (ignore level)) + (print-unreadable-object (uvec stream :identity t :type t))) + + +(defmethod print-object ((slotdef slot-definition) stream) + (print-unreadable-object (slotdef stream :identity t :type t) + (format stream "for ~a slot ~s" + (string-downcase (slot-definition-allocation slotdef)) + (standard-slot-definition.name slotdef)))) + +(defmethod print-object ((spec eql-specializer) stream) + (print-unreadable-object (spec stream :identity t :type t) + (format stream "~s" (if (slot-boundp spec 'object) + (eql-specializer-object spec) + "")))) + + +(defmethod print-object ((slot-id slot-id) stream) + (print-unreadable-object (slot-id stream :identity t :type t) + (format stream "for ~s/~d" + (slot-id.name slot-id) + (slot-id.index slot-id)))) + +#+x86-target +(defmethod print-object ((tra tagged-return-address) stream) + (print-unreadable-object (tra stream :identity t :type t) + (let* ((f (%return-address-function tra)) + (offset (if f (%return-address-offset tra)))) + (when offset + (format stream "in function ") + (%lfun-name-string f stream) + (format stream " (+~d)" offset))))) + +#+x8664-target +(defmethod print-object ((sv symbol-vector) stream) + (print-unreadable-object (sv stream :identity t :type t) + (format stream "for ~s" (%symptr->symbol (%symvector->symptr sv))))) + +#+x8664-target +(defmethod print-object ((fv function-vector) stream) + (print-unreadable-object (fv stream :identity t :type t) + (format stream "for ") + (%lfun-name-string (%function-vector-to-function fv) stream))) + +(defmethod print-object ((c class-cell) stream) + (print-unreadable-object (c stream :type t :identity t) + (format stream "for ~s" (class-cell-name c)))) + + + +;;; ====================================================================== + + +(defun real-print-stream (&optional (stream nil)) + (cond ((null stream) + *standard-output*) + ((eq stream t) + *terminal-io*) + ((streamp stream) + stream) + ;; This never gets called because streamp is true for xp-structure... + ((istruct-typep stream 'xp-structure) + (get-xp-stream stream)) + (t + (report-bad-arg stream '(or stream (member nil t)))))) + +(defun write-1 (object stream &optional levels-left) + (setq stream (%real-print-stream stream)) + (when (not levels-left) + (setq levels-left + (if *current-level* + (if *print-level* + (- *print-level* *current-level*) + target::target-most-positive-fixnum) + (%current-write-level% stream t)))) + (cond + ((< levels-left 0) + ;; *print-level* truncation + (stream-write-entire-string stream "#")) + (t (write-internal stream + object + (min levels-left target::target-most-positive-fixnum) + nil))) + object) + +;;;; ---------------------------------------------------------------------- +;;;; User-level interface to the printer + + +(defun write (object + &key (stream *standard-output*) + (escape *print-escape*) + (radix *print-radix*) + (base *print-base*) + (circle *print-circle*) + (pretty *print-pretty*) + (level *print-level*) + (length *print-length*) + (case *print-case*) + (gensym *print-gensym*) + (array *print-array*) + (readably *print-readably*) + (right-margin *print-right-margin*) + (miser-width *print-miser-width*) + (lines *print-lines*) + (pprint-dispatch *print-pprint-dispatch*) + ;;>> Do I really want to add these to WRITE?? + (structure *print-structure*) + (simple-vector *print-simple-vector*) + (simple-bit-vector *print-simple-bit-vector*) + (string-length *print-string-length*)) + "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*" + (let ((*print-escape* escape) + (*print-radix* radix) + (*print-base* base) + (*print-circle* circle) + (*print-pretty* pretty) + (*print-level* level) + (*print-length* length) + (*print-case* case) + (*print-gensym* gensym) + (*print-array* array) + (*print-readably* readably) + (*print-right-margin* right-margin) + (*print-miser-width* miser-width) + (*print-lines* lines) + (*print-pprint-dispatch* pprint-dispatch) + ;;>> Do I really want to add these to WRITE?? + (*print-structure* structure) + (*print-simple-vector* simple-vector) + (*print-simple-bit-vector* simple-bit-vector) + (*print-string-length* string-length)) + (write-1 object stream))) + +(defun write-to-string (object + &key (escape *print-escape*) + (radix *print-radix*) + (base *print-base*) + (circle *print-circle*) + (pretty *print-pretty*) + (level *print-level*) + (length *print-length*) + (case *print-case*) + (gensym *print-gensym*) + (array *print-array*) + (readably *print-readably*) + (right-margin *print-right-margin*) + (miser-width *print-miser-width*) + (lines *print-lines*) + (pprint-dispatch *print-pprint-dispatch*) + ;;>> Do I really want to add these to WRITE?? + (structure *print-structure*) + (simple-vector *print-simple-vector*) + (simple-bit-vector *print-simple-bit-vector*) + (string-length *print-string-length*)) + "Return the printed representation of OBJECT as a string." + (let ((*print-escape* escape) + (*print-radix* radix) + (*print-base* base) + (*print-circle* circle) + (*print-pretty* pretty) + (*print-level* level) + (*print-length* length) + (*print-case* case) + (*print-gensym* gensym) + (*print-array* array) + ;; I didn't really wan't to add these, but I had to. + (*print-readably* readably) + (*print-right-margin* right-margin) + (*print-miser-width* miser-width) + (*print-lines* lines) + (*print-pprint-dispatch* pprint-dispatch) + ;;>> Do I really want to add these to WRITE?? + (*print-structure* structure) + (*print-simple-vector* simple-vector) + (*print-simple-bit-vector* simple-bit-vector) + (*print-string-length* string-length)) + (with-output-to-string (stream) + (write-1 object stream)))) + +(defun prin1-to-string (object) + "Return the printed representation of OBJECT as a string with + slashification on." + (with-output-to-string (s) + (prin1 object s))) + +(defun princ-to-string (object) + "Return the printed representation of OBJECT as a string with + slashification off." + (with-output-to-string (s) + (princ object s))) + +(defun prin1 (object &optional stream) + "Output a mostly READable printed representation of OBJECT on the specified + STREAM." + (let ((*print-escape* t)) + (write-1 object stream))) + +(defun princ (object &optional stream) + "Output an aesthetic but not necessarily READable printed representation + of OBJECT on the specified STREAM." + (let ((*print-escape* nil) + (*print-readably* nil)) + (write-1 object stream))) + +(defun print (object &optional stream) + "Output a newline, the mostly READable printed representation of OBJECT, and + space to the specified STREAM." + (terpri stream) + (let ((*print-escape* t)) + (write-1 object stream)) + (write-char #\Space stream) + object) + +; redefined by pprint module if loaded +(defun pprint (object &optional stream) + (print object stream) + nil) ; pprint returns nil + + +(defun read-sequence (seq stream &key (start 0) end) + "Destructively modify SEQ by reading elements from STREAM. + That part of SEQ bounded by START and END is destructively modified by + copying successive elements into it from STREAM. If the end of file + for STREAM is reached before copying all elements of the subsequence, + then the extra elements near the end of sequence are not updated, and + the index of the next element is returned." + (setq end (check-sequence-bounds seq start end)) + (locally (declare (fixnum start end)) + (if (= start end) + start + (seq-dispatch + seq + (+ start (the fixnum (stream-read-list + stream + (nthcdr start seq) + (the fixnum (- end start))))) + (multiple-value-bind (vector offset) (array-data-and-offset seq) + (declare (fixnum offset)) + (- + (stream-read-vector + stream + vector + (the fixnum (+ offset start)) + (the fixnum (+ offset end))) + offset)))))) + + + +(defun write-sequence (seq stream &key (start 0) end) + "Write the elements of SEQ bounded by START and END to STREAM." + (setq end (check-sequence-bounds seq start end)) + (locally (declare (fixnum start end)) + (seq-dispatch + seq + (stream-write-list stream (nthcdr start seq) (the fixnum (- end start))) + (multiple-value-bind (vector offset) (array-data-and-offset seq) + (stream-write-vector + stream + vector + (the fixnum (+ offset start)) + (the fixnum (+ offset end)))))) + seq) + +(defpackage "GRAY" + (:use) + (:import-from "CCL" + "FUNDAMENTAL-STREAM" + "FUNDAMENTAL-INPUT-STREAM" + "FUNDAMENTAL-OUTPUT-STREAM" + "FUNDAMENTAL-CHARACTER-STREAM" + "FUNDAMENTAL-CHARACTER-INPUT-STREAM" + "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" + "FUNDAMENTAL-BINARY-STREAM" + "FUNDAMENTAL-BINARY-INPUT-STREAM" + "FUNDAMENTAL-BINARY-OUTPUT-STREAM" + + "STREAM-READ-CHAR" + "STREAM-UNREAD-CHAR" + "STREAM-READ-CHAR-NO-HANG" + "STREAM-PEEK-CHAR" + "STREAM-LISTEN" + "STREAM-READ-LINE" + "STREAM-CLEAR-INPUT" + + "STREAM-WRITE-CHAR" + "STREAM-LINE-COLUMN" + "STREAM-START-LINE-P" + "STREAM-WRITE-STRING" + "STREAM-TERPRI" + "STREAM-FRESH-LINE" + "STREAM-FORCE-OUTPUT" + "STREAM-FINISH-OUTPUT" + "STREAM-CLEAR-OUTPUT" + "STREAM-ADVANCE-TO-COLUMN" + + "STREAM-READ-BYTE" + "STREAM-WRITE-BYTE" + ) + (:export + "FUNDAMENTAL-STREAM" + "FUNDAMENTAL-INPUT-STREAM" + "FUNDAMENTAL-OUTPUT-STREAM" + "FUNDAMENTAL-CHARACTER-STREAM" + "FUNDAMENTAL-CHARACTER-INPUT-STREAM" + "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" + "FUNDAMENTAL-BINARY-STREAM" + "FUNDAMENTAL-BINARY-INPUT-STREAM" + "FUNDAMENTAL-BINARY-OUTPUT-STREAM" + + "STREAM-READ-CHAR" + "STREAM-UNREAD-CHAR" + "STREAM-READ-CHAR-NO-HANG" + "STREAM-PEEK-CHAR" + "STREAM-LISTEN" + "STREAM-READ-LINE" + "STREAM-CLEAR-INPUT" + + "STREAM-WRITE-CHAR" + "STREAM-LINE-COLUMN" + "STREAM-START-LINE-P" + "STREAM-WRITE-STRING" + "STREAM-TERPRI" + "STREAM-FRESH-LINE" + "STREAM-FORCE-OUTPUT" + "STREAM-FINISH-OUTPUT" + "STREAM-CLEAR-OUTPUT" + "STREAM-ADVANCE-TO-COLUMN" + + "STREAM-READ-BYTE" + "STREAM-WRITE-BYTE" +)) + + Index: /branches/qres/ccl/level-1/l1-lisp-threads.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-lisp-threads.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-lisp-threads.lisp (revision 13564) @@ -0,0 +1,1116 @@ +;;; -*- Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; l1-lisp-threads.lisp + +(in-package "CCL") + +(defvar *bind-io-control-vars-per-process* nil + "If true, bind I/O control variables per process") + + + +(defun lisp-thread-p (thing) + (istruct-typep thing 'lisp-thread)) + +(setf (type-predicate 'lisp-thread) 'lisp-thread-p) + +(defloadvar *ticks-per-second* + #+windows-target 1000 + #-windows-target + (#_sysconf #$_SC_CLK_TCK)) + +(defloadvar *ns-per-tick* + (floor 1000000000 *ticks-per-second*)) + +#-windows-target +(defun %nanosleep (seconds nanoseconds) + (with-process-whostate ("Sleep") + (rlet ((a :timespec) + (b :timespec)) + (setf (pref a :timespec.tv_sec) seconds + (pref a :timespec.tv_nsec) nanoseconds) + (let* ((aptr a) + (bptr b)) + (loop + (let* ((result + (external-call #+darwin-target "_nanosleep" + #-darwin-target "nanosleep" + :address aptr + :address bptr + :signed-fullword))) + (declare (type (signed-byte 32) result)) + (if (and (< result 0) + (eql (%get-errno) (- #$EINTR))) + ;; x86-64 Leopard bug. + (let* ((asec (pref aptr :timespec.tv_sec)) + (bsec (pref bptr :timespec.tv_sec))) + (if (and (>= bsec 0) + (or (< bsec asec) + (and (= bsec asec) + (< (pref bptr :timespec.tv_nsec) + (pref aptr :timespec.tv_nsec))))) + (psetq aptr bptr bptr aptr) + (return))) + (return)))))))) + + +(defun timeval->ticks (tv) + (+ (* *ticks-per-second* (pref tv :timeval.tv_sec)) + (round (pref tv :timeval.tv_usec) (floor 1000000 *ticks-per-second*)))) + + +(defun gettimeofday (ptimeval &optional ptz) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-gettimeofday) + :address ptimeval + :address (or ptz (%null-ptr)) + :int)) + +(defloadvar *lisp-start-timeval* + (progn + (let* ((r (make-record :timeval))) + (gettimeofday r) + r))) + + +(defloadvar *internal-real-time-session-seconds* nil) + + +(defun get-internal-real-time () + "Return the real time in the internal time format. (See + INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding elapsed time." + (rlet ((tv :timeval)) + (gettimeofday tv) + (let* ((units (truncate (the fixnum (pref tv :timeval.tv_usec)) (/ 1000000 internal-time-units-per-second))) + (initial *internal-real-time-session-seconds*)) + (if initial + (locally + (declare (type (unsigned-byte 32) initial)) + (+ (* internal-time-units-per-second + (the (unsigned-byte 32) + (- (the (unsigned-byte 32) (pref tv :timeval.tv_sec)) + initial))) + units)) + (progn + (setq *internal-real-time-session-seconds* + (pref tv :timeval.tv_sec)) + units))))) + +(defun get-tick-count () + (values (floor (get-internal-real-time) + (floor internal-time-units-per-second + *ticks-per-second*)))) + + + + +(defun %kernel-global-offset (name-or-offset) + (if (fixnump name-or-offset) + name-or-offset + (target::%kernel-global name-or-offset))) + + +(defun %kernel-global-offset-form (name-or-offset-form) + (cond ((quoted-form-p name-or-offset-form) + `(%target-kernel-global ,name-or-offset-form)) + ((fixnump name-or-offset-form) + name-or-offset-form) + (t `(%target-kernel-global ',name-or-offset-form)))) + + + +(defmacro %set-kernel-global (name-or-offset new-value) + `(%set-kernel-global-from-offset + ,(%kernel-global-offset-form name-or-offset) + ,new-value)) + + + +; The number of bytes in a consing (or stack) area +(defun %area-size (area) + (ash (- (%fixnum-ref area target::area.high) + (%fixnum-ref area target::area.low)) + target::fixnumshift)) + +(defun %stack-area-usable-size (area) + (ash (- (%fixnum-ref area target::area.high) + (%fixnum-ref area target::area.softlimit)) + target::fixnum-shift)) + +(defun %cons-lisp-thread (name &optional tcr) + (%istruct 'lisp-thread + tcr + name + 0 + 0 + 0 + nil + nil + (make-lock) + nil + :reset + (make-lock))) + +(defvar *current-lisp-thread* + (%cons-lisp-thread "Initial" (%current-tcr))) + +(defstatic *initial-lisp-thread* *current-lisp-thread*) + +(defun thread-change-state (thread oldstate newstate) + (with-lock-grabbed ((lisp-thread.state-change-lock thread)) + (when (eq (lisp-thread.state thread) oldstate) + (setf (lisp-thread.state thread) newstate)))) + +(thread-change-state *initial-lisp-thread* :reset :run) + +(defun thread-state (thread) + (with-lock-grabbed ((lisp-thread.state-change-lock thread)) + (lisp-thread.state thread))) + +(defun thread-make-startup-function (thread tcr) + #'(lambda () + (thread-change-state thread :reset :run) + (let* ((*current-lisp-thread* thread) + (initial-function (lisp-thread.initial-function.args thread))) + (tcr-clear-preset-state tcr) + (%set-tcr-toplevel-function tcr nil) + (setf (interrupt-level) 0) + (apply (car initial-function) (cdr initial-function)) + (cleanup-thread-tcr thread tcr)))) + +(defun init-thread-from-tcr (tcr thread) + (let* ((cs-area (%fixnum-ref tcr target::tcr.cs-area)) + (vs-area (%fixnum-ref tcr target::tcr.vs-area)) + (ts-area (%fixnum-ref tcr target::tcr.ts-area))) + (when (or (zerop cs-area) + (zerop vs-area) + (zerop ts-area)) + (error "Can't allocate new thread")) + (setf (lisp-thread.tcr thread) tcr + (lisp-thread.cs-size thread) + (%stack-area-usable-size cs-area) + (lisp-thread.vs-size thread) + (%stack-area-usable-size vs-area) + (lisp-thread.ts-size thread) + (%stack-area-usable-size ts-area) + (lisp-thread.startup-function thread) + (thread-make-startup-function thread tcr))) + (thread-change-state thread :exit :reset) + thread) + +(defun default-allocation-quantum () + (ash 1 (%get-kernel-global 'default-allocation-quantum))) + +(defun new-lisp-thread-from-tcr (tcr name) + (let* ((thread (%cons-lisp-thread name tcr))) + (init-thread-from-tcr tcr thread) + (push thread (population-data *lisp-thread-population*)) + thread)) + +(def-ccl-pointers initial-thread () + (init-thread-from-tcr (%current-tcr) *initial-lisp-thread*)) + +(defmethod print-object ((thread lisp-thread) stream) + (print-unreadable-object (thread stream :type t :identity t) + (format stream "~a" (lisp-thread.name thread)) + (let* ((tcr (lisp-thread.tcr thread))) + (if (and tcr (not (eql 0 tcr))) + (format stream " [tcr @ #x~x]" (ash tcr target::fixnumshift)))))) + + +(defvar *lisp-thread-population* + (%cons-population (list *initial-lisp-thread*) $population_weak-list nil)) + + + + + +(defparameter *default-control-stack-size* + #+32-bit-target (ash 1 20) + #+64-bit-target (ash 2 20)) +(defparameter *default-value-stack-size* + #+32-bit-target (ash 1 20) + #+64-bit-target (ash 2 20)) +(defparameter *default-temp-stack-size* + #+32-bit-target (ash 1 19) + #+64-bit-target (ash 2 19)) + + +(defstatic *initial-listener-default-control-stack-size* *default-control-stack-size*) +(defstatic *initial-listener-default-value-stack-size* *default-value-stack-size*) +(defstatic *initial-listener-default-temp-stack-size* *default-temp-stack-size*) + + +(def-ccl-pointers listener-stack-sizes () + (let* ((size (%get-kernel-global 'stack-size))) ; set by --thread-stack-size + (declare (fixnum size)) + (when (> size 0) + (setq *initial-listener-default-control-stack-size* size + *initial-listener-default-value-stack-size* size + *initial-listener-default-temp-stack-size* (floor size 2))))) + + +(defmacro with-area-macptr ((var area) &body body) + `(with-macptrs (,var) + (%setf-macptr-to-object ,var ,area) + ,@body)) + + +(defun gc-area.return-sp (area) + (%fixnum-ref area target::area.gc-count)) + + +(defun (setf gc-area.return-sp) (return-sp area) + (setf (%fixnum-ref area target::area.gc-count) return-sp)) + + + +(defun shutdown-lisp-threads () + ) + +(defun %current-xp () + (let ((xframe (%fixnum-ref (%current-tcr) target::tcr.xframe))) + (when (eql xframe 0) + (error "No current exception frame")) + (%fixnum-ref xframe + (get-field-offset :xframe-list.this)))) + +(defun new-tcr (cs-size vs-size ts-size) + (let* ((tcr (macptr->fixnum + (ff-call + (%kernel-import target::kernel-import-newthread) + #+64-bit-target :unsigned-doubleword + #+32-bit-target :unsigned-fullword cs-size + #+64-bit-target :unsigned-doubleword + #+32-bit-target :unsigned-fullword vs-size + #+64-bit-target :unsigned-doubleword + #+32-bit-target :unsigned-fullword ts-size + :address)))) + (declare (fixnum tcr)) + (if (zerop tcr) + (error "Can't create thread") + tcr))) + +(defun new-thread (name cstack-size vstack-size tstack-size) + (new-lisp-thread-from-tcr (new-tcr cstack-size vstack-size tstack-size) name)) + +(defun new-tcr-for-thread (thread) + (let* ((tcr (new-tcr + (lisp-thread.cs-size thread) + (lisp-thread.vs-size thread) + (lisp-thread.ts-size thread)))) + (setf (lisp-thread.tcr thread) tcr + (lisp-thread.startup-function thread) + (thread-make-startup-function thread tcr)) + (thread-change-state thread :exit :reset) + tcr)) + + + + + +(defconstant cstack-hardprot (ash 100 10)) +(defconstant cstack-softprot (ash 100 10)) + + + +(defun tcr-flags (tcr) + (%fixnum-ref tcr target::tcr.flags)) + + + +(defun %tcr-frame-ptr (tcr) + (with-macptrs (p) + (%setf-macptr-to-object p tcr) + (%fixnum-from-macptr + (ff-call (%kernel-import target::kernel-import-tcr-frame-ptr) + :address p + :address)))) + +(defun thread-exhausted-p (thread) + (or (null thread) + (null (lisp-thread.tcr thread)))) + +(defun thread-total-run-time (thread) + (unless (thread-exhausted-p thread) + nil)) + +(defun %tcr-interrupt (tcr) + ;; The other thread's interrupt-pending flag might get cleared + ;; right after we look and see it set, but since this is called + ;; with the lock on the thread's interrupt queue held, the + ;; pending interrupt won't have been taken yet. + ;; When a thread dies, it should try to clear its interrupt-pending + ;; flag. + (if (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending)) + (%%tcr-interrupt tcr) + 0)) + + + + + + +(defun thread-interrupt (thread process function &rest args) + (with-lock-grabbed ((lisp-thread.state-change-lock thread)) + (case (lisp-thread.state thread) + (:run + (with-lock-grabbed ((lisp-thread.interrupt-lock thread)) + (let ((tcr (lisp-thread.tcr thread))) + (when tcr + (push (cons function args) + (lisp-thread.interrupt-functions thread)) + (eql 0 (%tcr-interrupt tcr)))))) + (:reset + ;; Preset the thread with a function that'll return to the :reset + ;; state + (let* ((pif (process-initial-form process)) + (pif-f (car pif)) + (pif-args (cdr pif))) + (process-preset process #'(lambda () + (%rplaca pif pif-f) + (%rplacd pif pif-args) + (apply function args) + ;; If function returns normally, + ;; return to the reset state + (%process-reset nil))) + (thread-enable thread (process-termination-semaphore process) (1- (integer-length (process-allocation-quantum process))) 0) + t))))) + +(defun thread-handle-interrupts () + (let* ((thread *current-lisp-thread*)) + (with-process-whostate ("Active") + (loop + (let* ((f (with-lock-grabbed ((lisp-thread.interrupt-lock thread)) + (pop (lisp-thread.interrupt-functions thread))))) + (if f + (apply (car f) (cdr f)) + (return))))))) + + + +(defun thread-preset (thread function &rest args) + (setf (lisp-thread.initial-function.args thread) + (cons function args))) + +(defun thread-enable (thread termination-semaphore allocation-quantum &optional (timeout (* 60 60 24))) + (let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread)))) + (with-macptrs (s) + (%setf-macptr-to-object s (%fixnum-ref tcr target::tcr.reset-completion)) + (when (%timed-wait-on-semaphore-ptr s timeout nil) + (%set-tcr-toplevel-function + tcr + (lisp-thread.startup-function thread)) + (%activate-tcr tcr termination-semaphore allocation-quantum) + thread)))) + + +(defun cleanup-thread-tcr (thread tcr) + (let* ((flags (%fixnum-ref tcr target::tcr.flags))) + (declare (fixnum flags)) + (if (logbitp arch::tcr-flag-bit-awaiting-preset flags) + (thread-change-state thread :run :reset) + (progn + (thread-change-state thread :run :exit) + (setf (lisp-thread.tcr thread) nil))))) + +(defun kill-lisp-thread (thread) + (unless (eq thread *initial-lisp-thread*) + (let* ((tcr (lisp-thread.tcr thread))) + (when tcr + (setf (lisp-thread.tcr thread) nil + (lisp-thread.state thread) :exit) + (%kill-tcr tcr))))) + +;;; This returns the underlying pthread, whatever that is, as an +;;; unsigned integer. +(defun lisp-thread-os-thread (thread) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (lisp-thread.tcr thread)) + (unless (%null-ptr-p tcrp) + (let* ((natural (%get-natural tcrp target::tcr.osid))) + (unless (zerop natural) natural))))) + + + +;;; This returns something lower-level than the pthread, if that +;;; concept makes sense. On current versions of Linux, it returns +;;; the pid of the clone()d process; on Darwin, it returns a Mach +;;; thread. On some (near)future version of Linux, the concept +;;; may not apply. +;;; The future is here: on Linux systems using NPTL, this returns +;;; exactly the same thing that (getpid) does. +;;; This should probably be retired; even if it does something +;;; interesting, is the value it returns useful ? + +(defun lisp-thread-native-thread (thread) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (lisp-thread.tcr thread)) + (unless (%null-ptr-p tcrp) + (#+32-bit-target %get-unsigned-long + #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.native-thread-id)))) + +(defun lisp-thread-suspend-count (thread) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (lisp-thread.tcr thread)) + (unless (%null-ptr-p tcrp) + (#+32-bit-target %get-unsigned-long + #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.suspend-count)))) + +(defun tcr-clear-preset-state (tcr) + (let* ((flags (%fixnum-ref tcr target::tcr.flags))) + (declare (fixnum flags)) + (setf (%fixnum-ref tcr target::tcr.flags) + (bitclr arch::tcr-flag-bit-awaiting-preset flags)))) + +(defun tcr-set-preset-state (tcr) + (let* ((flags (%fixnum-ref tcr target::tcr.flags))) + (declare (fixnum flags)) + (setf (%fixnum-ref tcr target::tcr.flags) + (bitset arch::tcr-flag-bit-awaiting-preset flags)))) + +;;; This doesn't quite activate the thread; see PROCESS-TCR-ENABLE. +(defun %activate-tcr (tcr termination-semaphore allocation-quantum) + (declare (ignore termination-semaphore)) + (if (and tcr (not (eql 0 tcr))) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp tcr) + (setf (%get-natural tcrp target::tcr.log2-allocation-quantum) + (or allocation-quantum (default-allocation-quantum))) + t))) + +(defvar *canonical-error-value* + '(*canonical-error-value*)) + + +(defun symbol-value-in-tcr (sym tcr) + (if (eq tcr (%current-tcr)) + (%sym-value sym) + (unwind-protect + (progn + (%suspend-tcr tcr) + (let* ((loc (%tcr-binding-location tcr sym))) + (if loc + (%fixnum-ref loc) + (%sym-global-value sym)))) + (%resume-tcr tcr)))) + +(defun (setf symbol-value-in-tcr) (value sym tcr) + (if (eq tcr (%current-tcr)) + (%set-sym-value sym value) + (unwind-protect + (progn + (%suspend-tcr tcr) + (let* ((loc (%tcr-binding-location tcr sym))) + (if loc + (setf (%fixnum-ref loc) value) + (%set-sym-global-value sym value)))) + (%resume-tcr tcr)))) + +;;; Backtrace support +;;; + + + +(defmacro do-db-links ((db-link &optional var value) &body body) + (let ((thunk (gensym)) + (var-var (or var (gensym))) + (value-var (or value (gensym)))) + `(block nil + (let ((,thunk #'(lambda (,db-link ,var-var ,value-var) + (declare (ignorable ,db-link)) + ,@(unless var (list `(declare (ignore ,var-var)))) + ,@(unless value (list `(declare (ignore ,value-var)))) + ,@body))) + (declare (dynamic-extent ,thunk)) + (map-db-links ,thunk))))) + + + + +(defun map-db-links (f) + (without-interrupts + (let ((db-link (%current-db-link))) + (loop + (when (eql 0 db-link) (return)) + (funcall f db-link (%fixnum-ref db-link (* 1 target::node-size)) (%fixnum-ref db-link (* 2 target::node-size))) + (setq db-link (%fixnum-ref db-link)))))) + +(defun %get-frame-ptr () + (%current-frame-ptr)) + +(defun %current-exception-frame () + #+ppc-target *fake-stack-frames* + #+x86-target (or (let* ((xcf (%current-xcf))) + (if xcf + (%%frame-backlink xcf))) + (%current-frame-ptr))) + + + + + +(defun next-catch (catch) + (let ((next-catch (uvref catch target::catch-frame.link-cell))) + (unless (eql next-catch 0) next-catch))) + + + + +; @@@ this needs to load early so errors can work +(defun next-lisp-frame (p context) + (let ((frame p)) + (loop + (let ((parent (%frame-backlink frame context))) + (multiple-value-bind (lisp-frame-p bos-p) (lisp-frame-p parent context) + (if lisp-frame-p + (return parent) + (if bos-p + (return nil)))) + (setq frame parent))))) + +(defun parent-frame (p context) + (loop + (let ((parent (next-lisp-frame p context))) + (when (or (null parent) + (not (catch-csp-p parent context))) + (return parent)) + (setq p parent)))) + + + + + +(defun last-frame-ptr (&optional context origin) + (let* ((current (or origin + (if context (bt.current context) (%current-frame-ptr)))) + (last current)) + (loop + (setq current (parent-frame current context)) + (if current + (setq last current) + (return last))))) + + + +(defun child-frame (p context ) + (let* ((current (if context (bt.current context) (%current-frame-ptr))) + (last nil)) + (loop + (when (null current) + (return nil)) + (when (eq current p) (return last)) + (setq last current + current (parent-frame current context))))) + + + + + +; This returns the current head of the db-link chain. +(defun db-link (&optional context) + (if context + (bt.db-link context) + (%fixnum-ref (%current-tcr) target::tcr.db-link))) + +(defun previous-db-link (db-link start ) + (declare (fixnum db-link start)) + (let ((prev nil)) + (loop + (when (or (eql db-link start) (eql 0 start)) + (return prev)) + (setq prev start + start (%fixnum-ref start 0))))) + +(defun count-db-links-in-frame (vsp parent-vsp &optional context) + (declare (fixnum vsp parent-vsp)) + (let ((db (db-link context)) + (count 0) + (first nil) + (last nil)) + (declare (fixnum db count)) + (loop + (cond ((eql db 0) + (return (values count (or first 0) (or last 0)))) + ((and (>= db vsp) (< db parent-vsp)) + (unless first (setq first db)) + (setq last db) + (incf count))) + (setq db (%fixnum-ref db))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; bogus-thing-p support +;;; + +(defun %ptr-in-area-p (ptr area) + (declare (optimize (speed 3) (safety 0)) (fixnum ptr area)) ; lie, maybe + (and (<= (the fixnum (%fixnum-ref area target::area.low)) ptr) + (> (the fixnum (%fixnum-ref area target::area.high)) ptr))) + +(defun %active-area (area active) + (or (do ((a area (%fixnum-ref a target::area.older))) + ((eql a 0)) + (when (%ptr-in-area-p active a) + (return a))) + (do ((a (%fixnum-ref area target::area.younger) (%fixnum-ref a target::area.younger))) + ((eql a 0)) + (when (%ptr-in-area-p active a) + (return a))))) + +(defun %ptr-to-vstack-p (tcr idx) + (%ptr-in-area-p idx (%fixnum-ref tcr target::tcr.vs-area))) + +(defun %on-tsp-stack (tcr object) + (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.ts-area))) + +(defun %on-csp-stack (tcr object) + (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.cs-area))) + +(defparameter *aux-tsp-ranges* ()) +(defparameter *aux-vsp-ranges* ()) +(defparameter *aux-csp-ranges* ()) + +(defun object-in-range-p (object range) + (declare (fixnum object)) + (when range + (destructuring-bind (active . high) range + (declare (fixnum active high)) + (and (< active object) + (< object high))))) + +(defun object-in-some-range (object ranges) + (dolist (r ranges) + (when (object-in-range-p object r) + (return t)))) + + +(defun on-any-tsp-stack (object) + (or (%on-tsp-stack (%current-tcr) object) + (object-in-some-range object *aux-tsp-ranges*))) + +(defun on-any-vstack (idx) + (or (%ptr-to-vstack-p (%current-tcr) idx) + (object-in-some-range idx *aux-vsp-ranges*))) + +(defun on-any-csp-stack (object) + (or (%on-csp-stack (%current-tcr) object) + (object-in-some-range object *aux-csp-ranges*))) + +;;; This MUST return either T or NIL. +(defun temporary-cons-p (x) + (and (consp x) + (not (null (or (on-any-vstack x) + (on-any-tsp-stack x)))))) + + + + + + + +(defun %value-cell-header-at-p (cur-vsp) + (eql target::value-cell-header (%fixnum-address-of (%fixnum-ref cur-vsp)))) + +(defun count-stack-consed-value-cells-in-frame (vsp parent-vsp) + (let ((cur-vsp vsp) + (count 0)) + (declare (fixnum cur-vsp count)) + (loop + (when (>= cur-vsp parent-vsp) (return)) + (when (and (evenp cur-vsp) (%value-cell-header-at-p cur-vsp)) + (incf count) + (incf cur-vsp)) ; don't need to check value after header + (incf cur-vsp)) + count)) + +;;; stack consed value cells are one of two forms: +;;; Well, they were of two forms. When they existed, that is. +;;; +;;; nil ; n-4 +;;; header ; n = even address (multiple of 8) +;;; value ; n+4 +;;; +;;; header ; n = even address (multiple of 8) +;;; value ; n+4 +;;; nil ; n+8 + +(defun in-stack-consed-value-cell-p (arg-vsp vsp parent-vsp) + (declare (fixnum arg-vsp vsp parent-vsp)) + (if (evenp arg-vsp) + (%value-cell-header-at-p arg-vsp) + (or (and (> arg-vsp vsp) + (%value-cell-header-at-p (the fixnum (1- arg-vsp)))) + (let ((next-vsp (1+ arg-vsp))) + (declare (fixnum next-vsp)) + (and (< next-vsp parent-vsp) + (%value-cell-header-at-p next-vsp)))))) + + + +(defun count-values-in-frame (p context &optional child) + (declare (ignore child)) + (multiple-value-bind (vsp parent-vsp) (vsp-limits p context) + (values + (- parent-vsp + vsp + (* 2 (count-db-links-in-frame vsp parent-vsp context)))))) + +(defun nth-value-in-frame-loc (sp n context lfun pc vsp parent-vsp) + (declare (fixnum sp)) + (setq n (require-type n 'fixnum)) + (unless (or (null vsp) (fixnump vsp)) + (setq vsp (require-type vsp '(or null fixnum)))) + (unless (or (null parent-vsp) (fixnump parent-vsp)) + (setq parent-vsp (require-type parent-vsp '(or null fixnum)))) + (unless (and vsp parent-vsp) + (multiple-value-setq (vsp parent-vsp) (vsp-limits sp context))) + (locally (declare (fixnum n vsp parent-vsp)) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame vsp parent-vsp context) + (declare (ignore db-count)) + (declare (fixnum first-db last-db)) + (let ((arg-vsp (1- parent-vsp)) + (cnt n) + (phys-cell 0) + db-link-p) + (declare (fixnum arg-vsp cnt phys-cell)) + (loop + (if (eql (the fixnum (- arg-vsp 2)) last-db) + (setq db-link-p t + arg-vsp last-db + last-db (previous-db-link last-db first-db) + phys-cell (+ phys-cell 2)) + (setq db-link-p nil)) + (when (< (decf cnt) 0) + (return + (if db-link-p + (values (+ 2 arg-vsp) + :saved-special + (binding-index-symbol (%fixnum-ref (1+ arg-vsp)))) + (multiple-value-bind (type name) (find-local-name phys-cell lfun pc) + (values arg-vsp type name))))) + (incf phys-cell) + (when (< (decf arg-vsp) vsp) + (error "~d out of range" n))))))) + + + +(defun nth-value-in-frame (sp n context &optional lfun pc vsp parent-vsp) + (multiple-value-bind (loc type name) + (nth-value-in-frame-loc sp n context lfun pc vsp parent-vsp) + (let* ((val (%fixnum-ref loc))) + (when (and (eq type :saved-special) + (eq val (%no-thread-local-binding-marker)) + name) + (setq val (%sym-global-value name))) + (values val type name)))) + +(defun set-nth-value-in-frame (sp n context new-value &optional vsp parent-vsp) + (multiple-value-bind (loc type name) + (nth-value-in-frame-loc sp n context nil nil vsp parent-vsp) + (let* ((old-value (%fixnum-ref loc))) + (if (and (eq type :saved-special) + (eq old-value (%no-thread-local-binding-marker)) + name) + ;; Setting the (shallow-bound) value of the outermost + ;; thread-local binding of NAME. Hmm. + (%set-sym-global-value name new-value) + (setf (%fixnum-ref loc) new-value))))) + +(defun nth-raw-frame (n start-frame context) + (declare (fixnum n)) + (do* ((p start-frame (parent-frame p context)) + (i 0 (1+ i)) + (q (last-frame-ptr context))) + ((or (null p) (eq p q) (%stack< q p context))) + (declare (fixnum i)) + (if (= i n) + (return p)))) + +;;; True if the object is in one of the heap areas +(defun %in-consing-area-p (x area) + (declare (optimize (speed 3) (safety 0)) (fixnum x)) ; lie + (let* ((low (%fixnum-ref area target::area.low)) + (high (%fixnum-ref area target::area.high)) +) + (declare (fixnum low high)) + (and (<= low x) (< x high)))) + + + +(defun in-any-consing-area-p (x) + (do-consing-areas (area) + (when (%in-consing-area-p x area) + (return t)))) + + + + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; terminate-when-unreachable +;;; + +#| +Message-Id: +Mime-Version: 1.0 +Content-Type: text/plain; charset="us-ascii" +Date: Wed, 7 Feb 1996 10:32:55 -0500 +To: pmcldev@digitool.com +From: bitCraft@taconic.net (Bill St. Clair) +Subject: terminate-when-unreachable + +I propose that we add a general termination mechanism to PPC MCL. +We need it to properly terminate stack groups, it would be +a nicer way to do the termination for macptrs than the current +ad-hoc mechanism (which BTW is not yet part of PPC MCL), and +it is a nice addition to MCL. I don't think it's hard to make +the garbage collector support this, and I volunteer to do the +work unless Gary really wants to. + +I see two ways to support termination: + +1) Do termination for hash tables. This was our plan for + 2.0, but Gary got confused about how to mark the objects at + the right time (or so I remember). + +2) Resurrect weak alists (they're not part of the PPC garbage + collector) and add a termination bit to the population type. + This allows for termination of weak lists and weak alists, + though the termination mechanism really only needs termination + for a single weak alist. + +I prefer option 2, weak alists, since it avoids the overhead +necessary to grow and rehash a hash table. It also uses less space, +since a finalizeable hash table needs to allocate two cons cells +for each entry so that the finalization code has some place to +put the deleted entry. + +I propose the following interface (slightly modified from what +Apple Dylan provides): + +terminate-when-unreachable object &optional (function 'terminate) + When OBJECT becomes unreachable, funcall FUNCTION with OBJECT + as a single argument. Each call of terminate-when-unreachable + on a single (EQ) object registers a new termination function. + All will be called when the object becomes unreachable. + +terminate object [generic function] + The default termination function + +terminate (object t) [method] + The default method. Ignores object. Returns nil. + +drain-termination-queue [function] + Drain the termination queue. I.e. call the termination function + for every object that has become unreachable. + +*enable-automatic-termination* [variable] + If true, the default, drain-termination-queue will be automatically + called on the first event check after the garbage collector runs. + If you set this to false, you are responsible for calling + drain-termination-queue. + +cancel-terminate-when-unreachable object &optional function + Removes the effect of the last call to terminate-when-unreachable + for OBJECT & FUNCTION (both tested with EQ). Returns true if + it found a match (which it won't if the object has been moved + to the termination queue since terminate-when-unreachable was called). + If FUNCTION is NIL or unspecified, then it will not be used; the + last call to terminate-when-unreachable with the given OBJECT will + be undone. + +termination-function object + Return the function passed to the last call of terminate-when-unreachable + for OBJECT. Will be NIL if the object has been put in the + termination queue since terminate-when-unreachable was called. + +|# + + +(defstatic *termination-population* + (%cons-terminatable-alist)) + +(defstatic *termination-population-lock* (make-lock)) + + +(defvar *enable-automatic-termination* t) + +(defun terminate-when-unreachable (object &optional (function 'terminate)) + "The termination mechanism is a way to have the garbage collector run a +function right before an object is about to become garbage. It is very +similar to the finalization mechanism which Java has. It is not standard +Common Lisp, although other Lisp implementations have similar features. +It is useful when there is some sort of special cleanup, deallocation, +or releasing of resources which needs to happen when a certain object is +no longer being used." + (let ((new-cell (cons object function)) + (population *termination-population*)) + (without-interrupts + (with-lock-grabbed (*termination-population-lock*) + (atomic-push-uvector-cell population population.data new-cell))) + function)) + +(defmethod terminate ((object t)) + nil) + +(defun drain-termination-queue () + (with-lock-grabbed (*termination-population-lock*) + (let* ((population *termination-population*)) + (loop + (multiple-value-bind (cell existed) + (atomic-pop-uvector-cell population population.termination-list) + (if (not existed) + (return) + (funcall (cdr cell) (car cell)))))))) + +(defun cancel-terminate-when-unreachable (object &optional (function nil function-p)) + (let* ((found nil)) + (with-lock-grabbed (*termination-population-lock*) + ;; We don't really need to be very paranoid here. Nothing can + ;; be added to the termination queue while we hold the lock, + ;; and the GC can't splice anything out of the list while + ;; we hold a strong reference to that list. + (let* ((population *termination-population*) + (queue (population.data population))) + (do* ((prev nil spine) + (spine queue (cdr spine))) + ((null spine)) + (let* ((entry (car spine))) + (destructuring-bind (o . f) entry + (when (and (eq o object) + (or (null function-p) + (eq function f))) + (if prev + (setf (cdr prev) (cdr spine)) + (setf (population.data population) (cdr spine))) + (setq found t) + (return))))) + found)))) + + +(defun termination-function (object) + (without-interrupts + (with-lock-grabbed (*termination-population-lock*) + (cdr (assq object (population-data *termination-population*)))))) + +(defun do-automatic-termination () + (when *enable-automatic-termination* + (drain-termination-queue))) + +(queue-fixup + (add-gc-hook 'do-automatic-termination :post-gc)) + +;;; A callback to handle foreign thread preparation, initialization, +;;; and termination. +;;; "preparation" involves telling the kernel to reserve space for +;;; some initial thread-specific special bindings. The kernel +;;; needs to reserve this space on the foreign thread's vstack; +;;; it needs us to tell it how much space to reserve (enough +;;; for bindings of *current-thread*, *current-process*, and +;;; the default initial bindings of *PACKAGE*, etc.) +;;; +;;; "initialization" involves making those special bindings in +;;; the vstack space reserved by the kernel, and setting the +;;; values of *current-thread* and *current-process* to newly +;;; created values. +;;; +;;; "termination" involves removing the current thread and +;;; current process from the global thread/process lists. +;;; "preparation" and "initialization" happen when the foreign +;;; thread first tries to call lisp code. "termination" happens +;;; via the pthread thread-local-storage cleanup mechanism. +(defcallback %foreign-thread-control (:without-interrupts t :int param :int) + (declare (fixnum param)) + (cond ((< param 0) (%foreign-thread-prepare)) + ((= param 0) (%foreign-thread-initialize) 0) + (t (%foreign-thread-terminate) 0))) + + + +(defun %foreign-thread-prepare () + (let* ((initial-bindings (standard-initial-bindings))) + (%save-standard-binding-list initial-bindings) + (* 3 (+ 2 (length initial-bindings))))) + + +(defun %foreign-thread-initialize () + ;; Recover the initial-bindings alist. + (let* ((bsp (%saved-bindings-address)) + (initial-bindings (%fixnum-ref bsp ))) + (declare (fixnum bsp)) + ;; Um, this is a little more complicated now that we use + ;; thread-local shallow binding + (flet ((save-binding (new-value sym prev) + (let* ((idx (symbol-binding-index sym)) + (byte-idx (ash idx target::fixnum-shift)) + (binding-vector (%fixnum-ref (%current-tcr) target::tcr.tlb-pointer)) + (old-value (%fixnum-ref binding-vector byte-idx))) + (setf (%fixnum-ref binding-vector byte-idx) new-value + (%fixnum-ref bsp (ash -1 target::word-shift)) old-value + (%fixnum-ref bsp (ash -2 target::word-shift)) idx + (%fixnum-ref bsp (ash -3 target::word-shift)) prev + bsp (- bsp 3))))) + (save-binding nil '*current-lisp-thread* 0) + (save-binding nil '*current-process* bsp) + (dolist (pair initial-bindings) + (save-binding (funcall (cdr pair)) (car pair) bsp)) + ;; These may (or may not) be the most recent special bindings. + ;; If they are, just set the current tcr's db-link to point + ;; to BSP; if not, "append" them to the end of the current + ;; linked list. + (let* ((current-db-link (%fixnum-ref (%current-tcr) target::tcr.db-link))) + (declare (fixnum current-db-link)) + (if (zerop current-db-link) + (setf (%fixnum-ref (%current-tcr) target::tcr.db-link) bsp) + (do* ((binding current-db-link) + (next (%fixnum-ref binding 0) + (%fixnum-ref binding 0))) + () + (if (zerop next) + (return (setf (%fixnum-ref binding 0) bsp)) + (setq binding next))))) + ;; Ensure that pending unwind-protects (for WITHOUT-INTERRUPTS + ;; on the callback) don't try to unwind the binding stack beyond + ;; where it was just set. + (do* ((catch (%fixnum-ref (%current-tcr) target::tcr.catch-top) + (%fixnum-ref catch target::catch-frame.link))) + ((zerop catch)) + (declare (fixnum catch)) + (when (eql 0 (%fixnum-ref catch target::catch-frame.db-link)) + (setf (%fixnum-ref catch target::catch-frame.db-link) bsp))))) + (let* ((thread (new-lisp-thread-from-tcr (%current-tcr) "foreign"))) + (setq *current-lisp-thread* thread + *current-process* + (make-process "foreign" :thread thread) + *whostate* "Foreign thread callback"))) + +;;; Remove the foreign thread's lisp-thread and lisp process from +;;; the global lists. +(defun %foreign-thread-terminate () + (let* ((proc *current-process*)) + (when proc + (remove-from-all-processes proc) + (let* ((ts (process-termination-semaphore proc))) + (when ts (signal-semaphore ts)))))) + Index: /branches/qres/ccl/level-1/l1-numbers.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-numbers.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-numbers.lisp (revision 13564) @@ -0,0 +1,964 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") +) + +(defun %parse-number-token (string &optional start end radix) + (if end (require-type end 'fixnum)(setq end (length string))) + (if start (require-type start 'fixnum)(setq start 0)) + (multiple-value-bind (string offset)(array-data-and-offset string) + (new-numtoken string (+ start offset)(- end start) (%validate-radix (or radix 10))))) + +(defun new-numtoken (string start len radix &optional no-rat no-sign) + (declare (fixnum start len radix)) + (if (eq 0 len) + nil + (let ((c (%scharcode string start)) + (nstart start) + (end (+ start len)) + (hic (if (<= radix 10) + (+ (char-code #\0) (1- radix)) + (+ (char-code #\A) (- radix 11)))) + dot dec dgt) + (declare (fixnum nstart end hic)) + (when (or (eq c (char-code #\+))(eq c (char-code #\-))) + (if no-sign + (return-from new-numtoken nil) + (setq nstart (1+ nstart)))) + (when (eq nstart end)(return-from new-numtoken nil)) ; just a sign + (do ((i nstart (1+ i))) + ((eq i end)) + (let () + (setq c (%scharcode string i)) + (cond + ((eq c (char-code #\.)) + (when dot (return-from new-numtoken nil)) + (setq dot t) + (when dec (return-from new-numtoken nil)) + (setq hic (char-code #\9))) + ((< c (char-code #\0)) + (when (and (eq c (char-code #\/))(not dot)(not no-rat)) + (let ((top (new-numtoken string start (- i start) radix))) + (when top + (let ((bottom (new-numtoken string (+ start i 1) (- len i 1) radix t t))) + (when bottom + (return-from new-numtoken (/ top bottom))))))) + (return-from new-numtoken nil)) + ((<= c (char-code #\9)) + (when (> c hic) + ; seen a decimal digit above base. + (setq dgt t))) + (t (when (>= c (char-code #\a))(setq c (- c 32))) + ;; don't care about *read-base* if float + (cond ((or (< c (char-code #\A))(> c hic)) + (when (and (neq i nstart) ; need some digits first + (memq c '#.(list (char-code #\E)(char-code #\F) + (char-code #\D)(char-code #\L) + (char-code #\S)))) + (return-from new-numtoken (parse-float string len start))) + (return-from new-numtoken nil)) + (t ; seen a "digit" in base that ain't decimal + (setq dec t))))))) + (when (and dot (or (and (neq nstart start)(eq len 2)) + (eq len 1))) ;. +. or -. + (return-from new-numtoken nil)) + (when dot + (if (eq c (char-code #\.)) + (progn (setq len (1- len) end (1- end)) + (when dec (return-from new-numtoken nil)) + ; make #o9. work (should it) + (setq radix 10 dgt nil)) + (return-from new-numtoken (parse-float string len start)))) + (when dgt (return-from new-numtoken nil)) ; so why didnt we quit at first sight of it? + ; and we ought to accumulate as we go until she gets too big - maybe + (cond (nil ;(or (and (eq radix 10)(< (- end nstart) 9))(and (eq radix 8)(< (- end nstart) 10))) + (let ((num 0)) + (declare (fixnum num)) + (do ((i nstart (1+ i))) + ((eq i end)) + (setq num (%i+ (%i* num radix)(%i- (%scharcode string i) (char-code #\0))))) + (if (eq (%scharcode string start) (char-code #\-)) (setq num (- num))) + num)) + (t (token2int string start len radix)))))) + + +;; Will Clingers number 1.448997445238699 +;; Doug Curries numbers 214748.3646, 1073741823/5000 +;; My number: 12. +;; Your number: + + + + + +(defun logand (&lexpr numbers) + "Return the bit-wise and of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + -1 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logand (%lexpr-ref numbers count i) n0)))))))) + + +(defun logior (&lexpr numbers) + "Return the bit-wise or of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logior (%lexpr-ref numbers count i) n0)))))))) + +(defun logxor (&lexpr numbers) + "Return the bit-wise exclusive or of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logxor (%lexpr-ref numbers count i) n0)))))))) + +(defun logeqv (&lexpr numbers) + "Return the bit-wise equivalence of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers)) + (result (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logxor (%lexpr-ref numbers count i) n0)))))))) + (declare (fixnum count)) + (if (evenp count) + (lognot result) + result))) + + + + +(defun = (num &lexpr more) + "Return T if all of its arguments are numerically equal, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'number) + t) + (dotimes (i count t) + (unless (=-2 (%lexpr-ref more count i) num) (return)))))) + +(defun /= (num &lexpr more) + "Return T if no two of its arguments are numerically equal, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'number) + t) + (dotimes (i count t) + (declare (fixnum i)) + (do ((j i (1+ j))) + ((= j count)) + (declare (fixnum j)) + (when (=-2 num (%lexpr-ref more count j)) + (return-from /= nil))) + (setq num (%lexpr-ref more count i)))))) + +(defun - (num &lexpr more) + "Subtract the second and all subsequent arguments from the first; + or with one argument, negate the first argument." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (- num) + (dotimes (i count num) + (setq num (--2 num (%lexpr-ref more count i))))))) + +(defun / (num &lexpr more) + "Divide the first argument by each of the following arguments, in turn. + With one argument, return reciprocal." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (%quo-1 num) + (dotimes (i count num) + (setq num (/-2 num (%lexpr-ref more count i))))))) + +(defun + (&lexpr numbers) + "Return the sum of its arguments. With no args, returns 0." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'number) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (setq n0 (+-2 (%lexpr-ref numbers count i) n0)))))))) + + + +(defun * (&lexpr numbers) + "Return the product of its arguments. With no args, returns 1." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 1 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'number) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (*-2 (%lexpr-ref numbers count i) n0)))))))) + + +(defun < (num &lexpr more) + "Return T if its arguments are in strictly increasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (< num (setq num (%lexpr-ref more count i))) + (return)))))) + +(defun <= (num &lexpr more) + "Return T if arguments are in strictly non-decreasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (<= num (setq num (%lexpr-ref more count i))) + (return)))))) + + +(defun > (num &lexpr more) + "Return T if its arguments are in strictly decreasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (> num (setq num (%lexpr-ref more count i))) + (return)))))) + +(defun >= (num &lexpr more) + "Return T if arguments are in strictly non-increasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (>= num (setq num (%lexpr-ref more count i))) + (return)))))) + +(defun max-2 (n0 n1) + (if (> n0 n1) n0 n1)) + +(defun max (num &lexpr more) + "Return the greatest of its arguments; among EQUALP greatest, return + the first." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (require-type num 'real) + (dotimes (i count num) + (declare (optimize (speed 3) (safety 0))) + (setq num (max-2 (%lexpr-ref more count i) num)))))) + +(defun min-2 (n0 n1) + (if (< n0 n1) n0 n1)) + +(defun min (num &lexpr more) + "Return the least of its arguments; among EQUALP least, return + the first." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (require-type num 'real) + (dotimes (i count num) + (declare (optimize (speed 3) (safety 0))) + (setq num (min-2 (%lexpr-ref more count i) num)))))) + + + +;Not CL. Used by transforms. +(defun deposit-byte (value size position integer) + (let ((mask (byte-mask size))) + (logior (ash (logand value mask) position) + (logandc1 (ash mask position) integer)))) + +(defun deposit-field (value bytespec integer) + "Return new integer with newbyte in specified position, newbyte is not right justified." + (if (> bytespec 0) + (logior (logandc1 bytespec integer) (logand bytespec value)) + (progn + (require-type value 'integer) + (require-type integer 'integer)))) + +;;;;;;;;;; Byte field functions ;;;;;;;;;;;;;;;; + +;;; Size = 0, position = 0 -> 0 +;;; size = 0, position > 0 -> -position +;;; else -> (ash (byte-mask size) position) +(defun byte (size position) + "Return a byte specifier which may be used by other byte functions + (e.g. LDB)." + (unless (and (typep size 'integer) + (>= size 0)) + (report-bad-arg size 'unsigned-byte)) + (unless (and (typep position 'integer) + (>= position 0)) + (report-bad-arg position 'unsigned-byte)) + (if (eql 0 size) + (if (eql 0 position) + 0 + (- position)) + (ash (byte-mask size) position))) + + + +(defun byte-size (bytespec) + "Return the size part of the byte specifier bytespec." + (if (> bytespec 0) + (logcount bytespec) + 0)) + +(defun ldb (bytespec integer) + "Extract the specified byte from integer, and right justify result." + (if (and (fixnump bytespec) (> (the fixnum bytespec) 0) (fixnump integer)) + (%ilsr (byte-position bytespec) (%ilogand bytespec integer)) + (let ((size (byte-size bytespec)) + (position (byte-position bytespec))) + (if (eql size 0) + (progn + (require-type integer 'integer) + 0) + (if (and (bignump integer) + (<= size (- (1- target::nbits-in-word) target::fixnumshift)) + (fixnump position)) + (%ldb-fixnum-from-bignum integer size position) + (ash (logand bytespec integer) (- position))))))) + +(defun mask-field (bytespec integer) + "Extract the specified byte from integer, but do not right justify result." + (if (>= bytespec 0) + (logand bytespec integer) + (logand integer 0))) + +(defun dpb (value bytespec integer) + "Return new integer with newbyte in specified position, newbyte is right justified." + (if (and (fixnump value) + (fixnump bytespec) + (> (the fixnum bytespec) 0) + (fixnump integer)) + (%ilogior (%ilogand bytespec (%ilsl (byte-position bytespec) value)) + (%ilogand (%ilognot bytespec) integer)) + (deposit-field (ash value (byte-position bytespec)) bytespec integer))) + +(defun ldb-test (bytespec integer) + "Return T if any of the specified bits in integer are 1's." + (if (> bytespec 0) + (logtest bytespec integer) + (progn + (require-type integer 'integer) + nil))) + +;;; random associated stuff except for the print-object method which +;;; is still in "lib;numbers.lisp" + +(defun init-random-state-seeds () + (let* ((ticks (ldb (byte 32 0) + (+ (mixup-hash-code (%current-tcr)) + (let* ((iface (primary-ip-interface))) + (or (and iface (ip-interface-addr iface)) + 0)) + (mixup-hash-code + (logand (get-internal-real-time) + (1- target::target-most-positive-fixnum)))))) + (high (ldb (byte 16 16) (if (zerop ticks) #x10000 ticks))) + (low (ldb (byte 16 0) ticks))) + (declare (fixnum high low)) + (values high low))) + +(defun %cons-mrg31k3p-state (x0 x1 x2 x3 x4 x5) + (let ((array (make-array 6 :element-type '(unsigned-byte 32) + :initial-contents (list x0 x1 x2 x3 x4 x5)))) + (%istruct 'random-state array))) + +(defun initialize-mrg31k3p-state (x0 x1 x2 x3 x4 x5) + (let ((args (list x0 x1 x2 x3 x4 x5))) + (declare (dynamic-extent args)) + (dolist (a args) + (unless (and (integerp a) (<= 0 a) (< a mrg31k3p-limit)) + (report-bad-arg a `(integer 0 (,mrg31k3p-limit))))) + (when (and (zerop x0) (zerop x1) (zerop x2)) + (error "The first three arguments must not all be zero.")) + (when (and (zerop x3) (zerop x4) (zerop x5)) + (error "The second three arguments must not all be zero.")) + (%cons-mrg31k3p-state x0 x1 x2 x3 x4 x5))) + +#+windows-target +(defun random-mrg31k3p-state () + (flet ((random-u32 () + (%stack-block ((buf 4)) + ;; BOOLEAN RtlGenRandom(PVOID buf, ULONG len) + (let ((r (external-call "SystemFunction036" :address buf + :unsigned 4 :byte))) + (if (plusp r) + (%get-unsigned-long buf) + (init-random-state-seeds)))))) + (loop repeat 6 + for n = (random-u32) + ;; The first three seed elements must not be all zero, and + ;; likewise for the second three. Avoid the issue by + ;; excluding zero values. + collect (1+ (mod n (1- mrg31k3p-limit))) into seed + finally (return (apply #'%cons-mrg31k3p-state seed))))) + +#-windows-target +(defun random-mrg31k3p-state () + (with-open-file (stream "/dev/urandom" :element-type '(unsigned-byte 32) + :if-does-not-exist nil) + (loop repeat 6 + for n = (if stream (read-byte stream) (init-random-state-seeds)) + ;; The first three seed elements must not be all zero, and + ;; likewise for the second three. Avoid the issue by + ;; excluding zero values. + collect (1+ (mod n (1- mrg31k3p-limit))) into seed + finally (return (apply #'%cons-mrg31k3p-state seed))))) + +(defun initial-random-state () + (initialize-mrg31k3p-state 314159 42 1776 271828 6021023 1066)) + +(defun make-random-state (&optional state) + "Make a new random state object. If STATE is not supplied, return a + copy of the current random state. If STATE is a random state, then + return a copy of it. If STATE is T then return a randomly + initialized random state." + (if (eq state t) + (random-mrg31k3p-state) + (progn + (setq state (require-type (or state *random-state*) 'random-state)) + (let ((seed (coerce (random.mrg31k3p-state state) 'list))) + (apply #'%cons-mrg31k3p-state seed))))) + +(defun random-state-p (thing) (istruct-typep thing 'random-state)) + +(defun %random-state-equalp (x y) + ;; x and y are both random-state objects + (equalp (random.mrg31k3p-state x) (random.mrg31k3p-state y))) + +;;; transcendental stuff. Should go in level-0;l0-float +;;; but shleps don't work in level-0. Or do they ? +; Destructively set z to x^y and return z. +(defun %double-float-expt! (b e result) + (declare (double-float b e result)) + (with-stack-double-floats ((temp)) + (%setf-double-float temp (#_pow b e)) + (%df-check-exception-2 'expt b e (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+(and 32-bit-target (not win32-target)) +(defun %single-float-expt! (b e result) + (declare (single-float b e result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float temp (#_powf b e)) + (%sf-check-exception-2 'expt b e (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+win32-target +(defun %single-float-expt! (b e result) + (declare (single-float b e result)) + (with-stack-double-floats ((temp) (db b) (de e)) + (%setf-double-float temp (#_pow db de)) + (%df-check-exception-2 'expt b e (%ffi-exception-status)) + (%double-float->short-float temp result))) + +#+64-bit-target +(defun %single-float-expt (b e) + (declare (single-float b e)) + (let* ((result (#_powf b e))) + (%sf-check-exception-2 'expt b e (%ffi-exception-status)) + result)) + +(defun %double-float-sin! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_sin n)) + (%df-check-exception-1 'sin n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-sin! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_sinf n)) + (%sf-check-exception-1 'sin n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-sin (n) + (declare (single-float n)) + (let* ((result (#_sinf n))) + (%sf-check-exception-1 'sin n (%ffi-exception-status)) + result)) + +(defun %double-float-cos! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_cos n)) + (%df-check-exception-1 'cos n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-cos! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_cosf n)) + (%sf-check-exception-1 'cos n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-cos (n) + (declare (single-float n)) + (let* ((result (#_cosf n))) + (%sf-check-exception-1 'cos n (%ffi-exception-status)) + result)) + +(defun %double-float-acos! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_acos n)) + (%df-check-exception-1 'acos n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-acos! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_acosf n)) + (%sf-check-exception-1 'acos n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-acos (n) + (declare (single-float n)) + (let* ((result (#_acosf n))) + (%sf-check-exception-1 'acos n (%ffi-exception-status)) + result)) + +(defun %double-float-asin! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_asin n)) + (%df-check-exception-1 'asin n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-asin! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_asinf n)) + (%sf-check-exception-1 'asin n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-asin (n) + (declare (single-float n)) + (let* ((result (#_asinf n))) + (%sf-check-exception-1 'asin n (%ffi-exception-status)) + result)) + +(defun %double-float-cosh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_cosh n)) + (%df-check-exception-1 'cosh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-cosh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "coshf" :single-float n :single-float)) + (%sf-check-exception-1 'cosh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-cosh (n) + (declare (single-float n)) + (let* ((result (#_coshf n))) + (%sf-check-exception-1 'cosh n (%ffi-exception-status)) + result)) + +(defun %double-float-log! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_log n)) + (%df-check-exception-1 'log n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-log! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_logf n)) + (%sf-check-exception-1 'log n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-log (n) + (let* ((result (#_logf n))) + (%sf-check-exception-1 'log n (%ffi-exception-status)) + result)) + +(defun %double-float-tan! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_tan n)) + (%df-check-exception-1 'tan n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-tan! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_tanf n)) + (%sf-check-exception-1 'tan n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-tan (n) + (declare (single-float n)) + (let* ((result (#_tanf n))) + (%sf-check-exception-1 'tan n (%ffi-exception-status)) + result)) + +(defun %double-float-atan! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_atan n)) + (%df-check-exception-1 'atan n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + + +#+32-bit-target +(defun %single-float-atan! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_atanf n)) + (%sf-check-exception-1 'atan n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atan (n) + (declare (single-float n)) + (let* ((temp (#_atanf n))) + (%sf-check-exception-1 'atan n (%ffi-exception-status)) + temp)) + +(defun %double-float-atan2! (x y result) + (declare (double-float x y result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_atan2 x y)) + (%df-check-exception-2 'atan2 x y (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-atan2! (x y result) + (declare (single-float x y result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_atan2f x y)) + (%sf-check-exception-2 'atan2 x y (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atan2 (x y) + (declare (single-float x y)) + (let* ((result (#_atan2f x y))) + (%sf-check-exception-2 'atan2 x y (%ffi-exception-status)) + result)) + +(defun %double-float-exp! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_exp n)) + (%df-check-exception-1 'exp n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+(and 32-bit-target (not windows target)) +(defun %single-float-exp! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_expf n)) + (%sf-check-exception-1 'exp n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+(and 32-bit-target windows-target) +(defun %single-float-exp! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "expf" :single-float n :single-float)) + (%sf-check-exception-1 'exp n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-exp (n) + (declare (single-float n)) + (let* ((result (#_expf n))) + (%sf-check-exception-1 'exp n (%ffi-exception-status)) + result)) + +(defun %double-float-sinh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_sinh n)) + (%df-check-exception-1 'sinh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-sinh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "sinhf" :single-float n :single-float)) + (%sf-check-exception-1 'sinh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-sinh (n) + (declare (single-float n)) + (let* ((result (#_sinhf n))) + (%sf-check-exception-1 'sinh n (%ffi-exception-status)) + result)) + +(defun %double-float-tanh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_tanh n)) + (%df-check-exception-1 'tanh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-tanh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "tanhf" :single-float n :single-float)) + (%sf-check-exception-1 'tanh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-tanh (n) + (declare (single-float n)) + (let* ((result (#_tanhf n))) + (%sf-check-exception-1 'tanh n (%ffi-exception-status)) + result)) + +#+windows-target +(progn +(defun %double-float-asinh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (external-call "asinh" :double-float n :double-float)) + (%df-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-asinh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "asinhf" :float n :float)) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-asinh (n) + (declare (single-float n)) + (let* ((result (external-call "asinhf" :float n :float))) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + result))) + +#-windows-target +(progn +(defun %double-float-asinh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_asinh n)) + (%df-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + + +#+32-bit-target +(defun %single-float-asinh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_asinhf n)) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-asinh (n) + (declare (single-float n)) + (let* ((result (#_asinhf n))) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + result)) +) + +#+windows-target +(progn +(defun %double-float-acosh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (external-call "acosh" :double n :double)) + (%df-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-acosh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "acoshf" :float n :float)) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-acosh (n) + (declare (single-float n)) + (let* ((result (external-call "acoshf" :float n :float))) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + result)) + +) + +#-windows-target +(progn +(defun %double-float-acosh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_acosh n)) + (%df-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-acosh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_acoshf n)) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-acosh (n) + (declare (single-float n)) + (let* ((result (#_acoshf n))) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + result)) +) + +#+windows-target +(progn +(defun %double-float-atanh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (external-call "atanh" :double n :double)) + (%df-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-atanh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "atanhf" :float n :float)) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atanh (n) + (declare (single-float n)) + (let* ((result (external-call "atanhf" :float n :float))) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + result)) + +) + +#-windows-target +(progn +(defun %double-float-atanh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_atanh n)) + (%df-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-atanh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_atanhf n)) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atanh (n) + (declare (single-float n)) + (let* ((result (#_atanhf n))) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + result)) +) Index: /branches/qres/ccl/level-1/l1-pathnames.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-pathnames.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-pathnames.lisp (revision 13564) @@ -0,0 +1,708 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (c) 2001-2009 Clozure Associates. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +;; L1-pathnames.lisp +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;ANSI CL logical pathnames + +(in-package "CCL") + +(defun heap-image-name () + (let* ((p (%null-ptr)) + (string (%get-utf-8-cstring (%get-kernel-global-ptr 'image-name p)))) + (declare (dynamic-extent p)) + #+windows-target (nbackslash-to-forward-slash string) + #+darwin-target (precompose-simple-string string) + #-(or windows-target darwin-target) string)) + +(defloadvar *heap-image-name* (heap-image-name)) + +(defloadvar *command-line-argument-list* + (let* ((argv (%null-ptr)) + (res ())) + (declare (dynamic-extent argv)) + (%get-kernel-global-ptr 'argv argv) + (do* ((i 0 (+ i target::node-size)) + (arg (%get-ptr argv i) (%get-ptr argv i))) + ((%null-ptr-p arg) (nreverse res)) + (declare (fixnum i)) + (push (%get-utf-8-cstring arg) res)))) + +;These are used by make-pathname +(defun %verify-logical-component (name type) + (when (and name (neq name :unspecific)) + (setq name (ensure-simple-string name)) + (when (or (eql 0 (length name)) + (%str-member *pathname-escape-character* name) ;; Hmm, why? + (%path-mem "/;" name)) + (error "Illegal logical pathname ~A component ~S" type name))) + name) + + +(defun verify-logical-host-name (host) + (or (and host + (%verify-logical-component host "host") + (%str-assoc host %logical-host-translations%) + host) + (host-error host))) + +(defun %logical-version-component (version) + (if (or (fixnump version) + (stringp version) + (memq version '(nil :wild :newest :unspecific))) + version + (require-type version '(or fixnum string (member nil :wild :newest :unspecific))))) + +(defun logical-pathname-translations (host) + "Return the (logical) host object argument's list of translations." + (setq host (verify-logical-host-name host)) + (let ((translations (%str-assoc host %logical-host-translations%))) + (unless translations (host-error host)) + (%cdr translations))) + +(defun logical-host-p (host) + (%str-assoc host %logical-host-translations%)) + +(defun host-error (host) ; supposed to be a type-error + (signal-type-error host '(satisfies logical-host-p) "~S is not a defined logical host")) + +(defun set-logical-pathname-translations (host list) + (setq host (%verify-logical-component host "host")) + (let ((old (%str-assoc host %logical-host-translations%)) + (new (let ((%logical-host-translations% (cons (list host) %logical-host-translations%))) + ;; Do this in the context when host is defined, so no errors. + (mapcar #'(lambda (trans) + (destructuring-bind (from to &rest ignored) trans + (declare (ignore ignored)) + (let ((from-path (parse-namestring from host)) + (to-path (pathname to))) + (list (require-type from-path 'logical-pathname) to-path)))) + list)))) + (if old + (progn (%rplaca old host) (%rplacd old new)) + (push (cons host new) %logical-host-translations%))) + list) + +(defsetf logical-pathname-translations set-logical-pathname-translations) + +;;; doesnt check if already there - adds at front +(defun add-logical-pathname-translation (host translation) + (let ((trans (%str-assoc host %logical-host-translations%))) + (if (not trans) + (set-logical-pathname-translations host (list translation)) + (let ((new (destructuring-bind (from to &rest ignored) translation + (declare (ignore ignored)) + (list (parse-namestring from host) (pathname to))))) + (rplacd trans (cons new (cdr trans))) + (cdr trans))))) + +(defun %component-match-p (name wild) + (if (or (eq name :unspecific)(eq name :wild)(eq name :wild-inferiors)(and (stringp name) (or (string= name "*")(string= name "**")))) + (setq name nil)) + (if (or (eq wild :unspecific)(eq wild :wild)(eq wild :wild-inferiors)(eq wild :newest)(and (stringp wild) (or (string= wild "*")(string= wild "**")))) + (setq wild nil)) + (cond ((null name) + (null wild)) + ((null wild) + t) + ((not (and (stringp name) (stringp wild))) + (eq name wild)) + (t (%path-str*= name wild)))) + +(defun translate-directory (source from to reversible &optional thost) + (declare (ignore thost)) ;; leftover from a mac kludge. + (let* ((result (translate-directory2 (cdr source)(cdr from)(cdr to) reversible)) + (relative-p (eq (car source) :relative))) + (cond ((and (not relative-p)(eq result (cdr source))) (or source (list :absolute))) + ((and (not relative-p)(eq result (cdr to))) to) + (t (cons (car (or to source from)) result))))) + + + +(defun translate-directory2 (source from to reversible) + ; we already know it matches + (let (result srest match tfirst trest twild) + (multiple-value-setq (tfirst trest twild) + (%split-ccdirectory to)) + (when (and to (not twild)) + (return-from translate-directory2 to)) + (multiple-value-bind (ffirst frest fwild) + (%split-ccdirectory from) + (setq srest (nthcdr (length ffirst) source)) + (cond ((eq fwild '**) + (setq match (nth-value 1 (%pathname-match-dir1 srest frest t))) + (cond ((eq twild '**) + (setq result (nconc tfirst match)) + (setq srest (nthcdr (length match) srest))) + (t (return-from translate-directory2 + (translate-directory2 source (nconc ffirst match frest) + to reversible))))) + ((eq twild '**) + (let ((length (length tfirst))) + (setq srest (nthcdr length source)) + (setq frest (nthcdr length from)) + (setq match (nth-value 1 (%pathname-match-dir1 srest trest t))) + (cond ((null match) + (setq result tfirst)) + (t (setq srest (nthcdr (setq length (length match)) srest)) + (setq frest (nthcdr length frest)) + (setq result (nconc tfirst match)))))) + (t + (cond ((null fwild) + ; to has a wild component e.g. *abc, from is not wild + ; by defintion source is also not wild + ; which random source component gets plugged in here?? + (setq srest (nthcdr (length tfirst) source)) + (setq frest (nthcdr (length tfirst) source)))) + (let ((part (translate-component + (car srest) (car frest)(car trest) reversible))) + (if (null part)(setq result tfirst) + (progn + (setq part (list part)) + (setq result (nconc tfirst part))))) + (setq srest (cdr srest) frest (cdr frest) trest (cdr trest)))) + (when trest + (let ((foo (translate-directory2 srest frest trest reversible))) + (when foo (setq result (nconc result foo)))))) + result)) + +; cc stands for cdr canonical +; ("abc" "**" "def" => ("abc") ("def") +; ("abc" "*de") => ("abc") ("*de") +(defun %split-ccdirectory (dir) + (let ((pos 0) (wildp nil)(rest dir)) + (dolist (e dir) + (case e + (:wild (setq wildp '*)) + (:wild-inferiors + (setq wildp '**) + (setq rest (cdr rest))) + (:up nil) + (t + (when (%path-mem "*" e) + (cond ((string= e "**") + (setq rest (cdr rest)) + (setq wildp '**)) + ((eql 1 (length (the string e))) + (setq wildp '*)) + (t (setq wildp t)))))) + (when wildp (return)) + (setq rest (cdr rest)) + (setq pos (%i+ 1 pos))) + (cond ((not wildp) + (values dir)) + (t (let (first) + (when rest (setq rest (copy-list rest))) + (dotimes (i pos) + (declare (fixnum i)) + (push (car dir) first) + (setq dir (cdr dir))) + (values (nreverse first) rest wildp)))))) + +; could avoid calling component-match-p by checking here maybe +; if "gazonk" "gaz*" "h*" => "honk" +; then "gazonk" "gaz*" "*" => "onk" or is it "gazonk" (per pg 625) +; I believe in symbolics land "gazonk" is a regular translation +; and "onk" is a reversible translation (achieved by not doing pg 625) AHH +; similarly is "a:" "a:**:" "**" Nil or "a:" +(defun translate-component (source from to &optional reversible) + (let ((orig-to to)) + (cond + ((and (consp source)(consp from)) ; source and from both logical + (setq source (cadr source) from (cadr from))) + ((or (consp source)(consp from)) ; or neither + #-bccl (error "Something non-kosher in translate pathname") + )) + (when (memq from '(:wild :wild-inferiors)) (setq from "*")) + (when (memq source '(:wild :wild-inferiors))(setq source "*")) + (when (memq to '(:wild :wild-inferiors))(setq to "*")) + (cond ((consp to)(setq to (cadr to)))) ;?? + (cond ((and (stringp to)(not (%path-mem "*" to))) + to) + ((and (or (not reversible)(not (stringp source))) ; << + (or (null to) + (and (stringp to)(or (string= to "**")(string= to "*"))))) + source) + ((eq to :unspecific) to) ; here we interpret :unspecific to mean don't want it + ((not (stringp source)) to) + (t + (let ((slen (length source)) srest match spos result (f2 nil) snextpos) + (multiple-value-bind (tfirst trest twild) + (%split-component to) + (cond ((and to (not twild))(return-from translate-component to))) + (multiple-value-bind (ffirst frest fwild) + (%split-component from) + (cond (fwild + (setq spos (if ffirst (length ffirst) 0)) ; start of source hunk + (if frest (setq f2 (%split-component frest))) + (setq snextpos (if f2 (%path-member f2 source spos) slen)) + (setq match (%substr source spos snextpos)) + (if frest (setq srest (%substr source snextpos slen))) + (setq result (if tfirst (%str-cat tfirst match) match)) + (when frest + (let ((foo (translate-component srest frest trest reversible))) + (when foo (setq result (%str-cat result foo)))))) + (t ; to is wild, from and source are not + (setq result (if tfirst (%str-cat tfirst source) source)) + (when trest (setq result (%str-cat result trest)))))) + (if (consp orig-to)(progn (error "shouldnt")(list :logical result)) result) ; 7/96 + )))))) + + +(defun %path-member (small big &optional (start 0)) + (let* ((end (length big)) + (s-end (length small)) + (s-start 1) + (c1 (%schar small 0)) + (pstart start)) + (if (%i> s-end end)(return-from %path-member nil)) + (when (eql c1 *pathname-escape-character*) + (setq c1 (%schar small 1)) + (setq s-start 2)) + (while (and (progn (if (eql (%schar big pstart) *pathname-escape-character*) + (setq pstart (%i+ pstart 1))) + T) + (%i< pstart end) + (neq (%schar big pstart) c1)) + (setq pstart (%i+ pstart 1))) + (if (neq c1 (%schar big pstart))(return-from %path-member nil)) + (setq start (%i+ pstart 1)) + (while (and (progn (if (eql (%schar big start) *pathname-escape-character*) + (setq start (%i+ 1 start))) + (if (eql (%schar small s-start) *pathname-escape-character*) + (setq s-start (%i+ 1 s-start))) + T) + (%i< start end) + (%i< s-start s-end) + (eql (%schar big start)(%schar small s-start))) + (setq start (%i+ start 1) s-start (%i+ s-start 1))) + (cond ((= (the fixnum s-start) (the fixnum s-end)) + pstart) + ((%i< start end) + (%path-member small big (%i+ 1 pstart))) + (T nil)))) + +(defun %split-component (thing &aux pos) + ;"ab*cd*" -> "ab" "cd*" + (if (or (not (typep thing 'string))(null (setq pos (%path-mem "*" thing)))) + (values thing nil nil) + (let* ((len (length thing))) + (declare (fixnum len)) + (values (if (%izerop pos) nil (%substr thing 0 pos)) + (cond ((eql len (%i+ pos 1)) nil) + (t + (when (eq (%schar thing (+ pos 1)) #\*) + (setq pos (+ pos 1))) + (cond ((eql len (%i+ pos 1)) nil) + (t (%substr thing (%i+ pos 1) len))))) + T)))) + +(defun translate-pathname (source from-wildname to-wildname &key reversible) + "Use the source pathname to translate the from-wildname's wild and + unspecified elements into a completed to-pathname based on the to-wildname." + (when (not (pathnamep source)) (setq source (pathname source))) + (flet ((translate-pathname-component-mismatch (component-name source from) + (error "~S components of source ~S and from-wildname ~S do not match" component-name source from))) + (let (r-host r-directory r-name r-type r-version s-host f-host t-host t-device) + (setq s-host (pathname-host source)) + (setq f-host (pathname-host from-wildname)) + (setq t-host (pathname-host to-wildname)) + (setq t-device (pathname-device to-wildname)) + (if (not (%host-component-match-p s-host f-host)) (translate-pathname-component-mismatch 'pathname-host source from-wildname)) + (setq r-host (translate-component s-host f-host t-host reversible)) + (let ((s-dir (%std-directory-component (pathname-directory source) s-host)) + (f-dir (%std-directory-component (pathname-directory from-wildname) f-host)) + (t-dir (%std-directory-component (pathname-directory to-wildname) t-host))) + (let ((match (%pathname-match-directory s-dir f-dir))) + (if (not match)(translate-pathname-component-mismatch 'pathname-directory source from-wildname)) + (setq r-directory (translate-directory s-dir f-dir t-dir reversible t-host)))) + (let ((s-name (pathname-name source)) + (f-name (pathname-name from-wildname)) + (t-name (pathname-name to-wildname))) + (if (not (%component-match-p s-name f-name))(translate-pathname-component-mismatch 'pathname-name source from-wildname)) + (setq r-name (translate-component s-name f-name t-name reversible))) + (let ((s-type (pathname-type source)) + (f-type (pathname-type from-wildname)) + (t-type (pathname-type to-wildname))) + (if (not (%component-match-p s-type f-type))(translate-pathname-component-mismatch 'pathname-component source from-wildname)) + (setq r-type (translate-component s-type f-type t-type reversible))) + (let ((s-version (pathname-version source)) + (f-version (pathname-version from-wildname)) + (t-version (pathname-version to-wildname))) + (if (not (%component-match-p s-version f-version)) (translate-pathname-component-mismatch 'pathname-version source from-wildname)) + (setq r-version (translate-component s-version f-version t-version reversible)) + ;(if (eq r-version :unspecific)(setq r-version nil)) + ) + (make-pathname :device t-device :host r-host :directory r-directory + :name r-name :type r-type :version r-version :defaults nil) + ))) + + + + +(defvar %empty-logical-pathname% (%cons-logical-pathname nil nil nil nil nil)) + +(defun logical-pathname-namestring-p (string) + (multiple-value-bind (sstr start end) (get-pathname-sstring string) + (let ((host (pathname-host-sstr sstr start end t))) + (and host (not (eq host :unspecific)))))) + + +;; This extends CL in that it allows a host-less pathname, like "foo;bar;baz". +(defun logical-pathname (thing &aux (path thing)) + "Converts the pathspec argument to a logical-pathname and returns it." + (when (typep path 'stream) (setq path (%path-from-stream path))) + (etypecase path + (logical-pathname path) + (pathname (report-bad-arg thing 'logical-pathname)) + (string + (multiple-value-bind (sstr start end) (get-sstring path) + ;; Prescan the host, to avoid unknown host errors. + (let ((host (pathname-host-sstr sstr start end t))) + (when (or (null host) (eq host :unspecific)) + (report-bad-arg path '(satisfies logical-pathname-namestring-p))) + (let ((%logical-host-translations% (cons (list host) %logical-host-translations%))) + (declare (special %logical-host-translations%)) + ;; By calling string-to-pathname with a logical pathname as default, we force + ;; parsing as a logical pathname. + (string-to-pathname sstr start end nil %empty-logical-pathname%))))))) + +(defun %host-component-match-p (path-host wild-host) + ;; Note that %component-match-p is case sensitive. Need a + ;; case-insensitive version for hosts. + ;; In addition, host components do not support wildcards. + (or (eq path-host wild-host) + (and (stringp path-host) + (stringp wild-host) + (string-equal path-host wild-host)))) + +(defun pathname-match-p (pathname wildname) + "Pathname matches the wildname template?" + (let ((path-host (pathname-host pathname)) + (wild-host (pathname-host wildname))) + (and + (%host-component-match-p path-host wild-host) + (%component-match-p (pathname-device pathname)(pathname-device wildname)) + (%pathname-match-directory + (%std-directory-component (pathname-directory pathname) path-host) + (%std-directory-component (pathname-directory wildname) wild-host)) + (%component-match-p (pathname-name pathname)(pathname-name wildname)) + (%component-match-p (pathname-type pathname)(pathname-type wildname)) + (%component-match-p (pathname-version pathname)(pathname-version wildname))))) + + +; expects canonicalized directory - how bout absolute vs. relative? +(defun %pathname-match-directory (path wild) + (cond ((equal path wild) t) + ; Don't allow matching absolute and relative, so that can have distinct + ; absolute and wild translations in logical-pathname-translations for + ; a host, and have them match separately. + ((and (consp path)(consp wild)(neq (car path) (car wild))) + nil) ; one absolute & one relative ?? + ((or ;(and (null wild) + ; (let ((dir (cadr path))) + ; (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))) + (and (null (cddr wild)) + (let ((dir (cadr wild))) + (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))) + ((null path) + ;; Make missing dir match (:absolute) or (:relative) - is that right? + (null (cdr wild))) + ((null wild) + nil) + (t (%pathname-match-dir0 (cdr path)(cdr wild))))) + +; munch on tails path and wild +(defun %pathname-match-dir0 (path wild) + (flet ((only-wild (dir) + (when (null (cdr dir)) + (setq dir (car dir)) + (when (consp dir) (setq dir (cadr dir))) + (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors))))) + (cond ((eq path wild) t) + ((only-wild wild) + t) + (t (let ((result t)) + (block nil + (while (and path wild) + (let ((pathstr (car path)) + (wildstr (car wild))) + ; allow logical to match physical today + ; because one of these days these logical things will disappear! + (when (consp pathstr)(setq pathstr (cadr pathstr))) + (when (consp wildstr)(setq wildstr (cadr wildstr))) + (case wildstr + (:wild (setq wildstr "*")) + (:wild-inferiors (setq wildstr "**"))) + (case pathstr + (:wild (setq pathstr "*")) + (:wild-inferiors (setq pathstr "**"))) + (if (or (memq wildstr '(:up :back))(memq pathstr '(:up :back))) ;; ????? <<<< + (when (neq pathstr wildstr)(setq result nil) (return-from nil)) + (when (not + (cond ((string= wildstr "**") + (setq result (%pathname-match-dir1 path (cdr wild))) + (return-from nil)) + ((%path-str*= pathstr wildstr)))) + (setq result nil) + (return-from nil))) + (setq wild (cdr wild) path (cdr path)))) + (when (and (or path wild)(not (only-wild wild))) + (setq result nil))) + result))))) + + + +; wild is stuff after a "**" - looking for what matches the ** in (path) +(defun %pathname-match-dir1 (path wild &optional cons-result) + (let ((match nil) pathstr wildstr) + (cond ((null wild) + (values T (if cons-result (mapcar #'(lambda (e) + (if (consp e)(cadr e) e)) + path)))) + ((%pathname-match-dir0 path wild)) ; ie ** matches nothing + (t + (prog nil + AGN + (setq pathstr (car path) wildstr (car wild)) + (when (consp pathstr)(setq pathstr (cadr pathstr))) + (when (consp wildstr)(setq wildstr (cadr wildstr))) + (case wildstr + (:wild (setq wildstr "*")) + (:wild-inferiors (setq wildstr "**"))) + (case pathstr + (:wild (setq pathstr "*")) + (:wild-inferiors (setq pathstr "**"))) + (until (or (not (consp path)) + (%path-str*= pathstr wildstr)) + (when cons-result (push pathstr match)) + (setq path (cdr path)) + (setq pathstr (car path)) + (when (consp pathstr)(setq pathstr (cadr pathstr)))) + ;; either got a match - w and path both have the thing we looked for + ;; or path is empty + (when (null path)(return nil)) + (let ((path1 (cdr path))(wild (cdr wild))) + (when (and (null path1)(null wild)) + (return (values t (when match (nreverse match))))) + (cond ((%pathname-match-dir0 path1 wild) ; is the rest happy too? + (return (values t (nreverse match)))) + (t (when cons-result (push pathstr match)) ; nope, let ** eat more + (setq path (cdr path)) + (go AGN))))))))) + +; three times bigger and 3 times slower - does it matter? +(defun %path-str*= (string pattern) + (multiple-value-bind (string s-start s-end) (get-sstring string) + (multiple-value-bind (pattern p-start p-end) (get-sstring pattern) + (path-str-sub pattern string p-start s-start p-end s-end)))) + +(defun path-str-sub (pattern str p-start s-start p-end s-end) + (declare (fixnum p-start s-start p-end s-end) + (type simple-base-string pattern str)) + (declare (optimize (speed 3)(safety 0))) + (let ((p (%scharcode pattern p-start)) + (esc (char-code *pathname-escape-character*))) + (cond + ((eq p (char-code #\*)) + ; starts with a * find what we looking for unless * is last in which case done + (loop ; lots of *'s same as one + (when (eq (%i+ 1 p-start) p-end) + (return-from path-str-sub t)) + (if (eq (%schar pattern (%i+ 1 p-start)) #\*) + (setq p-start (1+ p-start)) + (return))) + (let* ((next* (%path-mem "*" pattern (%i+ 1 p-start))) + (len (- (or next* p-end) (%i+ 1 p-start)))) + (loop + (when (> (+ s-start len) s-end)(return nil)) + (let ((res (find-str-pattern pattern str (%i+ 1 p-start) s-start (or next* p-end) s-end))) + (if (null res) + (return nil) + (if (null next*) + (if (eq res s-end) + (return t)) + (return (path-str-sub pattern str next* (+ s-start len) p-end s-end))))) + (setq s-start (1+ s-start))))) + (t (when (eq p esc) + (setq p-start (1+ p-start)) + (setq p (%scharcode pattern p-start))) + (let* ((next* (%path-mem "*" pattern (if (eq p (char-code #\*))(%i+ 1 p-start) p-start))) + (this-s-end (if next* (+ s-start (- next* p-start)) s-end))) + (if (> this-s-end s-end) + nil + (if (path-str-match-p pattern str p-start s-start (or next* p-end) this-s-end) + (if (null next*) + t + (path-str-sub pattern str next* this-s-end p-end s-end))))))))) + +; find match of pattern between start and end in str +; rets one past end of pattern in str or nil +(defun find-str-pattern (pattern str p-start s-start p-end s-end) + (declare (fixnum p-start s-start p-end s-end) + (type simple-base-string pattern str)) + (declare (optimize (speed 3)(safety 0))) + (let* ((first-p (%scharcode pattern p-start)) + (esc (char-code *pathname-escape-character*))) + (when (and (eq first-p esc) (not (eq (setq p-start (1+ p-start)) p-end))) + (setq first-p (%scharcode pattern p-start))) + (do* ((i s-start (1+ i)) + (last-i (%i- s-end (%i- p-end p-start)))) + ((> i last-i) nil) + (declare (fixnum i last-i)) + (let ((s (%scharcode str i))) + (when (eq first-p s) + (do* ((j (1+ i) (1+ j)) + (k (1+ p-start)(1+ k))) + ((>= k p-end) (return-from find-str-pattern j)) + (declare (fixnum j k)) + (let* ((p (%scharcode pattern k)) + (s (%scharcode str j))) + (when (and (eq p esc) (< (setq k (1+ k)) p-end)) + (setq p (%scharcode pattern k))) + (when (not (eq p s)) + (return))))))))) + + +(defun path-str-match-p (pattern str p-start s-start p-end s-end) + (declare (fixnum p-start s-start p-end s-end) + (type simple-base-string pattern str)) + (declare (optimize (speed 3)(safety 0))) + ;; does pattern match str between p-start p-end + (let ((esc (char-code *pathname-escape-character*))) + (loop + (when (eq p-start p-end) + (return (eq s-start s-end))) + (when (eq s-start s-end) + (return nil)) + (let ((p (%scharcode pattern p-start))) + (unless *case-sensitive-filesystem* + (setq p (%char-code-upcase p))) + (when (eq p esc) + (when (eq (setq p-start (1+ p-start)) p-end) + (return nil)) + (setq p (%scharcode pattern p-start)) + (unless *case-sensitive-filesystem* + (setq p (%char-code-upcase p)))) + (let* ((q (%scharcode str s-start))) + (unless *case-sensitive-filesystem* + (setq q (%char-code-upcase q))) + (unless (eq p q) + (return nil))) + (setq p-start (1+ p-start)) + (setq s-start (1+ s-start)))))) + + + +(defun ccl-directory () + (let* ((dirpath (getenv "CCL_DEFAULT_DIRECTORY"))) + (if dirpath + (native-to-directory-pathname dirpath) + (let* ((heap-image-path (%realpath (heap-image-name)))) + (make-pathname :directory (pathname-directory heap-image-path) + :device (pathname-device heap-image-path)))))) + +(defun user-homedir-pathname (&optional host) + "Return the home directory of the user as a pathname." + (declare (ignore host)) + (let* ((native + (ignore-errors + (truename + (native-to-directory-pathname (or #+ccl-0711 (getenv "HOME") + (get-user-home-dir (getuid)))))))) + (if (and native (eq :absolute (car (pathname-directory native)))) + native + ;; Another plausible choice here is + ;; #p"/tmp/.hidden-directory-of-some-irc-bot-in-eastern-europe/" + ;; Of course, that might already be the value of $HOME. Anyway, + ;; the user's home directory just contains "config files" (like + ;; SSH keys), and spoofing it can't hurt anything. + (make-pathname :directory '(:absolute) :defaults nil)))) + + + + +(defun translate-logical-pathname (pathname &key) + "Translate PATHNAME to a physical pathname, which is returned." + (setq pathname (pathname pathname)) + (let ((host (pathname-host pathname))) + (cond ((eq host :unspecific) pathname) + ((null host) (%cons-pathname (pathname-directory pathname) + (pathname-name pathname) + (pathname-type pathname) + (pathname-version pathname) + (pathname-device pathname))) + (t + (let ((rule (assoc pathname (logical-pathname-translations host) + :test #'pathname-match-p))) ; how can they match if hosts neq?? + (if rule + (translate-logical-pathname + (translate-pathname pathname (car rule) (cadr rule))) + (signal-file-error $xnotranslation pathname))))))) + +(defloadvar *user-homedir-pathname* (user-homedir-pathname)) + + +;;; Hide this from COMPILE-FILE, for obscure cross-compilation reasons + +(defun setup-initial-translations () + (setf (logical-pathname-translations "home") + `(("**;*.*" ,(merge-pathnames "**/*.*" (user-homedir-pathname))))) + + (setf (logical-pathname-translations "ccl") + `(("l1;**;*.*" "ccl:level-1;**;*.*") + ("l1f;**;*.*" "ccl:l1-fasls;**;*.*") + ("ccl;*.*" ,(merge-pathnames "*.*" (ccl-directory))) + ("**;*.*" ,(merge-pathnames "**/*.*" (ccl-directory)))))) + +(setup-initial-translations) + + +;;; Translate the pathname; if the directory component of the result +;;; is relative, make it absolute (relative to the current directory.) +(defun full-pathname (path &key (no-error t)) + (let* ((path (handler-case (translate-logical-pathname (merge-pathnames path)) + (error (condition) (if no-error + (return-from full-pathname nil) + (error condition))))) + (dir (%pathname-directory path))) + (if (eq (car dir) :absolute) + path + (cons-pathname (absolute-directory-list dir) + (%pathname-name path) + (%pathname-type path) + (pathname-host path) + (pathname-version path))))) + + + + +(defparameter *module-search-path* (list + (cons-pathname '(:absolute "bin") nil nil "ccl") + (cons-pathname '(:absolute "openmcl" "modules") nil nil "home") + (cons-pathname '(:absolute "lib") nil nil "ccl") + (cons-pathname '(:absolute "library") nil nil "ccl") + (cons-pathname '(:absolute "examples" :wild-inferiors) nil nil "ccl") + (cons-pathname '(:absolute "contrib" :wild-inferiors) nil nil "ccl") + (cons-pathname '(:absolute "tools") nil nil "ccl") + (cons-pathname '(:absolute "objc-bridge") nil nil "ccl") + (cons-pathname '(:absolute "cocoa-ide") nil nil "ccl")) + "Holds a list of pathnames to search for the file that has same name + as a module somebody is looking for.") + Index: /branches/qres/ccl/level-1/l1-processes.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-processes.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-processes.lisp (revision 13564) @@ -0,0 +1,747 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;; L1-processes.lisp + +(cl:in-package "CCL") + + +(let* ((all-processes ()) + (shutdown-processes ()) + (all-processes-lock (make-lock))) + (defun add-to-all-processes (p) + (with-lock-grabbed (all-processes-lock) + (pushnew p all-processes :test #'eq) + p)) + (defun remove-from-all-processes (p) + (with-lock-grabbed (all-processes-lock) + (setq all-processes (delete p all-processes)) + t)) + (defun all-processes () + "Obtain a fresh list of all known Lisp threads." + (with-lock-grabbed (all-processes-lock) + (copy-list all-processes))) + (defun shutdown-processes () + (with-lock-grabbed (all-processes-lock) + (copy-list shutdown-processes))) + (defun %clear-shutdown-proceses () + (setq shutdown-processes nil)) + (defun add-to-shutdown-processes (p) + (with-lock-grabbed (all-processes-lock) + (pushnew p shutdown-processes :test #'eq)) + t) + (defun pop-shutdown-processes () + (with-lock-grabbed (all-processes-lock) + (pop shutdown-processes))) + (defun find-process (id) + (etypecase id + (process id) + (integer (with-lock-grabbed (all-processes-lock) + (find id all-processes + :key #'(lambda (p) + (process-serial-number p))))) + (string (with-lock-grabbed (all-processes-lock) + (find id all-processes + :key #'(lambda (p) + (process-name p)) + :test #'equal)))))) + + + +(defun not-in-current-process (p operation) + (if (eq p *current-process*) + (error "The current process (~s) can't perform the ~a operation on itself." + p operation))) + +(defun startup-shutdown-processes () + (let* ((p)) + (loop + (unless (setq p (pop-shutdown-processes)) (return)) + (new-tcr-for-thread (process-thread p)) + (%process-preset-internal p) + (process-enable p) + ))) + +;;; Done with a queue-fixup so that it will be the last thing +;;; that happens on startup. +(queue-fixup + (pushnew 'startup-shutdown-processes *lisp-system-pointer-functions*)) + + + + + + + +(defun wrap-initial-bindings (alist) + (mapcar #'(lambda (pair) + (destructuring-bind (symbol . valform) pair + (cons (require-type symbol 'symbol) + (cond ((symbolp valform) + (constantly (symbol-value valform))) + ((typep valform 'function) valform) + ((consp valform) + (if (eq (car valform) 'quote) + (constantly (cadr valform)) + #'(lambda () (apply (car valform) (cdr valform))))) + (t + (constantly valform)))))) + alist)) + + +(defun valid-allocation-quantum-p (x) + (and (>= x *host-page-size*) + (<= x (default-allocation-quantum)) + (= (logcount x) 1))) + + +(let* ((psn -1)) + (defun %new-psn () (incf psn))) + +(defclass process () + ((name :initform nil :initarg :name :accessor process-name) + (thread :initarg :thread :initform nil :accessor process-thread) + (initial-form :initform (cons nil nil) :reader process-initial-form) + (priority :initform 0 :initarg :priority :accessor process-priority) + (persistent :initform nil :initarg :persistent :reader process-persistent) + (splice :initform (cons nil nil) :accessor process-splice) + (initial-bindings :initform nil :initarg :initial-bindings + :accessor process-initial-bindings) + (serial-number :initform (%new-psn) :accessor process-serial-number) + (creation-time :initform (get-tick-count) :reader process-creation-time) + (total-run-time :initform nil :accessor %process-total-run-time) + (ui-object :initform (application-ui-object *application*) + :accessor process-ui-object) + (termination-semaphore :initform nil + :initarg :termination-semaphore + :accessor process-termination-semaphore + :type (or null semaphore)) + (allocation-quantum :initform (default-allocation-quantum) + :initarg :allocation-quantum + :reader process-allocation-quantum + :type (satisfies valid-allocation-quantum-p)) + (dribble-stream :initform nil) + (dribble-saved-terminal-io :initform nil) + (result :initform (cons nil nil) + :reader process-result)) + (:primary-p t)) + +(defparameter *print-process-whostate* t "make it optional") + +(defmethod print-object ((p process) s) + (print-unreadable-object (p s :type t :identity t) + (format s "~a(~d)" (process-name p) + (process-serial-number p)) + (when *print-process-whostate* + (format s " [~a]" (process-whostate p))))) + +(defvar *process-class* (find-class 'process)) + +(defun processp (p) + (memq *process-class* (class-precedence-list (class-of p)))) + +(set-type-predicate 'process 'processp) + +(defun make-process (name &key + thread + persistent + (priority 0) + (stack-size *default-control-stack-size*) + (vstack-size *default-value-stack-size*) + (tstack-size *default-temp-stack-size*) + (initial-bindings ()) + (use-standard-initial-bindings t) + (class (find-class 'process)) + (termination-semaphore ()) + (allocation-quantum (default-allocation-quantum))) + "Create and return a new process." + (let* ((p (make-instance + class + :name name + :priority priority + :persistent persistent + :initial-bindings (append (if use-standard-initial-bindings + (standard-initial-bindings)) + (wrap-initial-bindings + initial-bindings)) + :termination-semaphore (or termination-semaphore + (make-semaphore)) + :allocation-quantum allocation-quantum))) + (with-slots ((lisp-thread thread)) p + (unless lisp-thread + (setq lisp-thread + (or thread + (new-thread name stack-size vstack-size tstack-size))))) + (add-to-all-processes p) + (setf (car (process-splice p)) p) + p)) + + +(defstatic *initial-process* + (let* ((p (make-process + "Initial" + :thread *initial-lisp-thread* + :priority 0))) + p)) + + +(defvar *current-process* *initial-process* + "Bound in each process, to that process itself.") + +(defstatic *interactive-abort-process* *initial-process*) + + + + +(defun process-tcr (p) + (lisp-thread.tcr (process-thread p))) + + + +(defun process-exhausted-p (p) + (let* ((thread (process-thread p))) + (or (null thread) + (thread-exhausted-p thread)))) + +;;; This should be way more concerned about being correct and thread-safe +;;; than about being quick: it's generally only called while printing +;;; or debugging, and there are all kinds of subtle race conditions +;;; here. +(defun process-whostate (p) + "Return a string which describes the status of a specified process." + (let* ((ip *initial-process*)) + (cond ((eq p *current-process*) + (if (%tcr-binding-location (%current-tcr) '*whostate*) + *whostate* + (if (eq p ip) + "Active" + "Reset"))) + (t + (without-interrupts + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (let* ((tcr (process-tcr p))) + (if tcr + (unwind-protect + (let* ((loc nil)) + (%suspend-tcr tcr) + (setq loc (%tcr-binding-location tcr '*whostate*)) + (if loc + (%fixnum-ref loc) + (if (eq p ip) + "Active" + "Reset"))) + (%resume-tcr tcr)) + "Exhausted"))))))))) + +(defun (setf process-whostate) (new p) + (unless (process-exhausted-p p) + (setf (symbol-value-in-process '*whostate* p) new))) + + + +(defun process-total-run-time (p) + (or (%process-total-run-time p) + (thread-total-run-time (process-thread p)))) + + + + +(defun initial-bindings (alist) + (let* ((symbols ()) + (values ())) + (dolist (a alist (values (nreverse symbols) (nreverse values))) + (push (car a) symbols) + (push (funcall (cdr a)) values)))) + + + +(defun symbol-value-in-process (sym process) + (if (eq process *current-process*) + (symbol-value sym) + (let* ((val + (without-interrupts + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (let* ((tcr (process-tcr process))) + (if tcr + (symbol-value-in-tcr sym tcr) + (%sym-global-value sym)))))))) + (if (eq val (%unbound-marker)) + ;; This might want to be a CELL-ERROR. + (error "~S is unbound in ~S." sym process) + val)))) + +(defun (setf symbol-value-in-process) (value sym process) + (if (eq process *current-process*) + (setf (symbol-value sym) value) + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (let* ((tcr (process-tcr process))) + (if tcr + (setf (symbol-value-in-tcr sym tcr) value) + (%set-sym-global-value sym value))))))) + + +(defmethod process-enable ((p process) &optional (wait (* 60 60 24) wait-p)) + "Begin executing the initial function of a specified process." + (not-in-current-process p 'process-enable) + (when wait-p + (check-type wait (unsigned-byte 32))) + (unless (car (process-initial-form p)) + (error "Process ~s has not been preset. Use PROCESS-PRESET to preset the process." p)) + (let* ((thread (process-thread p))) + (do* ((total-wait wait (+ total-wait wait))) + ((thread-enable thread (process-termination-semaphore p) (1- (integer-length (process-allocation-quantum p))) wait) + (process-tcr-enable p (lisp-thread.tcr thread)) + p) + (cerror "Keep trying." + "Unable to enable process ~s; have been trying for ~s seconds." + p total-wait)))) + +(defmethod process-tcr-enable ((process process) tcr) + (when (and tcr (not (eql 0 tcr))) + (%signal-semaphore-ptr (%fixnum-ref-macptr tcr target::tcr.activate)) + )) + + + +(defun process-resume (p) + "Resume a specified process which had previously been suspended +by process-suspend." + (setq p (require-type p 'process)) + (let* ((tcr (process-tcr p))) + (and tcr (%resume-tcr tcr)))) + +(defun process-suspend (p) + "Suspend a specified process." + (setq p (require-type p 'process)) + (if (eq p *current-process*) + (error "Suspending the current process can't work. ~&(If the documentation claims otherwise, it's incorrect.)") + (let* ((tcr (process-tcr p))) + (and tcr (%suspend-tcr tcr))))) + +(defun process-suspend-count (p) + "Return the number of currently-pending suspensions applicable to +a given process." + (setq p (require-type p 'process)) + (let* ((thread (process-thread p))) + (if thread + (lisp-thread-suspend-count thread)))) + +(defun process-active-p (p) + (setq p (require-type p 'process)) + (and (eql 0 (process-suspend-count p)) + (not (process-exhausted-p p)))) + +;;; Used by process-run-function +(defmethod process-preset ((p process) function &rest args) + "Set the initial function and arguments of a specified process." + (let* ((f (require-type function 'function)) + (initial-form (process-initial-form p))) + (declare (type cons initial-form)) + (not-in-current-process p 'process-preset) + ; Not quite right ... + (rplaca initial-form f) + (rplacd initial-form args) + (%process-preset-internal p))) + +(defmethod %process-preset-internal ((process process)) + (let* ((initial-form (process-initial-form process)) + (thread (process-thread process))) + (declare (type cons initial-form)) + (thread-preset + thread + #'(lambda (process initial-form) + (let* ((*current-process* process)) + (add-to-all-processes process) + (multiple-value-bind (syms values) + (initial-bindings (process-initial-bindings process)) + (progv syms values + (setq *whostate* "Active") + (run-process-initial-form process initial-form))))) + process + initial-form) + process)) + + +(defun run-process-initial-form (process initial-form) + (let* ((exited nil) + (kill (handler-case + (restart-case + (let ((values + (multiple-value-list + (apply (car initial-form) + (cdr (the list initial-form))))) + (result (process-result process))) + (setf (cdr result) values + (car result) t) + (setq exited t) + nil) + (abort-break () :report "Reset this thread") + (abort () :report "Kill this thread" (setq exited t))) + (process-reset (condition) + (process-reset-kill condition))))) + ;; We either exited from the initial form normally, were told to + ;; exit prematurely, or are being reset and should enter the + ;; "awaiting preset" state. + (if (or kill exited) + (unless (eq kill :toplevel) + (process-initial-form-exited process (or kill t))) + (progn + (thread-change-state (process-thread process) :run :reset) + (tcr-set-preset-state (process-tcr process)))) + nil)) + +;;; Separated from run-process-initial-form just so I can change it easily. +(defun process-initial-form-exited (process kill) + (without-interrupts + (if (eq kill :shutdown) + (progn + (setq *whostate* "Shutdown") + (add-to-shutdown-processes process))) + (let* ((semaphore (process-termination-semaphore process))) + (when semaphore (signal-semaphore semaphore))) + (maybe-finish-process-kill process kill))) + +(defun maybe-finish-process-kill (process kill) + (when (and kill (neq kill :shutdown)) + (setf (process-whostate process) "Dead") + (remove-from-all-processes process) + (let ((thread (process-thread process))) + (unless (or (eq thread *current-lisp-thread*) + (thread-exhausted-p thread)) + (kill-lisp-thread thread)))) + nil) + + + + +(defun require-global-symbol (s &optional env) + (let* ((s (require-type s 'symbol)) + (bits (%symbol-bits s))) + (unless (or (logbitp $sym_vbit_global bits) + (let* ((defenv (if env (definition-environment env)))) + (if defenv + (eq :global (%cdr (assq s (defenv.specials defenv))))))) + (error "~s not defined with ~s" s 'defstatic)) + s)) + + +(defmethod print-object ((s lock) stream) + (print-unreadable-object (s stream :type t :identity t) + (let* ((val (uvref s target::lock._value-cell)) + (name (uvref s target::lock.name-cell))) + (when name + (format stream "~s " name)) + (if (typep val 'macptr) + (format stream "[ptr @ #x~x]" + (%ptr-to-int val)))))) + +(defun lockp (l) + (eq target::subtag-lock (typecode l))) + +(set-type-predicate 'lock 'lockp) + +(defun recursive-lock-p (l) + (and (eq target::subtag-lock (typecode l)) + (eq 'recursive-lock (%svref l target::lock.kind-cell)))) + +(defun read-write-lock-p (l) + (and (eq target::subtag-lock (typecode l)) + (eq 'read-write-lock (%svref l target::lock.kind-cell)))) + +(setf (type-predicate 'recursive-lock) 'recursive-lock-p + (type-predicate 'read-write-lock) 'read-write-lock-p) + + +(defun grab-lock (lock &optional flag) + "Wait until a given lock can be obtained, then obtain it." + (%lock-recursive-lock-object lock flag)) + +(defun release-lock (lock) + "Relinquish ownership of a given lock." + (%unlock-recursive-lock-object lock)) + +(defun try-lock (lock &optional flag) + "Obtain the given lock, but only if it is not necessary to wait for it." + (%try-recursive-lock-object lock flag)) + +(defun lock-acquisition-status (thing) + (if (istruct-typep thing 'lock-acquisition) + (lock-acquisition.status thing) + (report-bad-arg thing 'lock-acquisition))) + +(defun clear-lock-acquisition-status (thing) + (if (istruct-typep thing 'lock-acquisition) + (setf (lock-acquisition.status thing) nil) + (report-bad-arg thing 'lock-acquisition))) + +(defmethod print-object ((l lock-acquisition) stream) + (print-unreadable-object (l stream :type t :identity t) + (format stream "[status = ~s]" (lock-acquisition-status l)))) + +(defun semaphore-notification-status (thing) + (if (istruct-typep thing 'semaphore-notification) + (semaphore-notification.status thing) + (report-bad-arg thing 'semaphore-notification))) + +(defun clear-semaphore-notification-status (thing) + (if (istruct-typep thing 'semaphore-notification) + (setf (semaphore-notification.status thing) nil) + (report-bad-arg thing 'semaphore-notification))) + +(defmethod print-object ((l semaphore-notification) stream) + (print-unreadable-object (l stream :type t :identity t) + (format stream "[status = ~s]" (semaphore-notification-status l)))) + +(defun process-wait (whostate function &rest args) + "Causes the current lisp process (thread) to wait for a given +predicate to return true." + (declare (dynamic-extent args)) + (or (apply function args) + (with-process-whostate (whostate) + (loop + (when (apply function args) + (return)) + ;; Sleep for a tick + #-windows-target + (%nanosleep 0 *ns-per-tick*) + #+windows-target + (%windows-sleep 5))))) + + + +(defun process-wait-with-timeout (whostate time function &rest args) + "Cause the current thread to wait for a given predicate to return true, +or for a timeout to expire." + (declare (dynamic-extent args)) + (cond ((null time) (apply #'process-wait whostate function args) t) + (t (let* ((win nil) + (when (+ (get-tick-count) time)) + (f #'(lambda () (let ((val (apply function args))) + (if val + (setq win val) + (> (get-tick-count) when)))))) + (declare (dynamic-extent f)) + (process-wait whostate f) + win)))) + + +(defmethod process-interrupt ((process process) function &rest args) + "Arrange for the target process to invoke a specified function at +some point in the near future, and then return to what it was doing." + (let* ((p (require-type process 'process))) + (if (eq p *current-process*) + (progn + (apply function args) + t) + (thread-interrupt + (process-thread p) + process + #'apply + function args)))) + +(defmethod process-debug-condition ((p process) condition frame-pointer) + (declare (ignore condition frame-pointer))) + + + + +;;; This one is in the Symbolics documentation +(defun process-allow-schedule () + "Used for cooperative multitasking; probably never necessary." + (process-yield *current-process*)) + + +;;; something unique that users won't get their hands on +(defun process-reset-tag (process) + (process-splice process)) + +(defun process-run-function (name-or-keywords function &rest args) + "Create a process, preset it, and enable it." + (if (listp name-or-keywords) + (%process-run-function name-or-keywords function args) + (let ((keywords (list :name name-or-keywords))) + (declare (dynamic-extent keywords)) + (%process-run-function keywords function args)))) + +(defun %process-run-function (keywords function args) + (destructuring-bind (&key (name "Anonymous") + (priority 0) + (stack-size *default-control-stack-size*) + (vstack-size *default-value-stack-size*) + (tstack-size *default-temp-stack-size*) + (initial-bindings ()) + (persistent nil) + (use-standard-initial-bindings t) + (termination-semaphore nil) + (allocation-quantum (default-allocation-quantum))) + keywords + (setq priority (require-type priority 'fixnum)) + (let* ((process (make-process name + :priority priority + :stack-size stack-size + :vstack-size vstack-size + :tstack-size tstack-size + :persistent persistent + :use-standard-initial-bindings use-standard-initial-bindings + :initial-bindings initial-bindings + :termination-semaphore termination-semaphore + :allocation-quantum allocation-quantum))) + (process-preset process #'(lambda () (apply function args))) + (process-enable process) + process))) + +(defmethod process-reset ((process process) &optional kill) + "Cause a specified process to cleanly exit from any ongoing computation." + (setq process (require-type process 'process)) + (unless (memq kill '(nil :kill :shutdown)) + (setq kill (require-type kill '(member nil :kill :shutdown)))) + (if (eq process *current-process*) + (%process-reset kill) + (if (process-exhausted-p process) + (maybe-finish-process-kill process kill) + (progn + (process-interrupt process '%process-reset kill))))) + +(defmethod process-yield ((p process)) + #+windows-target (#_Sleep 0) + #-windows-target (#_sched_yield)) + + +(defun %process-reset (kill) + (signal 'process-reset :kill kill) + (maybe-finish-process-kill *current-process* kill)) + +;;; By default, it's just fine with the current process +;;; if the application/user wants to quit. +(defmethod process-verify-quit ((process process)) + t) + +(defmethod process-exit-application ((process process) thunk) + (when (eq process *initial-process*) + (with-standard-abort-handling "Exit Lisp" + (prepare-to-quit) + ;; We may have abruptly terminated a thread + ;; which owned the output lock on *STDOUT*. + ;; Don't block waiting on that lock if so. + (let* ((s *stdout*) + (lock (ioblock-outbuf-lock (basic-stream-ioblock s))) + (locked (make-lock-acquisition))) + (declare (dynamic-extent locked)) + (when (or (null lock) (%try-recursive-lock-object lock locked)) + (unwind-protect + (progn + (fresh-line s) + (finish-output s))) + (when (lock-acquisition.status locked) (release-lock lock))))) + (%set-toplevel thunk) + (toplevel))) + + + +(defmethod process-kill ((process process)) + "Cause a specified process to cleanly exit from any ongoing +computation, and then exit." + (and (process-interrupt process #'%process-reset :kill) + (setf (process-kill-issued process) t))) + +(defun process-abort (process &optional condition) + "Cause a specified process to process an abort condition, as if it +had invoked abort." + (process-interrupt process + #'(lambda () + (abort condition)))) + +(defmethod process-reset-and-enable ((process process)) + (not-in-current-process process 'process-reset-and-enable) + (process-reset process) + (process-enable process)) + +(defmethod process-kill-issued ((process process)) + (cdr (process-splice process))) + +(defmethod (setf process-kill-issued) (val (process process)) + (setf (cdr (process-splice process)) val)) + +(defun tcr->process (tcr) + (dolist (p (all-processes)) + (when (eq tcr (process-tcr p)) + (return p)))) + +(defun current-process-allocation-quantum () + (process-allocation-quantum *current-process*)) + +(defun (setf current-process-allocation-quantum) (new) + (if (valid-allocation-quantum-p new) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (%current-tcr)) + (setf (slot-value *current-process* 'allocation-quantum) new + (%get-natural tcrp target::tcr.log2-allocation-quantum) + (1- (integer-length new))) + new) + (report-bad-arg new '(satisfies valid-allocation-quantum-p)))) + + +(def-standard-initial-binding *backtrace-contexts* nil) + +(defmethod exit-interactive-process ((p process)) + (unless (eq p *initial-process*) + (when (eq p *current-process*) + (process-kill p)))) + +(defclass tty-listener (process) + ()) + +(defmethod exit-interactive-process ((p tty-listener)) + (when (eq p *current-process*) + (quit))) + +(defmethod process-stop-dribbling ((p process)) + (with-slots (dribble-stream dribble-saved-terminal-io) p + (when dribble-stream + (close dribble-stream) + (setq dribble-stream nil)) + (when dribble-saved-terminal-io + (setq *terminal-io* dribble-saved-terminal-io + dribble-saved-terminal-io nil)))) + +(defmethod process-dribble ((p process) path) + (with-slots (dribble-stream dribble-saved-terminal-io) p + (process-stop-dribbling p) + (when path + (let* ((in (two-way-stream-input-stream *terminal-io*)) + (out (two-way-stream-output-stream *terminal-io*)) + (f (open path :direction :output :if-exists :append + :if-does-not-exist :create))) + (without-interrupts + (setq dribble-stream f + dribble-saved-terminal-io *terminal-io* + *terminal-io* (make-echoing-two-way-stream + (make-echo-stream in f) + (make-broadcast-stream out f))))) + path))) + +(defmethod join-process ((p process) &key default) + (wait-on-semaphore (process-termination-semaphore p) nil "join-process") + (let ((result (process-result p))) + (cond ((car result) (values-list (cdr result))) + (t default)))) + + Index: /branches/qres/ccl/level-1/l1-reader.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-reader.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-reader.lisp (revision 13564) @@ -0,0 +1,3362 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; READ and related functions. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (defconstant readtable-case-keywords '((:upcase . 1) (:downcase . 2) (:preserve . 0) + (:invert . -1) (:studly . -2))) + (defmacro readtable-case-keywords () `',readtable-case-keywords)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-load-form ((ref package-ref) &optional env) + (declare (ignore env)) + `(register-package-ref ',(package-ref.name ref))) + +(defmethod print-object ((ref package-ref) stream) + (print-unreadable-object (ref stream :type t :identity t) + (format stream "for ~s [~s]" (package-ref.name ref) (package-ref.pkg ref)))) + +;;; Maps character names to characters +(defvar *name->char* (make-hash-table :test #'equalp)) +;;; Maps characters to (canonical) character names. +(defvar *char->name* (make-hash-table :test #'eql)) + +;;; This isn't thread-safe. If the user really wants to register character +;;; names from multiple threads, they should do their own locking. +(defun register-character-name (name char) + (setf (gethash name *name->char*) char) + (unless (gethash char *char->name*) + (setf (gethash char *char->name*) name))) + +(dolist (pair '( + ;; Standard character names + ("Newline" . #\012) ("Space" . #\040) + ;; Semi-standard character names + ("Rubout" . #\177) ("Page" . #\014) ("Tab" . #\011) + ("Backspace" . #\010) ("Return" . #\015) ("Linefeed" . #\012) + ;; Other character names. (When available, standard + ;; names should be used for printing in preference to + ;; any non-standard names.) + ("Null" . #\000) ("Nul" . #\000) + ("Bell" . #\007) ; ^G , used by Franz (and others with bells.) + ("Delete" . #\010) ("BS" . #\010) + ("LF" . #\012) + ("PageUp" . #\013) + ("PageDown" . #\014)("Formfeed" . #\014) ("FF" . #\014) + ("CR" . #\015) + ("Sub" . #\032) + ("ESC" . #\033) ("Escape" . #\033) ("Clear" . #\033) + ("Altmode" . #\033) ("ALT" . #\033) + ("Fs" . #\034) + ("Gs" . #\035) + ("Rs" . #\036) + ("Us" . #\037) + ("DEL" . #\177)("ForwardDelete" . #\177) + ("No-Break_Space" . #\u+00a0) + ("Inverted_Exclamation_Mark" . #\u+00a1) + ("Cent_Sign" . #\u+00a2) + ("Pound_Sign" . #\u+00a3) + ("Currency_Sign" . #\u+00a4) + ("Yen_Sign" . #\u+00a5) + ("Broken_Bar" . #\u+00a6) + ("Section_Sign" . #\u+00a7) + ("Diaeresis" . #\u+00a8) + ("Copyright_Sign" . #\u+00a9) + ("Feminine_Ordinal_Indicator" . #\u+00aa) + ("Left-Pointing_Double_Angle_Quotation_Mark" . #\u+00ab) + ("Not_Sign" . #\u+00ac) + ("Soft_Hyphen" . #\u+00ad) + ("Registered_Sign" . #\u+00ae) + ("Macron" . #\u+00af) + ("Degree_Sign" . #\u+00b0) + ("Plus-Minus_Sign" . #\u+00b1) + ("Superscript_Two" . #\u+00b2) + ("Superscript_Three" . #\u+00b3) + ("Acute_Accent" . #\u+00b4) + ("Micro_Sign" . #\u+00b5) + ("Pilcrow_Sign" . #\u+00b6) + ("Middle_Dot" . #\u+00b7) + ("Cedilla" . #\u+00b8) + ("Superscript_One" . #\u+00b9) + ("Masculine_Ordinal_Indicator" . #\u+00ba) + ("Right-Pointing_Double_Angle_Quotation_Mark" . #\u+00bb) + ("Vulgar_Fraction_One_Quarter" . #\u+00bc) + ("Vulgar_Fraction_One_Half" . #\u+00bd) + ("Vulgar_Fraction_Three_Quarters" . #\u+00be) + ("Inverted_Question_Mark" . #\u+00bf) + ("Latin_Capital_Letter_A_With_Grave" . #\u+00c0) + ("Latin_Capital_Letter_A_With_Acute" . #\u+00c1) + ("Latin_Capital_Letter_A_With_Circumflex" . #\u+00c2) + ("Latin_Capital_Letter_A_With_Tilde" . #\u+00c3) + ("Latin_Capital_Letter_A_With_Diaeresis" . #\u+00c4) + ("Latin_Capital_Letter_A_With_Ring_Above" . #\u+00c5) + ("Latin_Capital_Letter_Ae" . #\u+00c6) + ("Latin_Capital_Letter_C_With_Cedilla" . #\u+00c7) + ("Latin_Capital_Letter_E_With_Grave" . #\u+00c8) + ("Latin_Capital_Letter_E_With_Acute" . #\u+00c9) + ("Latin_Capital_Letter_E_With_Circumflex" . #\u+00ca) + ("Latin_Capital_Letter_E_With_Diaeresis" . #\u+00cb) + ("Latin_Capital_Letter_I_With_Grave" . #\u+00cc) + ("Latin_Capital_Letter_I_With_Acute" . #\u+00cd) + ("Latin_Capital_Letter_I_With_Circumflex" . #\u+00ce) + ("Latin_Capital_Letter_I_With_Diaeresis" . #\u+00cf) + ("Latin_Capital_Letter_Eth" . #\u+00d0) + ("Latin_Capital_Letter_N_With_Tilde" . #\u+00d1) + ("Latin_Capital_Letter_O_With_Grave" . #\u+00d2) + ("Latin_Capital_Letter_O_With_Acute" . #\u+00d3) + ("Latin_Capital_Letter_O_With_Circumflex" . #\u+00d4) + ("Latin_Capital_Letter_O_With_Tilde" . #\u+00d5) + ("Latin_Capital_Letter_O_With_Diaeresis" . #\u+00d6) + ("Multiplication_Sign" . #\u+00d7) + ("Latin_Capital_Letter_O_With_Stroke" . #\u+00d8) + ("Latin_Capital_Letter_U_With_Grave" . #\u+00d9) + ("Latin_Capital_Letter_U_With_Acute" . #\u+00da) + ("Latin_Capital_Letter_U_With_Circumflex" . #\u+00db) + ("Latin_Capital_Letter_U_With_Diaeresis" . #\u+00dc) + ("Latin_Capital_Letter_Y_With_Acute" . #\u+00dd) + ("Latin_Capital_Letter_Thorn" . #\u+00de) + ("Latin_Small_Letter_Sharp_S" . #\u+00df) + ("Latin_Small_Letter_A_With_Grave" . #\u+00e0) + ("Latin_Small_Letter_A_With_Acute" . #\u+00e1) + ("Latin_Small_Letter_A_With_Circumflex" . #\u+00e2) + ("Latin_Small_Letter_A_With_Tilde" . #\u+00e3) + ("Latin_Small_Letter_A_With_Diaeresis" . #\u+00e4) + ("Latin_Small_Letter_A_With_Ring_Above" . #\u+00e5) + ("Latin_Small_Letter_Ae" . #\u+00e6) + ("Latin_Small_Letter_C_With_Cedilla" . #\u+00e7) + ("Latin_Small_Letter_E_With_Grave" . #\u+00e8) + ("Latin_Small_Letter_E_With_Acute" . #\u+00e9) + ("Latin_Small_Letter_E_With_Circumflex" . #\u+00ea) + ("Latin_Small_Letter_E_With_Diaeresis" . #\u+00eb) + ("Latin_Small_Letter_I_With_Grave" . #\u+00ec) + ("Latin_Small_Letter_I_With_Acute" . #\u+00ed) + ("Latin_Small_Letter_I_With_Circumflex" . #\u+00ee) + ("Latin_Small_Letter_I_With_Diaeresis" . #\u+00ef) + ("Latin_Small_Letter_Eth" . #\u+00f0) + ("Latin_Small_Letter_N_With_Tilde" . #\u+00f1) + ("Latin_Small_Letter_O_With_Grave" . #\u+00f2) + ("Latin_Small_Letter_O_With_Acute" . #\u+00f3) + ("Latin_Small_Letter_O_With_Circumflex" . #\u+00f4) + ("Latin_Small_Letter_O_With_Tilde" . #\u+00f5) + ("Latin_Small_Letter_O_With_Diaeresis" . #\u+00f6) + ("Division_Sign" . #\u+00f7) + ("Latin_Small_Letter_O_With_Stroke" . #\u+00f8) + ("Latin_Small_Letter_U_With_Grave" . #\u+00f9) + ("Latin_Small_Letter_U_With_Acute" . #\u+00fa) + ("Latin_Small_Letter_U_With_Circumflex" . #\u+00fb) + ("Latin_Small_Letter_U_With_Diaeresis" . #\u+00fc) + ("Latin_Small_Letter_Y_With_Acute" . #\u+00fd) + ("Latin_Small_Letter_Thorn" . #\u+00fe) + ("Latin_Small_Letter_Y_With_Diaeresis" . #\u+00ff) + ("Latin_Capital_Letter_A_With_Macron" . #\u+0100) + ("Latin_Small_Letter_A_With_Macron" . #\u+0101) + ("Latin_Capital_Letter_A_With_Breve" . #\u+0102) + ("Latin_Small_Letter_A_With_Breve" . #\u+0103) + ("Latin_Capital_Letter_A_With_Ogonek" . #\u+0104) + ("Latin_Small_Letter_A_With_Ogonek" . #\u+0105) + ("Latin_Capital_Letter_C_With_Acute" . #\u+0106) + ("Latin_Small_Letter_C_With_Acute" . #\u+0107) + ("Latin_Capital_Letter_C_With_Circumflex" . #\u+0108) + ("Latin_Small_Letter_C_With_Circumflex" . #\u+0109) + ("Latin_Capital_Letter_C_With_Dot_Above" . #\u+010a) + ("Latin_Small_Letter_C_With_Dot_Above" . #\u+010b) + ("Latin_Capital_Letter_C_With_Caron" . #\u+010c) + ("Latin_Small_Letter_C_With_Caron" . #\u+010d) + ("Latin_Capital_Letter_D_With_Caron" . #\u+010e) + ("Latin_Small_Letter_D_With_Caron" . #\u+010f) + ("Latin_Capital_Letter_D_With_Stroke" . #\u+0110) + ("Latin_Small_Letter_D_With_Stroke" . #\u+0111) + ("Latin_Capital_Letter_E_With_Macron" . #\u+0112) + ("Latin_Small_Letter_E_With_Macron" . #\u+0113) + ("Latin_Capital_Letter_E_With_Breve" . #\u+0114) + ("Latin_Small_Letter_E_With_Breve" . #\u+0115) + ("Latin_Capital_Letter_E_With_Dot_Above" . #\u+0116) + ("Latin_Small_Letter_E_With_Dot_Above" . #\u+0117) + ("Latin_Capital_Letter_E_With_Ogonek" . #\u+0118) + ("Latin_Small_Letter_E_With_Ogonek" . #\u+0119) + ("Latin_Capital_Letter_E_With_Caron" . #\u+011a) + ("Latin_Small_Letter_E_With_Caron" . #\u+011b) + ("Latin_Capital_Letter_G_With_Circumflex" . #\u+011c) + ("Latin_Small_Letter_G_With_Circumflex" . #\u+011d) + ("Latin_Capital_Letter_G_With_Breve" . #\u+011e) + ("Latin_Small_Letter_G_With_Breve" . #\u+011f) + ("Latin_Capital_Letter_G_With_Dot_Above" . #\u+0120) + ("Latin_Small_Letter_G_With_Dot_Above" . #\u+0121) + ("Latin_Capital_Letter_G_With_Cedilla" . #\u+0122) + ("Latin_Small_Letter_G_With_Cedilla" . #\u+0123) + ("Latin_Capital_Letter_H_With_Circumflex" . #\u+0124) + ("Latin_Small_Letter_H_With_Circumflex" . #\u+0125) + ("Latin_Capital_Letter_H_With_Stroke" . #\u+0126) + ("Latin_Small_Letter_H_With_Stroke" . #\u+0127) + ("Latin_Capital_Letter_I_With_Tilde" . #\u+0128) + ("Latin_Small_Letter_I_With_Tilde" . #\u+0129) + ("Latin_Capital_Letter_I_With_Macron" . #\u+012a) + ("Latin_Small_Letter_I_With_Macron" . #\u+012b) + ("Latin_Capital_Letter_I_With_Breve" . #\u+012c) + ("Latin_Small_Letter_I_With_Breve" . #\u+012d) + ("Latin_Capital_Letter_I_With_Ogonek" . #\u+012e) + ("Latin_Small_Letter_I_With_Ogonek" . #\u+012f) + ("Latin_Capital_Letter_I_With_Dot_Above" . #\u+0130) + ("Latin_Small_Letter_Dotless_I" . #\u+0131) + ("Latin_Capital_Ligature_Ij" . #\u+0132) + ("Latin_Small_Ligature_Ij" . #\u+0133) + ("Latin_Capital_Letter_J_With_Circumflex" . #\u+0134) + ("Latin_Small_Letter_J_With_Circumflex" . #\u+0135) + ("Latin_Capital_Letter_K_With_Cedilla" . #\u+0136) + ("Latin_Small_Letter_K_With_Cedilla" . #\u+0137) + ("Latin_Small_Letter_Kra" . #\u+0138) + ("Latin_Capital_Letter_L_With_Acute" . #\u+0139) + ("Latin_Small_Letter_L_With_Acute" . #\u+013a) + ("Latin_Capital_Letter_L_With_Cedilla" . #\u+013b) + ("Latin_Small_Letter_L_With_Cedilla" . #\u+013c) + ("Latin_Capital_Letter_L_With_Caron" . #\u+013d) + ("Latin_Small_Letter_L_With_Caron" . #\u+013e) + ("Latin_Capital_Letter_L_With_Middle_Dot" . #\u+013f) + ("Latin_Small_Letter_L_With_Middle_Dot" . #\u+0140) + ("Latin_Capital_Letter_L_With_Stroke" . #\u+0141) + ("Latin_Small_Letter_L_With_Stroke" . #\u+0142) + ("Latin_Capital_Letter_N_With_Acute" . #\u+0143) + ("Latin_Small_Letter_N_With_Acute" . #\u+0144) + ("Latin_Capital_Letter_N_With_Cedilla" . #\u+0145) + ("Latin_Small_Letter_N_With_Cedilla" . #\u+0146) + ("Latin_Capital_Letter_N_With_Caron" . #\u+0147) + ("Latin_Small_Letter_N_With_Caron" . #\u+0148) + ("Latin_Small_Letter_N_Preceded_By_Apostrophe" . #\u+0149) + ("Latin_Capital_Letter_Eng" . #\u+014a) + ("Latin_Small_Letter_Eng" . #\u+014b) + ("Latin_Capital_Letter_O_With_Macron" . #\u+014c) + ("Latin_Small_Letter_O_With_Macron" . #\u+014d) + ("Latin_Capital_Letter_O_With_Breve" . #\u+014e) + ("Latin_Small_Letter_O_With_Breve" . #\u+014f) + ("Latin_Capital_Letter_O_With_Double_Acute" . #\u+0150) + ("Latin_Small_Letter_O_With_Double_Acute" . #\u+0151) + ("Latin_Capital_Ligature_Oe" . #\u+0152) + ("Latin_Small_Ligature_Oe" . #\u+0153) + ("Latin_Capital_Letter_R_With_Acute" . #\u+0154) + ("Latin_Small_Letter_R_With_Acute" . #\u+0155) + ("Latin_Capital_Letter_R_With_Cedilla" . #\u+0156) + ("Latin_Small_Letter_R_With_Cedilla" . #\u+0157) + ("Latin_Capital_Letter_R_With_Caron" . #\u+0158) + ("Latin_Small_Letter_R_With_Caron" . #\u+0159) + ("Latin_Capital_Letter_S_With_Acute" . #\u+015a) + ("Latin_Small_Letter_S_With_Acute" . #\u+015b) + ("Latin_Capital_Letter_S_With_Circumflex" . #\u+015c) + ("Latin_Small_Letter_S_With_Circumflex" . #\u+015d) + ("Latin_Capital_Letter_S_With_Cedilla" . #\u+015e) + ("Latin_Small_Letter_S_With_Cedilla" . #\u+015f) + ("Latin_Capital_Letter_S_With_Caron" . #\u+0160) + ("Latin_Small_Letter_S_With_Caron" . #\u+0161) + ("Latin_Capital_Letter_T_With_Cedilla" . #\u+0162) + ("Latin_Small_Letter_T_With_Cedilla" . #\u+0163) + ("Latin_Capital_Letter_T_With_Caron" . #\u+0164) + ("Latin_Small_Letter_T_With_Caron" . #\u+0165) + ("Latin_Capital_Letter_T_With_Stroke" . #\u+0166) + ("Latin_Small_Letter_T_With_Stroke" . #\u+0167) + ("Latin_Capital_Letter_U_With_Tilde" . #\u+0168) + ("Latin_Small_Letter_U_With_Tilde" . #\u+0169) + ("Latin_Capital_Letter_U_With_Macron" . #\u+016a) + ("Latin_Small_Letter_U_With_Macron" . #\u+016b) + ("Latin_Capital_Letter_U_With_Breve" . #\u+016c) + ("Latin_Small_Letter_U_With_Breve" . #\u+016d) + ("Latin_Capital_Letter_U_With_Ring_Above" . #\u+016e) + ("Latin_Small_Letter_U_With_Ring_Above" . #\u+016f) + ("Latin_Capital_Letter_U_With_Double_Acute" . #\u+0170) + ("Latin_Small_Letter_U_With_Double_Acute" . #\u+0171) + ("Latin_Capital_Letter_U_With_Ogonek" . #\u+0172) + ("Latin_Small_Letter_U_With_Ogonek" . #\u+0173) + ("Latin_Capital_Letter_W_With_Circumflex" . #\u+0174) + ("Latin_Small_Letter_W_With_Circumflex" . #\u+0175) + ("Latin_Capital_Letter_Y_With_Circumflex" . #\u+0176) + ("Latin_Small_Letter_Y_With_Circumflex" . #\u+0177) + ("Latin_Capital_Letter_Y_With_Diaeresis" . #\u+0178) + ("Latin_Capital_Letter_Z_With_Acute" . #\u+0179) + ("Latin_Small_Letter_Z_With_Acute" . #\u+017a) + ("Latin_Capital_Letter_Z_With_Dot_Above" . #\u+017b) + ("Latin_Small_Letter_Z_With_Dot_Above" . #\u+017c) + ("Latin_Capital_Letter_Z_With_Caron" . #\u+017d) + ("Latin_Small_Letter_Z_With_Caron" . #\u+017e) + ("Latin_Small_Letter_Long_S" . #\u+017f) + ("Latin_Small_Letter_B_With_Stroke" . #\u+0180) + ("Latin_Capital_Letter_B_With_Hook" . #\u+0181) + ("Latin_Capital_Letter_B_With_Topbar" . #\u+0182) + ("Latin_Small_Letter_B_With_Topbar" . #\u+0183) + ("Latin_Capital_Letter_Tone_Six" . #\u+0184) + ("Latin_Small_Letter_Tone_Six" . #\u+0185) + ("Latin_Capital_Letter_Open_O" . #\u+0186) + ("Latin_Capital_Letter_C_With_Hook" . #\u+0187) + ("Latin_Small_Letter_C_With_Hook" . #\u+0188) + ("Latin_Capital_Letter_African_D" . #\u+0189) + ("Latin_Capital_Letter_D_With_Hook" . #\u+018a) + ("Latin_Capital_Letter_D_With_Topbar" . #\u+018b) + ("Latin_Small_Letter_D_With_Topbar" . #\u+018c) + ("Latin_Small_Letter_Turned_Delta" . #\u+018d) + ("Latin_Capital_Letter_Reversed_E" . #\u+018e) + ("Latin_Capital_Letter_Schwa" . #\u+018f) + ("Latin_Capital_Letter_Open_E" . #\u+0190) + ("Latin_Capital_Letter_F_With_Hook" . #\u+0191) + ("Latin_Small_Letter_F_With_Hook" . #\u+0192) + ("Latin_Capital_Letter_G_With_Hook" . #\u+0193) + ("Latin_Capital_Letter_Gamma" . #\u+0194) + ("Latin_Small_Letter_Hv" . #\u+0195) + ("Latin_Capital_Letter_Iota" . #\u+0196) + ("Latin_Capital_Letter_I_With_Stroke" . #\u+0197) + ("Latin_Capital_Letter_K_With_Hook" . #\u+0198) + ("Latin_Small_Letter_K_With_Hook" . #\u+0199) + ("Latin_Small_Letter_L_With_Bar" . #\u+019a) + ("Latin_Small_Letter_Lambda_With_Stroke" . #\u+019b) + ("Latin_Capital_Letter_Turned_M" . #\u+019c) + ("Latin_Capital_Letter_N_With_Left_Hook" . #\u+019d) + ("Latin_Small_Letter_N_With_Long_Right_Leg" . #\u+019e) + ("Latin_Capital_Letter_O_With_Middle_Tilde" . #\u+019f) + ("Latin_Capital_Letter_O_With_Horn" . #\u+01a0) + ("Latin_Small_Letter_O_With_Horn" . #\u+01a1) + ("Latin_Capital_Letter_Oi" . #\u+01a2) + ("Latin_Small_Letter_Oi" . #\u+01a3) + ("Latin_Capital_Letter_P_With_Hook" . #\u+01a4) + ("Latin_Small_Letter_P_With_Hook" . #\u+01a5) + ("Latin_Letter_Yr" . #\u+01a6) + ("Latin_Capital_Letter_Tone_Two" . #\u+01a7) + ("Latin_Small_Letter_Tone_Two" . #\u+01a8) + ("Latin_Capital_Letter_Esh" . #\u+01a9) + ("Latin_Letter_Reversed_Esh_Loop" . #\u+01aa) + ("Latin_Small_Letter_T_With_Palatal_Hook" . #\u+01ab) + ("Latin_Capital_Letter_T_With_Hook" . #\u+01ac) + ("Latin_Small_Letter_T_With_Hook" . #\u+01ad) + ("Latin_Capital_Letter_T_With_Retroflex_Hook" . #\u+01ae) + ("Latin_Capital_Letter_U_With_Horn" . #\u+01af) + ("Latin_Small_Letter_U_With_Horn" . #\u+01b0) + ("Latin_Capital_Letter_Upsilon" . #\u+01b1) + ("Latin_Capital_Letter_V_With_Hook" . #\u+01b2) + ("Latin_Capital_Letter_Y_With_Hook" . #\u+01b3) + ("Latin_Small_Letter_Y_With_Hook" . #\u+01b4) + ("Latin_Capital_Letter_Z_With_Stroke" . #\u+01b5) + ("Latin_Small_Letter_Z_With_Stroke" . #\u+01b6) + ("Latin_Capital_Letter_Ezh" . #\u+01b7) + ("Latin_Capital_Letter_Ezh_Reversed" . #\u+01b8) + ("Latin_Small_Letter_Ezh_Reversed" . #\u+01b9) + ("Latin_Small_Letter_Ezh_With_Tail" . #\u+01ba) + ("Latin_Letter_Two_With_Stroke" . #\u+01bb) + ("Latin_Capital_Letter_Tone_Five" . #\u+01bc) + ("Latin_Small_Letter_Tone_Five" . #\u+01bd) + ("Latin_Letter_Inverted_Glottal_Stop_With_Stroke" . #\u+01be) + ("Latin_Letter_Wynn" . #\u+01bf) + ("Latin_Letter_Dental_Click" . #\u+01c0) + ("Latin_Letter_Lateral_Click" . #\u+01c1) + ("Latin_Letter_Alveolar_Click" . #\u+01c2) + ("Latin_Letter_Retroflex_Click" . #\u+01c3) + ("Latin_Capital_Letter_Dz_With_Caron" . #\u+01c4) + ("Latin_Capital_Letter_D_With_Small_Letter_Z_With_Caron" . #\u+01c5) + ("Latin_Small_Letter_Dz_With_Caron" . #\u+01c6) + ("Latin_Capital_Letter_Lj" . #\u+01c7) + ("Latin_Capital_Letter_L_With_Small_Letter_J" . #\u+01c8) + ("Latin_Small_Letter_Lj" . #\u+01c9) + ("Latin_Capital_Letter_Nj" . #\u+01ca) + ("Latin_Capital_Letter_N_With_Small_Letter_J" . #\u+01cb) + ("Latin_Small_Letter_Nj" . #\u+01cc) + ("Latin_Capital_Letter_A_With_Caron" . #\u+01cd) + ("Latin_Small_Letter_A_With_Caron" . #\u+01ce) + ("Latin_Capital_Letter_I_With_Caron" . #\u+01cf) + ("Latin_Small_Letter_I_With_Caron" . #\u+01d0) + ("Latin_Capital_Letter_O_With_Caron" . #\u+01d1) + ("Latin_Small_Letter_O_With_Caron" . #\u+01d2) + ("Latin_Capital_Letter_U_With_Caron" . #\u+01d3) + ("Latin_Small_Letter_U_With_Caron" . #\u+01d4) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Macron" . #\u+01d5) + ("Latin_Small_Letter_U_With_Diaeresis_And_Macron" . #\u+01d6) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Acute" . #\u+01d7) + ("Latin_Small_Letter_U_With_Diaeresis_And_Acute" . #\u+01d8) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Caron" . #\u+01d9) + ("Latin_Small_Letter_U_With_Diaeresis_And_Caron" . #\u+01da) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Grave" . #\u+01db) + ("Latin_Small_Letter_U_With_Diaeresis_And_Grave" . #\u+01dc) + ("Latin_Small_Letter_Turned_E" . #\u+01dd) + ("Latin_Capital_Letter_A_With_Diaeresis_And_Macron" . #\u+01de) + ("Latin_Small_Letter_A_With_Diaeresis_And_Macron" . #\u+01df) + ("Latin_Capital_Letter_A_With_Dot_Above_And_Macron" . #\u+01e0) + ("Latin_Small_Letter_A_With_Dot_Above_And_Macron" . #\u+01e1) + ("Latin_Capital_Letter_Ae_With_Macron" . #\u+01e2) + ("Latin_Small_Letter_Ae_With_Macron" . #\u+01e3) + ("Latin_Capital_Letter_G_With_Stroke" . #\u+01e4) + ("Latin_Small_Letter_G_With_Stroke" . #\u+01e5) + ("Latin_Capital_Letter_G_With_Caron" . #\u+01e6) + ("Latin_Small_Letter_G_With_Caron" . #\u+01e7) + ("Latin_Capital_Letter_K_With_Caron" . #\u+01e8) + ("Latin_Small_Letter_K_With_Caron" . #\u+01e9) + ("Latin_Capital_Letter_O_With_Ogonek" . #\u+01ea) + ("Latin_Small_Letter_O_With_Ogonek" . #\u+01eb) + ("Latin_Capital_Letter_O_With_Ogonek_And_Macron" . #\u+01ec) + ("Latin_Small_Letter_O_With_Ogonek_And_Macron" . #\u+01ed) + ("Latin_Capital_Letter_Ezh_With_Caron" . #\u+01ee) + ("Latin_Small_Letter_Ezh_With_Caron" . #\u+01ef) + ("Latin_Small_Letter_J_With_Caron" . #\u+01f0) + ("Latin_Capital_Letter_Dz" . #\u+01f1) + ("Latin_Capital_Letter_D_With_Small_Letter_Z" . #\u+01f2) + ("Latin_Small_Letter_Dz" . #\u+01f3) + ("Latin_Capital_Letter_G_With_Acute" . #\u+01f4) + ("Latin_Small_Letter_G_With_Acute" . #\u+01f5) + ("Latin_Capital_Letter_Hwair" . #\u+01f6) + ("Latin_Capital_Letter_Wynn" . #\u+01f7) + ("Latin_Capital_Letter_N_With_Grave" . #\u+01f8) + ("Latin_Small_Letter_N_With_Grave" . #\u+01f9) + ("Latin_Capital_Letter_A_With_Ring_Above_And_Acute" . #\u+01fa) + ("Latin_Small_Letter_A_With_Ring_Above_And_Acute" . #\u+01fb) + ("Latin_Capital_Letter_Ae_With_Acute" . #\u+01fc) + ("Latin_Small_Letter_Ae_With_Acute" . #\u+01fd) + ("Latin_Capital_Letter_O_With_Stroke_And_Acute" . #\u+01fe) + ("Latin_Small_Letter_O_With_Stroke_And_Acute" . #\u+01ff) + ("Latin_Capital_Letter_A_With_Double_Grave" . #\u+0200) + ("Latin_Small_Letter_A_With_Double_Grave" . #\u+0201) + ("Latin_Capital_Letter_A_With_Inverted_Breve" . #\u+0202) + ("Latin_Small_Letter_A_With_Inverted_Breve" . #\u+0203) + ("Latin_Capital_Letter_E_With_Double_Grave" . #\u+0204) + ("Latin_Small_Letter_E_With_Double_Grave" . #\u+0205) + ("Latin_Capital_Letter_E_With_Inverted_Breve" . #\u+0206) + ("Latin_Small_Letter_E_With_Inverted_Breve" . #\u+0207) + ("Latin_Capital_Letter_I_With_Double_Grave" . #\u+0208) + ("Latin_Small_Letter_I_With_Double_Grave" . #\u+0209) + ("Latin_Capital_Letter_I_With_Inverted_Breve" . #\u+020a) + ("Latin_Small_Letter_I_With_Inverted_Breve" . #\u+020b) + ("Latin_Capital_Letter_O_With_Double_Grave" . #\u+020c) + ("Latin_Small_Letter_O_With_Double_Grave" . #\u+020d) + ("Latin_Capital_Letter_O_With_Inverted_Breve" . #\u+020e) + ("Latin_Small_Letter_O_With_Inverted_Breve" . #\u+020f) + ("Latin_Capital_Letter_R_With_Double_Grave" . #\u+0210) + ("Latin_Small_Letter_R_With_Double_Grave" . #\u+0211) + ("Latin_Capital_Letter_R_With_Inverted_Breve" . #\u+0212) + ("Latin_Small_Letter_R_With_Inverted_Breve" . #\u+0213) + ("Latin_Capital_Letter_U_With_Double_Grave" . #\u+0214) + ("Latin_Small_Letter_U_With_Double_Grave" . #\u+0215) + ("Latin_Capital_Letter_U_With_Inverted_Breve" . #\u+0216) + ("Latin_Small_Letter_U_With_Inverted_Breve" . #\u+0217) + ("Latin_Capital_Letter_S_With_Comma_Below" . #\u+0218) + ("Latin_Small_Letter_S_With_Comma_Below" . #\u+0219) + ("Latin_Capital_Letter_T_With_Comma_Below" . #\u+021a) + ("Latin_Small_Letter_T_With_Comma_Below" . #\u+021b) + ("Latin_Capital_Letter_Yogh" . #\u+021c) + ("Latin_Small_Letter_Yogh" . #\u+021d) + ("Latin_Capital_Letter_H_With_Caron" . #\u+021e) + ("Latin_Small_Letter_H_With_Caron" . #\u+021f) + ("Latin_Capital_Letter_N_With_Long_Right_Leg" . #\u+0220) + ("Latin_Small_Letter_D_With_Curl" . #\u+0221) + ("Latin_Capital_Letter_Ou" . #\u+0222) + ("Latin_Small_Letter_Ou" . #\u+0223) + ("Latin_Capital_Letter_Z_With_Hook" . #\u+0224) + ("Latin_Small_Letter_Z_With_Hook" . #\u+0225) + ("Latin_Capital_Letter_A_With_Dot_Above" . #\u+0226) + ("Latin_Small_Letter_A_With_Dot_Above" . #\u+0227) + ("Latin_Capital_Letter_E_With_Cedilla" . #\u+0228) + ("Latin_Small_Letter_E_With_Cedilla" . #\u+0229) + ("Latin_Capital_Letter_O_With_Diaeresis_And_Macron" . #\u+022a) + ("Latin_Small_Letter_O_With_Diaeresis_And_Macron" . #\u+022b) + ("Latin_Capital_Letter_O_With_Tilde_And_Macron" . #\u+022c) + ("Latin_Small_Letter_O_With_Tilde_And_Macron" . #\u+022d) + ("Latin_Capital_Letter_O_With_Dot_Above" . #\u+022e) + ("Latin_Small_Letter_O_With_Dot_Above" . #\u+022f) + ("Latin_Capital_Letter_O_With_Dot_Above_And_Macron" . #\u+0230) + ("Latin_Small_Letter_O_With_Dot_Above_And_Macron" . #\u+0231) + ("Latin_Capital_Letter_Y_With_Macron" . #\u+0232) + ("Latin_Small_Letter_Y_With_Macron" . #\u+0233) + ("Latin_Small_Letter_L_With_Curl" . #\u+0234) + ("Latin_Small_Letter_N_With_Curl" . #\u+0235) + ("Latin_Small_Letter_T_With_Curl" . #\u+0236) + ("Latin_Small_Letter_Dotless_J" . #\u+0237) + ("Latin_Small_Letter_Db_Digraph" . #\u+0238) + ("Latin_Small_Letter_Qp_Digraph" . #\u+0239) + ("Latin_Capital_Letter_A_With_Stroke" . #\u+023a) + ("Latin_Capital_Letter_C_With_Stroke" . #\u+023b) + ("Latin_Small_Letter_C_With_Stroke" . #\u+023c) + ("Latin_Capital_Letter_L_With_Bar" . #\u+023d) + ("Latin_Capital_Letter_T_With_Diagonal_Stroke" . #\u+023e) + ("Latin_Small_Letter_S_With_Swash_Tail" . #\u+023f) + ("Latin_Small_Letter_Z_With_Swash_Tail" . #\u+0240) + ("Latin_Capital_Letter_Glottal_Stop" . #\u+0241) + ("Latin_Small_Letter_Glottal_Stop" . #\u+0242) + ("Latin_Capital_Letter_B_With_Stroke" . #\u+0243) + ("Latin_Capital_Letter_U_Bar" . #\u+0244) + ("Latin_Capital_Letter_Turned_V" . #\u+0245) + ("Latin_Capital_Letter_E_With_Stroke" . #\u+0246) + ("Latin_Small_Letter_E_With_Stroke" . #\u+0247) + ("Latin_Capital_Letter_J_With_Stroke" . #\u+0248) + ("Latin_Small_Letter_J_With_Stroke" . #\u+0249) + ("Latin_Capital_Letter_Small_Q_With_Hook_Tail" . #\u+024a) + ("Latin_Small_Letter_Q_With_Hook_Tail" . #\u+024b) + ("Latin_Capital_Letter_R_With_Stroke" . #\u+024c) + ("Latin_Small_Letter_R_With_Stroke" . #\u+024d) + ("Latin_Capital_Letter_Y_With_Stroke" . #\u+024e) + ("Latin_Small_Letter_Y_With_Stroke" . #\u+024f) + ("Latin_Small_Letter_Turned_A" . #\u+0250) + ("Latin_Small_Letter_Alpha" . #\u+0251) + ("Latin_Small_Letter_Turned_Alpha" . #\u+0252) + ("Latin_Small_Letter_B_With_Hook" . #\u+0253) + ("Latin_Small_Letter_Open_O" . #\u+0254) + ("Latin_Small_Letter_C_With_Curl" . #\u+0255) + ("Latin_Small_Letter_D_With_Tail" . #\u+0256) + ("Latin_Small_Letter_D_With_Hook" . #\u+0257) + ("Latin_Small_Letter_Reversed_E" . #\u+0258) + ("Latin_Small_Letter_Schwa" . #\u+0259) + ("Latin_Small_Letter_Schwa_With_Hook" . #\u+025a) + ("Latin_Small_Letter_Open_E" . #\u+025b) + ("Latin_Small_Letter_Reversed_Open_E" . #\u+025c) + ("Latin_Small_Letter_Reversed_Open_E_With_Hook" . #\u+025d) + ("Latin_Small_Letter_Closed_Reversed_Open_E" . #\u+025e) + ("Latin_Small_Letter_Dotless_J_With_Stroke" . #\u+025f) + ("Latin_Small_Letter_G_With_Hook" . #\u+0260) + ("Latin_Small_Letter_Script_G" . #\u+0261) + ("Latin_Letter_Small_Capital_G" . #\u+0262) + ("Latin_Small_Letter_Gamma" . #\u+0263) + ("Latin_Small_Letter_Rams_Horn" . #\u+0264) + ("Latin_Small_Letter_Turned_H" . #\u+0265) + ("Latin_Small_Letter_H_With_Hook" . #\u+0266) + ("Latin_Small_Letter_Heng_With_Hook" . #\u+0267) + ("Latin_Small_Letter_I_With_Stroke" . #\u+0268) + ("Latin_Small_Letter_Iota" . #\u+0269) + ("Latin_Letter_Small_Capital_I" . #\u+026a) + ("Latin_Small_Letter_L_With_Middle_Tilde" . #\u+026b) + ("Latin_Small_Letter_L_With_Belt" . #\u+026c) + ("Latin_Small_Letter_L_With_Retroflex_Hook" . #\u+026d) + ("Latin_Small_Letter_Lezh" . #\u+026e) + ("Latin_Small_Letter_Turned_M" . #\u+026f) + ("Latin_Small_Letter_Turned_M_With_Long_Leg" . #\u+0270) + ("Latin_Small_Letter_M_With_Hook" . #\u+0271) + ("Latin_Small_Letter_N_With_Left_Hook" . #\u+0272) + ("Latin_Small_Letter_N_With_Retroflex_Hook" . #\u+0273) + ("Latin_Letter_Small_Capital_N" . #\u+0274) + ("Latin_Small_Letter_Barred_O" . #\u+0275) + ("Latin_Letter_Small_Capital_Oe" . #\u+0276) + ("Latin_Small_Letter_Closed_Omega" . #\u+0277) + ("Latin_Small_Letter_Phi" . #\u+0278) + ("Latin_Small_Letter_Turned_R" . #\u+0279) + ("Latin_Small_Letter_Turned_R_With_Long_Leg" . #\u+027a) + ("Latin_Small_Letter_Turned_R_With_Hook" . #\u+027b) + ("Latin_Small_Letter_R_With_Long_Leg" . #\u+027c) + ("Latin_Small_Letter_R_With_Tail" . #\u+027d) + ("Latin_Small_Letter_R_With_Fishhook" . #\u+027e) + ("Latin_Small_Letter_Reversed_R_With_Fishhook" . #\u+027f) + ("Latin_Letter_Small_Capital_R" . #\u+0280) + ("Latin_Letter_Small_Capital_Inverted_R" . #\u+0281) + ("Latin_Small_Letter_S_With_Hook" . #\u+0282) + ("Latin_Small_Letter_Esh" . #\u+0283) + ("Latin_Small_Letter_Dotless_J_With_Stroke_And_Hook" . #\u+0284) + ("Latin_Small_Letter_Squat_Reversed_Esh" . #\u+0285) + ("Latin_Small_Letter_Esh_With_Curl" . #\u+0286) + ("Latin_Small_Letter_Turned_T" . #\u+0287) + ("Latin_Small_Letter_T_With_Retroflex_Hook" . #\u+0288) + ("Latin_Small_Letter_U_Bar" . #\u+0289) + ("Latin_Small_Letter_Upsilon" . #\u+028a) + ("Latin_Small_Letter_V_With_Hook" . #\u+028b) + ("Latin_Small_Letter_Turned_V" . #\u+028c) + ("Latin_Small_Letter_Turned_W" . #\u+028d) + ("Latin_Small_Letter_Turned_Y" . #\u+028e) + ("Latin_Letter_Small_Capital_Y" . #\u+028f) + ("Latin_Small_Letter_Z_With_Retroflex_Hook" . #\u+0290) + ("Latin_Small_Letter_Z_With_Curl" . #\u+0291) + ("Latin_Small_Letter_Ezh" . #\u+0292) + ("Latin_Small_Letter_Ezh_With_Curl" . #\u+0293) + ("Latin_Letter_Glottal_Stop" . #\u+0294) + ("Latin_Letter_Pharyngeal_Voiced_Fricative" . #\u+0295) + ("Latin_Letter_Inverted_Glottal_Stop" . #\u+0296) + ("Latin_Letter_Stretched_C" . #\u+0297) + ("Latin_Letter_Bilabial_Click" . #\u+0298) + ("Latin_Letter_Small_Capital_B" . #\u+0299) + ("Latin_Small_Letter_Closed_Open_E" . #\u+029a) + ("Latin_Letter_Small_Capital_G_With_Hook" . #\u+029b) + ("Latin_Letter_Small_Capital_H" . #\u+029c) + ("Latin_Small_Letter_J_With_Crossed-Tail" . #\u+029d) + ("Latin_Small_Letter_Turned_K" . #\u+029e) + ("Latin_Letter_Small_Capital_L" . #\u+029f) + ("Latin_Small_Letter_Q_With_Hook" . #\u+02a0) + ("Latin_Letter_Glottal_Stop_With_Stroke" . #\u+02a1) + ("Latin_Letter_Reversed_Glottal_Stop_With_Stroke" . #\u+02a2) + ("Latin_Small_Letter_Dz_Digraph" . #\u+02a3) + ("Latin_Small_Letter_Dezh_Digraph" . #\u+02a4) + ("Latin_Small_Letter_Dz_Digraph_With_Curl" . #\u+02a5) + ("Latin_Small_Letter_Ts_Digraph" . #\u+02a6) + ("Latin_Small_Letter_Tesh_Digraph" . #\u+02a7) + ("Latin_Small_Letter_Tc_Digraph_With_Curl" . #\u+02a8) + ("Latin_Small_Letter_Feng_Digraph" . #\u+02a9) + ("Latin_Small_Letter_Ls_Digraph" . #\u+02aa) + ("Latin_Small_Letter_Lz_Digraph" . #\u+02ab) + ("Latin_Letter_Bilabial_Percussive" . #\u+02ac) + ("Latin_Letter_Bidental_Percussive" . #\u+02ad) + ("Latin_Small_Letter_Turned_H_With_Fishhook" . #\u+02ae) + ("Latin_Small_Letter_Turned_H_With_Fishhook_And_Tail" . #\u+02af) + ("Modifier_Letter_Small_H" . #\u+02b0) + ("Modifier_Letter_Small_H_With_Hook" . #\u+02b1) + ("Modifier_Letter_Small_J" . #\u+02b2) + ("Modifier_Letter_Small_R" . #\u+02b3) + ("Modifier_Letter_Small_Turned_R" . #\u+02b4) + ("Modifier_Letter_Small_Turned_R_With_Hook" . #\u+02b5) + ("Modifier_Letter_Small_Capital_Inverted_R" . #\u+02b6) + ("Modifier_Letter_Small_W" . #\u+02b7) + ("Modifier_Letter_Small_Y" . #\u+02b8) + ("Modifier_Letter_Prime" . #\u+02b9) + ("Modifier_Letter_Double_Prime" . #\u+02ba) + ("Modifier_Letter_Turned_Comma" . #\u+02bb) + ("Modifier_Letter_Apostrophe" . #\u+02bc) + ("Modifier_Letter_Reversed_Comma" . #\u+02bd) + ("Modifier_Letter_Right_Half_Ring" . #\u+02be) + ("Modifier_Letter_Left_Half_Ring" . #\u+02bf) + ("Modifier_Letter_Glottal_Stop" . #\u+02c0) + ("Modifier_Letter_Reversed_Glottal_Stop" . #\u+02c1) + ("Modifier_Letter_Left_Arrowhead" . #\u+02c2) + ("Modifier_Letter_Right_Arrowhead" . #\u+02c3) + ("Modifier_Letter_Up_Arrowhead" . #\u+02c4) + ("Modifier_Letter_Down_Arrowhead" . #\u+02c5) + ("Modifier_Letter_Circumflex_Accent" . #\u+02c6) + ("Caron" . #\u+02c7) + ("Modifier_Letter_Vertical_Line" . #\u+02c8) + ("Modifier_Letter_Macron" . #\u+02c9) + ("Modifier_Letter_Acute_Accent" . #\u+02ca) + ("Modifier_Letter_Grave_Accent" . #\u+02cb) + ("Modifier_Letter_Low_Vertical_Line" . #\u+02cc) + ("Modifier_Letter_Low_Macron" . #\u+02cd) + ("Modifier_Letter_Low_Grave_Accent" . #\u+02ce) + ("Modifier_Letter_Low_Acute_Accent" . #\u+02cf) + ("Modifier_Letter_Triangular_Colon" . #\u+02d0) + ("Modifier_Letter_Half_Triangular_Colon" . #\u+02d1) + ("Modifier_Letter_Centred_Right_Half_Ring" . #\u+02d2) + ("Modifier_Letter_Centred_Left_Half_Ring" . #\u+02d3) + ("Modifier_Letter_Up_Tack" . #\u+02d4) + ("Modifier_Letter_Down_Tack" . #\u+02d5) + ("Modifier_Letter_Plus_Sign" . #\u+02d6) + ("Modifier_Letter_Minus_Sign" . #\u+02d7) + ("Breve" . #\u+02d8) + ("Dot_Above" . #\u+02d9) + ("Ring_Above" . #\u+02da) + ("Ogonek" . #\u+02db) + ("Small_Tilde" . #\u+02dc) + ("Double_Acute_Accent" . #\u+02dd) + ("Modifier_Letter_Rhotic_Hook" . #\u+02de) + ("Modifier_Letter_Cross_Accent" . #\u+02df) + ("Modifier_Letter_Small_Gamma" . #\u+02e0) + ("Modifier_Letter_Small_L" . #\u+02e1) + ("Modifier_Letter_Small_S" . #\u+02e2) + ("Modifier_Letter_Small_X" . #\u+02e3) + ("Modifier_Letter_Small_Reversed_Glottal_Stop" . #\u+02e4) + ("Modifier_Letter_Extra-High_Tone_Bar" . #\u+02e5) + ("Modifier_Letter_High_Tone_Bar" . #\u+02e6) + ("Modifier_Letter_Mid_Tone_Bar" . #\u+02e7) + ("Modifier_Letter_Low_Tone_Bar" . #\u+02e8) + ("Modifier_Letter_Extra-Low_Tone_Bar" . #\u+02e9) + ("Modifier_Letter_Yin_Departing_Tone_Mark" . #\u+02ea) + ("Modifier_Letter_Yang_Departing_Tone_Mark" . #\u+02eb) + ("Modifier_Letter_Voicing" . #\u+02ec) + ("Modifier_Letter_Unaspirated" . #\u+02ed) + ("Modifier_Letter_Double_Apostrophe" . #\u+02ee) + ("Modifier_Letter_Low_Down_Arrowhead" . #\u+02ef) + ("Modifier_Letter_Low_Up_Arrowhead" . #\u+02f0) + ("Modifier_Letter_Low_Left_Arrowhead" . #\u+02f1) + ("Modifier_Letter_Low_Right_Arrowhead" . #\u+02f2) + ("Modifier_Letter_Low_Ring" . #\u+02f3) + ("Modifier_Letter_Middle_Grave_Accent" . #\u+02f4) + ("Modifier_Letter_Middle_Double_Grave_Accent" . #\u+02f5) + ("Modifier_Letter_Middle_Double_Acute_Accent" . #\u+02f6) + ("Modifier_Letter_Low_Tilde" . #\u+02f7) + ("Modifier_Letter_Raised_Colon" . #\u+02f8) + ("Modifier_Letter_Begin_High_Tone" . #\u+02f9) + ("Modifier_Letter_End_High_Tone" . #\u+02fa) + ("Modifier_Letter_Begin_Low_Tone" . #\u+02fb) + ("Modifier_Letter_End_Low_Tone" . #\u+02fc) + ("Modifier_Letter_Shelf" . #\u+02fd) + ("Modifier_Letter_Open_Shelf" . #\u+02fe) + ("Modifier_Letter_Low_Left_Arrow" . #\u+02ff) + ("Combining_Grave_Accent" . #\u+0300) + ("Combining_Acute_Accent" . #\u+0301) + ("Combining_Circumflex_Accent" . #\u+0302) + ("Combining_Tilde" . #\u+0303) + ("Combining_Macron" . #\u+0304) + ("Combining_Overline" . #\u+0305) + ("Combining_Breve" . #\u+0306) + ("Combining_Dot_Above" . #\u+0307) + ("Combining_Diaeresis" . #\u+0308) + ("Combining_Hook_Above" . #\u+0309) + ("Combining_Ring_Above" . #\u+030a) + ("Combining_Double_Acute_Accent" . #\u+030b) + ("Combining_Caron" . #\u+030c) + ("Combining_Vertical_Line_Above" . #\u+030d) + ("Combining_Double_Vertical_Line_Above" . #\u+030e) + ("Combining_Double_Grave_Accent" . #\u+030f) + ("Combining_Candrabindu" . #\u+0310) + ("Combining_Inverted_Breve" . #\u+0311) + ("Combining_Turned_Comma_Above" . #\u+0312) + ("Combining_Comma_Above" . #\u+0313) + ("Combining_Reversed_Comma_Above" . #\u+0314) + ("Combining_Comma_Above_Right" . #\u+0315) + ("Combining_Grave_Accent_Below" . #\u+0316) + ("Combining_Acute_Accent_Below" . #\u+0317) + ("Combining_Left_Tack_Below" . #\u+0318) + ("Combining_Right_Tack_Below" . #\u+0319) + ("Combining_Left_Angle_Above" . #\u+031a) + ("Combining_Horn" . #\u+031b) + ("Combining_Left_Half_Ring_Below" . #\u+031c) + ("Combining_Up_Tack_Below" . #\u+031d) + ("Combining_Down_Tack_Below" . #\u+031e) + ("Combining_Plus_Sign_Below" . #\u+031f) + ("Combining_Minus_Sign_Below" . #\u+0320) + ("Combining_Palatalized_Hook_Below" . #\u+0321) + ("Combining_Retroflex_Hook_Below" . #\u+0322) + ("Combining_Dot_Below" . #\u+0323) + ("Combining_Diaeresis_Below" . #\u+0324) + ("Combining_Ring_Below" . #\u+0325) + ("Combining_Comma_Below" . #\u+0326) + ("Combining_Cedilla" . #\u+0327) + ("Combining_Ogonek" . #\u+0328) + ("Combining_Vertical_Line_Below" . #\u+0329) + ("Combining_Bridge_Below" . #\u+032a) + ("Combining_Inverted_Double_Arch_Below" . #\u+032b) + ("Combining_Caron_Below" . #\u+032c) + ("Combining_Circumflex_Accent_Below" . #\u+032d) + ("Combining_Breve_Below" . #\u+032e) + ("Combining_Inverted_Breve_Below" . #\u+032f) + ("Combining_Tilde_Below" . #\u+0330) + ("Combining_Macron_Below" . #\u+0331) + ("Combining_Low_Line" . #\u+0332) + ("Combining_Double_Low_Line" . #\u+0333) + ("Combining_Tilde_Overlay" . #\u+0334) + ("Combining_Short_Stroke_Overlay" . #\u+0335) + ("Combining_Long_Stroke_Overlay" . #\u+0336) + ("Combining_Short_Solidus_Overlay" . #\u+0337) + ("Combining_Long_Solidus_Overlay" . #\u+0338) + ("Combining_Right_Half_Ring_Below" . #\u+0339) + ("Combining_Inverted_Bridge_Below" . #\u+033a) + ("Combining_Square_Below" . #\u+033b) + ("Combining_Seagull_Below" . #\u+033c) + ("Combining_X_Above" . #\u+033d) + ("Combining_Vertical_Tilde" . #\u+033e) + ("Combining_Double_Overline" . #\u+033f) + ("Combining_Grave_Tone_Mark" . #\u+0340) + ("Combining_Acute_Tone_Mark" . #\u+0341) + ("Combining_Greek_Perispomeni" . #\u+0342) + ("Combining_Greek_Koronis" . #\u+0343) + ("Combining_Greek_Dialytika_Tonos" . #\u+0344) + ("Combining_Greek_Ypogegrammeni" . #\u+0345) + ("Combining_Bridge_Above" . #\u+0346) + ("Combining_Equals_Sign_Below" . #\u+0347) + ("Combining_Double_Vertical_Line_Below" . #\u+0348) + ("Combining_Left_Angle_Below" . #\u+0349) + ("Combining_Not_Tilde_Above" . #\u+034a) + ("Combining_Homothetic_Above" . #\u+034b) + ("Combining_Almost_Equal_To_Above" . #\u+034c) + ("Combining_Left_Right_Arrow_Below" . #\u+034d) + ("Combining_Upwards_Arrow_Below" . #\u+034e) + ("Combining_Grapheme_Joiner" . #\u+034f) + ("Combining_Right_Arrowhead_Above" . #\u+0350) + ("Combining_Left_Half_Ring_Above" . #\u+0351) + ("Combining_Fermata" . #\u+0352) + ("Combining_X_Below" . #\u+0353) + ("Combining_Left_Arrowhead_Below" . #\u+0354) + ("Combining_Right_Arrowhead_Below" . #\u+0355) + ("Combining_Right_Arrowhead_And_Up_Arrowhead_Below" . #\u+0356) + ("Combining_Right_Half_Ring_Above" . #\u+0357) + ("Combining_Dot_Above_Right" . #\u+0358) + ("Combining_Asterisk_Below" . #\u+0359) + ("Combining_Double_Ring_Below" . #\u+035a) + ("Combining_Zigzag_Above" . #\u+035b) + ("Combining_Double_Breve_Below" . #\u+035c) + ("Combining_Double_Breve" . #\u+035d) + ("Combining_Double_Macron" . #\u+035e) + ("Combining_Double_Macron_Below" . #\u+035f) + ("Combining_Double_Tilde" . #\u+0360) + ("Combining_Double_Inverted_Breve" . #\u+0361) + ("Combining_Double_Rightwards_Arrow_Below" . #\u+0362) + ("Combining_Latin_Small_Letter_A" . #\u+0363) + ("Combining_Latin_Small_Letter_E" . #\u+0364) + ("Combining_Latin_Small_Letter_I" . #\u+0365) + ("Combining_Latin_Small_Letter_O" . #\u+0366) + ("Combining_Latin_Small_Letter_U" . #\u+0367) + ("Combining_Latin_Small_Letter_C" . #\u+0368) + ("Combining_Latin_Small_Letter_D" . #\u+0369) + ("Combining_Latin_Small_Letter_H" . #\u+036a) + ("Combining_Latin_Small_Letter_M" . #\u+036b) + ("Combining_Latin_Small_Letter_R" . #\u+036c) + ("Combining_Latin_Small_Letter_T" . #\u+036d) + ("Combining_Latin_Small_Letter_V" . #\u+036e) + ("Combining_Latin_Small_Letter_X" . #\u+036f) + ("Greek_Numeral_Sign" . #\u+0374) + ("Greek_Lower_Numeral_Sign" . #\u+0375) + ("Greek_Ypogegrammeni" . #\u+037a) + ("Greek_Small_Reversed_Lunate_Sigma_Symbol" . #\u+037b) + ("Greek_Small_Dotted_Lunate_Sigma_Symbol" . #\u+037c) + ("Greek_Small_Reversed_Dotted_Lunate_Sigma_Symbol" . #\u+037d) + ("Greek_Question_Mark" . #\u+037e) + ("Greek_Tonos" . #\u+0384) + ("Greek_Dialytika_Tonos" . #\u+0385) + ("Greek_Capital_Letter_Alpha_With_Tonos" . #\u+0386) + ("Greek_Ano_Teleia" . #\u+0387) + ("Greek_Capital_Letter_Epsilon_With_Tonos" . #\u+0388) + ("Greek_Capital_Letter_Eta_With_Tonos" . #\u+0389) + ("Greek_Capital_Letter_Iota_With_Tonos" . #\u+038a) + ("Greek_Capital_Letter_Omicron_With_Tonos" . #\u+038c) + ("Greek_Capital_Letter_Upsilon_With_Tonos" . #\u+038e) + ("Greek_Capital_Letter_Omega_With_Tonos" . #\u+038f) + ("Greek_Small_Letter_Iota_With_Dialytika_And_Tonos" . #\u+0390) + ("Greek_Capital_Letter_Alpha" . #\u+0391) + ("Greek_Capital_Letter_Beta" . #\u+0392) + ("Greek_Capital_Letter_Gamma" . #\u+0393) + ("Greek_Capital_Letter_Delta" . #\u+0394) + ("Greek_Capital_Letter_Epsilon" . #\u+0395) + ("Greek_Capital_Letter_Zeta" . #\u+0396) + ("Greek_Capital_Letter_Eta" . #\u+0397) + ("Greek_Capital_Letter_Theta" . #\u+0398) + ("Greek_Capital_Letter_Iota" . #\u+0399) + ("Greek_Capital_Letter_Kappa" . #\u+039a) + ("Greek_Capital_Letter_Lamda" . #\u+039b) + ("Greek_Capital_Letter_Mu" . #\u+039c) + ("Greek_Capital_Letter_Nu" . #\u+039d) + ("Greek_Capital_Letter_Xi" . #\u+039e) + ("Greek_Capital_Letter_Omicron" . #\u+039f) + ("Greek_Capital_Letter_Pi" . #\u+03a0) + ("Greek_Capital_Letter_Rho" . #\u+03a1) + ("Greek_Capital_Letter_Sigma" . #\u+03a3) + ("Greek_Capital_Letter_Tau" . #\u+03a4) + ("Greek_Capital_Letter_Upsilon" . #\u+03a5) + ("Greek_Capital_Letter_Phi" . #\u+03a6) + ("Greek_Capital_Letter_Chi" . #\u+03a7) + ("Greek_Capital_Letter_Psi" . #\u+03a8) + ("Greek_Capital_Letter_Omega" . #\u+03a9) + ("Greek_Capital_Letter_Iota_With_Dialytika" . #\u+03aa) + ("Greek_Capital_Letter_Upsilon_With_Dialytika" . #\u+03ab) + ("Greek_Small_Letter_Alpha_With_Tonos" . #\u+03ac) + ("Greek_Small_Letter_Epsilon_With_Tonos" . #\u+03ad) + ("Greek_Small_Letter_Eta_With_Tonos" . #\u+03ae) + ("Greek_Small_Letter_Iota_With_Tonos" . #\u+03af) + ("Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos" . #\u+03b0) + ("Greek_Small_Letter_Alpha" . #\u+03b1) + ("Greek_Small_Letter_Beta" . #\u+03b2) + ("Greek_Small_Letter_Gamma" . #\u+03b3) + ("Greek_Small_Letter_Delta" . #\u+03b4) + ("Greek_Small_Letter_Epsilon" . #\u+03b5) + ("Greek_Small_Letter_Zeta" . #\u+03b6) + ("Greek_Small_Letter_Eta" . #\u+03b7) + ("Greek_Small_Letter_Theta" . #\u+03b8) + ("Greek_Small_Letter_Iota" . #\u+03b9) + ("Greek_Small_Letter_Kappa" . #\u+03ba) + ("Greek_Small_Letter_Lamda" . #\u+03bb) + ("Greek_Small_Letter_Mu" . #\u+03bc) + ("Greek_Small_Letter_Nu" . #\u+03bd) + ("Greek_Small_Letter_Xi" . #\u+03be) + ("Greek_Small_Letter_Omicron" . #\u+03bf) + ("Greek_Small_Letter_Pi" . #\u+03c0) + ("Greek_Small_Letter_Rho" . #\u+03c1) + ("Greek_Small_Letter_Final_Sigma" . #\u+03c2) + ("Greek_Small_Letter_Sigma" . #\u+03c3) + ("Greek_Small_Letter_Tau" . #\u+03c4) + ("Greek_Small_Letter_Upsilon" . #\u+03c5) + ("Greek_Small_Letter_Phi" . #\u+03c6) + ("Greek_Small_Letter_Chi" . #\u+03c7) + ("Greek_Small_Letter_Psi" . #\u+03c8) + ("Greek_Small_Letter_Omega" . #\u+03c9) + ("Greek_Small_Letter_Iota_With_Dialytika" . #\u+03ca) + ("Greek_Small_Letter_Upsilon_With_Dialytika" . #\u+03cb) + ("Greek_Small_Letter_Omicron_With_Tonos" . #\u+03cc) + ("Greek_Small_Letter_Upsilon_With_Tonos" . #\u+03cd) + ("Greek_Small_Letter_Omega_With_Tonos" . #\u+03ce) + ("Greek_Beta_Symbol" . #\u+03d0) + ("Greek_Theta_Symbol" . #\u+03d1) + ("Greek_Upsilon_With_Hook_Symbol" . #\u+03d2) + ("Greek_Upsilon_With_Acute_And_Hook_Symbol" . #\u+03d3) + ("Greek_Upsilon_With_Diaeresis_And_Hook_Symbol" . #\u+03d4) + ("Greek_Phi_Symbol" . #\u+03d5) + ("Greek_Pi_Symbol" . #\u+03d6) + ("Greek_Kai_Symbol" . #\u+03d7) + ("Greek_Letter_Archaic_Koppa" . #\u+03d8) + ("Greek_Small_Letter_Archaic_Koppa" . #\u+03d9) + ("Greek_Letter_Stigma" . #\u+03da) + ("Greek_Small_Letter_Stigma" . #\u+03db) + ("Greek_Letter_Digamma" . #\u+03dc) + ("Greek_Small_Letter_Digamma" . #\u+03dd) + ("Greek_Letter_Koppa" . #\u+03de) + ("Greek_Small_Letter_Koppa" . #\u+03df) + ("Greek_Letter_Sampi" . #\u+03e0) + ("Greek_Small_Letter_Sampi" . #\u+03e1) + ("Coptic_Capital_Letter_Shei" . #\u+03e2) + ("Coptic_Small_Letter_Shei" . #\u+03e3) + ("Coptic_Capital_Letter_Fei" . #\u+03e4) + ("Coptic_Small_Letter_Fei" . #\u+03e5) + ("Coptic_Capital_Letter_Khei" . #\u+03e6) + ("Coptic_Small_Letter_Khei" . #\u+03e7) + ("Coptic_Capital_Letter_Hori" . #\u+03e8) + ("Coptic_Small_Letter_Hori" . #\u+03e9) + ("Coptic_Capital_Letter_Gangia" . #\u+03ea) + ("Coptic_Small_Letter_Gangia" . #\u+03eb) + ("Coptic_Capital_Letter_Shima" . #\u+03ec) + ("Coptic_Small_Letter_Shima" . #\u+03ed) + ("Coptic_Capital_Letter_Dei" . #\u+03ee) + ("Coptic_Small_Letter_Dei" . #\u+03ef) + ("Greek_Kappa_Symbol" . #\u+03f0) + ("Greek_Rho_Symbol" . #\u+03f1) + ("Greek_Lunate_Sigma_Symbol" . #\u+03f2) + ("Greek_Letter_Yot" . #\u+03f3) + ("Greek_Capital_Theta_Symbol" . #\u+03f4) + ("Greek_Lunate_Epsilon_Symbol" . #\u+03f5) + ("Greek_Reversed_Lunate_Epsilon_Symbol" . #\u+03f6) + ("Greek_Capital_Letter_Sho" . #\u+03f7) + ("Greek_Small_Letter_Sho" . #\u+03f8) + ("Greek_Capital_Lunate_Sigma_Symbol" . #\u+03f9) + ("Greek_Capital_Letter_San" . #\u+03fa) + ("Greek_Small_Letter_San" . #\u+03fb) + ("Greek_Rho_With_Stroke_Symbol" . #\u+03fc) + ("Greek_Capital_Reversed_Lunate_Sigma_Symbol" . #\u+03fd) + ("Greek_Capital_Dotted_Lunate_Sigma_Symbol" . #\u+03fe) + ("Greek_Capital_Reversed_Dotted_Lunate_Sigma_Symbol" . #\u+03ff) + ("Cyrillic_Capital_Letter_Ie_With_Grave" . #\u+0400) + ("Cyrillic_Capital_Letter_Io" . #\u+0401) + ("Cyrillic_Capital_Letter_Dje" . #\u+0402) + ("Cyrillic_Capital_Letter_Gje" . #\u+0403) + ("Cyrillic_Capital_Letter_Ukrainian_Ie" . #\u+0404) + ("Cyrillic_Capital_Letter_Dze" . #\u+0405) + ("Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I" . #\u+0406) + ("Cyrillic_Capital_Letter_Yi" . #\u+0407) + ("Cyrillic_Capital_Letter_Je" . #\u+0408) + ("Cyrillic_Capital_Letter_Lje" . #\u+0409) + ("Cyrillic_Capital_Letter_Nje" . #\u+040a) + ("Cyrillic_Capital_Letter_Tshe" . #\u+040b) + ("Cyrillic_Capital_Letter_Kje" . #\u+040c) + ("Cyrillic_Capital_Letter_I_With_Grave" . #\u+040d) + ("Cyrillic_Capital_Letter_Short_U" . #\u+040e) + ("Cyrillic_Capital_Letter_Dzhe" . #\u+040f) + ("Cyrillic_Capital_Letter_A" . #\u+0410) + ("Cyrillic_Capital_Letter_Be" . #\u+0411) + ("Cyrillic_Capital_Letter_Ve" . #\u+0412) + ("Cyrillic_Capital_Letter_Ghe" . #\u+0413) + ("Cyrillic_Capital_Letter_De" . #\u+0414) + ("Cyrillic_Capital_Letter_Ie" . #\u+0415) + ("Cyrillic_Capital_Letter_Zhe" . #\u+0416) + ("Cyrillic_Capital_Letter_Ze" . #\u+0417) + ("Cyrillic_Capital_Letter_I" . #\u+0418) + ("Cyrillic_Capital_Letter_Short_I" . #\u+0419) + ("Cyrillic_Capital_Letter_Ka" . #\u+041a) + ("Cyrillic_Capital_Letter_El" . #\u+041b) + ("Cyrillic_Capital_Letter_Em" . #\u+041c) + ("Cyrillic_Capital_Letter_En" . #\u+041d) + ("Cyrillic_Capital_Letter_O" . #\u+041e) + ("Cyrillic_Capital_Letter_Pe" . #\u+041f) + ("Cyrillic_Capital_Letter_Er" . #\u+0420) + ("Cyrillic_Capital_Letter_Es" . #\u+0421) + ("Cyrillic_Capital_Letter_Te" . #\u+0422) + ("Cyrillic_Capital_Letter_U" . #\u+0423) + ("Cyrillic_Capital_Letter_Ef" . #\u+0424) + ("Cyrillic_Capital_Letter_Ha" . #\u+0425) + ("Cyrillic_Capital_Letter_Tse" . #\u+0426) + ("Cyrillic_Capital_Letter_Che" . #\u+0427) + ("Cyrillic_Capital_Letter_Sha" . #\u+0428) + ("Cyrillic_Capital_Letter_Shcha" . #\u+0429) + ("Cyrillic_Capital_Letter_Hard_Sign" . #\u+042a) + ("Cyrillic_Capital_Letter_Yeru" . #\u+042b) + ("Cyrillic_Capital_Letter_Soft_Sign" . #\u+042c) + ("Cyrillic_Capital_Letter_E" . #\u+042d) + ("Cyrillic_Capital_Letter_Yu" . #\u+042e) + ("Cyrillic_Capital_Letter_Ya" . #\u+042f) + ("Cyrillic_Small_Letter_A" . #\u+0430) + ("Cyrillic_Small_Letter_Be" . #\u+0431) + ("Cyrillic_Small_Letter_Ve" . #\u+0432) + ("Cyrillic_Small_Letter_Ghe" . #\u+0433) + ("Cyrillic_Small_Letter_De" . #\u+0434) + ("Cyrillic_Small_Letter_Ie" . #\u+0435) + ("Cyrillic_Small_Letter_Zhe" . #\u+0436) + ("Cyrillic_Small_Letter_Ze" . #\u+0437) + ("Cyrillic_Small_Letter_I" . #\u+0438) + ("Cyrillic_Small_Letter_Short_I" . #\u+0439) + ("Cyrillic_Small_Letter_Ka" . #\u+043a) + ("Cyrillic_Small_Letter_El" . #\u+043b) + ("Cyrillic_Small_Letter_Em" . #\u+043c) + ("Cyrillic_Small_Letter_En" . #\u+043d) + ("Cyrillic_Small_Letter_O" . #\u+043e) + ("Cyrillic_Small_Letter_Pe" . #\u+043f) + ("Cyrillic_Small_Letter_Er" . #\u+0440) + ("Cyrillic_Small_Letter_Es" . #\u+0441) + ("Cyrillic_Small_Letter_Te" . #\u+0442) + ("Cyrillic_Small_Letter_U" . #\u+0443) + ("Cyrillic_Small_Letter_Ef" . #\u+0444) + ("Cyrillic_Small_Letter_Ha" . #\u+0445) + ("Cyrillic_Small_Letter_Tse" . #\u+0446) + ("Cyrillic_Small_Letter_Che" . #\u+0447) + ("Cyrillic_Small_Letter_Sha" . #\u+0448) + ("Cyrillic_Small_Letter_Shcha" . #\u+0449) + ("Cyrillic_Small_Letter_Hard_Sign" . #\u+044a) + ("Cyrillic_Small_Letter_Yeru" . #\u+044b) + ("Cyrillic_Small_Letter_Soft_Sign" . #\u+044c) + ("Cyrillic_Small_Letter_E" . #\u+044d) + ("Cyrillic_Small_Letter_Yu" . #\u+044e) + ("Cyrillic_Small_Letter_Ya" . #\u+044f) + ("Cyrillic_Small_Letter_Ie_With_Grave" . #\u+0450) + ("Cyrillic_Small_Letter_Io" . #\u+0451) + ("Cyrillic_Small_Letter_Dje" . #\u+0452) + ("Cyrillic_Small_Letter_Gje" . #\u+0453) + ("Cyrillic_Small_Letter_Ukrainian_Ie" . #\u+0454) + ("Cyrillic_Small_Letter_Dze" . #\u+0455) + ("Cyrillic_Small_Letter_Byelorussian-Ukrainian_I" . #\u+0456) + ("Cyrillic_Small_Letter_Yi" . #\u+0457) + ("Cyrillic_Small_Letter_Je" . #\u+0458) + ("Cyrillic_Small_Letter_Lje" . #\u+0459) + ("Cyrillic_Small_Letter_Nje" . #\u+045a) + ("Cyrillic_Small_Letter_Tshe" . #\u+045b) + ("Cyrillic_Small_Letter_Kje" . #\u+045c) + ("Cyrillic_Small_Letter_I_With_Grave" . #\u+045d) + ("Cyrillic_Small_Letter_Short_U" . #\u+045e) + ("Cyrillic_Small_Letter_Dzhe" . #\u+045f) + ("Cyrillic_Capital_Letter_Omega" . #\u+0460) + ("Cyrillic_Small_Letter_Omega" . #\u+0461) + ("Cyrillic_Capital_Letter_Yat" . #\u+0462) + ("Cyrillic_Small_Letter_Yat" . #\u+0463) + ("Cyrillic_Capital_Letter_Iotified_E" . #\u+0464) + ("Cyrillic_Small_Letter_Iotified_E" . #\u+0465) + ("Cyrillic_Capital_Letter_Little_Yus" . #\u+0466) + ("Cyrillic_Small_Letter_Little_Yus" . #\u+0467) + ("Cyrillic_Capital_Letter_Iotified_Little_Yus" . #\u+0468) + ("Cyrillic_Small_Letter_Iotified_Little_Yus" . #\u+0469) + ("Cyrillic_Capital_Letter_Big_Yus" . #\u+046a) + ("Cyrillic_Small_Letter_Big_Yus" . #\u+046b) + ("Cyrillic_Capital_Letter_Iotified_Big_Yus" . #\u+046c) + ("Cyrillic_Small_Letter_Iotified_Big_Yus" . #\u+046d) + ("Cyrillic_Capital_Letter_Ksi" . #\u+046e) + ("Cyrillic_Small_Letter_Ksi" . #\u+046f) + ("Cyrillic_Capital_Letter_Psi" . #\u+0470) + ("Cyrillic_Small_Letter_Psi" . #\u+0471) + ("Cyrillic_Capital_Letter_Fita" . #\u+0472) + ("Cyrillic_Small_Letter_Fita" . #\u+0473) + ("Cyrillic_Capital_Letter_Izhitsa" . #\u+0474) + ("Cyrillic_Small_Letter_Izhitsa" . #\u+0475) + ("Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent" . #\u+0476) + ("Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent" . #\u+0477) + ("Cyrillic_Capital_Letter_Uk" . #\u+0478) + ("Cyrillic_Small_Letter_Uk" . #\u+0479) + ("Cyrillic_Capital_Letter_Round_Omega" . #\u+047a) + ("Cyrillic_Small_Letter_Round_Omega" . #\u+047b) + ("Cyrillic_Capital_Letter_Omega_With_Titlo" . #\u+047c) + ("Cyrillic_Small_Letter_Omega_With_Titlo" . #\u+047d) + ("Cyrillic_Capital_Letter_Ot" . #\u+047e) + ("Cyrillic_Small_Letter_Ot" . #\u+047f) + ("Cyrillic_Capital_Letter_Koppa" . #\u+0480) + ("Cyrillic_Small_Letter_Koppa" . #\u+0481) + ("Cyrillic_Thousands_Sign" . #\u+0482) + ("Combining_Cyrillic_Titlo" . #\u+0483) + ("Combining_Cyrillic_Palatalization" . #\u+0484) + ("Combining_Cyrillic_Dasia_Pneumata" . #\u+0485) + ("Combining_Cyrillic_Psili_Pneumata" . #\u+0486) + ("Combining_Cyrillic_Hundred_Thousands_Sign" . #\u+0488) + ("Combining_Cyrillic_Millions_Sign" . #\u+0489) + ("Cyrillic_Capital_Letter_Short_I_With_Tail" . #\u+048a) + ("Cyrillic_Small_Letter_Short_I_With_Tail" . #\u+048b) + ("Cyrillic_Capital_Letter_Semisoft_Sign" . #\u+048c) + ("Cyrillic_Small_Letter_Semisoft_Sign" . #\u+048d) + ("Cyrillic_Capital_Letter_Er_With_Tick" . #\u+048e) + ("Cyrillic_Small_Letter_Er_With_Tick" . #\u+048f) + ("Cyrillic_Capital_Letter_Ghe_With_Upturn" . #\u+0490) + ("Cyrillic_Small_Letter_Ghe_With_Upturn" . #\u+0491) + ("Cyrillic_Capital_Letter_Ghe_With_Stroke" . #\u+0492) + ("Cyrillic_Small_Letter_Ghe_With_Stroke" . #\u+0493) + ("Cyrillic_Capital_Letter_Ghe_With_Middle_Hook" . #\u+0494) + ("Cyrillic_Small_Letter_Ghe_With_Middle_Hook" . #\u+0495) + ("Cyrillic_Capital_Letter_Zhe_With_Descender" . #\u+0496) + ("Cyrillic_Small_Letter_Zhe_With_Descender" . #\u+0497) + ("Cyrillic_Capital_Letter_Ze_With_Descender" . #\u+0498) + ("Cyrillic_Small_Letter_Ze_With_Descender" . #\u+0499) + ("Cyrillic_Capital_Letter_Ka_With_Descender" . #\u+049a) + ("Cyrillic_Small_Letter_Ka_With_Descender" . #\u+049b) + ("Cyrillic_Capital_Letter_Ka_With_Vertical_Stroke" . #\u+049c) + ("Cyrillic_Small_Letter_Ka_With_Vertical_Stroke" . #\u+049d) + ("Cyrillic_Capital_Letter_Ka_With_Stroke" . #\u+049e) + ("Cyrillic_Small_Letter_Ka_With_Stroke" . #\u+049f) + ("Cyrillic_Capital_Letter_Bashkir_Ka" . #\u+04a0) + ("Cyrillic_Small_Letter_Bashkir_Ka" . #\u+04a1) + ("Cyrillic_Capital_Letter_En_With_Descender" . #\u+04a2) + ("Cyrillic_Small_Letter_En_With_Descender" . #\u+04a3) + ("Cyrillic_Capital_Ligature_En_Ghe" . #\u+04a4) + ("Cyrillic_Small_Ligature_En_Ghe" . #\u+04a5) + ("Cyrillic_Capital_Letter_Pe_With_Middle_Hook" . #\u+04a6) + ("Cyrillic_Small_Letter_Pe_With_Middle_Hook" . #\u+04a7) + ("Cyrillic_Capital_Letter_Abkhasian_Ha" . #\u+04a8) + ("Cyrillic_Small_Letter_Abkhasian_Ha" . #\u+04a9) + ("Cyrillic_Capital_Letter_Es_With_Descender" . #\u+04aa) + ("Cyrillic_Small_Letter_Es_With_Descender" . #\u+04ab) + ("Cyrillic_Capital_Letter_Te_With_Descender" . #\u+04ac) + ("Cyrillic_Small_Letter_Te_With_Descender" . #\u+04ad) + ("Cyrillic_Capital_Letter_Straight_U" . #\u+04ae) + ("Cyrillic_Small_Letter_Straight_U" . #\u+04af) + ("Cyrillic_Capital_Letter_Straight_U_With_Stroke" . #\u+04b0) + ("Cyrillic_Small_Letter_Straight_U_With_Stroke" . #\u+04b1) + ("Cyrillic_Capital_Letter_Ha_With_Descender" . #\u+04b2) + ("Cyrillic_Small_Letter_Ha_With_Descender" . #\u+04b3) + ("Cyrillic_Capital_Ligature_Te_Tse" . #\u+04b4) + ("Cyrillic_Small_Ligature_Te_Tse" . #\u+04b5) + ("Cyrillic_Capital_Letter_Che_With_Descender" . #\u+04b6) + ("Cyrillic_Small_Letter_Che_With_Descender" . #\u+04b7) + ("Cyrillic_Capital_Letter_Che_With_Vertical_Stroke" . #\u+04b8) + ("Cyrillic_Small_Letter_Che_With_Vertical_Stroke" . #\u+04b9) + ("Cyrillic_Capital_Letter_Shha" . #\u+04ba) + ("Cyrillic_Small_Letter_Shha" . #\u+04bb) + ("Cyrillic_Capital_Letter_Abkhasian_Che" . #\u+04bc) + ("Cyrillic_Small_Letter_Abkhasian_Che" . #\u+04bd) + ("Cyrillic_Capital_Letter_Abkhasian_Che_With_Descender" . #\u+04be) + ("Cyrillic_Small_Letter_Abkhasian_Che_With_Descender" . #\u+04bf) + ("Cyrillic_Letter_Palochka" . #\u+04c0) + ("Cyrillic_Capital_Letter_Zhe_With_Breve" . #\u+04c1) + ("Cyrillic_Small_Letter_Zhe_With_Breve" . #\u+04c2) + ("Cyrillic_Capital_Letter_Ka_With_Hook" . #\u+04c3) + ("Cyrillic_Small_Letter_Ka_With_Hook" . #\u+04c4) + ("Cyrillic_Capital_Letter_El_With_Tail" . #\u+04c5) + ("Cyrillic_Small_Letter_El_With_Tail" . #\u+04c6) + ("Cyrillic_Capital_Letter_En_With_Hook" . #\u+04c7) + ("Cyrillic_Small_Letter_En_With_Hook" . #\u+04c8) + ("Cyrillic_Capital_Letter_En_With_Tail" . #\u+04c9) + ("Cyrillic_Small_Letter_En_With_Tail" . #\u+04ca) + ("Cyrillic_Capital_Letter_Khakassian_Che" . #\u+04cb) + ("Cyrillic_Small_Letter_Khakassian_Che" . #\u+04cc) + ("Cyrillic_Capital_Letter_Em_With_Tail" . #\u+04cd) + ("Cyrillic_Small_Letter_Em_With_Tail" . #\u+04ce) + ("Cyrillic_Small_Letter_Palochka" . #\u+04cf) + ("Cyrillic_Capital_Letter_A_With_Breve" . #\u+04d0) + ("Cyrillic_Small_Letter_A_With_Breve" . #\u+04d1) + ("Cyrillic_Capital_Letter_A_With_Diaeresis" . #\u+04d2) + ("Cyrillic_Small_Letter_A_With_Diaeresis" . #\u+04d3) + ("Cyrillic_Capital_Ligature_A_Ie" . #\u+04d4) + ("Cyrillic_Small_Ligature_A_Ie" . #\u+04d5) + ("Cyrillic_Capital_Letter_Ie_With_Breve" . #\u+04d6) + ("Cyrillic_Small_Letter_Ie_With_Breve" . #\u+04d7) + ("Cyrillic_Capital_Letter_Schwa" . #\u+04d8) + ("Cyrillic_Small_Letter_Schwa" . #\u+04d9) + ("Cyrillic_Capital_Letter_Schwa_With_Diaeresis" . #\u+04da) + ("Cyrillic_Small_Letter_Schwa_With_Diaeresis" . #\u+04db) + ("Cyrillic_Capital_Letter_Zhe_With_Diaeresis" . #\u+04dc) + ("Cyrillic_Small_Letter_Zhe_With_Diaeresis" . #\u+04dd) + ("Cyrillic_Capital_Letter_Ze_With_Diaeresis" . #\u+04de) + ("Cyrillic_Small_Letter_Ze_With_Diaeresis" . #\u+04df) + ("Cyrillic_Capital_Letter_Abkhasian_Dze" . #\u+04e0) + ("Cyrillic_Small_Letter_Abkhasian_Dze" . #\u+04e1) + ("Cyrillic_Capital_Letter_I_With_Macron" . #\u+04e2) + ("Cyrillic_Small_Letter_I_With_Macron" . #\u+04e3) + ("Cyrillic_Capital_Letter_I_With_Diaeresis" . #\u+04e4) + ("Cyrillic_Small_Letter_I_With_Diaeresis" . #\u+04e5) + ("Cyrillic_Capital_Letter_O_With_Diaeresis" . #\u+04e6) + ("Cyrillic_Small_Letter_O_With_Diaeresis" . #\u+04e7) + ("Cyrillic_Capital_Letter_Barred_O" . #\u+04e8) + ("Cyrillic_Small_Letter_Barred_O" . #\u+04e9) + ("Cyrillic_Capital_Letter_Barred_O_With_Diaeresis" . #\u+04ea) + ("Cyrillic_Small_Letter_Barred_O_With_Diaeresis" . #\u+04eb) + ("Cyrillic_Capital_Letter_E_With_Diaeresis" . #\u+04ec) + ("Cyrillic_Small_Letter_E_With_Diaeresis" . #\u+04ed) + ("Cyrillic_Capital_Letter_U_With_Macron" . #\u+04ee) + ("Cyrillic_Small_Letter_U_With_Macron" . #\u+04ef) + ("Cyrillic_Capital_Letter_U_With_Diaeresis" . #\u+04f0) + ("Cyrillic_Small_Letter_U_With_Diaeresis" . #\u+04f1) + ("Cyrillic_Capital_Letter_U_With_Double_Acute" . #\u+04f2) + ("Cyrillic_Small_Letter_U_With_Double_Acute" . #\u+04f3) + ("Cyrillic_Capital_Letter_Che_With_Diaeresis" . #\u+04f4) + ("Cyrillic_Small_Letter_Che_With_Diaeresis" . #\u+04f5) + ("Cyrillic_Capital_Letter_Ghe_With_Descender" . #\u+04f6) + ("Cyrillic_Small_Letter_Ghe_With_Descender" . #\u+04f7) + ("Cyrillic_Capital_Letter_Yeru_With_Diaeresis" . #\u+04f8) + ("Cyrillic_Small_Letter_Yeru_With_Diaeresis" . #\u+04f9) + ("Cyrillic_Capital_Letter_Ghe_With_Stroke_And_Hook" . #\u+04fa) + ("Cyrillic_Small_Letter_Ghe_With_Stroke_And_Hook" . #\u+04fb) + ("Cyrillic_Capital_Letter_Ha_With_Hook" . #\u+04fc) + ("Cyrillic_Small_Letter_Ha_With_Hook" . #\u+04fd) + ("Cyrillic_Capital_Letter_Ha_With_Stroke" . #\u+04fe) + ("Cyrillic_Small_Letter_Ha_With_Stroke" . #\u+04ff) + ("Cyrillic_Capital_Letter_Komi_De" . #\u+0500) + ("Cyrillic_Small_Letter_Komi_De" . #\u+0501) + ("Cyrillic_Capital_Letter_Komi_Dje" . #\u+0502) + ("Cyrillic_Small_Letter_Komi_Dje" . #\u+0503) + ("Cyrillic_Capital_Letter_Komi_Zje" . #\u+0504) + ("Cyrillic_Small_Letter_Komi_Zje" . #\u+0505) + ("Cyrillic_Capital_Letter_Komi_Dzje" . #\u+0506) + ("Cyrillic_Small_Letter_Komi_Dzje" . #\u+0507) + ("Cyrillic_Capital_Letter_Komi_Lje" . #\u+0508) + ("Cyrillic_Small_Letter_Komi_Lje" . #\u+0509) + ("Cyrillic_Capital_Letter_Komi_Nje" . #\u+050a) + ("Cyrillic_Small_Letter_Komi_Nje" . #\u+050b) + ("Cyrillic_Capital_Letter_Komi_Sje" . #\u+050c) + ("Cyrillic_Small_Letter_Komi_Sje" . #\u+050d) + ("Cyrillic_Capital_Letter_Komi_Tje" . #\u+050e) + ("Cyrillic_Small_Letter_Komi_Tje" . #\u+050f) + ("Cyrillic_Capital_Letter_Reversed_Ze" . #\u+0510) + ("Cyrillic_Small_Letter_Reversed_Ze" . #\u+0511) + ("Cyrillic_Capital_Letter_El_With_Hook" . #\u+0512) + ("Cyrillic_Small_Letter_El_With_Hook" . #\u+0513) + ("Armenian_Capital_Letter_Ayb" . #\u+0531) + ("Armenian_Capital_Letter_Ben" . #\u+0532) + ("Armenian_Capital_Letter_Gim" . #\u+0533) + ("Armenian_Capital_Letter_Da" . #\u+0534) + ("Armenian_Capital_Letter_Ech" . #\u+0535) + ("Armenian_Capital_Letter_Za" . #\u+0536) + ("Armenian_Capital_Letter_Eh" . #\u+0537) + ("Armenian_Capital_Letter_Et" . #\u+0538) + ("Armenian_Capital_Letter_To" . #\u+0539) + ("Armenian_Capital_Letter_Zhe" . #\u+053a) + ("Armenian_Capital_Letter_Ini" . #\u+053b) + ("Armenian_Capital_Letter_Liwn" . #\u+053c) + ("Armenian_Capital_Letter_Xeh" . #\u+053d) + ("Armenian_Capital_Letter_Ca" . #\u+053e) + ("Armenian_Capital_Letter_Ken" . #\u+053f) + ("Armenian_Capital_Letter_Ho" . #\u+0540) + ("Armenian_Capital_Letter_Ja" . #\u+0541) + ("Armenian_Capital_Letter_Ghad" . #\u+0542) + ("Armenian_Capital_Letter_Cheh" . #\u+0543) + ("Armenian_Capital_Letter_Men" . #\u+0544) + ("Armenian_Capital_Letter_Yi" . #\u+0545) + ("Armenian_Capital_Letter_Now" . #\u+0546) + ("Armenian_Capital_Letter_Sha" . #\u+0547) + ("Armenian_Capital_Letter_Vo" . #\u+0548) + ("Armenian_Capital_Letter_Cha" . #\u+0549) + ("Armenian_Capital_Letter_Peh" . #\u+054a) + ("Armenian_Capital_Letter_Jheh" . #\u+054b) + ("Armenian_Capital_Letter_Ra" . #\u+054c) + ("Armenian_Capital_Letter_Seh" . #\u+054d) + ("Armenian_Capital_Letter_Vew" . #\u+054e) + ("Armenian_Capital_Letter_Tiwn" . #\u+054f) + ("Armenian_Capital_Letter_Reh" . #\u+0550) + ("Armenian_Capital_Letter_Co" . #\u+0551) + ("Armenian_Capital_Letter_Yiwn" . #\u+0552) + ("Armenian_Capital_Letter_Piwr" . #\u+0553) + ("Armenian_Capital_Letter_Keh" . #\u+0554) + ("Armenian_Capital_Letter_Oh" . #\u+0555) + ("Armenian_Capital_Letter_Feh" . #\u+0556) + ("Armenian_Modifier_Letter_Left_Half_Ring" . #\u+0559) + ("Armenian_Apostrophe" . #\u+055a) + ("Armenian_Emphasis_Mark" . #\u+055b) + ("Armenian_Exclamation_Mark" . #\u+055c) + ("Armenian_Comma" . #\u+055d) + ("Armenian_Question_Mark" . #\u+055e) + ("Armenian_Abbreviation_Mark" . #\u+055f) + ("Armenian_Small_Letter_Ayb" . #\u+0561) + ("Armenian_Small_Letter_Ben" . #\u+0562) + ("Armenian_Small_Letter_Gim" . #\u+0563) + ("Armenian_Small_Letter_Da" . #\u+0564) + ("Armenian_Small_Letter_Ech" . #\u+0565) + ("Armenian_Small_Letter_Za" . #\u+0566) + ("Armenian_Small_Letter_Eh" . #\u+0567) + ("Armenian_Small_Letter_Et" . #\u+0568) + ("Armenian_Small_Letter_To" . #\u+0569) + ("Armenian_Small_Letter_Zhe" . #\u+056a) + ("Armenian_Small_Letter_Ini" . #\u+056b) + ("Armenian_Small_Letter_Liwn" . #\u+056c) + ("Armenian_Small_Letter_Xeh" . #\u+056d) + ("Armenian_Small_Letter_Ca" . #\u+056e) + ("Armenian_Small_Letter_Ken" . #\u+056f) + ("Armenian_Small_Letter_Ho" . #\u+0570) + ("Armenian_Small_Letter_Ja" . #\u+0571) + ("Armenian_Small_Letter_Ghad" . #\u+0572) + ("Armenian_Small_Letter_Cheh" . #\u+0573) + ("Armenian_Small_Letter_Men" . #\u+0574) + ("Armenian_Small_Letter_Yi" . #\u+0575) + ("Armenian_Small_Letter_Now" . #\u+0576) + ("Armenian_Small_Letter_Sha" . #\u+0577) + ("Armenian_Small_Letter_Vo" . #\u+0578) + ("Armenian_Small_Letter_Cha" . #\u+0579) + ("Armenian_Small_Letter_Peh" . #\u+057a) + ("Armenian_Small_Letter_Jheh" . #\u+057b) + ("Armenian_Small_Letter_Ra" . #\u+057c) + ("Armenian_Small_Letter_Seh" . #\u+057d) + ("Armenian_Small_Letter_Vew" . #\u+057e) + ("Armenian_Small_Letter_Tiwn" . #\u+057f) + ("Armenian_Small_Letter_Reh" . #\u+0580) + ("Armenian_Small_Letter_Co" . #\u+0581) + ("Armenian_Small_Letter_Yiwn" . #\u+0582) + ("Armenian_Small_Letter_Piwr" . #\u+0583) + ("Armenian_Small_Letter_Keh" . #\u+0584) + ("Armenian_Small_Letter_Oh" . #\u+0585) + ("Armenian_Small_Letter_Feh" . #\u+0586) + ("Armenian_Small_Ligature_Ech_Yiwn" . #\u+0587) + ("Armenian_Full_Stop" . #\u+0589) + ("Armenian_Hyphen" . #\u+058a) + ("Hebrew_Accent_Etnahta" . #\u+0591) + ("Hebrew_Accent_Segol" . #\u+0592) + ("Hebrew_Accent_Shalshelet" . #\u+0593) + ("Hebrew_Accent_Zaqef_Qatan" . #\u+0594) + ("Hebrew_Accent_Zaqef_Gadol" . #\u+0595) + ("Hebrew_Accent_Tipeha" . #\u+0596) + ("Hebrew_Accent_Revia" . #\u+0597) + ("Hebrew_Accent_Zarqa" . #\u+0598) + ("Hebrew_Accent_Pashta" . #\u+0599) + ("Hebrew_Accent_Yetiv" . #\u+059a) + ("Hebrew_Accent_Tevir" . #\u+059b) + ("Hebrew_Accent_Geresh" . #\u+059c) + ("Hebrew_Accent_Geresh_Muqdam" . #\u+059d) + ("Hebrew_Accent_Gershayim" . #\u+059e) + ("Hebrew_Accent_Qarney_Para" . #\u+059f) + ("Hebrew_Accent_Telisha_Gedola" . #\u+05a0) + ("Hebrew_Accent_Pazer" . #\u+05a1) + ("Hebrew_Accent_Atnah_Hafukh" . #\u+05a2) + ("Hebrew_Accent_Munah" . #\u+05a3) + ("Hebrew_Accent_Mahapakh" . #\u+05a4) + ("Hebrew_Accent_Merkha" . #\u+05a5) + ("Hebrew_Accent_Merkha_Kefula" . #\u+05a6) + ("Hebrew_Accent_Darga" . #\u+05a7) + ("Hebrew_Accent_Qadma" . #\u+05a8) + ("Hebrew_Accent_Telisha_Qetana" . #\u+05a9) + ("Hebrew_Accent_Yerah_Ben_Yomo" . #\u+05aa) + ("Hebrew_Accent_Ole" . #\u+05ab) + ("Hebrew_Accent_Iluy" . #\u+05ac) + ("Hebrew_Accent_Dehi" . #\u+05ad) + ("Hebrew_Accent_Zinor" . #\u+05ae) + ("Hebrew_Mark_Masora_Circle" . #\u+05af) + ("Hebrew_Point_Sheva" . #\u+05b0) + ("Hebrew_Point_Hataf_Segol" . #\u+05b1) + ("Hebrew_Point_Hataf_Patah" . #\u+05b2) + ("Hebrew_Point_Hataf_Qamats" . #\u+05b3) + ("Hebrew_Point_Hiriq" . #\u+05b4) + ("Hebrew_Point_Tsere" . #\u+05b5) + ("Hebrew_Point_Segol" . #\u+05b6) + ("Hebrew_Point_Patah" . #\u+05b7) + ("Hebrew_Point_Qamats" . #\u+05b8) + ("Hebrew_Point_Holam" . #\u+05b9) + ("Hebrew_Point_Holam_Haser_For_Vav" . #\u+05ba) + ("Hebrew_Point_Qubuts" . #\u+05bb) + ("Hebrew_Point_Dagesh_Or_Mapiq" . #\u+05bc) + ("Hebrew_Point_Meteg" . #\u+05bd) + ("Hebrew_Punctuation_Maqaf" . #\u+05be) + ("Hebrew_Point_Rafe" . #\u+05bf) + ("Hebrew_Punctuation_Paseq" . #\u+05c0) + ("Hebrew_Point_Shin_Dot" . #\u+05c1) + ("Hebrew_Point_Sin_Dot" . #\u+05c2) + ("Hebrew_Punctuation_Sof_Pasuq" . #\u+05c3) + ("Hebrew_Mark_Upper_Dot" . #\u+05c4) + ("Hebrew_Mark_Lower_Dot" . #\u+05c5) + ("Hebrew_Punctuation_Nun_Hafukha" . #\u+05c6) + ("Hebrew_Point_Qamats_Qatan" . #\u+05c7) + ("Hebrew_Letter_Alef" . #\u+05d0) + ("Hebrew_Letter_Bet" . #\u+05d1) + ("Hebrew_Letter_Gimel" . #\u+05d2) + ("Hebrew_Letter_Dalet" . #\u+05d3) + ("Hebrew_Letter_He" . #\u+05d4) + ("Hebrew_Letter_Vav" . #\u+05d5) + ("Hebrew_Letter_Zayin" . #\u+05d6) + ("Hebrew_Letter_Het" . #\u+05d7) + ("Hebrew_Letter_Tet" . #\u+05d8) + ("Hebrew_Letter_Yod" . #\u+05d9) + ("Hebrew_Letter_Final_Kaf" . #\u+05da) + ("Hebrew_Letter_Kaf" . #\u+05db) + ("Hebrew_Letter_Lamed" . #\u+05dc) + ("Hebrew_Letter_Final_Mem" . #\u+05dd) + ("Hebrew_Letter_Mem" . #\u+05de) + ("Hebrew_Letter_Final_Nun" . #\u+05df) + ("Hebrew_Letter_Nun" . #\u+05e0) + ("Hebrew_Letter_Samekh" . #\u+05e1) + ("Hebrew_Letter_Ayin" . #\u+05e2) + ("Hebrew_Letter_Final_Pe" . #\u+05e3) + ("Hebrew_Letter_Pe" . #\u+05e4) + ("Hebrew_Letter_Final_Tsadi" . #\u+05e5) + ("Hebrew_Letter_Tsadi" . #\u+05e6) + ("Hebrew_Letter_Qof" . #\u+05e7) + ("Hebrew_Letter_Resh" . #\u+05e8) + ("Hebrew_Letter_Shin" . #\u+05e9) + ("Hebrew_Letter_Tav" . #\u+05ea) + ("Hebrew_Ligature_Yiddish_Double_Vav" . #\u+05f0) + ("Hebrew_Ligature_Yiddish_Vav_Yod" . #\u+05f1) + ("Hebrew_Ligature_Yiddish_Double_Yod" . #\u+05f2) + ("Hebrew_Punctuation_Geresh" . #\u+05f3) + ("Hebrew_Punctuation_Gershayim" . #\u+05f4) + ("Arabic_Number_Sign" . #\u+0600) + ("Arabic_Sign_Sanah" . #\u+0601) + ("Arabic_Footnote_Marker" . #\u+0602) + ("Arabic_Sign_Safha" . #\u+0603) + ("Afghani_Sign" . #\u+060b) + ("Arabic_Comma" . #\u+060c) + ("Arabic_Date_Separator" . #\u+060d) + ("Arabic_Poetic_Verse_Sign" . #\u+060e) + ("Arabic_Sign_Misra" . #\u+060f) + ("Arabic_Sign_Sallallahou_Alayhe_Wassallam" . #\u+0610) + ("Arabic_Sign_Alayhe_Assallam" . #\u+0611) + ("Arabic_Sign_Rahmatullah_Alayhe" . #\u+0612) + ("Arabic_Sign_Radi_Allahou_Anhu" . #\u+0613) + ("Arabic_Sign_Takhallus" . #\u+0614) + ("Arabic_Small_High_Tah" . #\u+0615) + ("Arabic_Semicolon" . #\u+061b) + ("Arabic_Triple_Dot_Punctuation_Mark" . #\u+061e) + ("Arabic_Question_Mark" . #\u+061f) + ("Arabic_Letter_Hamza" . #\u+0621) + ("Arabic_Letter_Alef_With_Madda_Above" . #\u+0622) + ("Arabic_Letter_Alef_With_Hamza_Above" . #\u+0623) + ("Arabic_Letter_Waw_With_Hamza_Above" . #\u+0624) + ("Arabic_Letter_Alef_With_Hamza_Below" . #\u+0625) + ("Arabic_Letter_Yeh_With_Hamza_Above" . #\u+0626) + ("Arabic_Letter_Alef" . #\u+0627) + ("Arabic_Letter_Beh" . #\u+0628) + ("Arabic_Letter_Teh_Marbuta" . #\u+0629) + ("Arabic_Letter_Teh" . #\u+062a) + ("Arabic_Letter_Theh" . #\u+062b) + ("Arabic_Letter_Jeem" . #\u+062c) + ("Arabic_Letter_Hah" . #\u+062d) + ("Arabic_Letter_Khah" . #\u+062e) + ("Arabic_Letter_Dal" . #\u+062f) + ("Arabic_Letter_Thal" . #\u+0630) + ("Arabic_Letter_Reh" . #\u+0631) + ("Arabic_Letter_Zain" . #\u+0632) + ("Arabic_Letter_Seen" . #\u+0633) + ("Arabic_Letter_Sheen" . #\u+0634) + ("Arabic_Letter_Sad" . #\u+0635) + ("Arabic_Letter_Dad" . #\u+0636) + ("Arabic_Letter_Tah" . #\u+0637) + ("Arabic_Letter_Zah" . #\u+0638) + ("Arabic_Letter_Ain" . #\u+0639) + ("Arabic_Letter_Ghain" . #\u+063a) + ("Arabic_Tatweel" . #\u+0640) + ("Arabic_Letter_Feh" . #\u+0641) + ("Arabic_Letter_Qaf" . #\u+0642) + ("Arabic_Letter_Kaf" . #\u+0643) + ("Arabic_Letter_Lam" . #\u+0644) + ("Arabic_Letter_Meem" . #\u+0645) + ("Arabic_Letter_Noon" . #\u+0646) + ("Arabic_Letter_Heh" . #\u+0647) + ("Arabic_Letter_Waw" . #\u+0648) + ("Arabic_Letter_Alef_Maksura" . #\u+0649) + ("Arabic_Letter_Yeh" . #\u+064a) + ("Arabic_Fathatan" . #\u+064b) + ("Arabic_Dammatan" . #\u+064c) + ("Arabic_Kasratan" . #\u+064d) + ("Arabic_Fatha" . #\u+064e) + ("Arabic_Damma" . #\u+064f) + ("Arabic_Kasra" . #\u+0650) + ("Arabic_Shadda" . #\u+0651) + ("Arabic_Sukun" . #\u+0652) + ("Arabic_Maddah_Above" . #\u+0653) + ("Arabic_Hamza_Above" . #\u+0654) + ("Arabic_Hamza_Below" . #\u+0655) + ("Arabic_Subscript_Alef" . #\u+0656) + ("Arabic_Inverted_Damma" . #\u+0657) + ("Arabic_Mark_Noon_Ghunna" . #\u+0658) + ("Arabic_Zwarakay" . #\u+0659) + ("Arabic_Vowel_Sign_Small_V_Above" . #\u+065a) + ("Arabic_Vowel_Sign_Inverted_Small_V_Above" . #\u+065b) + ("Arabic_Vowel_Sign_Dot_Below" . #\u+065c) + ("Arabic_Reversed_Damma" . #\u+065d) + ("Arabic_Fatha_With_Two_Dots" . #\u+065e) + ("Arabic-Indic_Digit_Zero" . #\u+0660) + ("Arabic-Indic_Digit_One" . #\u+0661) + ("Arabic-Indic_Digit_Two" . #\u+0662) + ("Arabic-Indic_Digit_Three" . #\u+0663) + ("Arabic-Indic_Digit_Four" . #\u+0664) + ("Arabic-Indic_Digit_Five" . #\u+0665) + ("Arabic-Indic_Digit_Six" . #\u+0666) + ("Arabic-Indic_Digit_Seven" . #\u+0667) + ("Arabic-Indic_Digit_Eight" . #\u+0668) + ("Arabic-Indic_Digit_Nine" . #\u+0669) + ("Arabic_Percent_Sign" . #\u+066a) + ("Arabic_Decimal_Separator" . #\u+066b) + ("Arabic_Thousands_Separator" . #\u+066c) + ("Arabic_Five_Pointed_Star" . #\u+066d) + ("Arabic_Letter_Dotless_Beh" . #\u+066e) + ("Arabic_Letter_Dotless_Qaf" . #\u+066f) + ("Arabic_Letter_Superscript_Alef" . #\u+0670) + ("Arabic_Letter_Alef_Wasla" . #\u+0671) + ("Arabic_Letter_Alef_With_Wavy_Hamza_Above" . #\u+0672) + ("Arabic_Letter_Alef_With_Wavy_Hamza_Below" . #\u+0673) + ("Arabic_Letter_High_Hamza" . #\u+0674) + ("Arabic_Letter_High_Hamza_Alef" . #\u+0675) + ("Arabic_Letter_High_Hamza_Waw" . #\u+0676) + ("Arabic_Letter_U_With_Hamza_Above" . #\u+0677) + ("Arabic_Letter_High_Hamza_Yeh" . #\u+0678) + ("Arabic_Letter_Tteh" . #\u+0679) + ("Arabic_Letter_Tteheh" . #\u+067a) + ("Arabic_Letter_Beeh" . #\u+067b) + ("Arabic_Letter_Teh_With_Ring" . #\u+067c) + ("Arabic_Letter_Teh_With_Three_Dots_Above_Downwards" . #\u+067d) + ("Arabic_Letter_Peh" . #\u+067e) + ("Arabic_Letter_Teheh" . #\u+067f) + ("Arabic_Letter_Beheh" . #\u+0680) + ("Arabic_Letter_Hah_With_Hamza_Above" . #\u+0681) + ("Arabic_Letter_Hah_With_Two_Dots_Vertical_Above" . #\u+0682) + ("Arabic_Letter_Nyeh" . #\u+0683) + ("Arabic_Letter_Dyeh" . #\u+0684) + ("Arabic_Letter_Hah_With_Three_Dots_Above" . #\u+0685) + ("Arabic_Letter_Tcheh" . #\u+0686) + ("Arabic_Letter_Tcheheh" . #\u+0687) + ("Arabic_Letter_Ddal" . #\u+0688) + ("Arabic_Letter_Dal_With_Ring" . #\u+0689) + ("Arabic_Letter_Dal_With_Dot_Below" . #\u+068a) + ("Arabic_Letter_Dal_With_Dot_Below_And_Small_Tah" . #\u+068b) + ("Arabic_Letter_Dahal" . #\u+068c) + ("Arabic_Letter_Ddahal" . #\u+068d) + ("Arabic_Letter_Dul" . #\u+068e) + ("Arabic_Letter_Dal_With_Three_Dots_Above_Downwards" . #\u+068f) + ("Arabic_Letter_Dal_With_Four_Dots_Above" . #\u+0690) + ("Arabic_Letter_Rreh" . #\u+0691) + ("Arabic_Letter_Reh_With_Small_V" . #\u+0692) + ("Arabic_Letter_Reh_With_Ring" . #\u+0693) + ("Arabic_Letter_Reh_With_Dot_Below" . #\u+0694) + ("Arabic_Letter_Reh_With_Small_V_Below" . #\u+0695) + ("Arabic_Letter_Reh_With_Dot_Below_And_Dot_Above" . #\u+0696) + ("Arabic_Letter_Reh_With_Two_Dots_Above" . #\u+0697) + ("Arabic_Letter_Jeh" . #\u+0698) + ("Arabic_Letter_Reh_With_Four_Dots_Above" . #\u+0699) + ("Arabic_Letter_Seen_With_Dot_Below_And_Dot_Above" . #\u+069a) + ("Arabic_Letter_Seen_With_Three_Dots_Below" . #\u+069b) + ("Arabic_Letter_Seen_With_Three_Dots_Below_And_Three_Dots_Above" . #\u+069c) + ("Arabic_Letter_Sad_With_Two_Dots_Below" . #\u+069d) + ("Arabic_Letter_Sad_With_Three_Dots_Above" . #\u+069e) + ("Arabic_Letter_Tah_With_Three_Dots_Above" . #\u+069f) + ("Arabic_Letter_Ain_With_Three_Dots_Above" . #\u+06a0) + ("Arabic_Letter_Dotless_Feh" . #\u+06a1) + ("Arabic_Letter_Feh_With_Dot_Moved_Below" . #\u+06a2) + ("Arabic_Letter_Feh_With_Dot_Below" . #\u+06a3) + ("Arabic_Letter_Veh" . #\u+06a4) + ("Arabic_Letter_Feh_With_Three_Dots_Below" . #\u+06a5) + ("Arabic_Letter_Peheh" . #\u+06a6) + ("Arabic_Letter_Qaf_With_Dot_Above" . #\u+06a7) + ("Arabic_Letter_Qaf_With_Three_Dots_Above" . #\u+06a8) + ("Arabic_Letter_Keheh" . #\u+06a9) + ("Arabic_Letter_Swash_Kaf" . #\u+06aa) + ("Arabic_Letter_Kaf_With_Ring" . #\u+06ab) + ("Arabic_Letter_Kaf_With_Dot_Above" . #\u+06ac) + ("Arabic_Letter_Ng" . #\u+06ad) + ("Arabic_Letter_Kaf_With_Three_Dots_Below" . #\u+06ae) + ("Arabic_Letter_Gaf" . #\u+06af) + ("Arabic_Letter_Gaf_With_Ring" . #\u+06b0) + ("Arabic_Letter_Ngoeh" . #\u+06b1) + ("Arabic_Letter_Gaf_With_Two_Dots_Below" . #\u+06b2) + ("Arabic_Letter_Gueh" . #\u+06b3) + ("Arabic_Letter_Gaf_With_Three_Dots_Above" . #\u+06b4) + ("Arabic_Letter_Lam_With_Small_V" . #\u+06b5) + ("Arabic_Letter_Lam_With_Dot_Above" . #\u+06b6) + ("Arabic_Letter_Lam_With_Three_Dots_Above" . #\u+06b7) + ("Arabic_Letter_Lam_With_Three_Dots_Below" . #\u+06b8) + ("Arabic_Letter_Noon_With_Dot_Below" . #\u+06b9) + ("Arabic_Letter_Noon_Ghunna" . #\u+06ba) + ("Arabic_Letter_Rnoon" . #\u+06bb) + ("Arabic_Letter_Noon_With_Ring" . #\u+06bc) + ("Arabic_Letter_Noon_With_Three_Dots_Above" . #\u+06bd) + ("Arabic_Letter_Heh_Doachashmee" . #\u+06be) + ("Arabic_Letter_Tcheh_With_Dot_Above" . #\u+06bf) + ("Arabic_Letter_Heh_With_Yeh_Above" . #\u+06c0) + ("Arabic_Letter_Heh_Goal" . #\u+06c1) + ("Arabic_Letter_Heh_Goal_With_Hamza_Above" . #\u+06c2) + ("Arabic_Letter_Teh_Marbuta_Goal" . #\u+06c3) + ("Arabic_Letter_Waw_With_Ring" . #\u+06c4) + ("Arabic_Letter_Kirghiz_Oe" . #\u+06c5) + ("Arabic_Letter_Oe" . #\u+06c6) + ("Arabic_Letter_U" . #\u+06c7) + ("Arabic_Letter_Yu" . #\u+06c8) + ("Arabic_Letter_Kirghiz_Yu" . #\u+06c9) + ("Arabic_Letter_Waw_With_Two_Dots_Above" . #\u+06ca) + ("Arabic_Letter_Ve" . #\u+06cb) + ("Arabic_Letter_Farsi_Yeh" . #\u+06cc) + ("Arabic_Letter_Yeh_With_Tail" . #\u+06cd) + ("Arabic_Letter_Yeh_With_Small_V" . #\u+06ce) + ("Arabic_Letter_Waw_With_Dot_Above" . #\u+06cf) + ("Arabic_Letter_E" . #\u+06d0) + ("Arabic_Letter_Yeh_With_Three_Dots_Below" . #\u+06d1) + ("Arabic_Letter_Yeh_Barree" . #\u+06d2) + ("Arabic_Letter_Yeh_Barree_With_Hamza_Above" . #\u+06d3) + ("Arabic_Full_Stop" . #\u+06d4) + ("Arabic_Letter_Ae" . #\u+06d5) + ("Arabic_Small_High_Ligature_Sad_With_Lam_With_Alef_Maksura" . #\u+06d6) + ("Arabic_Small_High_Ligature_Qaf_With_Lam_With_Alef_Maksura" . #\u+06d7) + ("Arabic_Small_High_Meem_Initial_Form" . #\u+06d8) + ("Arabic_Small_High_Lam_Alef" . #\u+06d9) + ("Arabic_Small_High_Jeem" . #\u+06da) + ("Arabic_Small_High_Three_Dots" . #\u+06db) + ("Arabic_Small_High_Seen" . #\u+06dc) + ("Arabic_End_Of_Ayah" . #\u+06dd) + ("Arabic_Start_Of_Rub_El_Hizb" . #\u+06de) + ("Arabic_Small_High_Rounded_Zero" . #\u+06df) + ("Arabic_Small_High_Upright_Rectangular_Zero" . #\u+06e0) + ("Arabic_Small_High_Dotless_Head_Of_Khah" . #\u+06e1) + ("Arabic_Small_High_Meem_Isolated_Form" . #\u+06e2) + ("Arabic_Small_Low_Seen" . #\u+06e3) + ("Arabic_Small_High_Madda" . #\u+06e4) + ("Arabic_Small_Waw" . #\u+06e5) + ("Arabic_Small_Yeh" . #\u+06e6) + ("Arabic_Small_High_Yeh" . #\u+06e7) + ("Arabic_Small_High_Noon" . #\u+06e8) + ("Arabic_Place_Of_Sajdah" . #\u+06e9) + ("Arabic_Empty_Centre_Low_Stop" . #\u+06ea) + ("Arabic_Empty_Centre_High_Stop" . #\u+06eb) + ("Arabic_Rounded_High_Stop_With_Filled_Centre" . #\u+06ec) + ("Arabic_Small_Low_Meem" . #\u+06ed) + ("Arabic_Letter_Dal_With_Inverted_V" . #\u+06ee) + ("Arabic_Letter_Reh_With_Inverted_V" . #\u+06ef) + ("Extended_Arabic-Indic_Digit_Zero" . #\u+06f0) + ("Extended_Arabic-Indic_Digit_One" . #\u+06f1) + ("Extended_Arabic-Indic_Digit_Two" . #\u+06f2) + ("Extended_Arabic-Indic_Digit_Three" . #\u+06f3) + ("Extended_Arabic-Indic_Digit_Four" . #\u+06f4) + ("Extended_Arabic-Indic_Digit_Five" . #\u+06f5) + ("Extended_Arabic-Indic_Digit_Six" . #\u+06f6) + ("Extended_Arabic-Indic_Digit_Seven" . #\u+06f7) + ("Extended_Arabic-Indic_Digit_Eight" . #\u+06f8) + ("Extended_Arabic-Indic_Digit_Nine" . #\u+06f9) + ("Arabic_Letter_Sheen_With_Dot_Below" . #\u+06fa) + ("Arabic_Letter_Dad_With_Dot_Below" . #\u+06fb) + ("Arabic_Letter_Ghain_With_Dot_Below" . #\u+06fc) + ("Arabic_Sign_Sindhi_Ampersand" . #\u+06fd) + ("Arabic_Sign_Sindhi_Postposition_Men" . #\u+06fe) + ("Arabic_Letter_Heh_With_Inverted_V" . #\u+06ff) + ("Syriac_End_Of_Paragraph" . #\u+0700) + ("Syriac_Supralinear_Full_Stop" . #\u+0701) + ("Syriac_Sublinear_Full_Stop" . #\u+0702) + ("Syriac_Supralinear_Colon" . #\u+0703) + ("Syriac_Sublinear_Colon" . #\u+0704) + ("Syriac_Horizontal_Colon" . #\u+0705) + ("Syriac_Colon_Skewed_Left" . #\u+0706) + ("Syriac_Colon_Skewed_Right" . #\u+0707) + ("Syriac_Supralinear_Colon_Skewed_Left" . #\u+0708) + ("Syriac_Sublinear_Colon_Skewed_Right" . #\u+0709) + ("Syriac_Contraction" . #\u+070a) + ("Syriac_Harklean_Obelus" . #\u+070b) + ("Syriac_Harklean_Metobelus" . #\u+070c) + ("Syriac_Harklean_Asteriscus" . #\u+070d) + ("Syriac_Abbreviation_Mark" . #\u+070f) + ("Syriac_Letter_Alaph" . #\u+0710) + ("Syriac_Letter_Superscript_Alaph" . #\u+0711) + ("Syriac_Letter_Beth" . #\u+0712) + ("Syriac_Letter_Gamal" . #\u+0713) + ("Syriac_Letter_Gamal_Garshuni" . #\u+0714) + ("Syriac_Letter_Dalath" . #\u+0715) + ("Syriac_Letter_Dotless_Dalath_Rish" . #\u+0716) + ("Syriac_Letter_He" . #\u+0717) + ("Syriac_Letter_Waw" . #\u+0718) + ("Syriac_Letter_Zain" . #\u+0719) + ("Syriac_Letter_Heth" . #\u+071a) + ("Syriac_Letter_Teth" . #\u+071b) + ("Syriac_Letter_Teth_Garshuni" . #\u+071c) + ("Syriac_Letter_Yudh" . #\u+071d) + ("Syriac_Letter_Yudh_He" . #\u+071e) + ("Syriac_Letter_Kaph" . #\u+071f) + ("Syriac_Letter_Lamadh" . #\u+0720) + ("Syriac_Letter_Mim" . #\u+0721) + ("Syriac_Letter_Nun" . #\u+0722) + ("Syriac_Letter_Semkath" . #\u+0723) + ("Syriac_Letter_Final_Semkath" . #\u+0724) + ("Syriac_Letter_E" . #\u+0725) + ("Syriac_Letter_Pe" . #\u+0726) + ("Syriac_Letter_Reversed_Pe" . #\u+0727) + ("Syriac_Letter_Sadhe" . #\u+0728) + ("Syriac_Letter_Qaph" . #\u+0729) + ("Syriac_Letter_Rish" . #\u+072a) + ("Syriac_Letter_Shin" . #\u+072b) + ("Syriac_Letter_Taw" . #\u+072c) + ("Syriac_Letter_Persian_Bheth" . #\u+072d) + ("Syriac_Letter_Persian_Ghamal" . #\u+072e) + ("Syriac_Letter_Persian_Dhalath" . #\u+072f) + ("Syriac_Pthaha_Above" . #\u+0730) + ("Syriac_Pthaha_Below" . #\u+0731) + ("Syriac_Pthaha_Dotted" . #\u+0732) + ("Syriac_Zqapha_Above" . #\u+0733) + ("Syriac_Zqapha_Below" . #\u+0734) + ("Syriac_Zqapha_Dotted" . #\u+0735) + ("Syriac_Rbasa_Above" . #\u+0736) + ("Syriac_Rbasa_Below" . #\u+0737) + ("Syriac_Dotted_Zlama_Horizontal" . #\u+0738) + ("Syriac_Dotted_Zlama_Angular" . #\u+0739) + ("Syriac_Hbasa_Above" . #\u+073a) + ("Syriac_Hbasa_Below" . #\u+073b) + ("Syriac_Hbasa-Esasa_Dotted" . #\u+073c) + ("Syriac_Esasa_Above" . #\u+073d) + ("Syriac_Esasa_Below" . #\u+073e) + ("Syriac_Rwaha" . #\u+073f) + ("Syriac_Feminine_Dot" . #\u+0740) + ("Syriac_Qushshaya" . #\u+0741) + ("Syriac_Rukkakha" . #\u+0742) + ("Syriac_Two_Vertical_Dots_Above" . #\u+0743) + ("Syriac_Two_Vertical_Dots_Below" . #\u+0744) + ("Syriac_Three_Dots_Above" . #\u+0745) + ("Syriac_Three_Dots_Below" . #\u+0746) + ("Syriac_Oblique_Line_Above" . #\u+0747) + ("Syriac_Oblique_Line_Below" . #\u+0748) + ("Syriac_Music" . #\u+0749) + ("Syriac_Barrekh" . #\u+074a) + ("Syriac_Letter_Sogdian_Zhain" . #\u+074d) + ("Syriac_Letter_Sogdian_Khaph" . #\u+074e) + ("Syriac_Letter_Sogdian_Fe" . #\u+074f) + ("Arabic_Letter_Beh_With_Three_Dots_Horizontally_Below" . #\u+0750) + ("Arabic_Letter_Beh_With_Dot_Below_And_Three_Dots_Above" . #\u+0751) + ("Arabic_Letter_Beh_With_Three_Dots_Pointing_Upwards_Below" . #\u+0752) + ("Arabic_Letter_Beh_With_Three_Dots_Pointing_Upwards_Below_And_Two_Dots_Above" . #\u+0753) + ("Arabic_Letter_Beh_With_Two_Dots_Below_And_Dot_Above" . #\u+0754) + ("Arabic_Letter_Beh_With_Inverted_Small_V_Below" . #\u+0755) + ("Arabic_Letter_Beh_With_Small_V" . #\u+0756) + ("Arabic_Letter_Hah_With_Two_Dots_Above" . #\u+0757) + ("Arabic_Letter_Hah_With_Three_Dots_Pointing_Upwards_Below" . #\u+0758) + ("Arabic_Letter_Dal_With_Two_Dots_Vertically_Below_And_Small_Tah" . #\u+0759) + ("Arabic_Letter_Dal_With_Inverted_Small_V_Below" . #\u+075a) + ("Arabic_Letter_Reh_With_Stroke" . #\u+075b) + ("Arabic_Letter_Seen_With_Four_Dots_Above" . #\u+075c) + ("Arabic_Letter_Ain_With_Two_Dots_Above" . #\u+075d) + ("Arabic_Letter_Ain_With_Three_Dots_Pointing_Downwards_Above" . #\u+075e) + ("Arabic_Letter_Ain_With_Two_Dots_Vertically_Above" . #\u+075f) + ("Arabic_Letter_Feh_With_Two_Dots_Below" . #\u+0760) + ("Arabic_Letter_Feh_With_Three_Dots_Pointing_Upwards_Below" . #\u+0761) + ("Arabic_Letter_Keheh_With_Dot_Above" . #\u+0762) + ("Arabic_Letter_Keheh_With_Three_Dots_Above" . #\u+0763) + ("Arabic_Letter_Keheh_With_Three_Dots_Pointing_Upwards_Below" . #\u+0764) + ("Arabic_Letter_Meem_With_Dot_Above" . #\u+0765) + ("Arabic_Letter_Meem_With_Dot_Below" . #\u+0766) + ("Arabic_Letter_Noon_With_Two_Dots_Below" . #\u+0767) + ("Arabic_Letter_Noon_With_Small_Tah" . #\u+0768) + ("Arabic_Letter_Noon_With_Small_V" . #\u+0769) + ("Arabic_Letter_Lam_With_Bar" . #\u+076a) + ("Arabic_Letter_Reh_With_Two_Dots_Vertically_Above" . #\u+076b) + ("Arabic_Letter_Reh_With_Hamza_Above" . #\u+076c) + ("Arabic_Letter_Seen_With_Two_Dots_Vertically_Above" . #\u+076d) + ("Thaana_Letter_Haa" . #\u+0780) + ("Thaana_Letter_Shaviyani" . #\u+0781) + ("Thaana_Letter_Noonu" . #\u+0782) + ("Thaana_Letter_Raa" . #\u+0783) + ("Thaana_Letter_Baa" . #\u+0784) + ("Thaana_Letter_Lhaviyani" . #\u+0785) + ("Thaana_Letter_Kaafu" . #\u+0786) + ("Thaana_Letter_Alifu" . #\u+0787) + ("Thaana_Letter_Vaavu" . #\u+0788) + ("Thaana_Letter_Meemu" . #\u+0789) + ("Thaana_Letter_Faafu" . #\u+078a) + ("Thaana_Letter_Dhaalu" . #\u+078b) + ("Thaana_Letter_Thaa" . #\u+078c) + ("Thaana_Letter_Laamu" . #\u+078d) + ("Thaana_Letter_Gaafu" . #\u+078e) + ("Thaana_Letter_Gnaviyani" . #\u+078f) + ("Thaana_Letter_Seenu" . #\u+0790) + ("Thaana_Letter_Daviyani" . #\u+0791) + ("Thaana_Letter_Zaviyani" . #\u+0792) + ("Thaana_Letter_Taviyani" . #\u+0793) + ("Thaana_Letter_Yaa" . #\u+0794) + ("Thaana_Letter_Paviyani" . #\u+0795) + ("Thaana_Letter_Javiyani" . #\u+0796) + ("Thaana_Letter_Chaviyani" . #\u+0797) + ("Thaana_Letter_Ttaa" . #\u+0798) + ("Thaana_Letter_Hhaa" . #\u+0799) + ("Thaana_Letter_Khaa" . #\u+079a) + ("Thaana_Letter_Thaalu" . #\u+079b) + ("Thaana_Letter_Zaa" . #\u+079c) + ("Thaana_Letter_Sheenu" . #\u+079d) + ("Thaana_Letter_Saadhu" . #\u+079e) + ("Thaana_Letter_Daadhu" . #\u+079f) + ("Thaana_Letter_To" . #\u+07a0) + ("Thaana_Letter_Zo" . #\u+07a1) + ("Thaana_Letter_Ainu" . #\u+07a2) + ("Thaana_Letter_Ghainu" . #\u+07a3) + ("Thaana_Letter_Qaafu" . #\u+07a4) + ("Thaana_Letter_Waavu" . #\u+07a5) + ("Thaana_Abafili" . #\u+07a6) + ("Thaana_Aabaafili" . #\u+07a7) + ("Thaana_Ibifili" . #\u+07a8) + ("Thaana_Eebeefili" . #\u+07a9) + ("Thaana_Ubufili" . #\u+07aa) + ("Thaana_Ooboofili" . #\u+07ab) + ("Thaana_Ebefili" . #\u+07ac) + ("Thaana_Eybeyfili" . #\u+07ad) + ("Thaana_Obofili" . #\u+07ae) + ("Thaana_Oaboafili" . #\u+07af) + ("Thaana_Sukun" . #\u+07b0) + ("Thaana_Letter_Naa" . #\u+07b1) + ("Nko_Digit_Zero" . #\u+07c0) + ("Nko_Digit_One" . #\u+07c1) + ("Nko_Digit_Two" . #\u+07c2) + ("Nko_Digit_Three" . #\u+07c3) + ("Nko_Digit_Four" . #\u+07c4) + ("Nko_Digit_Five" . #\u+07c5) + ("Nko_Digit_Six" . #\u+07c6) + ("Nko_Digit_Seven" . #\u+07c7) + ("Nko_Digit_Eight" . #\u+07c8) + ("Nko_Digit_Nine" . #\u+07c9) + ("Nko_Letter_A" . #\u+07ca) + ("Nko_Letter_Ee" . #\u+07cb) + ("Nko_Letter_I" . #\u+07cc) + ("Nko_Letter_E" . #\u+07cd) + ("Nko_Letter_U" . #\u+07ce) + ("Nko_Letter_Oo" . #\u+07cf) + ("Nko_Letter_O" . #\u+07d0) + ("Nko_Letter_Dagbasinna" . #\u+07d1) + ("Nko_Letter_N" . #\u+07d2) + ("Nko_Letter_Ba" . #\u+07d3) + ("Nko_Letter_Pa" . #\u+07d4) + ("Nko_Letter_Ta" . #\u+07d5) + ("Nko_Letter_Ja" . #\u+07d6) + ("Nko_Letter_Cha" . #\u+07d7) + ("Nko_Letter_Da" . #\u+07d8) + ("Nko_Letter_Ra" . #\u+07d9) + ("Nko_Letter_Rra" . #\u+07da) + ("Nko_Letter_Sa" . #\u+07db) + ("Nko_Letter_Gba" . #\u+07dc) + ("Nko_Letter_Fa" . #\u+07dd) + ("Nko_Letter_Ka" . #\u+07de) + ("Nko_Letter_La" . #\u+07df) + ("Nko_Letter_Na_Woloso" . #\u+07e0) + ("Nko_Letter_Ma" . #\u+07e1) + ("Nko_Letter_Nya" . #\u+07e2) + ("Nko_Letter_Na" . #\u+07e3) + ("Nko_Letter_Ha" . #\u+07e4) + ("Nko_Letter_Wa" . #\u+07e5) + ("Nko_Letter_Ya" . #\u+07e6) + ("Nko_Letter_Nya_Woloso" . #\u+07e7) + ("Nko_Letter_Jona_Ja" . #\u+07e8) + ("Nko_Letter_Jona_Cha" . #\u+07e9) + ("Nko_Letter_Jona_Ra" . #\u+07ea) + ("Nko_Combining_Short_High_Tone" . #\u+07eb) + ("Nko_Combining_Short_Low_Tone" . #\u+07ec) + ("Nko_Combining_Short_Rising_Tone" . #\u+07ed) + ("Nko_Combining_Long_Descending_Tone" . #\u+07ee) + ("Nko_Combining_Long_High_Tone" . #\u+07ef) + ("Nko_Combining_Long_Low_Tone" . #\u+07f0) + ("Nko_Combining_Long_Rising_Tone" . #\u+07f1) + ("Nko_Combining_Nasalization_Mark" . #\u+07f2) + ("Nko_Combining_Double_Dot_Above" . #\u+07f3) + ("Nko_High_Tone_Apostrophe" . #\u+07f4) + ("Nko_Low_Tone_Apostrophe" . #\u+07f5) + ("Nko_Symbol_Oo_Dennen" . #\u+07f6) + ("Nko_Symbol_Gbakurunen" . #\u+07f7) + ("Nko_Comma" . #\u+07f8) + ("Nko_Exclamation_Mark" . #\u+07f9) + ("Nko_Lajanyalan" . #\u+07fa) + ("Figure_Space" . #\u+2007) + ("Zero_Width_Space" . #\u+200b) + ("Line_Separator" . #\u+2028) + ("Paragraph_Separator" . #\u+2029) + ("Replacement_Character" . #\u+fffd) + ("Skull_And_Crossbones" . #\u+2620))) + (destructuring-bind (name . char) pair + (register-character-name name char))) + + + +;;;(NAME-CHAR name) +;;;If name has an entry in the *NAME->CHAR*, return first such entry. +;;;Otherwise, if it consists of one char, return it. +;;;Otherwise, if it consists of two chars, the first of which is ^, +;;; return %code-char(c xor 64), where c is the uppercased second char. +;;;Otherwise, if it starts with the prefix "u+" or "U+" followed by +;;; hex digits, the number denoted by those hex digits is interpreted as the +;;; unicode code of the character; if this value is less than +;;; CHAR-CODE-LIMIT, CODE-CHAR of that value is returned. +;;;Otherwise, if it consists of octal digits, the number denoted by +;;; those octal digits is interpreted as per the U+ case above. +;;;Otherwise return NIL. + + +(defun name-char (name) + "Given an argument acceptable to STRING, NAME-CHAR returns a character + whose name is that string, if one exists. Otherwise, NIL is returned." + (if (characterp name) + name + (let* ((name (string name))) + (let* ((namelen (length name))) + (declare (fixnum namelen)) + (or (gethash name *name->char*) + (if (= namelen 1) + (char name 0) + (if (and (= namelen 2) (eq (char name 0) #\^)) + (let* ((c1 (char-code (char-upcase (char name 1))))) + (if (and (>= c1 64) (< c1 96)) + (code-char (the fixnum (logxor (the fixnum c1) #x40))))) + (let* ((n 0) + (start 1)) + (declare (fixnum start)) + (or + (if (and (> namelen 1) + (or (eql (char name 0) #\U) + (eql (char name 0) #\u)) + (or (= namelen 2) + (progn + (when (eql (char name 1) #\+) + (incf start)) + t))) + (do* ((i start (1+ i))) + ((= i namelen) (if (< n char-code-limit) + (code-char n))) + (declare (fixnum i)) + (let* ((pos (position (char-upcase (char name i)) + "0123456789ABCDEF"))) + (if pos + (setq n (logior (ash n 4) pos)) + (progn + (setq n 0) + (return)))))) + (dotimes (i namelen (if (< n char-code-limit) + (code-char n))) + (let* ((code (the fixnum (- (the fixnum (char-code (char name i))) + (char-code #\0))))) + (declare (fixnum code)) + (if (and (>= code 0) + (<= code 7)) + (setq n (logior code (the fixnum (ash n 3)))) + (return))))))))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant wsp #.(let ((str (make-string 6 :element-type 'base-char))) + (set-schar str 0 #\Space) + (set-schar str 1 #\^I) + (set-schar str 2 #\^L) + (set-schar str 3 #\^@) + (set-schar str 4 #\^J) + (set-schar str 5 (code-char #xa0)) + str)) + +(defconstant wsp&cr #.(let ((str (make-string 7 :element-type 'base-char))) + (set-schar str 0 #\Space) + (set-schar str 1 #\^M) + (set-schar str 2 #\^I) + (set-schar str 3 #\^L) + (set-schar str 4 #\^@) + (set-schar str 5 #\^J) + (set-schar str 0 #\Space) + (set-schar str 6 (code-char #xa0)) + str)) +) + +(defun whitespacep (char) + (eql $cht_wsp (%character-attribute char (rdtab.ttab *readtable*)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Readtables ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Readtable = istructure with data [1] type-table and [2] macro-char-alist +;;; Type-table is a 256 byte ivector with a type byte for each char. +;;; macro-char-alist is a list of (char . defn). The defn is either a +;;; cons of (#'read-dispatch . macro-char-alist) for +;;; dispatch macros, or it is a function or a symbol to call for simple macros. + +(defun readtablep (object) (istruct-typep object 'readtable)) + +(defun readtable-arg (object) + (if (null object) (setq object *readtable*)) + (unless (istruct-typep object 'readtable) + (report-bad-arg object 'readtable)) + object) + +(eval-when (:compile-toplevel :execute) +(def-accessors %svref + token.string + token.ipos + token.opos + token.len +) + +(defmacro with-token-buffer ((name) &body body &environment env) + (multiple-value-bind (body decls) (parse-body body env nil) + `(let* ((,name (vector (%get-token-string 16) 0 0 16 nil))) + (declare (dynamic-extent ,name)) + (unwind-protect + (locally ,@decls ,@body) + (%return-token-string ,name))))) +) + +(defun read-dispatch (stream char) + (let* ((info (cdr (assq char (rdtab.alist *readtable*))))) + (with-token-buffer (tb) + (let* ((subchar nil) + (numarg nil)) + (loop + (if (digit-char-p (setq subchar (%read-char-no-eof stream))) + (%add-char-to-token subchar tb) + (return (setq subchar (char-upcase subchar) + numarg (%token-to-number tb 10))))) + (let* ((dispfun (cdr (assq subchar (cdr info))))) ; <== WAS char + (if dispfun + (funcall dispfun stream subchar numarg) + (signal-reader-error stream "Undefined character ~S in a ~S dispatch macro." subchar char))))))) + +;;; This -really- gets initialized later in the file +(defvar %standard-readtable% + (let* ((ttab (make-array 256 :element-type '(unsigned-byte 8))) + (macs `((#\# . (,#'read-dispatch)))) + (case :upcase)) + (dotimes (i 256) (declare (fixnum i))(uvset ttab i $cht_cnst)) + (dotimes (ch (1+ (char-code #\Space))) + (uvset ttab ch $cht_wsp)) + (uvset ttab #xa0 $cht_wsp) + (uvset ttab (char-code #\\) $cht_sesc) + (uvset ttab (char-code #\|) $cht_mesc) + (uvset ttab (char-code #\#) $cht_ntmac) + (uvset ttab (char-code #\Backspace) $cht_ill) + (uvset ttab (char-code #\Rubout) $cht_ill) + (%istruct 'readtable ttab macs case))) + +(defvar %initial-readtable%) +(setq *readtable* %standard-readtable%) +(def-standard-initial-binding *readtable* ) +(queue-fixup (setq %initial-readtable% (copy-readtable *readtable*))) + +(defun copy-readtable (&optional (from *readtable*) to) + (setq from (if from (readtable-arg from) %standard-readtable%)) + (let* ((fttab (rdtab.ttab from)) + (ttablen (uvsize fttab))) + (declare (fixnum ttablen)) + (setq to (if to + (readtable-arg to) + (%istruct 'readtable + (make-array ttablen :element-type '(unsigned-byte 8)) + nil (rdtab.case from)))) + (setf (rdtab.alist to) (copy-tree (rdtab.alist from))) + (setf (rdtab.case to) (rdtab.case from)) + (let* ((tttab (rdtab.ttab to))) + (%copy-ivector-to-ivector fttab 0 tttab 0 ttablen)) + to)) + +(declaim (inline %character-attribute)) + +(defun %character-attribute (char attrtab) + (declare (character char) + (type (simple-array (unsigned-byte 8) (*)) attrtab) + (optimize (speed 3) (safety 0))) + (let* ((code (char-code char))) + (declare (fixnum code)) + (if (< code (uvsize attrtab)) + (aref attrtab code) + $cht_cnst))) + +(defun %set-character-attribute (char readtable attr) + (let* ((code (char-code char)) + (attrtab (rdtab.ttab readtable)) + (oldsize (uvsize attrtab))) + (declare (type (mod #x110000) code) + (type (simple-array (unsigned-byte 8) (*)) attrtab)) + (when (>= code oldsize) + ;; Characters whose code is > the current size of the table + ;; are implicitly constituents; don't grow the table just to + ;; store that info explicitly. + (if (eql attr $cht_cnst) + (return-from %set-character-attribute attr) + (let* ((newsize (min (+ code code) char-code-limit)) + (new (make-array newsize + :element-type '(unsigned-byte 8) + :initial-element $cht_cnst))) + (declare ((simple-array (unsigned-byte 8) (*)) new)) + (%copy-ivector-to-ivector attrtab 0 new 0 oldsize) + (setf (rdtab.ttab readtable) (setq attrtab new))))) + (setf (aref attrtab code) attr))) + + +;;; returns: (values attrib ), where +;;; = (char . fn), if terminating macro +;;; = (char . (fn . dispatch-alist)), if dispatching macro +;;; = nil otherwise + + +(defun %get-readtable-char (char &optional (readtable *readtable*)) + (setq char (require-type char 'character)) + (let* ((attr (%character-attribute char (rdtab.ttab readtable)))) + (declare (fixnum attr)) + (values attr (if (logbitp $cht_macbit attr) (assoc char (rdtab.alist readtable)))))) + + +(defun set-syntax-from-char (to-char from-char &optional to-readtable from-readtable) + "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the + optional readtable (defaults to the current readtable). The + FROM-TABLE defaults to the standard Lisp readtable when NIL." + (setq to-char (require-type to-char 'base-char)) + (setq from-char (require-type from-char 'base-char)) + (setq to-readtable (readtable-arg to-readtable)) + (setq from-readtable (readtable-arg (or from-readtable %initial-readtable%))) + (multiple-value-bind (from-attr from-info) (%get-readtable-char from-char from-readtable) + (let* ((new-tree (copy-tree (cdr from-info))) + (old-to-info (nth-value 1 (%get-readtable-char to-char to-readtable)))) + (without-interrupts + (if from-info + (if old-to-info + (setf (cdr old-to-info) new-tree) + (push (cons to-char new-tree) (rdtab.alist to-readtable))) + (if old-to-info + (setf (rdtab.alist to-readtable) (delq old-to-info (rdtab.alist to-readtable))))) + (%set-character-attribute to-char + to-readtable + (if (and (= from-attr $cht_cnst) + (member to-char '(#\Newline #\Linefeed #\Page #\Return + #\Space #\Tab #\Backspace #\Rubout))) + $cht_ill + from-attr))) + t))) + +(defun get-macro-character (char &optional readtable) + "Return the function associated with the specified CHAR which is a macro + character, or NIL if there is no such function. As a second value, return + T if CHAR is a macro character which is non-terminating, i.e. which can + be embedded in a symbol name." + (setq readtable (readtable-arg readtable)) + (multiple-value-bind (attr info) (%get-readtable-char char readtable) + (declare (fixnum attr) (list info)) + (let* ((def (cdr info))) + (values (if (consp def) (car def) def) + (= attr $cht_ntmac))))) + +(defun set-macro-character (char fn &optional non-terminating-p readtable) + "Causes CHAR to be a macro character which invokes FUNCTION when seen + by the reader. The NON-TERMINATINGP flag can be used to make the macro + character non-terminating, i.e. embeddable in a symbol name." + (setq char (require-type char 'base-char)) + (setq readtable (readtable-arg readtable)) + (when fn + (unless (or (symbolp fn) (functionp fn)) + (setq fn (require-type fn '(or symbol function))))) + (let* ((info (nth-value 1 (%get-readtable-char char readtable)))) + (declare (list info)) + (without-interrupts + (%set-character-attribute char readtable + (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac))) + (if (and (null fn) info) + (setf (rdtab.alist readtable) (delete info (rdtab.alist readtable) :test #'eq)) + (if (null info) + (push (cons char fn) (rdtab.alist readtable)) + (let* ((def (cdr info))) + (if (atom def) + (setf (cdr info) fn) ; Non-dispatching + (setf (car def) fn)))))) ; Dispatching + t)) + +(defun readtable-case (readtable) + (unless (istruct-typep readtable 'readtable) + (report-bad-arg readtable 'readtable)) + (let* ((case (rdtab.case (readtable-arg readtable)))) + (if (symbolp case) + case + (%car (rassoc case (readtable-case-keywords) :test #'eq))))) + +(defun %set-readtable-case (readtable case) + (unless (istruct-typep readtable 'readtable) + (report-bad-arg readtable 'readtable)) + (check-type case (member :upcase :downcase :preserve :invert)) + (setf (rdtab.case (readtable-arg readtable)) case)) + +(defsetf readtable-case %set-readtable-case) + +(defun make-dispatch-macro-character (char &optional non-terminating-p readtable) + "Cause CHAR to become a dispatching macro character in readtable (which + defaults to the current readtable). If NON-TERMINATING-P, the char will + be non-terminating." + (setq readtable (readtable-arg readtable)) + (setq char (require-type char 'base-char)) + (let* ((info (nth-value 1 (%get-readtable-char char readtable)))) + (declare (list info)) + (without-interrupts + (%set-character-attribute char readtable + (if non-terminating-p $cht_ntmac $cht_tmac)) + (if info + (rplacd (cdr info) nil) + (push (cons char (cons #'read-dispatch nil)) (rdtab.alist readtable))))) + t) + +(defun get-dispatch-macro-character (disp-ch sub-ch &optional (readtable *readtable*)) + "Return the macro character function for SUB-CHAR under DISP-CHAR + or NIL if there is no associated function." + (setq readtable (readtable-arg (or readtable %initial-readtable%))) + (setq disp-ch (require-type disp-ch 'base-char)) + (setq sub-ch (char-upcase (require-type sub-ch 'base-char))) + (unless (digit-char-p sub-ch 10) + (let* ((def (cdr (nth-value 1 (%get-readtable-char disp-ch readtable))))) + (if (consp def) + (cdr (assq sub-ch (cdr def))) + (error "~A is not a dispatching macro character in ~s ." disp-ch readtable))))) + +(defun set-dispatch-macro-character (disp-ch sub-ch fn &optional readtable) + "Cause FUNCTION to be called whenever the reader reads DISP-CHAR + followed by SUB-CHAR." + (setq readtable (readtable-arg readtable)) + (setq disp-ch (require-type disp-ch 'base-char)) + (setq sub-ch (char-upcase (require-type sub-ch 'base-char))) + (when (digit-char-p sub-ch 10) + (error "subchar can't be a decimal digit - ~a ." sub-ch)) + (let* ((info (nth-value 1 (%get-readtable-char disp-ch readtable))) + (def (cdr info))) + (declare (list info)) + (unless (consp def) + (error "~A is not a dispatching macro character in ~s ." disp-ch readtable)) + (let* ((alist (cdr def)) + (pair (assq sub-ch alist))) + (if pair + (setf (cdr pair) fn) + (push (cons sub-ch fn) (cdr def)))) + t)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reader ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *read-eval* t "When nil, #. signals an error.") +(defvar %read-objects% nil) +(defvar %keep-whitespace% nil) + + + + +(def-standard-initial-binding %token-strings% (%cons-pool nil)) + + +(defun %return-token-string (token) + (let* ((str (token.string token)) + (pool %token-strings%)) + (setf (token.string token) nil) + (without-interrupts + (setf (pool.data pool) + (cheap-cons str (pool.data pool)))))) + +;;;Look for an exact match, else create a simple-string. +(defun %get-token-string (len) + (declare (fixnum len)) + (without-interrupts + (do* ((pool %token-strings%) + (head (cons nil (pool.data pool))) + (prev head next) + (next (cdr prev) (cdr next))) + ((null next) + (make-string len :element-type 'base-char)) + (declare (dynamic-extent head) + (list head prev next)) + (let* ((s (car next))) + (when (= len (length s)) + (rplacd prev (cdr next)) + (setf (pool.data pool) (cdr head)) + (free-cons next) + (return s)))))) + +(defun %extend-token-string (token) + (let* ((old-string (token.string token)) + (old-length (token.len token))) + (declare (fixnum old-length)) + (let* ((new-length (the fixnum (ash old-length 1))) + (new-string (%get-token-string new-length))) + (dotimes (i old-length) + (setf (%schar new-string i) + (%schar old-string i))) + (%return-token-string token) + (setf (token.string token) new-string + (token.len token) new-length) + token))) + +(defun %add-char-to-token (char token) + (let* ((len (token.len token)) + (opos (token.opos token))) + (declare (fixnum len opos)) + (when (= opos len) + (%extend-token-string token)) + (setf (token.opos token) (the fixnum (1+ opos)) + (%schar (token.string token) opos) char))) + +(defun %string-from-token (token) + (let* ((opos (token.opos token)) + (ipos (token.ipos token)) + (tstr (token.string token)) + (len (the fixnum (- opos ipos))) + (string (make-string len :element-type 'base-char))) + (do* ((k 0 (1+ k)) + (i ipos (1+ i))) + ((= i opos) string) + (declare (fixnum i k)) + (setf (%schar string k) (%schar tstr i))))) + +(defun %next-token-char (token) + (let* ((ipos (token.ipos token))) + (declare (fixnum ipos)) + (when (< ipos (the fixnum (token.opos token))) + (setf (token.ipos token) (the fixnum (1+ ipos))) + (%schar (token.string token) ipos)))) + +(defun input-stream-arg (stream) + (cond ((null stream) *standard-input*) + ((eq stream t) *terminal-io*) + ;Otherwise, let ASK complain... + (t stream))) + +(defun %read-char-no-eof (stream) + (read-char stream)) + +(defun %next-char-and-attr (stream &optional (attrtab (rdtab.ttab *readtable*))) + (let* ((ch (read-char stream nil :eof))) + (if (eq ch :eof) + (values nil nil) + (values ch (%character-attribute ch attrtab))))) + +(defun %next-non-whitespace-char-and-attr (stream) + (let* ((attrtab (rdtab.ttab *readtable*))) + (loop + (multiple-value-bind (ch attr) (%next-char-and-attr stream attrtab) + (if (null ch) + (return (values nil nil)) + (unless (eql attr $cht_wsp) + (return (values ch attr)))))))) + +(defun %next-char-and-attr-no-eof (stream &optional (attrtab (rdtab.ttab *readtable*))) + (let* ((ch (%read-char-no-eof stream))) + (values ch (%character-attribute ch attrtab)))) + +(defun %next-non-whitespace-char-and-attr-no-eof (stream) + (let* ((attrtab (rdtab.ttab *readtable*))) + (loop + (multiple-value-bind (ch attr) (%next-char-and-attr-no-eof stream attrtab) + (declare (fixnum attr)) + (unless (= attr $cht_wsp) + (return (values ch attr))))))) + +;;; "escapes" is a list of escaped character positions, in reverse order +(defun %casify-token (token escapes) + (let* ((case (readtable-case *readtable*)) + (opos (token.opos token)) + (string (token.string token))) + (declare (fixnum opos)) + (if (and (null escapes) (eq case :upcase)) ; Most common case, pardon the pun + ; %strup is faster - boot probs tho + (dotimes (i opos) + (setf (%schar string i) (char-upcase (%schar string i)))) + (unless (eq case :preserve) + (when (eq case :invert) + (let* ((lower-seen nil) + (upper-seen nil)) + (do* ((i (1- opos) (1- i)) + (esclist escapes) + (nextesc (if esclist (pop esclist) -1))) + ((< i 0) (if upper-seen (unless lower-seen (setq case :downcase)) + (when lower-seen (setq case :upcase)))) + (declare (fixnum i nextesc)) + (if (= nextesc i) + (setq nextesc (if esclist (pop esclist) -1)) + (let* ((ch (%schar string i))) + (if (upper-case-p ch) + (setq upper-seen t) + (if (lower-case-p ch) + (setq lower-seen t)))))))) + (if (eq case :upcase) + (do* ((i (1- opos) (1- i)) + (nextesc (if escapes (pop escapes) -1))) + ((< i 0)) + (declare (fixnum i nextesc)) + (if (= nextesc i) + (setq nextesc (if escapes (pop escapes) -1)) + (setf (%schar string i) (char-upcase (%schar string i))))) + (if (eq case :downcase) + (do* ((i (1- opos) (1- i)) + (nextesc (if escapes (pop escapes) -1))) + ((< i 0)) + (declare (fixnum i nextesc)) + (if (= nextesc i) + (setq nextesc (if escapes (pop escapes) -1)) + (setf (%schar string i) (char-downcase (%schar string i))))))))))) + +;;; MCL's reader has historically treated ||:foo as a reference to the +;;; symbol FOO in the package which has the null string as its name. +;;; Some other implementations treat it as a keyword. This takes an +;;; argument indicating whether or not something was "seen" before the +;;; first colon was read, even if that thing caused no characters to +;;; be added to the token. + +(defun %token-package (token colonpos seenbeforecolon stream) + (if colonpos + (if (and (eql colonpos 0) (not seenbeforecolon)) + *keyword-package* + (let* ((string (token.string token))) + (or (%find-pkg string colonpos) + (signal-reader-error stream "Reference to unknown package ~s." (subseq string 0 colonpos))))) + *package*)) + +;;; Returns 4 values: reversed list of escaped character positions, +;;; explicit package (if unescaped ":" or "::") or nil, t iff any +;;; non-dot, non-escaped chars in token, and t if either no explicit +;;; package or "::" + +(defun %collect-xtoken (token stream 1stchar) + (let* ((escapes ()) + (nondots nil) + (explicit-package *read-suppress*) + (double-colon t) + (multi-escaped nil)) + (do* ((attrtab (rdtab.ttab *readtable*)) + (char 1stchar (read-char stream nil :eof ))) + ((eq char :eof)) + (flet ((add-note-escape-pos (char token escapes) + (push (token.opos token) escapes) + (%add-char-to-token char token) + escapes)) + (let* ((attr (%character-attribute char attrtab))) + (declare (fixnum attr)) + (when (or (= attr $cht_tmac) + (= attr $cht_wsp)) + (when (or (not (= attr $cht_wsp)) %keep-whitespace%) + (unread-char char stream)) + (return )) + (if (= attr $cht_ill) + (signal-reader-error stream "Illegal character ~S." char) + (if (= attr $cht_sesc) + (setq nondots t + escapes (add-note-escape-pos (%read-char-no-eof stream) token escapes)) + (if (= attr $cht_mesc) + (progn + (setq nondots t) + (loop + (multiple-value-bind (nextchar nextattr) (%next-char-and-attr-no-eof stream attrtab) + (declare (fixnum nextattr)) + (if (= nextattr $cht_mesc) + (return (setq multi-escaped t)) + (if (= nextattr $cht_sesc) + (setq escapes (add-note-escape-pos (%read-char-no-eof stream) token escapes)) + (setq escapes (add-note-escape-pos nextchar token escapes))))))) + (let* ((opos (token.opos token))) ; Add char to token, note 1st colonpos + (declare (fixnum opos)) + (if (and (eq char #\:) ; (package-delimiter-p char ?) + (not explicit-package)) + (let* ((nextch (%read-char-no-eof stream))) + (if (eq nextch #\:) + (setq double-colon t) + (progn + (unread-char nextch stream) + (setq double-colon nil))) + (%casify-token token escapes) + (setq explicit-package (%token-package token opos nondots stream) + nondots t + escapes nil) + (setf (token.opos token) 0)) + (progn + (unless (eq char #\.) (setq nondots t)) + (%add-char-to-token char token)))))))))) + (values (or escapes multi-escaped) (if *read-suppress* nil explicit-package) nondots double-colon))) + +(defun %validate-radix (radix) + (if (and (typep radix 'fixnum) + (>= (the fixnum radix) 2) + (<= (the fixnum radix) 36)) + radix + (progn + (check-type radix (integer 2 36)) + radix))) + +(defun %token-to-number (token radix &optional no-rat) + (new-numtoken (token.string token) (token.ipos token) (token.opos token) radix no-rat)) + +;;; If we're allowed to have a single "." in this context, DOT-OK is some distinguished +;;; value that's returned to the caller when exactly one dot is present. +(defun %parse-token (stream firstchar dot-ok) + (with-token-buffer (tb) + (multiple-value-bind (escapes explicit-package nondots double-colon) (%collect-xtoken tb stream firstchar) + (unless *read-suppress* + (let* ((string (token.string tb)) + (len (token.opos tb))) + (declare (fixnum len)) + (if (not nondots) + (if (= len 1) + (or dot-ok + (signal-reader-error stream "Dot context error in ~s." (%string-from-token tb))) + (signal-reader-error stream "Illegal symbol syntax in ~s." (%string-from-token tb))) + ;; Something other than a buffer full of dots. Thank god. + (let* ((num (if (null escapes) + (handler-case + (%token-to-number tb (%validate-radix *read-base*)) + (arithmetic-error (c) + (error 'impossible-number + :stream stream + :token (%string-from-token tb) + :condition c)))))) + (if (and num (not explicit-package)) + num + (if (and (zerop len) (null escapes)) + (%err-disp $XBADSYM) + (progn ; Muck with readtable case of extended token. + (%casify-token tb (unless (atom escapes) escapes)) + (let* ((pkg (or explicit-package *package*))) + (if (or double-colon (eq pkg *keyword-package*)) + (without-interrupts + (multiple-value-bind (symbol access internal-offset external-offset) + (%find-symbol string len pkg) + (if access + symbol + (%add-symbol (%string-from-token tb) pkg internal-offset external-offset)))) + (multiple-value-bind (found symbol) (%get-htab-symbol string len (pkg.etab pkg)) + (if found + symbol + (let* ((token (%string-from-token tb)) + (symbol (find-symbol token pkg))) + (with-simple-restart (continue + "~:[Create and use the internal symbol ~a::~a~;Use the internal symbol ~:*~s~]" + symbol (package-name pkg) token) + (%err-disp $XNOESYM token pkg)) + (or symbol (intern token pkg))))))))))))))))) + +#| +(defun %parse-token-test (string &key dot-ok (case (readtable-case *readtable*))) + (let* ((stream (make-string-input-stream string)) + (oldcase (readtable-case *readtable*))) + (unwind-protect + (progn + (setf (readtable-case *readtable*) case) + (%parse-token stream (read-char stream t) dot-ok)) + (setf (readtable-case *readtable*) oldcase)))) + +(%parse-token-test "ABC") +(%parse-token-test "TRAPS::_DEBUGGER") +(%parse-token-test "3.14159") +(ignore-errors (%parse-token-test "BAD-PACKAGE:WORSE-SYMBOL")) +(ignore-errors (%parse-token-test "CCL::")) +(%parse-token-test "TRAPS::_debugger" :case :preserve) +(%parse-token-test ":foo") +|# + +;;; firstchar must not be whitespace. +;;; People who think that there's so much overhead in all of +;;; this (multiple-value-list, etc.) should probably consider +;;; rewriting those parts of the CLOS and I/O code that make +;;; using things like READ-CHAR impractical... + +;;; mb: the reason multiple-value-list is used here is that we need to distunguish between the +;;; recursive parse call returning (values nil) and (values). +(defun %parse-expression (stream firstchar dot-ok) + (let* ((readtable *readtable*) + (attrtab (rdtab.ttab readtable)) + (attr (%character-attribute firstchar attrtab)) + (start-pos (stream-position stream))) + (declare (fixnum attr)) + (when (eql attr $cht_ill) + (signal-reader-error stream "Illegal character ~S." firstchar)) + (let* ((vals (multiple-value-list + (if (not (logbitp $cht_macbit attr)) + (%parse-token stream firstchar dot-ok) + (let* ((def (cdr (assq firstchar (rdtab.alist readtable))))) + (cond ((null def)) + ((atom def) + (funcall def stream firstchar)) + #+no ; include if %initial-readtable% broken (see above) + ((and (consp (car def)) + (eq (caar def) 'function)) + (funcall (cadar def) stream firstchar)) + ((functionp (car def)) + (funcall (car def) stream firstchar)) + (t (error "Bogus default dispatch fn: ~S" (car def)) nil)))))) + (end-pos (and start-pos (stream-position stream)))) + (declare (dynamic-extent vals) + (list vals)) + (if (null vals) + (values nil nil) + (destructuring-bind (form &optional nested-source-notes) + vals + ;; Can't really trust random reader macros to return source notes... + (unless (and (consp nested-source-notes) + (source-note-p (car nested-source-notes))) + (setq nested-source-notes nil)) + (values form + t + (and start-pos + (record-source-note :form form + :stream stream + :start-pos (1- start-pos) + :end-pos end-pos + :subform-notes nested-source-notes)))))))) + +#| +(defun %parse-expression-test (string) + (let* ((stream (make-string-input-stream string))) + (%parse-expression stream (read-char stream t) nil))) + +(%parse-expression-test ";hello") +(%parse-expression-test "#'cdr") +(%parse-expression-test "#+foo 1 2") + +|# + +(defun %read-list-expression (stream dot-ok &optional (termch #\))) + (loop + (let* ((firstch (%next-non-whitespace-char-and-attr-no-eof stream))) + (if (eq firstch termch) + (return (values nil nil nil)) + (multiple-value-bind (val val-p source-info) + (%parse-expression stream firstch dot-ok) + (if val-p + (return (values val t source-info)))))))) + +(defun read-list (stream &optional nodots (termch #\))) + (let* ((dot-ok (cons nil nil)) + (head (cons nil nil)) + (tail head) + (source-note-list nil)) + (declare (dynamic-extent dot-ok head) + (list head tail)) + (if nodots (setq dot-ok nil)) + (multiple-value-bind (firstform firstform-p firstform-source-note) + (%read-list-expression stream dot-ok termch) + (when firstform-source-note + (push firstform-source-note source-note-list)) + (when firstform-p + (if (and dot-ok (eq firstform dot-ok)) ; just read a dot + (signal-reader-error stream "Dot context error.")) + (rplacd tail (setq tail (cons firstform nil))) + (loop + (multiple-value-bind (nextform nextform-p nextform-source-note) + (%read-list-expression stream dot-ok termch) + (when nextform-source-note + (push nextform-source-note source-note-list)) + (if (not nextform-p) (return)) + (if (and dot-ok (eq nextform dot-ok)) ; just read a dot + (if (multiple-value-bind (lastform lastform-p lastform-source-note) + (%read-list-expression stream nil termch) + (when lastform-source-note + (push lastform-source-note source-note-list)) + (and lastform-p + (progn (rplacd tail lastform) + (not (nth-value 1 (%read-list-expression stream nil termch)))))) + (return) + (signal-reader-error stream "Dot context error.")) + (rplacd tail (setq tail (cons nextform nil)))))))) + (values (cdr head) source-note-list))) + +#| +(defun read-list-test (string &optional nodots) + (read-list (make-string-input-stream string) nodots)) + +(read-list-test ")") +(read-list-test "a b c)" t) +(read-list-test "a b ;hello +c)" t) + +|# + +(set-macro-character + #\( + #'(lambda (stream ignore) + (declare (ignore ignore)) + (read-list stream nil #\)))) + +(set-macro-character + #\' + (nfunction |'-reader| + (lambda (stream ignore) + (declare (ignore ignore)) + (multiple-value-bind (form source-note) + (read-internal stream t nil t) + (values `(quote ,form) (and source-note (list source-note))))))) + +(defparameter *alternate-line-terminator* + #+darwin-target #\Return + #-darwin-target nil + "This variable is currently only used by the standard reader macro +function for #\; (single-line comments); that function reads successive +characters until EOF, a #\NewLine is read, or a character EQL to the value +of *alternate-line-terminator* is read. In Clozure CL for Darwin, the value +of this variable is initially #\Return ; in Clozure CL for other OSes, it's +initially NIL.") + +(set-macro-character + #\; + (nfunction |;-reader| + (lambda (stream ignore) + (declare (ignore ignore)) + (let* ((ch nil)) + (loop + (if (or (eq :eof (setq ch (read-char stream nil :eof))) + (eq ch #\NewLine) + (eq ch *alternate-line-terminator*)) + (return (values)))))))) + +(defun read-string (stream termch) + (with-token-buffer (tb) + (do* ((attrs (rdtab.ttab *readtable*)) + (ch (%read-char-no-eof stream) + (%read-char-no-eof stream))) + ((eq ch termch) + (%string-from-token tb)) + (if (= (the fixnum (%character-attribute ch attrs)) $CHT_SESC) + (setq ch (%read-char-no-eof stream))) + (%add-char-to-token ch tb)))) + +(set-macro-character #\" #'read-string) + +(defparameter *ignore-extra-close-parenthesis* nil) + +(set-macro-character + #\) + #'(lambda (stream ch) + (let* ((pos (if (typep stream 'file-stream) + (file-position stream)))) + (if *ignore-extra-close-parenthesis* + (warn "Ignoring extra \"~c\" ~@[near position ~d~] on ~s ." ch pos stream) + (signal-reader-error stream "Unmatched ')' ~@[near position ~d~]." pos))))) + + + + +(eval-when (:load-toplevel) ; But not when mousing around! + (make-dispatch-macro-character #\# t)) + + +(set-dispatch-macro-character + #\# + #\( + (nfunction + |#(-reader| + (lambda (stream subchar numarg) + (declare (ignore subchar)) + (if (or (null numarg) *read-suppress*) + (multiple-value-bind (lst notes) (read-list stream t) + (let* ((len (length lst)) + (vec (make-array len))) + (declare (list lst) (fixnum len) (simple-vector vec)) + (dotimes (i len) + (setf (svref vec i) (pop lst))) + (values vec notes))) + (locally + (declare (fixnum numarg)) + (do* ((vec (make-array numarg)) + (notes ()) + (lastform) + (i 0 (1+ i))) + ((multiple-value-bind (form form-p source-info) + (%read-list-expression stream nil) + (if form-p + (progn + (setq lastform form) + (when source-info (push source-info notes))) + (unless (= i numarg) + (if (= i 0) + (%err-disp $XARROOB -1 vec) + (do* ((j i (1+ j))) + ((= j numarg)) + (declare (fixnum j)) + (setf (svref vec j) lastform))))) + (not form-p)) + (values vec notes)) + (declare (fixnum i)) + (setf (svref vec i) lastform))))))) + +(defun %read-rational (stream subchar radix) + (declare (ignore subchar)) + (with-token-buffer (tb) + (multiple-value-bind (escapes xpackage) + (%collect-xtoken tb stream (%next-non-whitespace-char-and-attr-no-eof stream)) + (unless *read-suppress* + (let* ((val (%token-to-number tb radix))) + (or (and (null escapes) + (null xpackage) + (typep val 'rational) + val) + (%err-disp $xbadnum))))))) + +(defun require-numarg (subchar numarg) + (or numarg *read-suppress* + (error "Numeric argument required for #~A reader macro ." subchar))) + +(defun require-no-numarg (subchar numarg) + (if (and numarg (not *read-suppress*)) + (error "Spurious numeric argument in #~D~A reader macro ." numarg subchar))) + +(defun read-eval (stream subchar numarg) + (require-no-numarg subchar numarg) + (if *read-eval* + (let* ((exp (%read-list-expression stream nil))) + (unless *read-suppress* + (eval exp))) + (signal-reader-error stream "#. reader macro invoked when ~S is false ." + '*read-eval*))) + +(set-dispatch-macro-character + #\# + #\C + #'(lambda (stream char arg) + (require-no-numarg char arg ) + (multiple-value-bind (form note) (read-internal stream t nil t) + (values (unless *read-suppress* (apply #'complex form)) (and note (list note)))))) + +(set-dispatch-macro-character + #\# + #\. + #'read-eval) + +;;; Read a valid, non-numeric token string from stream; *READ-SUPPRESS* +;;; is known to be false. +(defun read-symbol-token (stream) + (multiple-value-bind (firstch attr) (%next-non-whitespace-char-and-attr-no-eof stream) + (declare (fixnum attr)) + (with-token-buffer (tb) + (if (or (= attr $CHT_ILL) + (logbitp $cht_macbit attr) + (multiple-value-bind (escapes explicit-package nondots) (%collect-xtoken tb stream firstch) + (declare (ignore nondots)) + (%casify-token tb (unless (atom escapes) escapes)) + (or explicit-package + (and (not escapes) + (%token-to-number tb (%validate-radix *read-base*)))))) + (%err-disp $XBADSYM) + (%string-from-token tb))))) + +(set-dispatch-macro-character + #\# + #\: + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (if (not *read-suppress*) + (make-symbol (read-symbol-token stream)) + (progn + (%read-list-expression stream nil) + nil)))) + +(set-dispatch-macro-character + #\# + #\b + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (%read-rational stream subchar 2))) + +(set-dispatch-macro-character + #\# + #\o + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (%read-rational stream subchar 8))) + +(set-dispatch-macro-character + #\# + #\x + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (%read-rational stream subchar 16))) + +(set-dispatch-macro-character + #\# + #\r + #'(lambda (stream subchar numarg) + (unless *read-suppress* + (require-numarg subchar numarg) + (check-type numarg (integer 2 36))) + (%read-rational stream subchar numarg))) + +(set-dispatch-macro-character + #\# + #\' + (nfunction |#'-reader| + (lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (multiple-value-bind (form note) (read-internal stream t nil t) + (values `(function ,form) (and note (list note))))))) + +(set-dispatch-macro-character + #\# + #\| + (nfunction |#\|-reader| + (lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (do* ((lastch nil ch) + (ch ) + (level 1)) + ((= level 0) (values)) + (declare (fixnum level)) + (setq ch (%read-char-no-eof stream)) + (if (and (eq ch #\|) + (eq lastch #\#)) + (progn + (setq ch nil) + (incf level)) + (if (and (eq ch #\#) + (eq lastch #\|)) + (progn + (setq ch nil) + (decf level)))))))) + +(defun %unreadable (stream description) + (signal-reader-error stream "~S encountered." description)) + +(set-dispatch-macro-character + #\# + #\< + #'(lambda (stream &rest ignore) + (declare (ignore ignore)) + (%unreadable stream "#<"))) + +(dolist (ch '(#\null #\tab #\linefeed #\page #\return #\space #\312)) + (set-dispatch-macro-character + #\# + ch + #'(lambda (stream &rest ignore) + (declare (ignore ignore)) + (%unreadable stream "#")))) + +(set-dispatch-macro-character + #\# + #\) + #'(lambda (stream &rest ignore) + (declare (ignore ignore)) + (%unreadable stream "#)"))) + +(set-dispatch-macro-character + #\# + #\\ + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (with-token-buffer (tb) + (%collect-xtoken tb stream #\\) + (unless *read-suppress* + (let* ((str (%string-from-token tb))) + (or (name-char str) + (error "Unknown character name - \"~a\" ." str))))))) + + + +;;;Since some built-in read macros used to use internal reader entry points +;;;for efficiency, we couldn't reliably offer a protocol for stream-dependent +;;;recursive reading. So recursive reads always get done via tyi's, and streams +;;;only get to intercept toplevel reads. +(defun read (&optional stream (eof-error-p t) eof-value recursive-p) + (declare (resident)) + ;; just return the first value of read-internal + (values (read-internal stream eof-error-p eof-value recursive-p))) + +(defun read-internal (stream eof-error-p eof-value recursive-p) + (setq stream (input-stream-arg stream)) + (if recursive-p + (%read-form stream (if eof-error-p 0) nil) + (let ((%read-objects% nil) (%keep-whitespace% nil)) + (%read-form stream (if eof-error-p 0) eof-value)))) + +(defun read-preserving-whitespace (&optional stream (eof-error-p t) eof-value recursive-p) + "Read from STREAM and return the value read, preserving any whitespace + that followed the object." + (setq stream (input-stream-arg stream)) + (values + (if recursive-p + (%read-form stream 0 nil) + (let ((%read-objects% nil) (%keep-whitespace% t)) + (%read-form stream (if eof-error-p 0) eof-value))))) + + +(defun read-delimited-list (char &optional stream recursive-p) + "Read Lisp values from INPUT-STREAM until the next character after a + value's representation is CHAR, and return the objects as a list." + (setq char (require-type char 'character)) + (setq stream (input-stream-arg stream)) + (values + (let ((%keep-whitespace% nil)) + (if recursive-p + (%read-form stream char nil) + (let ((%read-objects% nil)) + (%read-form stream char nil)))))) + +(defun read-conditional (stream subchar int) + (declare (ignore int)) + (cond ((eq subchar (read-feature stream)) + (multiple-value-bind (form note) (read-internal stream t nil t) + (values form (and note (list note))))) + (t (let* ((*read-suppress* t)) + (read stream t nil t) + (values))))) + +(defun read-feature (stream) + (let* ((f (let* ((*package* *keyword-package*)) + (read stream t nil t)))) + (labels ((eval-feature (form) + (cond ((atom form) + (member form *features*)) + ((eq (car form) :not) + (not (eval-feature (cadr form)))) + ((eq (car form) :and) + (dolist (subform (cdr form) t) + (unless (eval-feature subform) (return)))) + ((eq (car form) :or) + (dolist (subform (cdr form) nil) + (when (eval-feature subform) (return t)))) + (t (%err-disp $XRDFEATURE form))))) + (if (eval-feature f) #\+ #\-)))) + +(set-dispatch-macro-character #\# #\+ #'read-conditional) +(set-dispatch-macro-character #\# #\- #'read-conditional) + +(defun %read-form (stream arg eof-val) + "Read a lisp form from STREAM + +arg=0 : read form, error if eof +arg=nil : read form, eof-val if eof. +arg=char : read delimited list" + (declare (resident)) + (check-type *readtable* readtable) + (check-type *package* package) + (if (and arg (not (eq arg 0))) + (read-list stream nil arg) + (loop + (let* ((ch (%next-non-whitespace-char-and-attr stream))) + (if (null ch) + (if arg + (error 'end-of-file :stream stream) + (return eof-val)) + (multiple-value-bind (form form-p source-note) + (%parse-expression stream ch nil) + (when form-p + (return + (values (if *read-suppress* nil form) + source-note))))))))) + +;;;Until load backquote... +(set-macro-character #\` + #'(lambda (stream char) (declare (ignore stream)) (%err-disp $xbadmac char))) +(set-macro-character #\, (get-macro-character #\`)) + + + +(set-dispatch-macro-character #\# #\P + (qlfun |#P-reader| (stream char flags &aux (invalid-string "Invalid flags (~S) for pathname ~S")) + (declare (ignore char)) + (when (null flags) (setq flags 0)) + (unless (memq flags '(0 1 2 3 4)) + (unless *read-suppress* (report-bad-arg flags '(integer 0 4)))) + (multiple-value-bind (path note) (read-internal stream t nil t) + (unless *read-suppress* + (unless (stringp path) (report-bad-arg path 'string)) + (setq path (pathname path)) + (when (%ilogbitp 0 flags) + (when (%pathname-type path) (error invalid-string flags path)) + (setf (%pathname-type path) :unspecific)) + (when (%ilogbitp 1 flags) + (when (%pathname-name path) (error invalid-string flags path)) + (setf (%pathname-name path) "")) + (values path (and note (list note))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (source-note (:conc-name "SOURCE-NOTE.") (:constructor %make-source-note)) + ;; For an inner source form, the source-note of the outer source form. + ;; For outer source note, octets + source + filename + ;; start and end file positions (NOT characters positions) + file-range) + +(defun make-source-note (&key filename start-pos end-pos source) + (%make-source-note :filename filename + :file-range (encode-file-range start-pos end-pos) + :source source)) + +(defmethod print-object ((sn source-note) stream) + (print-unreadable-object (sn stream :type t :identity nil) + (print-source-note sn stream))) + +(defun print-source-note (sn stream) + (let* ((file (source-note-filename sn)) + (text (ignore-errors (source-note-text sn)))) + (when file + ;; Should fix this when record the name. + (when (eq (pathname-version file) :newest) + (setq file (namestring (make-pathname :version nil :defaults file))))) + (when text + (setq text (string-sans-most-whitespace text 121)) + (when (> (length text) 120) + (setq text (concatenate 'string (subseq text 0 120) "...")))) + (if file + (format stream "*~s:~s-~s ~s" file + (source-note-start-pos sn) (source-note-end-pos sn) + text) + (format stream "Interactive ~s" text)))) + +(defun source-note-filename (source) + (if (source-note-p source) + (source-note.filename source) + ;; else null or a pathname, as in record-source-file + source)) + +(defun (setf source-note-filename) (filename source-note) + (setf (source-note.filename (require-type source-note 'source-note)) filename)) + +;; Since source notes are optional, it simplifies a lot of code +;; to have these accessors allow NIL. + +(defun source-note-source (source-note) + (when source-note + (source-note.source (require-type source-note 'source-note)))) + +(defun source-note-file-range (source-note) + (when source-note + (source-note.file-range (require-type source-note 'source-note)))) + +(defun source-note-start-pos (source-note) + (let ((range (source-note-file-range source-note))) + (when range + (if (consp range) (car range) (ash range -14))))) + +(defun source-note-end-pos (source-note) + (let ((range (source-note-file-range source-note))) + (when range + (if (consp range) (cdr range) (+ (ash range -14) (logand range #x3FFF)))))) + +(defun encode-file-range (start-pos end-pos) + (let ((len (- end-pos start-pos))) + (if (< len (ash 1 14)) + (+ (ash start-pos 14) len) + (cons start-pos end-pos)))) + +(defun source-note-text (source-note &optional start end) + (when source-note + (let* ((source (source-note-source source-note)) + (start-pos (source-note-start-pos source-note)) + (end-pos (source-note-end-pos source-note)) + (start (or start start-pos)) + (end (or end end-pos))) + (etypecase source + (source-note + (assert (<= (source-note-start-pos source) start end (source-note-end-pos source))) + (source-note-text source start end)) + ((simple-array (unsigned-byte 8) (*)) + (decf start start-pos) + (decf end start-pos) + (assert (and (<= 0 start end (length source)))) + (decode-string-from-octets source :start start :end end :external-format :utf-8)) + (null source))))) + +(defun source-note-toplevel-note (source-note) + (when source-note + (loop for source = (source-note-source source-note) + while (source-note-p source) + do (setq source-note source)) + source-note)) + +(defvar *recording-source-streams* ()) + +(defun record-source-note (&key form stream start-pos end-pos subform-notes) + (let ((recording (assq stream *recording-source-streams*))) + (when (and recording (not *read-suppress*)) + (destructuring-bind (map file-name stream-offset) (cdr recording) + (let* ((prev (gethash form map)) + (note (make-source-note :filename file-name + :start-pos (+ stream-offset start-pos) + :end-pos (+ stream-offset end-pos)))) + (setf (gethash form map) + (cond ((null prev) note) + ((consp prev) (cons note prev)) + (t (list note prev)))) + (loop for subnote in subform-notes + do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote)) + do (setf (source-note.source subnote) note)) + note))))) + +(defun read-recording-source (stream &key eofval file-name start-offset map save-source-text) + "Read a top-level form, perhaps recording source locations. +If MAP is NIL, just reads a form as if by READ. +If MAP is non-NIL, returns a second value of a source-note object describing the form. +In addition, if MAP is a hash table, it gets filled with source-note's for all +non-atomic nested subforms." + (when (null start-offset) (setq start-offset 0)) + (typecase map + (null (values (read-internal stream nil eofval nil) nil)) + (hash-table + (let* ((stream (recording-input-stream stream)) + (recording (list stream map file-name start-offset)) + (*recording-source-streams* (cons recording *recording-source-streams*))) + (declare (dynamic-extent recording *recording-source-streams*)) + (multiple-value-bind (form source-note) (read-internal stream nil eofval nil) + (when (and source-note (not (eq form eofval))) + (assert (null (source-note-source source-note))) + (loop for form being the hash-key using (hash-value note) of map + do (cond ((eq note source-note) nil) + ;; Remove entries with multiple source notes, which can happen + ;; for atoms. If we can't tell which instance we mean, then we + ;; don't have useful source info. + ((listp note) (remhash form map)) + ((loop for p = note then (source-note-source p) while (source-note-p p) + thereis (eq p source-note)) + ;; Flatten the backpointers so each subnote points directly + ;; to the toplevel note. + (setf (source-note.source note) source-note)))) + (when save-source-text + (setf (source-note.source source-note) + (fetch-octets-from-stream stream + (- (source-note-start-pos source-note) + start-offset) + (- (source-note-end-pos source-note) + start-offset))))) + (values form source-note)))) + (T ;; not clear if this is ever useful + (let* ((start-pos (stream-position stream)) + (form (read-internal stream nil eofval nil)) + (end-pos (and start-pos (neq form eofval) (stream-position stream))) + (source-note (and end-pos + (make-source-note :filename file-name + :start-pos (+ start-offset start-pos) + :end-pos (+ start-offset end-pos))))) + (when (and source-note save-source-text) + (setf (source-note.source source-note) (fetch-octets-from-stream stream start-pos end-pos))) + (values form source-note))))) + +(defmethod fetch-octets-from-stream ((stream input-stream) start-offset end-offset) + ;; We basically want to read the bytes between two positions, but there is no + ;; direct interface for that. So we let the stream decode and then we re-encode. + ;; (Just as well, since otherwise we'd have to remember the file's encoding). + (declare (fixnum start-offset)) + (when (< start-offset end-offset) + (let* ((cur-pos (stream-position stream)) + (noctets (- end-offset start-offset)) + (vec (make-array noctets :element-type '(unsigned-byte 8))) + (index 0) + (crlfp (eq :crlf + (cdr (assoc (external-format-line-termination + (stream-external-format stream)) + *canonical-line-termination-conventions*))))) + (declare (type fixnum end-offset noctets index) + (type (simple-array (unsigned-byte 8) (*)) vec)) + (macrolet ((out (code) + `(progn + (setf (aref vec index) ,code) + (when (eql (incf index) noctets) (return))))) + (stream-position stream start-offset) + (loop + (let ((code (char-code (read-char stream)))) + (declare (fixnum code)) + (cond ((< code #x80) + (when (and crlfp (= code (char-code #\NewLine))) + (out (char-code #\Return))) + (out code)) + ((< code #x800) + (out (logior #xc0 (ldb (byte 5 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + ((< code #x10000) + (out (logior #xe0 (ldb (byte 4 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + (t + (out (logior #xf0 (ldb (byte 3 18) code))) + (out (logior #xe0 (ldb (byte 6 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))))))) + (stream-position stream cur-pos) + vec))) + +(defun ensure-source-note-text (source-note &key (if-does-not-exist nil)) + "Fetch source text from file if don't have it" + (setq if-does-not-exist (require-type if-does-not-exist '(member :error nil))) + (if source-note + (let ((source (source-note-source source-note)) + (filename (source-note-filename source-note))) + (etypecase source + (null + (if filename + (with-open-file (stream filename :if-does-not-exist if-does-not-exist) + (when stream + (let ((start (source-note-start-pos source-note)) + (end (source-note-end-pos source-note)) + (len (file-length stream))) + (if (<= end len) + (setf (source-note.source source-note) + (fetch-octets-from-stream stream start end)) + (when if-does-not-exist + (error 'simple-file-error :pathname filename + :error-type "File ~s changed since source info recorded")))))) + (when if-does-not-exist + (error "Missing source text in internative source note")))) + (source-note + (ensure-source-note-text source)) + ((simple-array (unsigned-byte 8) (*)) + source))) + (when if-does-not-exist + (error "Missing source note")))) + + +;; This can be called explicitly by macros that do more complicated transforms +(defun note-source-transformation (original new) + (nx-note-source-transformation original new)) + + +;;; Wrapper stream for recording source of non-random-access streams. +(defclass recording-character-input-stream (fundamental-stream character-input-stream) + ((input-stream :initarg :input-stream) + (string :initform (make-array 1024 :element-type 'character :fill-pointer 0 :adjustable t)))) + +(defmethod stream-element-type ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-element-type input-stream))) + +(defmethod stream-read-char ((s recording-character-input-stream)) + (with-slots (input-stream string) s + (let ((char (stream-read-char input-stream))) + (when (and char (neq char :eof)) + (vector-push-extend char string)) + char))) + +(defmethod stream-read-char-no-hang ((s recording-character-input-stream)) + (with-slots (input-stream string) s + (let ((char (stream-read-char-no-hang input-stream))) + (when (and char (neq char :eof)) + (vector-push-extend char string)) + char))) + +(defmethod stream-peek-char ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-peek-char input-stream))) + +(defmethod stream-listen ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-listen input-stream))) + +(defmethod stream-read-line ((s recording-character-input-stream)) + (generic-read-line s)) + +(defmethod stream-read-list ((s recording-character-input-stream) list count) + (generic-character-read-list s list count)) + +(defmethod stream-read-vector ((s recording-character-input-stream) vector start end) + (generic-character-read-vector s vector start end)) + +(defmethod stream-unread-char ((s recording-character-input-stream) char) + (with-slots (input-stream string) s + (vector-pop string) ;; Error if no characters read since last reset. + (stream-unread-char input-stream char))) + +(defmethod stream-eofp ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-eofp input-stream))) + +(defmethod stream-clear-input ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-clear-input input-stream))) + +(defmethod stream-position ((s recording-character-input-stream) &optional newpos) + (with-slots (string) s + (unless newpos + (fill-pointer string)))) + +(defun recording-input-stream (stream) + (let ((pos (stream-position stream))) + (if (and pos (stream-position stream pos)) + stream + (make-instance 'recording-character-input-stream :input-stream stream)))) + +(defmethod fetch-octets-from-stream ((s recording-character-input-stream) start-offset end-offset) + (declare (fixnum start-offset end-offset)) + (with-slots (string) s + (when (< start-offset end-offset) + (let* ((sstring (array-data-and-offset string)) + (noctets (loop for i fixnum from start-offset below end-offset + as code fixnum = (%char-code (%schar sstring i)) + sum (cond ((< code #x80) 1) + ((< code #x800) 2) + ((< code #x10000) 3) + (t 4)) + of-type fixnum)) + (vec (make-array noctets :element-type '(unsigned-byte 8))) + (index 0)) + (declare (type fixnum noctets index) + (type simple-base-string sstring) + (type (simple-array (unsigned-byte 8) (*)) vec)) + (macrolet ((out (octet) `(progn + (setf (aref vec index) ,octet) + (incf index)))) + (loop for i fixnum from start-offset below end-offset + as code fixnum = (%char-code (%schar sstring i)) + do (cond ((< code #x80) + (out code)) + ((< code #x800) + (out (logior #xc0 (ldb (byte 5 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + ((< code #x10000) + (out (logior #xe0 (ldb (byte 4 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + (t + (out (logior #xf0 (ldb (byte 3 18) code))) + (out (logior #xe0 (ldb (byte 6 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code))))))) + (setf (fill-pointer string) 0) ;; reset + vec)))) + + + + +; end Index: /branches/qres/ccl/level-1/l1-readloop-lds.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-readloop-lds.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-readloop-lds.lisp (revision 13564) @@ -0,0 +1,734 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; l1-readloop-lds.lisp + +(in-package "CCL") + + + +(defun toplevel-loop () + (loop + (if (eq (catch :toplevel + (read-loop :break-level 0 )) $xstkover) + (format t "~&;[Stacks reset due to overflow.]") + (when (eq *current-process* *initial-process*) + (toplevel))))) + + +(defvar *defined-toplevel-commands* ()) +(defvar *active-toplevel-commands* ()) + +(defun %define-toplevel-command (group-name key name fn doc args) + (let* ((group (or (assoc group-name *defined-toplevel-commands*) + (car (push (list group-name) + *defined-toplevel-commands*)))) + (pair (assoc key (cdr group) :test #'eq))) + (if pair + (rplacd pair (list* fn doc args)) + (push (cons key (list* fn doc args)) (cdr group)))) + name) + +(define-toplevel-command + :global y (&optional p) "Yield control of terminal-input to process +whose name or ID matches

, or to any process if

is null" + (%%yield-terminal-to (if p (find-process p)))) ;may be nil + + +(define-toplevel-command + :global kill (p) "Kill process whose name or ID matches

" + (let* ((proc (find-process p))) + (if proc + (process-kill proc)))) + +(define-toplevel-command + :global proc (&optional p) "Show information about specified process

/all processes" + (flet ((show-process-info (proc) + (format t "~&~d : ~a ~a ~20t[~a] " + (process-serial-number proc) + (if (eq proc *current-process*) + "->" + " ") + (process-name proc) + (process-whostate proc)) + (let* ((suspend-count (process-suspend-count proc))) + (if (and suspend-count (not (eql 0 suspend-count))) + (format t " (Suspended)"))) + (let* ((terminal-input-shared-resource + (if (typep *terminal-io* 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream *terminal-io*))))) + (if (and terminal-input-shared-resource + (%shared-resource-requestor-p + terminal-input-shared-resource proc)) + (format t " (Requesting terminal input)"))) + (fresh-line))) + (if p + (let* ((proc (find-process p))) + (if (null proc) + (format t "~&;; not found - ~s" p) + (show-process-info proc))) + (dolist (proc (all-processes) (values)) + (show-process-info proc))))) + +(define-toplevel-command :global cd (dir) "Change to directory DIR" (setf (current-directory) dir) (toplevel-print (list (current-directory)))) + +(define-toplevel-command :global pwd () "Print the pathame of the current directory" (toplevel-print (list (current-directory)))) + + + +(defun list-restarts () + (format *debug-io* "~&> Type (:C ) to invoke one of the following restarts:") + (display-restarts)) + +(define-toplevel-command :break pop () "exit current break loop" (abort-break)) +(define-toplevel-command :break a () "exit current break loop" (abort-break)) +(define-toplevel-command :break go () "continue" (continue)) +(define-toplevel-command :break q () "return to toplevel" (toplevel)) +(define-toplevel-command :break r () "list restarts" (list-restarts)) + +(define-toplevel-command :break set (n frame value) "Set th item of frame to " + (let* ((frame-sp (nth-raw-frame frame *break-frame* nil))) + (if frame-sp + (toplevel-print (list (set-nth-value-in-frame frame-sp n nil value))) + (format *debug-io* "No frame with number ~D~%" frame)))) + +(define-toplevel-command :break nframes () + "print the number of stack frames accessible from this break loop" + (do* ((p *break-frame* (parent-frame p nil)) + (i 0 (1+ i)) + (last (last-frame-ptr))) + ((eql p last) (toplevel-print (list i))))) + +(define-toplevel-command :global ? () "help" + (format t "~&The following toplevel commands are available:") + (when *default-integer-command* + (format t "~& ~8Tthe same as (~s )" (car *default-integer-command*))) + (dolist (g *active-toplevel-commands*) + (dolist (c (cdr g)) + (let* ((command (car c)) + (doc (caddr c)) + (args (cdddr c))) + (if args + (format t "~& (~S~{ ~A~}) ~8T~A" command args doc) + (format t "~& ~S ~8T~A" command doc))))) + (format t "~&Any other form is evaluated and its results are printed out.")) + + +(define-toplevel-command :break b (&key start count show-frame-contents) "backtrace" + (when *break-frame* + (print-call-history :detailed-p show-frame-contents + :origin *break-frame* + :count count + :start-frame-number (or start 0)))) + +(define-toplevel-command :break c (&optional n) "Choose restart . If no , continue" + (if n + (select-restart n) + (continue))) + +(define-toplevel-command :break f (n) "Show backtrace frame " + (print-call-history :origin *break-frame* + :start-frame-number n + :count 1 + :detailed-p t)) + +(define-toplevel-command :break return-from-frame (i &rest values) "Return VALUES from the I'th stack frame" + (let* ((frame-sp (nth-raw-frame i *break-frame* nil))) + (if frame-sp + (apply #'return-from-frame frame-sp values)))) + +(define-toplevel-command :break apply-in-frame (i function &rest args) "Applies FUNCTION to ARGS in the execution context of the Ith stack frame" + (let* ((frame-sp (nth-raw-frame i *break-frame* nil))) + (if frame-sp + (apply-in-frame frame-sp function args)))) + + + +(define-toplevel-command :break raw (n) "Show raw contents of backtrace frame " + (print-call-history :origin *break-frame* + :start-frame-number n + :count 1 + :detailed-p :raw)) + +(define-toplevel-command :break v (n frame-number) "Return value in frame " + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (if frame-sp + (toplevel-print (list (nth-value-in-frame frame-sp n nil)))))) + +(define-toplevel-command :break arg (name frame-number) "Return value of argument named in frame " + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (let* ((unavailable (cons nil nil))) + (declare (dynamic-extent unavailable)) + (let* ((value (arg-value nil frame-sp lfun pc unavailable name))) + (if (eq value unavailable) + (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) + (toplevel-print (list value)))))))))) + +(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named in frame to value ." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (or (set-arg-value nil frame-sp lfun pc name new) + (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) + + +(define-toplevel-command :break local (name frame-number) "Return value of local denoted by in frame can either be a symbol - in which case the most recent +binding of that symbol is used - or an integer index into the frame's set of local bindings." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (let* ((unavailable (cons nil nil))) + (declare (dynamic-extent unavailable)) + (let* ((value (local-value nil frame-sp lfun pc unavailable name))) + (if (eq value unavailable) + (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) + (toplevel-print (list value)))))))))) + +(define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted (see :LOCAL) in frame to value ." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (or (set-local-value nil frame-sp lfun pc name new) + (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) + + +(define-toplevel-command :break form (frame-number) + "Return a form which looks like the call which established the stack frame identified by . This is only well-defined in certain cases: when the function is globally named and not a lexical closure and when it was compiled with *SAVE-LOCAL-SYMBOLS* in effect." + (let* ((form (dbg-form frame-number))) + (when form + (let* ((*print-level* *backtrace-print-level*) + (*print-length* *backtrace-print-length*)) + (toplevel-print (list form)))))) + +;;; Ordinarily, form follows function. +(define-toplevel-command :break function (frame-number) + "Returns the function invoked in backtrace frame . This may be useful for, e.g., disassembly" + (let* ((cfp (nth-raw-frame frame-number *break-frame* nil))) + (when (and cfp (not (catch-csp-p cfp nil))) + (let* ((function (cfp-lfun cfp))) + (when function + (toplevel-print (list function))))))) + + + + + + + +(defun %use-toplevel-commands (group-name) + ;; Push the whole group + (pushnew (assoc group-name *defined-toplevel-commands*) + *active-toplevel-commands* + :key #'(lambda (x) (car x)))) ; #'car not defined yet ... + +(%use-toplevel-commands :global) + +(defparameter *toplevel-commands-dwim* t + "If true, tries to interpret otherwise-erroneous toplevel expressions as commands. +In addition, will suppress standard error handling for expressions that look like +commands but aren't") + +(defvar *default-integer-command* nil + "If non-nil, should be (keyword min max)), causing integers between min and max to be + interpreted as (keyword integer)") + +(defun check-toplevel-command (form) + (when (and *default-integer-command* + (integerp form) + (<= (cadr *default-integer-command*) form (caddr *default-integer-command*))) + (setq form `(,(car *default-integer-command*) ,form))) + (let* ((cmd (if (consp form) (car form) form)) + (args (if (consp form) (cdr form)))) + (when (or (keywordp cmd) + (and *toplevel-commands-dwim* + (non-nil-symbol-p cmd) + (not (if (consp form) + (fboundp cmd) + (or (boundp cmd) + (nth-value 1 (gethash cmd *symbol-macros*))))) + ;; Use find-symbol so don't make unneeded keywords. + (setq cmd (find-symbol (symbol-name cmd) :keyword)))) + (when (eq cmd :help) (setq cmd :?)) + (flet ((run (cmd form) + (or (dolist (g *active-toplevel-commands*) + (let* ((pair (assoc cmd (cdr g)))) + (when pair + (apply (cadr pair) args) + (return t)))) + ;; Try to detect user mistyping a command + (when (and *toplevel-commands-dwim* + (if (consp form) + (and (keywordp (%car form)) (not (fboundp (%car form)))) + (keywordp form))) + (error "Unknown command ~s" cmd))))) + (declare (dynamic-extent #'run)) + (if *toplevel-commands-dwim* + (block nil + (handler-bind ((error (lambda (c) + (format t "~&~a" c) + (return t)))) + (run cmd form))) + (run cmd form)))))) + +(defparameter *quit-on-eof* nil) + +(defparameter *consecutive-eof-limit* 2 "max number of consecutive EOFs at a given break level, before we give up and abruptly exit.") + +(defmethod stream-eof-transient-p (stream) + (let ((fd (stream-device stream :input))) + (and fd (eof-transient-p fd)))) + +(defvar *save-interactive-source-locations* t) + +;;; This is the part common to toplevel loop and inner break loops. +(defun read-loop (&key (input-stream *standard-input*) + (output-stream *standard-output*) + (break-level *break-level*) + (prompt-function #'(lambda (stream) + (when (and *show-available-restarts* *break-condition*) + (list-restarts) + (setf *show-available-restarts* nil)) + (print-listener-prompt stream t)))) + (let* ((*break-level* break-level) + (*last-break-level* break-level) + (*loading-file-source-file* nil) + (*loading-toplevel-location* nil) + *in-read-loop* + *** ** * +++ ++ + /// // / - + (eof-value (cons nil nil)) + (eof-count 0) + (*show-available-restarts* (and *show-restarts-on-break* *break-condition*)) + (map (make-hash-table :test #'eq :shared nil))) + (declare (dynamic-extent eof-value)) + (loop + (restart-case + (catch :abort ;last resort... + (loop + (catch-cancel + (loop + (setq *in-read-loop* nil + *break-level* break-level) + (multiple-value-bind (form env print-result) + (toplevel-read :input-stream input-stream + :output-stream output-stream + :prompt-function prompt-function + :eof-value eof-value + :map (when *save-interactive-source-locations* + (clrhash map) + map)) + (if (eq form eof-value) + (progn + (when (> (incf eof-count) *consecutive-eof-limit*) + (#_ _exit 0)) + (if (and (not *batch-flag*) + (not *quit-on-eof*) + (stream-eof-transient-p input-stream)) + (progn + (stream-clear-input input-stream) + (abort-break)) + (exit-interactive-process *current-process*))) + (let ((*nx-source-note-map* (and *save-interactive-source-locations* map))) + (setq eof-count 0) + (or (check-toplevel-command form) + (let* ((values (toplevel-eval form env))) + (if print-result (toplevel-print values))))))))) + (format *terminal-io* "~&Cancelled"))) + (abort () :report (lambda (stream) + (if (eq break-level 0) + (format stream "Return to toplevel.") + (format stream "Return to break level ~D." break-level))) + #| ; Handled by interactive-abort + ; go up one more if abort occurred while awaiting/reading input + (when (and *in-read-loop* (neq break-level 0)) + (abort)) + |# + ) + (abort-break () + (unless (eq break-level 0) + (abort)))) + (clear-input input-stream) + (format output-stream "~%")))) + +;;; The first non-whitespace character available on INPUT-STREAM is a colon. +;;; Try to interpret the line as a colon command (or possibly just a keyword.) +(defun read-command-or-keyword (input-stream eof-value) + (let* ((line (read-line input-stream nil eof-value))) + (if (eq line eof-value) + eof-value + (let* ((in (make-string-input-stream line)) + (keyword (read in nil eof-value))) + (if (eq keyword eof-value) + eof-value + (if (not (keywordp keyword)) + keyword + (collect ((params)) + (loop + (let* ((param (read in nil eof-value))) + (if (eq param eof-value) + (return + (let* ((params (params))) + (if params + (cons keyword params) + keyword))) + (params (eval param)))))))))))) + +;;; Read a form from the specified stream. +(defun toplevel-read (&key (input-stream *standard-input*) + (output-stream *standard-output*) + (prompt-function #'print-listener-prompt) + (eof-value *eof-value*) + (map nil)) + (force-output output-stream) + (funcall prompt-function output-stream) + (read-toplevel-form input-stream :eof-value eof-value :map map)) + +(defvar *always-eval-user-defvars* nil) + +(defun process-single-selection (form) + (if (and *always-eval-user-defvars* + (listp form) (eq (car form) 'defvar) (cddr form)) + `(defparameter ,@(cdr form)) + form)) + +(defun toplevel-eval (form &optional env) + (destructuring-bind (vars . vals) (or env '(nil . nil)) + (progv vars vals + (setq +++ ++ ++ + + - - form) + (unwind-protect + (let* ((package *package*) + (values (multiple-value-list (cheap-eval-in-environment form nil)))) + (unless (eq package *package*) + ;; If changing a local value (e.g. buffer-local), not useful to notify app + ;; without more info. Perhaps should have a *source-context* that can send along? + (unless (member '*package* vars) + (application-ui-operation *application* :note-current-package *package*))) + values) + (loop for var in vars as pval on vals + do (setf (car pval) (symbol-value var))))))) + + +(defun toplevel-print (values &optional (out *standard-output*)) + (setq /// // // / / values) + (unless (eq (car values) (%unbound-marker)) + (setq *** ** ** * * (%car values))) + (when values + (fresh-line out) + (dolist (val values) (write val :stream out) (terpri out)))) + +(defparameter *listener-prompt-format* "~[?~:;~:*~d >~] ") + + +(defun print-listener-prompt (stream &optional (force t)) + (unless *quiet-flag* + (when (or force (neq *break-level* *last-break-level*)) + (let* ((*listener-indent* nil)) + (fresh-line stream) + (format stream *listener-prompt-format* *break-level*)) + (setq *last-break-level* *break-level*))) + (force-output stream)) + + +;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism +;;; for customizing it. + +(defvar *app-error-handler-mode* :quit + "one of :quit, :quit-quietly, :listener might be useful.") + +(defmethod application-error ((a application) condition error-pointer) + (case *app-error-handler-mode* + (:listener (break-loop-handle-error condition error-pointer)) + (:quit-quietly (quit -1)) + (:quit (format t "~&Fatal error in ~s : ~a" + (pathname-name (car *command-line-argument-list*)) + condition) + (quit -1)))) + +(defun make-application-error-handler (app mode) + (declare (ignore app)) + (setq *app-error-handler-mode* mode)) + + +; You may want to do this anyway even if your application +; does not otherwise wish to be a "lisp-development-system" +(defmethod application-error ((a lisp-development-system) condition error-pointer) + (break-loop-handle-error condition error-pointer)) + +(defun abnormal-application-exit () + (ignore-errors + (print-call-history) + (force-output *debug-io*) + (quit -1)) + (#__exit -1)) + +(defvar *top-error-frame* nil) + +(defun break-loop-handle-error (condition *top-error-frame*) + (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals) + (dolist (x bogus-globals) + (set x (funcall (pop newvals)))) + (when (and *debugger-hook* *break-on-errors* (not *batch-flag*)) + (let ((hook *debugger-hook*) + (*debugger-hook* nil)) + (funcall hook condition hook))) + (let ((msg (if *batch-flag* ;; Give a little more info if exiting + (format nil "Error of type ~s" (type-of condition)) + "Error"))) + (%break-message msg condition)) + (let* ((s *error-output*)) + (dolist (bogusness bogus-globals) + (let ((oldval (pop oldvals))) + (format s "~&; NOTE: ~S was " bogusness) + (if (eq oldval (%unbound-marker-8)) + (format s "unbound") + (format s "~s" oldval)) + (format s ", was reset to ~s ." (symbol-value bogusness))))) + (if (and *break-on-errors* (not *batch-flag*)) + (break-loop condition) + (if *batch-flag* + (abnormal-application-exit) + (abort))))) + +(defun break (&optional string &rest args) + "Print a message and invoke the debugger without allowing any possibility + of condition handling occurring." + (if *batch-flag* + (apply #'error (or string "BREAK invoked in batch mode") args) + (apply #'%break-in-frame (%get-frame-ptr) string args))) + +(defun %break-in-frame (fp &optional string &rest args) + (flet ((do-break-loop () + (let ((c (if (typep string 'condition) + string + (make-condition 'simple-condition + :format-control (or string "") + :format-arguments args)))) + (cbreak-loop "Break" "Return from BREAK." c fp)))) + (cond ((%i> *interrupt-level* -1) + (do-break-loop)) + (*break-loop-when-uninterruptable* + (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.") + (let ((interrupt-level (interrupt-level))) + (unwind-protect + (progn + (setf (interrupt-level) 0) + (do-break-loop)) + (setf (interrupt-level) interrupt-level)))) + (t (format *error-output* "Break while interrupt-level less than zero; ignored."))))) + + +(defun invoke-debugger (condition &aux (*top-error-frame* (%get-frame-ptr))) + "Enter the debugger." + (let ((c (require-type condition 'condition))) + (when *debugger-hook* + (let ((hook *debugger-hook*) + (*debugger-hook* nil)) + (funcall hook c hook))) + (%break-message "Debug" c) + (break-loop c))) + +(defun %break-message (msg condition &optional (error-pointer *top-error-frame*) (prefixchar #\>)) + (let ((*print-circle* *error-print-circle*) + ;(*print-prett*y nil) + (*print-array* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* *error-print-length*) + (*print-level* *error-print-level*) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-readably* nil) + (*print-right-margin* nil) + (*signal-printing-errors* nil) + (s (make-indenting-string-output-stream prefixchar nil)) + (sub (make-string-output-stream)) + (indent 0)) + (format s "~A ~A: " prefixchar msg) + (setf (indenting-string-output-stream-indent s) (setq indent (column s))) + (decf (stream-line-length sub) indent) + ;(format s "~A" condition) ; evil if circle + (report-condition condition sub) + (format s "~A" (get-output-stream-string sub)) + (if (not (and (typep condition 'simple-program-error) + (simple-program-error-context condition))) + (format *error-output* "~&~A~%~A While executing: ~S" + (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer)) + (format *error-output* "~&~A" + (get-output-stream-string s))) + (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*)) + (force-output *error-output*))) + ; returns NIL + +(defvar *break-hook* nil) + +(defun cbreak-loop (msg cont-string condition *top-error-frame*) + (let* ((*print-readably* nil) + (hook *break-hook*)) + (restart-case (progn + (when hook + (let ((*break-hook* nil)) + (funcall hook condition hook)) + (setq hook nil)) + (%break-message msg condition) + (when (and (eq (type-of condition) 'simple-condition) + (equal (simple-condition-format-control condition) "")) + (setq condition (make-condition 'simple-condition + :format-control "~a" + :format-arguments (list msg)))) + (break-loop condition)) + (continue () :report (lambda (stream) (write-string cont-string stream)))) + (unless hook + (fresh-line *error-output*)) + nil)) + +(defun warn (condition-or-format-string &rest args) + "Warn about a situation by signalling a condition formed by DATUM and + ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart + exists that causes WARN to immediately return NIL." + (when (typep condition-or-format-string 'condition) + (unless (typep condition-or-format-string 'warning) + (report-bad-arg condition-or-format-string 'warning)) + (when args + (error 'type-error :datum args :expected-type 'null + :format-control "Extra arguments in ~s."))) + (let ((fp (%get-frame-ptr)) + (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning))) + (when *break-on-warnings* + (cbreak-loop "Warning" "Signal the warning." c fp)) + (restart-case (signal c) + (muffle-warning () :report "Skip the warning" (return-from warn nil))) + (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;) + )) + +(declaim (notinline select-backtrace)) + +(defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level) + (let* ((cond (gensym))) + `(let* ((,cond ,condition)) + (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level)))) + +(defun select-backtrace () + (declare (notinline select-backtrace)) + ;(require 'new-backtrace) + (require :inspector) + (select-backtrace)) + +(defvar *break-condition* nil "condition argument to innermost break-loop.") +(defvar *break-frame* nil "frame-pointer arg to break-loop") +(defvar *break-loop-when-uninterruptable* t) +(defvar *show-restarts-on-break* #+ccl-0711 t #-ccl-0711 nil) +(defvar *show-available-restarts* nil) + +(defvar *error-reentry-count* 0) + +(defun funcall-with-error-reentry-detection (thunk) + (let* ((count *error-reentry-count*) + (*error-reentry-count* (1+ count))) + (cond ((eql count 0) (funcall thunk)) + ((eql count 1) (error "Error reporting error")) + (t (bug "Error reporting error"))))) + + + + +(defvar %last-continue% nil) +(defun break-loop (condition &optional (frame-pointer *top-error-frame*)) + "Never returns" + (let* ((%handlers% (last %handlers%)) ; firewall + (*break-frame* frame-pointer) + (*break-condition* condition) + (*compiling-file* nil) + (*backquote-stack* nil) + (continue (find-restart 'continue)) + (*continuablep* (unless (eq %last-continue% continue) continue)) + (%last-continue% continue) + (*standard-input* *debug-io*) + (*standard-output* *debug-io*) + (*signal-printing-errors* nil) + (*read-suppress* nil) + (*print-readably* nil) + (*default-integer-command* `(:c 0 ,(1- (length (compute-restarts condition))))) + (context (new-backtrace-info nil + frame-pointer + (if *backtrace-contexts* + (or (child-frame + (bt.youngest (car *backtrace-contexts*)) + nil) + (last-frame-ptr)) + (last-frame-ptr)) + (%current-tcr) + condition + (%current-frame-ptr) + #+ppc-target *fake-stack-frames* + #+x86-target (%current-frame-ptr) + (db-link) + (1+ *break-level*))) + (*backtrace-contexts* (cons context *backtrace-contexts*))) + (with-terminal-input + (with-toplevel-commands :break + (if *continuablep* + (let* ((*print-circle* *error-print-circle*) + (*print-level* *error-print-level*) + (*print-length* *error-print-length*) + ;(*print-pretty* nil) + (*print-array* nil)) + (format t (or (application-ui-operation *application* :break-options-string t) + "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")) + (format t "~&> If continued: ~A~%" continue)) + (format t (or (application-ui-operation *application* :break-options-string nil) + "~&> Type :POP to abort, :R for a list of available restarts.~%"))) + (format t "~&> Type :? for other options.") + (terpri) + (force-output) + + (clear-input *debug-io*) + (setq *error-reentry-count* 0) ; succesfully reported error + (ignoring-without-interrupts + (unwind-protect + (progn + (application-ui-operation *application* + :enter-backtrace-context context) + (read-loop :break-level (1+ *break-level*) + :input-stream *debug-io* + :output-stream *debug-io*)) + (application-ui-operation *application* :exit-backtrace-context + context))))))) + + + +(defun display-restarts (&optional (condition *break-condition*)) + (loop + for restart in (compute-restarts condition) + for count upfrom 0 + do (format *debug-io* "~&~D. ~A" count restart) + finally (fresh-line *debug-io*))) + +(defun select-restart (n &optional (condition *break-condition*)) + (let* ((restarts (compute-restarts condition))) + (invoke-restart-interactively + (nth (require-type n `(integer 0 (,(length restarts)))) restarts)))) + + + + +; End of l1-readloop-lds.lisp Index: /branches/qres/ccl/level-1/l1-readloop.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-readloop.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-readloop.lisp (revision 13564) @@ -0,0 +1,877 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;L1-readloop.lisp + + +(defvar *break-on-signals* nil + "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will + enter the debugger prior to signalling that condition.") +(defvar *break-on-warnings* nil) +(defvar *break-on-errors* t "Not CL.") +(defvar *debugger-hook* nil + "This is either NIL or a function of two arguments, a condition and the value + of *DEBUGGER-HOOK*. This function can either handle the condition or return + which causes the standard debugger to execute. The system passes the value + of this variable to the function because it binds *DEBUGGER-HOOK* to NIL + around the invocation.") +(defvar *backtrace-on-break* nil) +(defvar *** nil + "the previous value of **") +(defvar ** nil + "the previous value of *") +(defvar * nil + "the value of the most recent top level EVAL") +(defvar /// nil + "the previous value of //") +(defvar // nil + "the previous value of /") +(defvar / nil + "a list of all the values returned by the most recent top level EVAL") +(defvar +++ nil + "the previous value of ++") +(defvar ++ nil + "the previous value of +") +(defvar + nil + "the value of the most recent top level READ") +(defvar - nil + "the form currently being evaluated") + +(defvar *continuablep* nil) +(defvar *in-read-loop* nil + "Is T if waiting for input in the read loop") + + +(defvar *did-startup* nil) + + + +(defmacro catch-cancel (&body body) + `(catch :cancel ,@body)) + +(defmacro throw-cancel (&optional value) + `(throw :cancel ,value)) + +;;; Throwing like this works in listeners and in the initial process. +;;; Can't easily tell if a process is a listener. Should be able to. +(defun toplevel () + (throw :toplevel nil)) + + +;;; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS - +;;; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either. +(defun interactive-abort () + (interactive-abort-in-process *current-process*)) + +(defun interactive-abort-in-process (p) + (if p (process-interrupt p + #'(lambda () + (unless *inhibit-abort* + (if *in-read-loop* + (abort-break) + (abort)) + ))))) + + +(defun abort (&optional condition) + "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if + none exists." + (invoke-restart-no-return (find-restart 'abort condition))) + +(defun continue (&optional condition) + "Transfer control to a restart named CONTINUE, or return NIL if none exists." + (let ((r (find-restart 'continue condition))) + (if r (invoke-restart r)))) + +(defun muffle-warning (&optional condition) + "Transfer control to a restart named MUFFLE-WARNING, signalling a + CONTROL-ERROR if none exists." + (invoke-restart-no-return (find-restart 'muffle-warning condition))) + +(defun abort-break () + (invoke-restart-no-return 'abort-break)) + + +(defun quit (&optional (exit 0) &key error-handler) + "exit must be either a (signed-byte 32) exit status or a function to call to exit lisp + error-handler can be a function of one argument, the condition, that will be called if an + error occurs while preparing to quit. The error handler should exit" + (if (or (null exit) (typep exit '(signed-byte 32))) + (setq exit (let ((exit-status (or exit 0))) + #'(lambda () (#__exit exit-status)))) + (unless (typep exit 'function) + (report-bad-arg exit '(or (signed-byte 32) function)))) + (let* ((ip *initial-process*) + (cp *current-process*)) + (when (process-verify-quit ip) + (process-interrupt ip + #'(lambda () + (handler-bind ((error (lambda (c) + (when error-handler + (funcall error-handler c))))) + (process-exit-application *current-process* + #'(lambda () + (%set-toplevel nil) + (funcall exit) ;; must exit + (bug "Exit function didn't exit")))))) + (unless (eq cp ip) + (process-kill cp))))) + + +(defloadvar *quitting* nil) + + +(defun prepare-to-quit (&optional part) + (let-globally ((*quitting* t)) + (when (or (null part) (eql 0 part)) + (dolist (f *lisp-cleanup-functions*) + (funcall f))) + (let* ((stragglers ())) + (dolist (p (all-processes)) + (unless (or (eq p *initial-process*) + (not (process-active-p p))) + (if (process-persistent p) + (process-reset p :shutdown) + (process-kill p)))) + (dolist (p (all-processes)) + (let* ((semaphore (process-termination-semaphore p))) + (when semaphore + (unless (eq p *initial-process*) + (unless (timed-wait-on-semaphore semaphore 0.05) + (push p stragglers)))))) + (dolist (p stragglers) + (let* ((semaphore (process-termination-semaphore p))) + (maybe-finish-process-kill p :kill) + (when semaphore + (timed-wait-on-semaphore semaphore 0.10))))) + (shutdown-lisp-threads) + (loop + (let* ((streams (open-file-streams))) + (when (null streams) (return)) + (let* ((ioblock (stream-ioblock (car streams) nil))) + (when ioblock + (setf (ioblock-inbuf-lock ioblock) nil + (ioblock-outbuf-lock ioblock) nil + (ioblock-owner ioblock) nil))) + (close (car streams)))) + (setf (interrupt-level) -1) ; can't abort after this + ) + ;; Didn't abort, so really quitting. + (setq *quitting* t)) + + +(defun signal (condition &rest args) + "Invokes the signal facility on a condition formed from DATUM and + ARGUMENTS. If the condition is not handled, NIL is returned. If + (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked + before any signalling is done." + (setq condition (condition-arg condition args 'simple-condition)) + (let* ((*break-on-signals* *break-on-signals*)) + (let* ((old-bos *break-on-signals*)) + (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos))) + (setq *break-on-signals* nil) + (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals* old-bos))) + + (when (typep condition *break-on-signals*) + (let ((*break-on-signals* nil)) + (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr))))) + (let ((%handlers% %handlers%)) + (while %handlers% + (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers))) + ((null handlers)) + (when (typep condition (car handlers)) + (let ((fn (cadr handlers))) + (cond ((null fn) (throw tag condition)) + ((fixnump fn) (throw tag (cons fn condition))) + (t (funcall fn condition))))))))) + +(defvar *error-print-circle* nil) ; reset to T when we actually can print-circle + + + +;;;*********************************** +;;;Mini-evaluator +;;;*********************************** + +(defun new-lexical-environment (&optional parent) + (%istruct 'lexical-environment parent nil nil nil nil nil nil)) + +(defmethod make-load-form ((e lexical-environment) &optional env) + (declare (ignore env)) + nil) + +(defun new-definition-environment (&optional (type 'compile-file)) + (%istruct 'definition-environment (list type) nil nil nil nil nil nil nil nil nil nil nil nil )) + +(defun definition-environment (env &optional clean-only &aux parent) + (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment)) + (do* () + ((or (null env) + (listp (setq parent (lexenv.parent-env env))) + (and clean-only (or (lexenv.variables env) (lexenv.functions env))))) + (setq env parent)) + (if (consp parent) + env)) + +(defvar *symbol-macros* (make-hash-table :test #'eq)) + +(defun %define-symbol-macro (name expansion) + (if (or (constant-symbol-p name) + (proclaimed-special-p name)) + (signal-program-error "Symbol ~s already globally defined as a ~A" + name (if (constant-symbol-p name) + 'constant + 'variable))) + (setf (gethash name *symbol-macros*) expansion) + name) + +(defvar *macroexpand-hook* 'funcall + "The value of this variable must be a designator for a function that can + take three arguments, a macro expander function, the macro form to be + expanded, and the lexical environment to expand in. The function should + return the expanded form. This function is called by MACROEXPAND-1 + whenever a runtime expansion is needed. Initially this is set to + FUNCALL.") ; Should be #'funcall. +;(queue-fixup (setq *macroexpand-hook* #'funcall)) ; No it shouldn't. + +(defun %symbol-macroexpand-1 (sym env) + (flet ((expand-it (expansion) + (funcall *macroexpand-hook* + (constantly expansion) + sym + env))) + (if (and env (not (istruct-typep env 'lexical-environment))) + (report-bad-arg env 'lexical-environment)) + (do* ((env env (lexenv.parent-env env))) + ((null env)) + (if (istruct-typep env 'definition-environment) + (let* ((info (assq sym (defenv.symbol-macros env)))) + (if info + (return-from %symbol-macroexpand-1 (values (expand-it (cdr info)) t)) + (return))) + (let* ((vars (lexenv.variables env))) + (dolist (vdecl (lexenv.vdecls env)) + (if (and (eq (car vdecl) sym) + (eq (cadr vdecl) 'special)) + (return-from %symbol-macroexpand-1 (values sym nil)))) + (when (consp vars) + (let* ((info (dolist (var vars) + (if (eq (var-name var) sym) + (return var))))) + (when info + (if (and (consp (setq info (var-expansion info))) + (eq (%car info) :symbol-macro)) + (return-from %symbol-macroexpand-1 (values (expand-it (%cdr info)) t)) + (return-from %symbol-macroexpand-1 (values sym nil))))))))) + ;; Look it up globally. + (multiple-value-bind (expansion win) (gethash sym *symbol-macros*) + (if win (values (expand-it expansion) t) (values sym nil))))) + +(defun macroexpand-all (form &optional (env (new-lexical-environment))) + "Recursivly expand all macros in FORM." + (flet ((mexpand (forms env) + (mapcar (lambda (form) (macroexpand-all form env)) forms))) + (macrolet ((destructuring-bind-body (binds form &body body) + (if (eql '&body (first (last binds))) + (let ((&body (gensym "&BODY"))) + `(destructuring-bind ,(append (butlast binds) (list '&body &body)) + ,form + (multiple-value-bind (body decls) + (parse-body ,&body env nil) + ,@body))) + `(destructuring-bind ,binds ,form ,@body)))) + (multiple-value-bind (expansion win) + (macroexpand-1 form env) + (if win + (macroexpand-all expansion env) + (if (atom form) + form + (case (first form) + (macrolet + (destructuring-bind-body (macros &body) (rest form) + (setf env (augment-environment env + :macro (mapcar (lambda (macro) + (destructuring-bind + (name arglist &body body) + macro + (list name (enclose (parse-macro name arglist body env))))) + macros) + :declare (decl-specs-from-declarations decls))) + (let ((body (mexpand body env))) + (if decls + `(locally ,@decls ,@body) + `(progn ,@body))))) + (symbol-macrolet + (destructuring-bind-body (symbol-macros &body) (rest form) + (setf env (augment-environment env :symbol-macro symbol-macros :declare (decl-specs-from-declarations decls))) + (let ((body (mexpand body env))) + (if decls + `(locally ,@decls ,@body) + `(progn ,@body))))) + ((let let* compiler-let) + (destructuring-bind-body (bindings &body) (rest form) + `(,(first form) + ,(mapcar (lambda (binding) + + (if (listp binding) + (list (first binding) (macroexpand-all (second binding) env)) + binding)) + bindings) + ,@decls + ,@(mexpand body env)))) + ((flet labels) + (destructuring-bind-body (bindings &body) (rest form) + (let ((augmented-env + (augment-environment env :function (mapcar #'car bindings)))) + `(,(first form) + ,(mapcar (lambda (binding) + (list* (first binding) + (cdr (macroexpand-all `(lambda ,@(rest binding)) + (if (eq (first form) 'labels) + augmented-env + env))))) + bindings) + ,@decls + ,@(mexpand body augmented-env))))) + (nfunction (list* 'nfunction (second form) (macroexpand-all (third form) env))) + (function + (if (and (consp (second form)) + (eql 'lambda (first (second form)))) + (destructuring-bind (lambda arglist &body body&decls) + (second form) + (declare (ignore lambda)) + (multiple-value-bind (body decls) + (parse-body body&decls env) + `(lambda ,arglist ,@decls ,@(mexpand body env)))) + form)) + ((eval-when the locally block return-from) + (list* (first form) (second form) (mexpand (cddr form) env))) + (setq + `(setq ,@(loop for (name value) on (rest form) by #'cddr + collect name + collect (macroexpand-all value env)))) + ((go quote) form) + ((fbind with-c-frame with-variable-c-frame ppc-lap-function) + (error "Unable to macroexpand ~S." form)) + ((catch if load-time-value multiple-value-call multiple-value-prog1 progn + progv tagbody throw unwind-protect) + (cons (first form) (mexpand (rest form) env))) + (t + ;; need to check that (first form) is either fboundp or a local function... + (cons (first form) (mexpand (rest form) env)))))))))) + +(defun macroexpand-1 (form &optional env &aux fn) + "If form is a macro (or symbol macro), expand it once. Return two values, + the expanded form and a T-or-NIL flag indicating whether the form was, in + fact, a macro. ENV is the lexical environment to expand in, which defaults + to the null environment." + (declare (resident)) + (if (and (consp form) + (symbolp (%car form))) + (if (setq fn (macro-function (%car form) env)) + (values (funcall *macroexpand-hook* fn form env) t) + (values form nil)) + (if (and form (symbolp form)) + (%symbol-macroexpand-1 form env) + (values form nil)))) + +(defun macroexpand (form &optional env) + "Repetitively call MACROEXPAND-1 until the form can no longer be expanded. + Returns the final resultant form, and T if it was expanded. ENV is the + lexical environment to expand in, or NIL (the default) for the null + environment." + (declare (resident)) + (multiple-value-bind (new win) (macroexpand-1 form env) + (do* ((won-at-least-once win)) + ((null win) (values new won-at-least-once)) + (multiple-value-setq (new win) (macroexpand-1 new env))))) + +(defun %symbol-macroexpand (form env &aux win won) + ; Keep expanding until no longer a symbol-macro or no longer a symbol. + (loop + (unless (and form (symbolp form)) (return)) + (multiple-value-setq (form win) (macroexpand-1 form env)) + (if win (setq won t) (return))) + (values form won)) + +(defun retain-lambda-expression (name lambda-expression env) + (if (and (let* ((lambda-list (cadr lambda-expression))) + (and (not (memq '&lap lambda-list)) + (not (memq '&method lambda-list)) + (not (memq '&lexpr lambda-list)))) + (nx-declared-inline-p name env) + (not (gethash name *nx1-alphatizers*)) + ; A toplevel definition defined inside a (symbol-)macrolet should + ; be inlineable. It isn't; call DEFINITION-ENVIRONMENT with a + ; "clean-only" argument to ensure that there are no lexically + ; bound macros or symbol-macros. + (definition-environment env t)) + lambda-expression)) + + +(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers) + (ecase type + (defun nil) + (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=nil + (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-gfn-bit) lfbits))) + (defmethod (setq data (list :methods + (%cons-def-info-method lfbits keyvect qualifiers specializers)) + lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit)) + keyvect nil)) + (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file*)))) + (vector lfbits keyvect *loading-file-source-file* data)) + +(defun def-info.lfbits (def-info) + (and def-info + (let ((lfbits (svref def-info 0))) + (if (consp lfbits) (%car lfbits) lfbits)))) + +(defun def-info.keyvect (def-info) + (and def-info (svref def-info 1))) + +(defun def-info.file (def-info) + (and def-info (svref def-info 2))) + +(defun def-info.lambda (def-info) + (and def-info + (let ((data (svref def-info 3))) + (and (eq (car data) 'lambda) data)))) + +(defun def-info.methods (def-info) + (and def-info + (let ((data (svref def-info 3))) + (and (eq (car data) :methods) (%cdr data))))) + +(defun %cons-def-info-method (lfbits keyvect qualifiers specializers) + (cons (cons (and keyvect + (if (logbitp $lfbits-aok-bit lfbits) + (and (not (logbitp $lfbits-rest-bit lfbits)) + (list keyvect)) + keyvect)) + *loading-file-source-file*) + (cons qualifiers specializers))) + +(defun def-info-method.keyvect (def-info-method) + (let ((kv (caar def-info-method))) + (if (listp kv) + (values (car kv) t) + (values kv nil)))) + +(defun def-info-method.file (def-info-method) + (cdar def-info-method)) + +(defun def-info-with-new-methods (def-info new-bits new-methods) + (if (and (eq new-methods (def-info.methods def-info)) + (eql new-bits (def-info.lfbits def-info))) + def-info + (let ((new (copy-seq def-info)) + (old-bits (svref def-info 0))) + (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bits)) old-bits)) + (setf (svref new 3) (cons :methods new-methods)) + new))) + +(defun def-info.macro-p (def-info) + (let ((data (and def-info (svref def-info 3)))) + (eq (car data) 'macro))) + +(defun def-info.function-p (def-info) + (not (and def-info (eq (car (svref def-info 3)) 'type)))) + +(defun def-info.function-type (def-info) + (if (null def-info) + nil ;; ftype only, for the purposes here, is same as nothing. + (let ((data (svref def-info 3))) + (ecase (car data) + ((nil lambda) 'defun) + (:methods 'defgeneric) + (macro 'defmacro) + (ftype nil) + (type nil))))) + +(defun def-info.deftype (def-info) + (and def-info + (let ((bits (svref def-info 0))) + ;; bits or (bits . type-source-file) + (and (consp bits) bits)))) + +(defun def-info.deftype-type (def-info) + ;; 'class (for defclass/defstruct) or 'macro (for deftype et. al.) + (and def-info + (consp (svref def-info 0)) + (svref def-info 1))) + +(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x)))) + +(defvar *compiler-warn-on-duplicate-definitions* t) + +(defun combine-deftype-infos (name def-info old-deftype new-deftype) + (when (or new-deftype old-deftype) + (when (and old-deftype new-deftype *compiler-warn-on-duplicate-definitions*) + (nx1-whine :duplicate-definition + `(type ,name) + (cdr old-deftype) + (cdr new-deftype))) + (let ((target (if new-deftype + (or (cdr new-deftype) (cdr old-deftype)) + (cdr old-deftype))) + (target-deftype (def-info.deftype def-info))) + (unless (and target-deftype (eq (cdr target-deftype) target)) + (setq def-info (copy-seq (or def-info '#(nil nil nil (ftype))))) + (setf (svref def-info 0) (cons (def-info.lfbits def-info) target))))) + def-info) + +#+debug +(defun describe-def-info (def-info) + (list :lfbits (def-info.lfbits def-info) + :keyvect (def-info.keyvect def-info) + :macro-p (def-info.macro-p def-info) + :function-p (def-info.function-p def-info) + :lambda (and (def-info.function-p def-info) (def-info.lambda def-info)) + :methods (and (def-info.function-p def-info) (def-info.methods def-info)) + :function-type (def-info.function-type def-info) + :deftype (def-info.deftype def-info) + :deftype-type (def-info.deftype-type def-info))) + +(defun combine-gf-def-infos (name old-info new-info) + (let* ((old-bits (def-info.lfbits old-info)) + (new-bits (def-info.lfbits new-info)) + (old-methods (def-info.methods old-info)) + (new-methods (def-info.methods new-info))) + (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit new-bits)) + (when *compiler-warn-on-duplicate-definitions* + (nx1-whine :duplicate-definition + name + (def-info.file old-info) + (def-info.file new-info))) + (return-from combine-gf-def-infos new-info)) + (unless (congruent-lfbits-p old-bits new-bits) + (if (logbitp $lfbits-gfn-bit new-bits) + ;; A defgeneric, incongruent with previously defined methods + (nx1-whine :incongruent-gf-lambda-list name) + ;; A defmethod incongruent with previously defined explicit or implicit generic + (nx1-whine :incongruent-method-lambda-list + (if new-methods `(:method ,@(cadar new-methods) ,name ,(cddar new-methods)) name) + name)) + ;; Perhaps once this happens, should just mark it somehow to not complain again + (return-from combine-gf-def-infos + (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info))) + (loop for new-method in new-methods + as old = (member (cdr new-method) old-methods :test #'equal :key #'cdr) + do (when old + (when *compiler-warn-on-duplicate-definitions* + (nx1-whine :duplicate-definition + `(:method ,@(cadr new-method) ,name ,(cddr new-method)) + (def-info-method.file (car old)) + (def-info-method.file new-method))) + (setq old-methods (remove (car old) old-methods :test #'eq))) + do (push new-method old-methods)) + (cond ((logbitp $lfbits-gfn-bit new-bits) + ;; If adding a defgeneric, use its info. + (setq old-info new-info old-bits new-bits)) + ((not (logbitp $lfbits-gfn-bit old-bits)) + ;; If no defgeneric (yet?) just remember whether any method has &key + (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits-keys-bit)))))) + ;; Check that all methods implement defgeneric keys + (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvect old-info)))) + (when (> (length gfkeys) 0) + (loop for minfo in old-methods + do (multiple-value-bind (mkeys aok) (def-info-method.keyvect minfo) + (when (and mkeys + (not aok) + (setq mkeys (loop for gk across gfkeys + unless (find gk mkeys) collect gk))) + (nx1-whine :gf-keys-not-accepted + `(:method ,@(cadr minfo) ,name ,(cddr minfo)) + mkeys)))))) + (def-info-with-new-methods old-info old-bits old-methods))) + +(defun combine-definition-infos (name old-info new-info) + (let ((old-type (def-info.function-type old-info)) + (old-deftype (def-info.deftype old-info)) + (new-type (def-info.function-type new-info)) + (new-deftype (def-info.deftype new-info))) + (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric)) + (setq new-info (combine-gf-def-infos name old-info new-info))) + ((or (eq (or old-type 'defun) (or new-type 'defun)) + (eq (or old-type 'defgeneric) (or new-type 'defgeneric))) + (when (and old-type new-type *compiler-warn-on-duplicate-definitions*) + (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info))) + (unless new-info (setq new-info old-info))) + (t + (when (and (def-info.function-p old-info) (def-info.function-p new-info) + *compiler-warn-on-duplicate-definitions*) + (apply #'nx1-whine :duplicate-definition + name + (def-info.file old-info) + (def-info.file new-info) + (cond ((eq old-type 'defmacro) '("macro" "function")) + ((eq new-type 'defmacro) '("function" "macro")) + ((eq old-type 'defgeneric) '("generic function" "function")) + (t '("function" "generic function"))))) + (unless new-type (setq new-info old-info)))) + (combine-deftype-infos name new-info old-deftype new-deftype))) + +(defun record-definition-info (name info env) + (let* ((definition-env (definition-environment env))) + (if definition-env + (let* ((defs (defenv.defined definition-env)) + (already (if (listp defs) (assq name defs) (gethash name defs)))) + (if already + (setf (%cdr already) (combine-definition-infos name (%cdr already) info)) + (let ((outer (loop for defer = (cdr (defenv.type definition-env)) + then (deferred-warnings.parent defer) + while (typep defer 'deferred-warnings) + thereis (gethash name (deferred-warnings.defs defer))))) + (when outer + (setq info (combine-definition-infos name (%cdr outer) info))) + (let ((new (cons name info))) + (if (listp defs) + (setf (defenv.defined definition-env) (cons new defs)) + (setf (gethash name defs) new))))) + info)))) + +(defun record-function-info (name info env) + (record-definition-info name info env)) + +;;; This is different from AUGMENT-ENVIRONMENT. +(defun note-function-info (name lambda-expression env) + (let* ((info nil) + (name (maybe-setf-function-name name))) + (when (lambda-expression-p lambda-expression) + (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t) + (setq info (%cons-def-info 'defun lfbits keyvect + (retain-lambda-expression name lambda-expression env))))) + (record-function-info name info env)) + name) + +(defun note-type-info (name kind env) + (record-definition-info name (%cons-def-info 'deftype nil kind) env)) + + +; And this is different from FUNCTION-INFORMATION. +(defun retrieve-environment-function-info (name env) + (let ((defenv (definition-environment env))) + (when defenv + (let* ((defs (defenv.defined defenv)) + (sym (maybe-setf-function-name name)) + (info (if (listp defs) (assq sym defs) (gethash sym defs)))) + (and info (def-info.function-p (cdr info)) info))))) + +;;; Must differ from -something-, but not sure what ... +(defun note-variable-info (name info env) + (let ((definition-env (definition-environment env))) + (if definition-env (push (cons name info) (defenv.specials definition-env))) + name)) + +(defun compile-file-environment-p (env) + (let ((defenv (definition-environment env))) + (and defenv (eq 'compile-file (car (defenv.type defenv)))))) + +;; This is EVAL. +(defun cheap-eval (form) + ;; Don't record source locations for explicit calls to EVAL. + (let ((*nx-source-note-map* nil)) + (cheap-eval-in-environment form nil))) + +; used by nfcomp too +; Should preserve order of decl-specs; it sometimes matters. +(defun decl-specs-from-declarations (declarations) + (let ((decl-specs nil)) + (dolist (declaration declarations decl-specs) + ;(unless (eq (car declaration) 'declare) (say "what")) + (dolist (decl-spec (cdr declaration)) + (setq decl-specs (nconc decl-specs (list decl-spec))))))) + +(defun cheap-eval-macroexpand-1 (form env) + (multiple-value-bind (new win) (macroexpand-1 form env) + (when win + (note-source-transformation form new)) + (values new win))) + +(defun cheap-eval-transform (original new) + (note-source-transformation original new) + new) + +(defun cheap-eval-function (name lambda env) + (multiple-value-bind (lfun warnings) + (compile-named-function lambda + :name name + :env env + :function-note *loading-toplevel-location* + :keep-lambda *save-definitions* + :keep-symbols *save-local-symbols* + :source-notes *nx-source-note-map*) + (signal-or-defer-warnings warnings env) + lfun)) + +(fset 'nx-source-note (nlambda bootstrapping-source-note (form) (declare (ignore form)) nil)) + +(defun cheap-eval-in-environment (form env &aux sym) + ;; Allow ADVICE, TRACE to have effects on self-calls. + (declare (notinline cheap-eval-in-environment)) + ;; records source locations if *nx-source-note-map* is bound by caller + (setq *loading-toplevel-location* (or (nx-source-note form) *loading-toplevel-location*)) + (flet ((progn-in-env (body&decls parse-env base-env) + (multiple-value-bind (body decls) (parse-body body&decls parse-env) + (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls))) + (loop with default-location = *loading-toplevel-location* + while (cdr body) as form = (pop body) + do (cheap-eval-in-environment form base-env) + do (setq *loading-toplevel-location* default-location)) + (cheap-eval-in-environment (car body) base-env)))) + (if form + (cond ((symbolp form) + (multiple-value-bind (expansion win) (cheap-eval-macroexpand-1 form env) + (if win + (cheap-eval-in-environment expansion env) + (let* ((defenv (definition-environment env)) + (constant (if defenv (assq form (defenv.constants defenv)))) + (constval (%cdr constant))) + (if constant + (if (neq (%unbound-marker-8) constval) + constval + (error "Can't determine value of constant symbol ~s" form)) + (if (constant-symbol-p form) + (%sym-global-value form) + (symbol-value form))))))) + ((atom form) form) + ((eq (setq sym (%car form)) 'quote) + (verify-arg-count form 1 1) + (%cadr form)) + ((eq sym 'function) + (verify-arg-count form 1 1) + (cond ((symbolp (setq sym (%cadr form))) + (multiple-value-bind (kind local-p) + (function-information sym env) + (if (and local-p (eq kind :macro)) + (error "~s can't be used to reference lexically defined macro ~S" 'function sym))) + (%function sym)) + ((setf-function-name-p sym) + (multiple-value-bind (kind local-p) + (function-information sym env) + (if (and local-p (eq kind :macro)) + (error "~s can't be used to reference lexically defined macro ~S" 'function sym))) + (%function (setf-function-name (%cadr sym)))) + (t (cheap-eval-function nil sym env)))) + ((eq sym 'nfunction) + (verify-arg-count form 2 2) + (cheap-eval-function (%cadr form) (%caddr form) env)) + ((eq sym 'progn) (progn-in-env (%cdr form) env env)) + ((eq sym 'setq) + (if (not (%ilogbitp 0 (list-length form))) + (verify-arg-count form 0 0)) ;Invoke a "Too many args" error. + (let* ((sym nil) + (val nil) + (original form)) + (while (setq form (%cdr form)) + (setq sym (require-type (pop form) 'symbol)) + (multiple-value-bind (expansion expanded) + (cheap-eval-macroexpand-1 sym env) + (if expanded + (setq val (cheap-eval-in-environment + (cheap-eval-transform original `(setf ,expansion ,(%car form))) + env)) + (set sym (setq val (cheap-eval-in-environment (%car form) env)))))) + val)) + ((eq sym 'eval-when) + (destructuring-bind (when . body) (%cdr form) + (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env)))) + ((eq sym 'if) + (destructuring-bind (test true &optional false) (%cdr form) + (setq test (let ((*loading-toplevel-location* *loading-toplevel-location*)) + (cheap-eval-in-environment test env))) + (cheap-eval-in-environment (if test true false) env))) + ((eq sym 'locally) (progn-in-env (%cdr form) env env)) + ((eq sym 'symbol-macrolet) + (multiple-value-bind (body decls) (parse-body (cddr form) env) + (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls))))) + ((eq sym 'macrolet) + (let ((temp-env (augment-environment env + :macro + (mapcar #'(lambda (m) + (destructuring-bind (name arglist &body body) m + (list name (enclose (parse-macro name arglist body env) + env)))) + (cadr form))))) + (progn-in-env (cddr form) temp-env temp-env))) + ((and (symbolp sym) + (compiler-special-form-p sym) + (not (functionp (fboundp sym)))) + (if (eq sym 'unwind-protect) + (destructuring-bind (protected-form . cleanup-forms) (cdr form) + (unwind-protect + (let ((*loading-toplevel-location* *loading-toplevel-location*)) + (cheap-eval-in-environment protected-form env)) + (progn-in-env cleanup-forms env env))) + (let ((fn (cheap-eval-function nil (cheap-eval-transform form `(lambda () (progn ,form))) env))) + (funcall fn)))) + ((and (symbolp sym) (macro-function sym env)) + (cheap-eval-in-environment (cheap-eval-macroexpand-1 form env) env)) + ((or (symbolp sym) + (and (consp sym) (eq (%car sym) 'lambda))) + (let ((args nil) (form-location *loading-toplevel-location*)) + (dolist (elt (%cdr form)) + (push (cheap-eval-in-environment elt env) args) + (setq *loading-toplevel-location* form-location)) + (apply #'call-check-regs (if (symbolp sym) sym (cheap-eval-function nil sym env)) + (nreverse args)))) + (t + (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form)))))) + + +(%fhave 'eval #'cheap-eval) + + + + +(defun call-check-regs (fn &rest args) + (declare (dynamic-extent args) + (optimize (debug 3))) ; don't use any saved registers + (let ((old-regs (multiple-value-list (get-saved-register-values)))) + (declare (dynamic-extent old-regs)) + (multiple-value-prog1 (apply fn args) + (let* ((new-regs (multiple-value-list (get-saved-register-values))) + (new-regs-tail new-regs)) + (declare (dynamic-extent new-regs)) + (unless (dolist (old-reg old-regs t) + (unless (eq old-reg (car new-regs-tail)) + (return nil)) + (pop new-regs-tail)) + (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}" + fn args + (mapcan 'list + (let ((res nil)) + (dotimes (i (length old-regs)) + (push (format nil "save~d" i) res)) + (nreverse res)) + old-regs + new-regs))))))) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Stack frame accessors. + +; Kinda scant, wouldn't you say ? + + +;end of L1-readloop.lisp + Index: /branches/qres/ccl/level-1/l1-sockets.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-sockets.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-sockets.lisp (revision 13564) @@ -0,0 +1,1516 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + +;;; basic socket API +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(MAKE-SOCKET + ACCEPT-CONNECTION + DOTTED-TO-IPADDR + IPADDR-TO-DOTTED + IPADDR-TO-HOSTNAME + LOOKUP-HOSTNAME + LOOKUP-PORT + ;;with-pending-connect + RECEIVE-FROM + SEND-TO + SHUTDOWN + ;;socket-control + SOCKET-OS-FD + REMOTE-HOST + REMOTE-PORT + REMOTE-FILENAME + LOCAL-HOST + LOCAL-PORT + LOCAL-FILENAME + SOCKET-ADDRESS-FAMILY + SOCKET-CONNECT + SOCKET-FORMAT + SOCKET-TYPE + SOCKET-ERROR + SOCKET-ERROR-CODE + SOCKET-ERROR-IDENTIFIER + SOCKET-ERROR-SITUATION + SOCKET-CREATION-ERROR + SOCKET-CREATION-ERROR-CODE + SOCKET-CREATION-ERROR-IDENTIFIER + SOCKET-CREATION-ERROR-SITUATION + WITH-OPEN-SOCKET)) + #+windows-target + (defmacro check-winsock-error (form) + (let* ((val (gensym))) + `(let* ((,val ,form)) + (if (< ,val 0) + (%get-winsock-error) + ,val)))) + (defmacro check-socket-error (form) + #+windows-target `(check-winsock-error ,form) + #-windows-target `(int-errno-call ,form)) + ) + + +#+windows-target +(defun %get-winsock-error () + (- (#_WSAGetLastError))) + +;;; The PPC is big-endian (uses network byte order), which makes +;;; things like #_htonl and #_htonl no-ops. These functions aren't +;;; necessarily defined as functions in some header files (I'm sure +;;; that that either complies with or violates some C standard), and +;;; it doesn't seem to make much sense to fight that to do ff-calls +;;; to a couple of identity functions. + +#+big-endian-target +(progn + (defmacro HTONL (x) x) + (defmacro HTONS (x) x) + (defmacro NTOHL (x) x) + (defmacro NTOHS (x) x)) + +#+little-endian-target +(progn + (declaim (inline %bswap32 %bswap16)) + (defun %bswap32 (x) + (declare (type (unsigned-byte 32) x)) + (%swap-u32 x)) + (defun %bswap16 (x) + (declare (type (unsigned-byte 16) x)) + (%swap-u16 x)) + (defmacro HTONL (x) `(%bswap32 ,x)) + (defmacro HTONS (x) `(%bswap16 ,x)) + (defmacro NTOHL (x) `(%bswap32 ,x)) + (defmacro NTOHS (x) `(%bswap16 ,x))) + +(defparameter *default-socket-character-encoding* + nil) + +(defmethod default-character-encoding ((domain (eql :socket))) + *default-socket-character-encoding*) + + +;;; On some (hypothetical) little-endian platform, we might want to +;;; define HTONL and HTONS to actually swap bytes around. + +(defpackage "OPENMCL-SOCKET" + (:use "CL") + (:import-from "CCL" + "MAKE-SOCKET" + "ACCEPT-CONNECTION" + "DOTTED-TO-IPADDR" + "IPADDR-TO-DOTTED" + "IPADDR-TO-HOSTNAME" + "LOOKUP-HOSTNAME" + "LOOKUP-PORT" + ;;with-pending-connect + "RECEIVE-FROM" + "SEND-TO" + "SHUTDOWN" + ;;socket-control + "SOCKET-OS-FD" + "REMOTE-HOST" + "REMOTE-PORT" + "REMOTE-FILENAME" + "LOCAL-HOST" + "LOCAL-PORT" + "LOCAL-FILENAME" + "SOCKET-ADDRESS-FAMILY" + "SOCKET-CONNECT" + "SOCKET-FORMAT" + "SOCKET-TYPE" + "SOCKET-ERROR" + "SOCKET-ERROR-CODE" + "SOCKET-ERROR-IDENTIFIER" + "SOCKET-ERROR-SITUATION" + "SOCKET-CREATION-ERROR" + "SOCKET-CREATION-ERROR-CODE" + "SOCKET-CREATION-ERROR-IDENTIFIER" + "SOCKET-CREATION-ERROR-SITUATION" + "WITH-OPEN-SOCKET") + (:export "MAKE-SOCKET" + "ACCEPT-CONNECTION" + "DOTTED-TO-IPADDR" + "IPADDR-TO-DOTTED" + "IPADDR-TO-HOSTNAME" + "LOOKUP-HOSTNAME" + "LOOKUP-PORT" + ;;with-pending-connect + "RECEIVE-FROM" + "SEND-TO" + "SHUTDOWN" + ;;socket-control + "SOCKET-OS-FD" + "REMOTE-HOST" + "REMOTE-PORT" + "REMOTE-FILENAME" + "LOCAL-HOST" + "LOCAL-PORT" + "LOCAL-FILENAME" + "SOCKET-ADDRESS-FAMILY" + "SOCKET-CONNECT" + "SOCKET-FORMAT" + "SOCKET-TYPE" + "SOCKET-ERROR" + "SOCKET-ERROR-CODE" + "SOCKET-ERROR-IDENTIFIER" + "SOCKET-ERROR-SITUATION" + "SOCKET-CREATION-ERROR" + "SOCKET-CREATION-ERROR-CODE" + "SOCKET-CREATION-ERROR-IDENTIFIER" + "SOCKET-CREATION-ERROR-SITUATION" + "WITH-OPEN-SOCKET")) + +(define-condition socket-error (simple-stream-error) + ((code :initarg :code :reader socket-error-code) + (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier) + (situation :initarg :situation :reader socket-error-situation))) + +(define-condition socket-creation-error (simple-error) + ((code :initarg :code :reader socket-creation-error-code) + (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier) + (situation :initarg :situation :reader socket-creation-error-situation))) + +(defparameter *gai-error-identifiers* + (list #$EAI_AGAIN :try-again + #$EAI_FAIL :no-recovery + #$EAI_NONAME :host-not-found)) + +(defvar *socket-error-identifiers* + #-windows-target + (list #$EADDRINUSE :address-in-use + #$ECONNABORTED :connection-aborted + #$ENOBUFS :no-buffer-space + #$ENOMEM :no-buffer-space + #$ENFILE :no-buffer-space + #$ETIMEDOUT :connection-timed-out + #$ECONNREFUSED :connection-refused + #$ENETUNREACH :host-unreachable + #$EHOSTUNREACH :host-unreachable + #$EHOSTDOWN :host-down + #$ENETDOWN :network-down + #$EADDRNOTAVAIL :address-not-available + #$ENETRESET :network-reset + #$ECONNRESET :connection-reset + #$ESHUTDOWN :shutdown + #$EACCES :access-denied + #$EPERM :access-denied) + #+windows-target + (list #$WSAEADDRINUSE :address-in-use + #$WSAECONNABORTED :connection-aborted + #$WSAENOBUFS :no-buffer-space + #$ENOMEM :no-buffer-space + #$ENFILE :no-buffer-space + #$WSAETIMEDOUT :connection-timed-out + #$WSAECONNREFUSED :connection-refused + #$WSAENETUNREACH :host-unreachable + #$WSAEHOSTUNREACH :host-unreachable + #$WSAEHOSTDOWN :host-down + #$WSAENETDOWN :network-down + #$WSAEADDRNOTAVAIL :address-not-available + #$WSAENETRESET :network-reset + #$WSAECONNRESET :connection-reset + #$WSAESHUTDOWN :shutdown + #$EACCES :access-denied + #$EPERM :access-denied) + ) + + +(declaim (inline socket-call)) +(defun socket-call (stream where res) + (if (< res 0) + (socket-error stream where res) + res)) + +#-windows-target +(defun %gai-strerror (err) + (let ((p (#_gai_strerror err))) + (if (%null-ptr-p p) + (format nil "Unknown nameserver error ~d" err) + (%get-cstring p)))) + +(defun socket-error (stream where errno &optional nameserver-p) + "Creates and signals (via error) one of two socket error +conditions, based on the state of the arguments." + (unless nameserver-p + (setq errno (abs errno))) + (if stream + (error (make-condition 'socket-error + :stream stream + :code errno + :identifier (getf *socket-error-identifiers* errno :unknown) + :situation where + :format-control "~a (error #~d) during ~a" + :format-arguments (list + #+windows-target + (%windows-error-string errno) + #-windows-target + (%strerror errno) + errno where))) + (let ((identifiers (if nameserver-p + *gai-error-identifiers* + *socket-error-identifiers*))) + (error (make-condition 'socket-creation-error + :code errno + :identifier (getf identifiers errno :unknown) + :situation where + :format-control "~a (error #~d) during socket creation or nameserver operation in ~a" + :format-arguments (list + #+windows-target + (%windows-error-string errno) + #-windows-target + (if nameserver-p + (%gai-strerror errno) + (%strerror errno)) + errno where)))))) + +;; If true, this will try to allow other cooperative processes to run +;; while socket io is happening. Since CCL threads are preemptively +;; scheduled, this isn't particularly meaningful. +(defvar *multiprocessing-socket-io* nil) + +(defclass socket () + ()) + +(defmacro with-open-socket ((var . args) &body body + &aux (socket (make-symbol "socket")) + (done (make-symbol "done"))) + "Execute body with var bound to the result of applying make-socket to +make-socket-args. The socket gets closed on exit." + `(let (,socket ,done) + (unwind-protect + (multiple-value-prog1 + (let ((,var (setq ,socket (make-socket ,@args)))) + ,@body) + (setq ,done t)) + (when ,socket (close ,socket :abort (not ,done)))))) + +(defgeneric socket-address-family (socket) + (:documentation "Return :internet or :file, as appropriate.")) + +(defclass ip-socket (socket) + ()) + +(defmethod socket-address-family ((socket ip-socket)) :internet) + +(defclass file-socket (socket) + ()) + +(defmethod socket-address-family ((socket file-socket)) :file) + +(defclass tcp-socket (ip-socket) + ()) + +(defgeneric socket-type (socket) + (:documentation + "Return :stream for tcp-stream and listener-socket, and :datagram +for udp-socket.")) + +(defmethod socket-type ((socket tcp-socket)) :stream) + +(defclass stream-file-socket (file-socket) + ()) + +(defmethod socket-type ((socket stream-file-socket)) :stream) + + +;;; An active TCP socket is an honest-to-goodness stream. +(defclass tcp-stream (tcp-socket) + ()) + +(defclass fundamental-tcp-stream (tcp-stream + fd-stream + buffered-binary-io-stream-mixin + buffered-character-io-stream-mixin) + ()) + +(make-built-in-class 'basic-tcp-stream + 'tcp-stream + 'basic-binary-io-stream + 'basic-character-io-stream) + +(defgeneric socket-connect (stream) + (:documentation + "Return :active for tcp-stream, :passive for listener-socket, and NIL +for udp-socket")) + +(defmethod socket-connect ((stream tcp-stream)) :active) + +(defgeneric socket-format (stream) + (:documentation + "Return the socket format as specified by the :format argument to +make-socket.")) + +(defmethod socket-format ((stream tcp-stream)) + (if (eq (stream-element-type stream) 'character) + :text + ;; Should distinguish between :binary and :bivalent, but hardly + ;; seems worth carrying around an extra slot just for that. + :bivalent)) + +(defmethod socket-device ((stream tcp-stream)) + (let ((ioblock (stream-ioblock stream nil))) + (and ioblock (ioblock-device ioblock)))) + +(defmethod select-stream-class ((class tcp-stream) in-p out-p char-p) + (declare (ignore char-p)) ; TODO: is there any real reason to care about this? + ;; Yes, in general. There is. + (assert (and in-p out-p) () "Non-bidirectional tcp stream?") + 'fundamental-tcp-stream) + +(defmethod map-to-basic-stream-class-name ((name (eql 'tcp-stream))) + 'basic-tcp-stream) + +(defmethod select-stream-class ((s (eql 'basic-tcp-stream)) in-p out-p char-p) + (declare (ignore char-p)) + (assert (and in-p out-p) () "Non-bidirectional tcp stream?") + 'basic-tcp-stream) + +;;; A FILE-SOCKET-STREAM is also honest. To goodness. +(defclass file-socket-stream (stream-file-socket) + ()) + +(defclass fundamental-file-socket-stream (file-socket-stream + fd-stream + buffered-binary-io-stream-mixin + buffered-character-io-stream-mixin) + ()) + +(make-built-in-class 'basic-file-socket-stream + 'file-socket-stream + 'basic-binary-io-stream + 'basic-character-io-stream) + + +(defmethod map-to-basic-stream-class-name ((name (eql 'file-socket-stream))) + 'basic-file-socket-stream) + +(defmethod select-stream-class ((class file-socket-stream) in-p out-p char-p) + (declare (ignore char-p)) ; TODO: is there any real reason to care about this? + (assert (and in-p out-p) () "Non-bidirectional file-socket stream?") + 'fundamental-file-socket-stream) + +(defmethod select-stream-class ((s (eql 'basic-file-socket-stream)) in-p out-p char-p) + (declare (ignore char-p)) + (assert (and in-p out-p) () "Non-bidirectional file-socket stream?") + 'basic-file-socket-stream) + +(defclass unconnected-socket (socket) + ((device :initarg :device :accessor socket-device) + (keys :initarg :keys :reader socket-keys))) + +(defmethod socket-format ((socket unconnected-socket)) + (or (getf (socket-keys socket) :format) :text)) + +(defgeneric close (socket &key abort) + (:documentation + "The close generic function can be applied to sockets. It releases the +operating system resources associated with the socket.")) + +(defmethod close ((socket unconnected-socket) &key abort) + (declare (ignore abort)) + (when (socket-device socket) + (fd-close (socket-device socket)) + (setf (socket-device socket) nil) + t)) + +;; A passive tcp socket just generates connection streams +(defclass listener-socket (tcp-socket unconnected-socket) ()) + +(defmethod SOCKET-CONNECT ((stream listener-socket)) :passive) + +(defclass file-listener-socket (stream-file-socket unconnected-socket) ()) + +(defmethod SOCKET-CONNECT ((stream file-listener-socket)) :passive) + +;;; A FILE-LISTENER-SOCKET should try to delete the filesystem +;;; entity when closing. + +#-windows-target +(defmethod close :before ((s file-listener-socket) &key abort) + (declare (ignore abort)) + (let* ((path (local-socket-filename (socket-device s) s))) + (when path (%delete-file path)))) + + +;; A udp socket just sends and receives packets. +(defclass udp-socket (ip-socket unconnected-socket) ()) + +(defmethod socket-type ((stream udp-socket)) :datagram) +(defmethod socket-connect ((stream udp-socket)) nil) + +(defgeneric socket-os-fd (socket) + (:documentation + "Return the native OS's representation of the socket, or NIL if the +socket is closed. On Unix, this is the Unix 'file descriptor', a small +non-negative integer. Note that it is rather dangerous to mess around +with tcp-stream fd's, as there is all sorts of buffering and asynchronous +I/O going on above the OS level. listener-socket and udp-socket fd's are +safer to mess with directly as there is less magic going on.")) + +;; Returns nil for closed stream... +(defmethod socket-os-fd ((socket socket)) + (socket-device socket)) + +;; Returns nil for closed stream +(defun local-socket-info (fd type socket) + (and fd + (rlet ((sockaddr :sockaddr_in) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_in)) + (socket-call socket "getsockname" (c_getsockname fd sockaddr namelen)) + (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family)) + (ecase type + (:host (ntohl (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))) + (:port (ntohs (pref sockaddr :sockaddr_in.sin_port)))))))) + +#-windows-target +(defun path-from-unix-address (addr) + (when (= #$AF_UNIX (pref addr :sockaddr_un.sun_family)) + #+darwin-target + (%str-from-ptr (pref addr :sockaddr_un.sun_path) + (- (pref addr :sockaddr_un.sun_len) 2)) + #-darwin-target + (%get-cstring (pref addr :sockaddr_un.sun_path)))) + +#-windows-target +(defun local-socket-filename (fd socket) + (and fd + (rlet ((addr :sockaddr_un) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_un)) + (socket-call socket "getsockname" (c_getsockname fd addr namelen)) + (path-from-unix-address addr)))) + +(defmacro with-if ((var expr) &body body) + `(let ((,var ,expr)) + (if ,var + (progn + ,@body)))) + +(defun remote-socket-info (socket type) + (with-if (fd (socket-device socket)) + (rlet ((sockaddr :sockaddr_in) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_in)) + (let ((err (c_getpeername fd sockaddr namelen))) + (cond ((eql err (- #+windows-target #$WSAENOTCONN #-windows-target #$ENOTCONN)) nil) + ((< err 0) (socket-error socket "getpeername" err)) + (t + (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family)) + (ecase type + (:host (ntohl (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))) + (:port (ntohs (pref sockaddr :sockaddr_in.sin_port))))))))))) + +#-windows-target +(defun remote-socket-filename (socket) + (with-if (fd (socket-device socket)) + (rlet ((addr :sockaddr_un) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_un)) + (let* ((err (c_getsockname fd addr namelen))) + (cond ((eql err (- #$ENOTCONN)) nil) + ((< err 0) (socket-error socket "getpeername" err)) + (t (path-from-unix-address addr))))))) + +(defgeneric local-port (socket) + (:documentation "Return the local port number.")) + +(defmethod local-port ((socket socket)) + (local-socket-info (socket-device socket) :port socket)) + +(defgeneric local-host (socket) + (:documentation + "Return 32-bit unsigned IP address of the local host.")) + +(defmethod local-host ((socket socket)) + (local-socket-info (socket-device socket) :host socket)) + +#-windows-target +(defmethod local-filename ((socket socket)) + (local-socket-filename (socket-device socket) socket)) + +(defgeneric remote-host (socket) + (:documentation + "Return the 32-bit unsigned IP address of the remote host, or NIL if +the socket is not connected.")) + +;; Returns NIL if socket is not connected +(defmethod remote-host ((socket socket)) + (remote-socket-info socket :host)) + +(defgeneric remote-port (socket) + (:documentation + "Return the remote port number, or NIL if the socket is not connected.")) + +(defmethod remote-port ((socket socket)) + (remote-socket-info socket :port)) + +#-windows-target +(defmethod remote-filename ((socket socket)) + (remote-socket-filename socket)) + +(defun set-socket-fd-blocking (fd block-flag) + #+windows-target + (rlet ((argp :u_long (if block-flag 0 1))) + (#_ioctlsocket fd #$FIONBIO argp)) + #-windows-target + (if block-flag + (fd-clear-flag fd #$O_NONBLOCK) + (fd-set-flag fd #$O_NONBLOCK))) + +(defun get-socket-fd-blocking (fd) + "returns T iff socket is in blocking mode" + #+windows-target (declare (ignore fd)) + #+windows-target t + #-windows-target + (not (logtest #$O_NONBLOCK (fd-get-flags fd)))) + +(defun set-socket-options (fd-or-socket &key + keepalive + reuse-address + nodelay + broadcast + linger + address-family + local-port + local-host + local-filename + type + connect + out-of-band-inline + &allow-other-keys) + ;; see man socket(7) tcp(7) ip(7) + (multiple-value-bind (socket fd) (etypecase fd-or-socket + (socket (values fd-or-socket (socket-device fd-or-socket))) + (integer (values nil fd-or-socket))) + + (if (null address-family) + (setq address-family :internet)) + (when keepalive + (int-setsockopt fd #$SOL_SOCKET #$SO_KEEPALIVE 1)) + (when reuse-address + (int-setsockopt fd #$SOL_SOCKET #$SO_REUSEADDR 1)) + (when broadcast + (int-setsockopt fd #$SOL_SOCKET #$SO_BROADCAST 1)) + (when out-of-band-inline + (int-setsockopt fd #$SOL_SOCKET #$SO_OOBINLINE 1)) + (when (eq address-family :internet) + (when (eq type :stream) + (rlet ((plinger :linger)) + (setf (pref plinger :linger.l_onoff) (if linger 1 0) + (pref plinger :linger.l_linger) (or linger 0)) + (socket-call socket "setsockopt" + (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER + plinger (record-length :linger))))) + (when nodelay + (int-setsockopt fd + #+linux-target #$SOL_TCP + #-linux-target #$IPPROTO_TCP + #$TCP_NODELAY 1)) + (when (or local-port local-host) + (let* ((proto (if (eq type :stream) "tcp" "udp")) + (port-n (if local-port (port-as-inet-port local-port proto) 0)) + (host-n (if local-host (host-as-inet-host local-host) #$INADDR_ANY))) + ;; Darwin includes the SIN_ZERO field of the sockaddr_in when + ;; comparing the requested address to the addresses of configured + ;; interfaces (as if the zeros were somehow part of either address.) + ;; "rletz" zeros out the stack-allocated structure, so those zeros + ;; will be 0. + (rletz ((sockaddr :sockaddr_in)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET + (pref sockaddr :sockaddr_in.sin_port) port-n + (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr + ) host-n) + (socket-call socket "bind" (c_bind fd sockaddr (record-length :sockaddr_in))))))) + (when (and (eq address-family :file) + (eq connect :passive) + local-filename) + #+windows-target (error "can't create file socket on Windows") + #-windows-target (bind-unix-socket fd local-filename)))) + +;; I hope the inline declaration makes the &rest/apply's go away... +(declaim (inline make-ip-socket)) +(defun make-ip-socket (&rest keys &key type &allow-other-keys) + (declare (dynamic-extent keys)) + (ecase type + ((nil :stream) (apply #'make-tcp-socket keys)) + ((:datagram) (apply #'make-udp-socket keys)))) + +(declaim (inline make-file-socket)) +(defun make-file-socket (&rest keys &key type &allow-other-keys) + (declare (dynamic-extent keys)) + (ecase type + ((nil :stream) (apply #'make-stream-file-socket keys)) + (:datagram (apply #'make-datagram-file-socket keys)))) + +(defun make-socket (&rest keys + &key address-family + ;; List all keys here just for error checking... + ;; &allow-other-keys + type connect remote-host remote-port eol format + keepalive reuse-address nodelay broadcast linger + local-port local-host backlog class out-of-band-inline + local-filename remote-filename sharing basic + external-format (auto-close t) + connect-timeout input-timeout output-timeout deadline + fd) + "Create and return a new socket." + (declare (dynamic-extent keys)) + (declare (ignore type connect remote-host remote-port eol format + keepalive reuse-address nodelay broadcast linger + local-port local-host backlog class out-of-band-inline + local-filename remote-filename sharing basic external-format + auto-close connect-timeout input-timeout output-timeout deadline fd)) + (ecase address-family + ((:file) (apply #'make-file-socket keys)) + ((nil :internet) (apply #'make-ip-socket keys)))) + + + +(defun make-udp-socket (&rest keys &key (fd -1) &allow-other-keys) + (unwind-protect + (let (socket) + (when (< fd 0) + (setq fd (socket-call nil "socket" + (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP)))) + (apply #'set-socket-options fd keys) + (setq socket (make-instance 'udp-socket + :device fd + :keys keys)) + (setq fd -1) + socket) + (unless (< fd 0) + (fd-close fd)))) + +(defun make-tcp-socket (&rest keys &key connect (fd -1) &allow-other-keys) + (unwind-protect + (let (socket) + (when (< fd 0) + (setq fd (socket-call nil "socket" + (c_socket #$AF_INET #$SOCK_STREAM #$IPPROTO_TCP)))) + (apply #'set-socket-options fd keys) + (setq socket + (ecase connect + ((nil :active) (apply #'make-tcp-stream-socket fd keys)) + ((:passive) (apply #'make-tcp-listener-socket fd keys)))) + (setq fd -1) + socket) + (unless (< fd 0) + (fd-close fd)))) + +(defun make-stream-file-socket (&rest keys &key connect (fd -1) &allow-other-keys) + (unwind-protect + (let (socket) + (when (< fd 0) + (setq fd (socket-call nil "socket" (c_socket #$PF_UNIX #$SOCK_STREAM 0)))) + (apply #'set-socket-options fd keys) + (setq socket + (ecase connect + ((nil :active) (apply #'make-file-stream-socket fd keys)) + ((:passive) (apply #'make-file-listener-socket fd keys)))) + (setq fd -1) + socket) + (unless (< fd 0) + (fd-close fd)))) + +(defun make-datagram-file-socket (&rest keys) + (declare (ignore keys)) + (error "Datagram file sockets aren't implemented.")) + + +(defun %socket-connect (fd addr addrlen &optional timeout-in-milliseconds) + (let* ((err (c_connect fd addr addrlen timeout-in-milliseconds))) + (declare (fixnum err)) + (unless (eql err 0) (fd-close fd) (socket-error nil "connect" err)))) + +(defun inet-connect (fd host-n port-n &optional timeout-in-milliseconds) + (rlet ((sockaddr :sockaddr_in)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET + (pref sockaddr :sockaddr_in.sin_port) port-n + (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr + ) host-n) + (%socket-connect fd sockaddr (record-length :sockaddr_in) timeout-in-milliseconds))) + +#-windows-target +(defun file-socket-connect (fd remote-filename) + (rletz ((sockaddr :sockaddr_un)) + (init-unix-sockaddr sockaddr remote-filename) + (%socket-connect fd sockaddr (record-length :sockaddr_un)))) + +#+windows-target +(defun file-socket-connect (fd remote-filename) + (declare (ignore fd)) + (error "Can't create file socket to ~s on Windows" remote-filename)) + +(defun make-tcp-stream-socket (fd &rest keys + &key remote-host + remote-port + connect-timeout + deadline + &allow-other-keys) + (let* ((timeout-in-milliseconds + (if deadline + (max (round (- deadline (get-internal-real-time)) + (/ internal-time-units-per-second 1000)) + 0) + (if connect-timeout + (round (* connect-timeout 1000)))))) + (inet-connect fd + (host-as-inet-host remote-host) + (port-as-inet-port remote-port "tcp") + timeout-in-milliseconds) + (apply #'make-tcp-stream fd keys))) + +(defun make-file-stream-socket (fd &rest keys + &key remote-filename + &allow-other-keys) + (file-socket-connect fd remote-filename) + (apply #'make-file-socket-stream fd keys)) + + +(defun make-tcp-stream (fd + &key (format :bivalent) + external-format + (class 'tcp-stream) + sharing + (basic t) + (auto-close t) + input-timeout + output-timeout + deadline + &allow-other-keys) + (let* ((external-format (normalize-external-format :socket external-format))) + (let ((element-type (ecase format + ((nil :text) 'character) + ((:binary :bivalent) '(unsigned-byte 8))))) + ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close + ;; See if should specialize any of 'em. + (make-fd-stream fd + :class class + :direction :io + :element-type element-type + :sharing sharing + :character-p (not (eq format :binary)) + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :basic basic + :auto-close auto-close + :input-timeout input-timeout + :output-timeout output-timeout + :deadline deadline)))) + +(defun make-file-socket-stream (fd + &key (format :bivalent) + external-format + (class 'file-socket-stream) + sharing + basic + (auto-close t) + input-timeout + output-timeout + deadline + &allow-other-keys) + (let* ((external-format (normalize-external-format :socket external-format))) + + (let ((element-type (ecase format + ((nil :text) 'character) + ((:binary :bivalent) '(unsigned-byte 8))))) + ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close + ;; See if should specialize any of 'em. + (make-fd-stream fd + :class class + :direction :io + :element-type element-type + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :sharing sharing + :character-p (not (eq format :binary)) + :basic basic + :auto-close auto-close + :input-timeout input-timeout + :output-timeout output-timeout + :deadline deadline)))) + +(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys) + (socket-call nil "listen" (c_listen fd (or backlog 5))) + (make-instance 'listener-socket + :device fd + :keys keys)) + +(defun make-file-listener-socket (fd &rest keys &key backlog &allow-other-keys) + (socket-call nil "listen" (c_listen fd (or backlog 5))) + (make-instance 'file-listener-socket + :device fd + :keys keys)) + +(defun socket-accept (fd wait) + (flet ((_accept (fd async) + (let ((res (c_accept fd (%null-ptr) (%null-ptr)))) + (declare (fixnum res)) + ;; See the inscrutable note under ERROR HANDLING in + ;; man accept(2). This is my best guess at what they mean... + (if (and async (< res 0) + #+windows-target + (= res #$WSAEWOULDBLOCK) + #-windows-target + (or (eql res (- #$ENETDOWN)) + (eql res (- #+linux-target #$EPROTO + #-linux-target #$EPROTOTYPE)) + (eql res (- #$ENOPROTOOPT)) + (eql res (- #$EHOSTDOWN)) + (eql res (- #+linux-target #$ENONET + #-linux-target #$ENETDOWN)) + (eql res (- #$EHOSTUNREACH)) + (eql res (- #$EOPNOTSUPP)) + (eql res (- #$ENETUNREACH)))) + (- #$EAGAIN) + res)))) + (cond (wait + (with-eagain fd :input + (_accept fd *multiprocessing-socket-io*))) + (*multiprocessing-socket-io* + (_accept fd t)) + (t + (let ((was-blocking (get-socket-fd-blocking fd))) + (unwind-protect + (progn + (set-socket-fd-blocking fd nil) + (_accept fd t)) + (set-socket-fd-blocking fd was-blocking))))))) + +(defun accept-socket-connection (socket wait stream-create-function &optional stream-args) + (let ((listen-fd (socket-device socket)) + (fd -1)) + (unwind-protect + (let ((keys (append stream-args (socket-keys socket)))) + (setq fd (socket-accept listen-fd wait)) + (cond ((>= fd 0) + (prog1 (apply stream-create-function fd keys) + (setq fd -1))) + ((eql fd (- #$EAGAIN)) nil) + (t (socket-error socket "accept" fd)))) + (when (>= fd 0) + (fd-close fd))))) + +(defgeneric accept-connection (socket &key wait stream-args) + (:documentation + "Extract the first connection on the queue of pending connections, +accept it (i.e. complete the connection startup protocol) and return a new +tcp-stream or file-socket-stream representing the newly established +connection. The tcp stream inherits any properties of the listener socket +that are relevant (e.g. :keepalive, :nodelay, etc.) Additional arguments +may be specified using STREAM-ARGS. The original listener +socket continues to be open listening for more connections, so you can call +accept-connection on it again.")) + +(defmethod accept-connection ((socket listener-socket) &key (wait t) stream-args) + (accept-socket-connection socket wait #'make-tcp-stream stream-args)) + +(defmethod accept-connection ((socket file-listener-socket) &key (wait t) stream-args) + (accept-socket-connection socket wait #'make-file-socket-stream stream-args)) + +(defun verify-socket-buffer (buf offset size) + (unless offset (setq offset 0)) + (unless (<= (+ offset size) (length buf)) + (report-bad-arg size `(integer 0 ,(- (length buf) offset)))) + (multiple-value-bind (arr start) (array-data-and-offset buf) + (setq buf arr offset (+ offset start))) + ;; TODO: maybe should allow any raw vector + (let ((subtype (typecode buf))) + (unless #+ppc32-target (and (<= ppc32::min-8-bit-ivector-subtag subtype) + (<= subtype ppc32::max-8-bit-ivector-subtag)) + #+ppc64-target (= (the fixnum (logand subtype ppc64::fulltagmask)) + ppc64::ivector-class-8-bit) + #+x8632-target (and (<= x8632::min-8-bit-ivector-subtag subtype) + (<= subtype x8632::max-8-bit-ivector-subtag)) + #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag) + (<= subtype x8664::max-8-bit-ivector-subtag)) + (report-bad-arg buf `(or (array character) + (array (unsigned-byte 8)) + (array (signed-byte 8)))))) + (values buf offset)) + +(defmethod send-to ((socket udp-socket) msg size + &key remote-host remote-port offset) + "Send a UDP packet over a socket." + (let ((fd (socket-device socket))) + (multiple-value-setq (msg offset) (verify-socket-buffer msg offset size)) + (unless remote-host + (setq remote-host (or (getf (socket-keys socket) :remote-host) + (remote-socket-info socket :host)))) + (unless remote-port + (setq remote-port (or (getf (socket-keys socket) :remote-port) + (remote-socket-info socket :port)))) + (rlet ((sockaddr :sockaddr_in)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET) + (setf (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr) + (if remote-host (host-as-inet-host remote-host) #$INADDR_ANY)) + (setf (pref sockaddr :sockaddr_in.sin_port) + (if remote-port (port-as-inet-port remote-port "udp") 0)) + (%stack-block ((bufptr size)) + (%copy-ivector-to-ptr msg offset bufptr 0 size) + (socket-call socket "sendto" + (with-eagain fd :output + (c_sendto fd bufptr size 0 sockaddr (record-length :sockaddr_in)))))))) + +(defmethod receive-from ((socket udp-socket) size &key buffer extract offset) + "Read a UDP packet from a socket. If no packets are available, wait for +a packet to arrive. Returns four values: + The buffer with the data + The number of bytes read + The 32-bit unsigned IP address of the sender of the data + The port number of the sender of the data." + (let ((fd (socket-device socket)) + (vec-offset offset) + (vec buffer) + (ret-size -1)) + (when vec + (multiple-value-setq (vec vec-offset) + (verify-socket-buffer vec vec-offset size))) + (rlet ((sockaddr :sockaddr_in) + (namelen :signed)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET) + (setf (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr) + #$INADDR_ANY) + (setf (pref sockaddr :sockaddr_in.sin_port) 0) + (setf (pref namelen :signed) (record-length :sockaddr_in)) + (%stack-block ((bufptr size)) + (setq ret-size (socket-call socket "recvfrom" + (with-eagain fd :input + (c_recvfrom fd bufptr size 0 sockaddr namelen)))) + (unless vec + (setq vec (make-array ret-size + :element-type + (ecase (socket-format socket) + ((:text) 'base-char) + ((:binary :bivalent) '(unsigned-byte 8)))) + vec-offset 0)) + (%copy-ptr-to-ivector bufptr 0 vec vec-offset ret-size)) + (values (cond ((null buffer) + vec) + ((or (not extract) + (and (eql 0 (or offset 0)) + (eql ret-size (length buffer)))) + buffer) + (t + (subseq vec vec-offset (+ vec-offset ret-size)))) + ret-size + (ntohl (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)) + (ntohs (pref sockaddr :sockaddr_in.sin_port)))))) + +(defgeneric shutdown (socket &key direction) + (:documentation + "Shut down part of a bidirectional connection. This is useful if e.g. +you need to read responses after sending an end-of-file signal.")) + +(defmethod shutdown (socket &key direction) + ;; TODO: should we ignore ENOTCONN error? (at least make sure it + ;; is a distinct, catchable error type). + (let ((fd (socket-device socket))) + (socket-call socket "shutdown" + (c_shutdown fd (ecase direction + (:input 0) + (:output 1)))))) + +;; Accepts port as specified by user, returns port number in network byte +;; order. Protocol should be one of "tcp" or "udp". Error if not known. +(defun port-as-inet-port (port proto) + (or (etypecase port + (fixnum (htons port)) + (string (_getservbyname port proto)) + (symbol (_getservbyname (string-downcase (symbol-name port)) proto))) + (socket-error nil "getservbyname" (- #$ENOENT)))) + +(defun lookup-port (port proto) + "Find the port number for the specified port and protocol." + (if (fixnump port) + port + (ntohs (port-as-inet-port port proto)))) + +;; Accepts host as specified by user, returns host number in network byte +;; order. +(defun host-as-inet-host (host) + (etypecase host + (integer (htonl host)) + (string (or (and (every #'(lambda (c) (position c ".0123456789")) host) + (_inet_aton host)) + (multiple-value-bind (addr err) (c_gethostbyname host) + (or addr + (socket-error nil "gethostbyname" err t))))))) + + +(defun dotted-to-ipaddr (name &key (errorp t)) + "Convert a dotted-string representation of a host address to a 32-bit +unsigned IP address." + (let ((addr (_inet_aton name))) + (if addr (ntohl addr) + (and errorp (error "Invalid dotted address ~s" name))))) + +(defun lookup-hostname (host) + "Convert a host spec in any of the acceptable formats into a 32-bit +unsigned IP address." + (if (typep host 'integer) + host + (ntohl (host-as-inet-host host)))) + +(defun ipaddr-to-dotted (addr &key values) + "Convert a 32-bit unsigned IP address into octets." + (let* ((a (ldb (byte 8 24) addr)) + (b (ldb (byte 8 16) addr)) + (c (ldb (byte 8 8) addr)) + (d (ldb (byte 8 0) addr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + "Convert a 32-bit unsigned IP address into a host name string." + (declare (ignore ignore-cache)) + (multiple-value-bind (name err) (c_gethostbyaddr (htonl ipaddr)) + (or name (socket-error nil "gethostbyaddr" err t)))) + + + +(defun int-getsockopt (socket level optname) + (rlet ((valptr :signed) + (vallen :signed)) + (setf (pref vallen :signed) 4) + (let* ((err (c_getsockopt socket level optname valptr vallen))) + (if (and (eql 0 err) + (eql 4 (pref vallen :signed))) + (pref valptr :signed) + (socket-error socket "getsockopt" err))))) + +(defun timeval-setsockopt (socket level optname timeout) + (multiple-value-bind (seconds micros) + (microseconds timeout) + (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros)) + (socket-call socket "setsockopt" + (c_setsockopt socket level optname valptr (record-length :timeval)))))) + +(defun int-setsockopt (socket level optname optval) + (rlet ((valptr :signed)) + (setf (pref valptr :signed) optval) + (socket-call socket "setsockopt" + (c_setsockopt socket level optname valptr (record-length :signed))))) + + + + +(defun c_gethostbyaddr (addr-in-net-byte-order) + (rletZ ((sin #>sockaddr_in)) + (setf (pref sin :sockaddr_in.sin_family) #$AF_INET + (pref sin + #+(or windows-target solaris-target) #>sockaddr_in.sin_addr.S_un.S_addr + #-(or windows-target solaris-target) #>sockaddr_in.sin_addr.s_addr) addr-in-net-byte-order) + #+darwin-target (setf (pref sin :sockaddr_in.sin_len) (record-length :sockaddr_in)) + (%stack-block ((namep #$NI_MAXHOST)) + (let* ((err (#_getnameinfo sin (record-length #>sockaddr_in) namep #$NI_MAXHOST (%null-ptr) 0 #$NI_NAMEREQD))) + (if (eql 0 err) + (%get-cstring namep) + (values nil err)))))) + +(defun c_gethostbyname (name) + (with-cstrs ((name (string name))) + (rletZ ((hints #>addrinfo) + (results :address)) + (setf (pref hints #>addrinfo.ai_family) #$AF_INET) + (let* ((err (#_getaddrinfo name (%null-ptr) hints results))) + (if (eql 0 err) + (let* ((info (pref results :address)) + (sin (pref info #>addrinfo.ai_addr))) + (prog1 + #+(or windows-target solaris-target) + (pref sin #>sockaddr_in.sin_addr.S_un.S_addr) + #-(or windows-target solaris-target) + (pref sin #>sockaddr_in.sin_addr.s_addr) + (#_freeaddrinfo info))) + (values nil err)))))) + + + + + +(defun _getservbyname (name proto) + (with-cstrs ((name (string name)) + (proto (string proto))) + (let* ((servent-ptr (%null-ptr))) + (declare (dynamic-extent servent-ptr)) + (%setf-macptr servent-ptr (#_getservbyname name proto)) + (unless (%null-ptr-p servent-ptr) + (pref servent-ptr :servent.s_port))))) + +(defun _inet_aton (string) + (with-cstrs ((name string)) + #-windows-target + (rlet ((addr :in_addr)) + (let* ((result #+freebsd-target (#___inet_aton name addr) + #-freebsd-target (#_inet_aton name addr))) + (unless (eql result 0) + (pref addr + #-solaris-target :in_addr.s_addr + #+solaris-target #>in_addr.S_un.S_addr + )))) + #+windows-target + (rlet ((addr :sockaddr_in) + (addrlenp :int (record-length :sockaddr_in))) + (setf (pref addr :sockaddr_in.sin_family) #$AF_INET) + (when (zerop (#_WSAStringToAddressA name #$AF_INET (%null-ptr) addr addrlenp)) + (pref addr #>sockaddr_in.sin_addr.S_un.S_addr))))) + +(defun c_socket_1 (domain type protocol) + #-windows-target (int-errno-call (#_socket domain type protocol)) + #+windows-target (let* ((handle (#_socket domain type protocol))) + (if (< handle 0) + (%get-winsock-error) + handle))) + + + +(defun c_socket (domain type protocol) + (let* ((fd (c_socket_1 domain type protocol))) + (when (or (eql fd (- #$EMFILE)) + (eql fd (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq fd (c_socket_1 domain type protocol))) + fd)) + + +#-windows-target +(defun init-unix-sockaddr (addr path) + (macrolet ((sockaddr_un-path-len () + (/ (ensure-foreign-type-bits + (foreign-record-field-type + (%find-foreign-record-type-field + (parse-foreign-type '(:struct :sockaddr_un)) :sun_path))) + 8))) + (let* ((name (native-translated-namestring path)) + (namelen (length name)) + (pathlen (sockaddr_un-path-len)) + (copylen (min (1- pathlen) namelen))) + (setf (pref addr :sockaddr_un.sun_family) #$AF_UNIX) + (let* ((sun-path (pref addr :sockaddr_un.sun_path))) + (dotimes (i copylen) + (setf (%get-unsigned-byte sun-path i) + (let* ((code (char-code (schar name i)))) + (if (> code 255) + (char-code #\Sub) + code)))))))) + +#-windows-target +(defun bind-unix-socket (socketfd path) + (rletz ((addr :sockaddr_un)) + (init-unix-sockaddr addr path) + (socket-call + nil + "bind" + (c_bind socketfd + addr + (+ 2 + (#_strlen + (pref addr :sockaddr_un.sun_path))))))) + + +(defun c_bind (sockfd sockaddr addrlen) + (check-socket-error (#_bind sockfd sockaddr addrlen))) + + +#+windows-target +(defun windows-connect-wait (sockfd timeout-in-milliseconds) + (if (and timeout-in-milliseconds + (< timeout-in-milliseconds 0)) + (setq timeout-in-milliseconds nil)) + (rlet ((writefds :fd_set) + (exceptfds :fd_set) + (tv :timeval :tv_sec 0 :tv_usec 0)) + (fd-zero writefds) + (fd-zero exceptfds) + (fd-set sockfd writefds) + (fd-set sockfd exceptfds) + (when timeout-in-milliseconds + (multiple-value-bind (seconds milliseconds) + (floor timeout-in-milliseconds 1000) + (setf (pref tv :timeval.tv_sec) seconds + (pref tv :timeval.tv_usec) (* 1000 milliseconds)))) + (> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-milliseconds tv (%null-ptr))) 0))) + + +;;; If attempts to connnect are interrupted, we basically have to +;;; wait in #_select (or the equivalent). There's a good rant +;;; about these issues in: +;;; +(defun c_connect (sockfd addr len &optional timeout-in-milliseconds) + (let* ((was-blocking (get-socket-fd-blocking sockfd))) + (unwind-protect + (progn + (set-socket-fd-blocking sockfd nil) + (let* ((err (check-socket-error (#_connect sockfd addr len)))) + (cond ((or (eql err (- #+windows-target #$WSAEINPROGRESS + + #-windows-target #$EINPROGRESS)) + #+windows-target (eql err (- #$WSAEWOULDBLOCK)) + (eql err (- #$EINTR))) + (if + #+windows-target (windows-connect-wait sockfd timeout-in-milliseconds) + #-windows-target (process-output-wait sockfd timeout-in-milliseconds) + (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR)) + (- #+windows-target #$WSAETIMEDOUT #-windows-target #$ETIMEDOUT))) + (t err)))) + (set-socket-fd-blocking sockfd was-blocking)))) + +(defun c_listen (sockfd backlog) + (check-socket-error (#_listen sockfd backlog))) + +(defun c_accept (sockfd addrp addrlenp) + (ignoring-eintr + (check-socket-error (#_accept sockfd addrp addrlenp)))) + +(defun c_getsockname (sockfd addrp addrlenp) + (check-socket-error (#_getsockname sockfd addrp addrlenp))) + +(defun c_getpeername (sockfd addrp addrlenp) + (check-socket-error (#_getpeername sockfd addrp addrlenp))) + +#-windows-target +(defun c_socketpair (domain type protocol socketsptr) + (check-socket-error (#_socketpair domain type protocol socketsptr))) + + +(defun c_sendto (sockfd msgptr len flags addrp addrlen) + (ignoring-eintr (check-socket-error (#_sendto sockfd msgptr len flags addrp addrlen)))) + +(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp) + (ignoring-eintr (check-socket-error (#_recvfrom sockfd bufptr len flags addrp addrlenp)))) + +(defun c_shutdown (sockfd how) + (check-socket-error (#_shutdown sockfd how))) + +(defun c_setsockopt (sockfd level optname optvalp optlen) + (check-socket-error (#_setsockopt sockfd level optname optvalp optlen))) + +(defun c_getsockopt (sockfd level optname optvalp optlenp) + (check-socket-error (#_getsockopt sockfd level optname optvalp optlenp))) + +#-windows-target +(defun c_sendmsg (sockfd msghdrp flags) + (check-socket-error (#_sendmsg sockfd msghdrp flags))) + +#-windows-target +(defun c_recvmsg (sockfd msghdrp flags) + (check-socket-error (#_recvmsg sockfd msghdrp flags))) + + +;;; Return a list of currently configured interfaces, a la ifconfig. +(defstruct ip-interface + name + addr + netmask + flags + address-family) + +(defun dump-buffer (p n) + (dotimes (i n (progn (terpri) (terpri))) + (unless (logtest i 15) + (format t "~&~8,'0x: " (%ptr-to-int (%inc-ptr p i)))) + (format t " ~2,'0x" (%get-byte p i)))) + +#-(or windows-target solaris-target) +(defun %get-ip-interfaces () + (rlet ((p :address (%null-ptr))) + (if (zerop (#_getifaddrs p)) + (unwind-protect + (do* ((q (%get-ptr p) (pref q :ifaddrs.ifa_next)) + (res ())) + ((%null-ptr-p q) (nreverse res)) + (let* ((addr (pref q :ifaddrs.ifa_addr))) + (when (and (not (%null-ptr-p addr)) + (eql (pref addr :sockaddr.sa_family) #$AF_INET)) + (push (make-ip-interface + :name (%get-cstring (pref q :ifaddrs.ifa_name)) + :addr (ntohl (pref addr :sockaddr_in.sin_addr.s_addr)) + :netmask (ntohl + (pref (pref q :ifaddrs.ifa_netmask) + :sockaddr_in.sin_addr.s_addr)) + :flags (pref q :ifaddrs.ifa_flags) + :address-family #$AF_INET) + res)))) + (#_freeifaddrs (pref p :address)))))) + +#+solaris-target +(progn + ;;; Interface translator has trouble with a lot of ioctl constants. + (eval-when (:compile-toplevel :execute) + (defconstant os::|SIOCGLIFNUM| #xc00c6982) + (defconstant os::|SIOCGLIFCONF| #xc01069a5) + (defconstant os::|SIOCGLIFADDR| #xc0786971) + (defconstant os::|SIOCGLIFFLAGS| #xc0786975) + (defconstant os::|SIOCGLIFNETMASK| #xc078697d) + ) + +(defun %get-ip-interfaces () + (let* ((sock (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP)) + (res nil)) + (when (>= sock 0) + (unwind-protect + (let* ((flags (logior #$LIFC_NOXMIT #$LIFC_TEMPORARY #$LIFC_ALLZONES)) + (ninterfaces (rlet ((lifnum :lifnum + :lifn_flags flags + :lifn_family #$AF_INET + :lifn_count 0)) + (#_ioctl sock os::SIOCGLIFNUM :address lifnum) + (pref lifnum :lifnum.lifn_count)))) + (declare (fixnum ninterfaces)) + (when (> ninterfaces 0) + (let* ((bufsize (* ninterfaces (record-length :lifreq)))) + (%stack-block ((buf bufsize :clear t)) + (rlet ((lifc :lifconf + :lifc_family #$AF_INET + :lifc_flags flags + :lifc_len bufsize + :lifc_lifcu.lifcu_buf buf)) + (when (>= (#_ioctl sock os::SIOCGLIFCONF :address lifc) 0) + (do* ((i 0 (1+ i)) + (p (pref lifc :lifconf.lifc_lifcu.lifcu_buf) + (%inc-ptr p (record-length :lifreq)))) + ((= i ninterfaces)) + (let* ((name (%get-cstring (pref p :lifreq.lifr_name))) + (address-family (pref p :lifreq.lifr_lifru.lifru_addr.ss_family)) + (if-flags nil) + (address nil) + (netmask nil)) + (if (>= (#_ioctl sock os::SIOCGLIFFLAGS :address p) + 0) + (setq if-flags (pref p :lifreq.lifr_lifru.lifru_flags))) + (if (>= (#_ioctl sock os::SIOCGLIFADDR :address p) + 0) + (setq address (pref + (pref p :lifreq.lifr_lifru.lifru_addr) + #>sockaddr_in.sin_addr.S_un.S_addr))) + (if (>= (#_ioctl sock os::SIOCGLIFNETMASK :address p) + 0) + (setq netmask (pref + (pref p :lifreq.lifr_lifru.lifru_subnet) + #>sockaddr_in.sin_addr.S_un.S_addr))) + + (push (make-ip-interface + :name name + :addr (ntohl address) + :netmask (ntohl netmask) + :flags if-flags + :address-family address-family) + res))))))))) + (fd-close sock))) + res)) +) + + + + +#+windows-target +(defun %get-ip-interfaces () + (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP))) + (unwind-protect + (rlet ((realoutlen #>DWORD 0)) + (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO)) + (* 2 reservedlen))) + () + (%stack-block ((buf reservedlen)) + (unless (eql 0 (#_WSAIoctl + socket + #$SIO_GET_INTERFACE_LIST + (%null-ptr) + 0 + buf + reservedlen + realoutlen + (%null-ptr) + (%null-ptr))) + (return)) + (let* ((noutbytes (pref realoutlen #>DWORD))) + (when (< noutbytes reservedlen) + (let* ((interfaces nil)) + (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO))) + (nameidx 0 (1+ nameidx))) + ((>= offset noutbytes)) + (with-macptrs ((p (%inc-ptr buf offset))) + (push (make-ip-interface + :name (format nil "ip~d" nameidx) + :addr (ntohl + (pref (pref p #>INTERFACE_INFO.iiAddress) + #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr)) + :netmask (ntohl + (pref (pref p #>INTERFACE_INFO.iiNetmask) + #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr)) + :flags (pref p #>INTERFACE_INFO.iiFlags) + :address-family #$AF_INET) + interfaces))) + (return interfaces))))))) + (#_closesocket socket)))) + + + + +(defloadvar *ip-interfaces* ()) + +(defun ip-interfaces () + (or *ip-interfaces* + (setq *ip-interfaces* (%get-ip-interfaces)))) + +;;; This should presumably happen after a configuration change. +;;; How do we detect a configuration change ? +(defun %reset-ip-interfaces () + (setq *ip-interfaces* ())) + +;;; Return the first non-loopback interface that's up and whose address +;;; family is #$AF_INET. If no such interface exists, return +;;; the loopback interface. +(defun primary-ip-interface () + (let* ((ifaces (ip-interfaces))) + (or (find-if #'(lambda (i) + (and (eq #$AF_INET (ip-interface-address-family i)) + (ip-interface-addr i) + (let* ((flags (ip-interface-flags i))) + (and (not (logtest #$IFF_LOOPBACK flags)) + (logtest #$IFF_UP flags))))) + ifaces) + (car ifaces)))) + +(defun primary-ip-interface-address () + (let* ((iface (primary-ip-interface))) + (if iface + (ip-interface-addr iface) + (error "Can't determine primary IP interface")))) + + +(defmethod stream-io-error ((stream socket) errno where) + (socket-error stream where errno)) Index: /branches/qres/ccl/level-1/l1-sort.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-sort.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-sort.lisp (revision 13564) @@ -0,0 +1,167 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Low-level list sorting routines. Used by CLOS and SORT. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + +(defmacro apply-key (key value) + `(if ,key + (funcall ,key ,value) + ,value)) + +) + +;; A macro to make predicate & key into lfuns, or maybe NIL. +(defmacro canonicalize-pred-and-key (&optional (pred 'pred) (key 'key)) + `(progn (setq ,pred (coerce-to-function ,pred)) + (unless (null ,key) + (setq ,key (coerce-to-function ,key)) + (if (eq ,key #'identity) (setq ,key nil))))) + + +(defun final-cons (p) + (do* ((drag p lead) + (lead (cdr p) (cdr lead))) + ((null lead) + drag))) + +;;; modified to return a pointer to the end of the result +;;; and to not cons header each time its called. +;;; It destructively merges list-1 with list-2. In the resulting +;;; list, elements of list-2 are guaranteed to come after equal elements +;;; of list-1. +(defun merge-lists* (list-1 list-2 pred key) + (declare (optimize (speed 3) (safety 0))) + (if (null key) + (merge-lists*-no-key list-1 list-2 pred) + (cond ((null list-1) + (values list-2 (final-cons list-2))) + ((null list-2) + (values list-1 (final-cons list-1))) + (t (let* ((result (cons nil nil)) + (P result) ; P points to last cell of result + (key-1 (apply-key key (car list-1))) + (key-2 (apply-key key (car list-2)))) + (declare (dynamic-extent result)) + (declare (type list p)) + (loop + (cond ((funcall pred key-2 key-1) + (rplacd P list-2) ; append the lesser list to last cell of + (setq P (cdr P)) ; result. Note: test must bo done for + (pop list-2) ; list-2 < list-1 so merge will be + (unless list-2 ; stable for list-1 + (rplacd P list-1) + (return (values (cdr result) (final-cons p)))) + (setq key-2 (apply-key key (car list-2)))) + (T (rplacd P list-1) + (setq P (cdr P)) + (pop list-1) + (unless list-1 + (rplacd P list-2) + (return (values (cdr result) (final-cons p)))) + (setq key-1 (apply-key key (car list-1))))))))))) + +(defun merge-lists*-no-key (list-1 list-2 pred) + (declare (optimize (speed 3) (safety 0))) + (cond ((null list-1) + (values list-2 (final-cons list-2))) + ((null list-2) + (values list-1 (final-cons list-1))) + (t (let* ((result (cons nil nil)) + (P result) ; P points to last cell of result + (key-1 (car list-1)) + (key-2 (car list-2))) + (declare (dynamic-extent result)) + (declare (type list p)) + (loop + (cond ((funcall pred key-2 key-1) + (rplacd P list-2) ; append the lesser list to last cell of + (setq P (cdr P)) ; result. Note: test must bo done for + (pop list-2) ; list-2 < list-1 so merge will be + (unless list-2 ; stable for list-1 + (rplacd P list-1) + (return (values (cdr result) (final-cons p)))) + (setq key-2 (car list-2))) + (T (rplacd P list-1) + (setq P (cdr P)) + (pop list-1) + (unless list-1 + (rplacd P list-2) + (return (values (cdr result) (final-cons p)))) + (setq key-1 (car list-1))))))))) + +(defun sort-list (list pred key) + (canonicalize-pred-and-key pred key) + (let ((head (cons nil list)) ; head holds on to everything + (n 1) ; bottom-up size of lists to be merged + unsorted ; unsorted is the remaining list to be + ; broken into n size lists and merged + list-1 ; list-1 is one length n list to be merged + last) ; last points to the last visited cell + (declare (fixnum n)) + (declare (dynamic-extent head)) + (loop + ;; start collecting runs of n at the first element + (setf unsorted (cdr head)) + ;; tack on the first merge of two n-runs to the head holder + (setf last head) + (let ((n-1 (1- n))) + (declare (fixnum n-1)) + (loop + (setf list-1 unsorted) + (let ((temp (nthcdr n-1 list-1)) + list-2) + (cond (temp + ;; there are enough elements for a second run + (setf list-2 (cdr temp)) + (setf (cdr temp) nil) + (setf temp (nthcdr n-1 list-2)) + (cond (temp + (setf unsorted (cdr temp)) + (setf (cdr temp) nil)) + ;; the second run goes off the end of the list + (t (setf unsorted nil))) + (multiple-value-bind (merged-head merged-last) + (merge-lists* list-1 list-2 pred key) + (setf (cdr last) merged-head) + (setf last merged-last)) + (if (null unsorted) (return))) + ;; if there is only one run, then tack it on to the end + (t (setf (cdr last) list-1) + (return))))) + (setf n (ash n 1)) ; (+ n n) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two runs given n, so all the elements have been merged + ;; into one list. This may waste one outer iteration to realize. + (if (eq list-1 (cdr head)) + (return list-1)))))) + + +;; The no-key version of %sort-list +;; list had better be a list. +;; pred had better be functionp. +(defun %sort-list-no-key (list pred) + (sort-list list pred nil)) + +(defun sort-list-error () + (error "List arg to SORT not a proper list")) + + + Index: /branches/qres/ccl/level-1/l1-streams.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-streams.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-streams.lisp (revision 13564) @@ -0,0 +1,6529 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; + +(defclass stream () + ()) + + +(defclass input-stream (stream) + ()) + + +(defclass output-stream (stream) ()) + +(defmethod stream-direction ((s stream)) + ) + +(defmethod stream-domain ((s stream)) + t) + + +(defmethod stream-direction ((s input-stream)) + (if (typep s 'output-stream) + :io + :input)) + +(defmethod stream-direction ((s output-stream)) + (if (typep s 'input-stream) + :io + :output)) + +(defun check-io-timeout (timeout) + (when timeout + (require-type timeout '(real 0 1000000)))) + +(defmethod stream-input-timeout ((s input-stream)) + nil) + +(defmethod (setf input-stream-timeout) (new (s input-stream)) + (check-io-timeout new)) + +(defmethod stream-output-timeout ((s output-stream)) + nil) + +(defmethod (setf stream-output-timeout) (new (s output-stream)) + (check-io-timeout new)) + +;;; Try to return a string containing characters that're near the +;;; stream's current position, if that makes sense. Return NIL +;;; if it doesn't make sense. +;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs +;;; whose STREAM args aren't streams. That's wrong, but +;;; defining this method on T keeps things from blowing up worse. +(defmethod stream-surrounding-characters ((s t)) + (declare (ignore s)) + nil) + + +;;; The "direction" argument only helps us dispatch on two-way streams: +;;; it's legal to ask for the :output device of a stream that's only open +;;; for input, and one might get a non-null answer in that case. +(defmethod stream-device ((s stream) direction) + (declare (ignore direction))) + +;;; Some generic stream functions: +(defmethod stream-length ((x t) &optional new) + (declare (ignore new)) + (report-bad-arg x 'stream)) + +(defmethod stream-position ((x t) &optional new) + (declare (ignore new)) + (report-bad-arg x 'stream)) + +(defmethod stream-element-type ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-force-output ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-position ((s stream) &optional newpos) + (declare (ignore newpos))) + +;;; For input streams: + +;; From Shannon Spires, slightly modified. +(defun generic-read-line (s) + (let* ((str (make-array 20 :element-type 'base-char + :adjustable t :fill-pointer 0)) + (eof nil)) + (do* ((ch (read-char s nil :eof) (read-char s nil :eof))) + ((or (eq ch #\newline) (setq eof (eq ch :eof))) + (values (ensure-simple-string str) eof)) + (vector-push-extend ch str)))) + +(defun generic-character-read-list (stream list count) + (declare (fixnum count)) + (do* ((tail list (cdr tail)) + (i 0 (1+ i))) + ((= i count) count) + (declare (fixnum i)) + (let* ((ch (read-char stream nil :eof))) + (if (eq ch :eof) + (return i) + (rplaca tail ch))))) + +(defun generic-binary-read-list (stream list count) + (declare (fixnum count)) + (do* ((tail list (cdr tail)) + (i 0 (1+ i))) + ((= i count) count) + (declare (fixnum i)) + (let* ((ch (stream-read-byte stream))) + (if (eq ch :eof) + (return i) + (rplaca tail ch))))) + +(defun generic-character-read-vector (stream vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((ch (stream-read-char stream))) + (if (eq ch :eof) + (return i) + (setf (uvref vector i) ch))))) + +(defun generic-binary-read-vector (stream vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((byte (stream-read-byte stream))) + (if (eq byte :eof) + (return i) + (setf (uvref vector i) byte))))) + + +;;; For output streams: + +(defun generic-advance-to-column (s col) + (let* ((current (column s))) + (unless (null current) + (when (< current col) + (do* ((i current (1+ i))) + ((= i col)) + (write-char #\Space s))) + t))) + + + +(defun generic-stream-write-string (stream string start end) + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (vect offset) (array-data-and-offset string) + (declare (fixnum offset)) + (unless (zerop offset) + (incf start offset) + (incf end offset)) + (do* ((i start (1+ i))) + ((= i end) string) + (declare (fixnum i)) + (write-char (schar vect i) stream))))) + + + + + + + + + + + + + +(defstatic *heap-ivectors* ()) +(defvar *heap-ivector-lock* (make-lock)) + + + +(defun %make-heap-ivector (subtype size-in-bytes size-in-elts) + (with-macptrs ((ptr (malloc (+ size-in-bytes + #+32-bit-target (+ 4 2 7) ; 4 for header, 2 for delta, 7 for round up + #+64-bit-target (+ 8 2 15) ; 8 for header, 2 for delta, 15 for round up + )))) + (let ((vect (fudge-heap-pointer ptr subtype size-in-elts)) + (p (%null-ptr))) + (%vect-data-to-macptr vect p) + (with-lock-grabbed (*heap-ivector-lock*) + (push vect *heap-ivectors*)) + (values vect p)))) + +(defun %heap-ivector-p (v) + (with-lock-grabbed (*heap-ivector-lock*) + (not (null (member v *heap-ivectors* :test #'eq))))) + + +(defun dispose-heap-ivector (v) + (if (%heap-ivector-p v) + (with-macptrs (p) + (with-lock-grabbed (*heap-ivector-lock*) + (setq *heap-ivectors* (delq v *heap-ivectors*))) + (%%make-disposable p v) + (free p)))) + +(defun %dispose-heap-ivector (v) + (dispose-heap-ivector v)) + +(defun make-heap-ivector (element-count element-type) + (require-type element-count `(unsigned-byte ,(- target::nbits-in-word + target::num-subtag-bits))) + (let* ((subtag (ccl::element-type-subtype element-type))) + (unless + #+ppc32-target + (= (logand subtag ppc32::fulltagmask) + ppc32::fulltag-immheader) + #+ppc64-target + (= (logand subtag ppc64::lowtagmask) + ppc64::lowtag-immheader) + #+x8632-target + (= (logand subtag x8632::fulltagmask) + x8632::fulltag-immheader) + #+x8664-target + (logbitp (the (mod 16) (logand subtag x8664::fulltagmask)) + (logior (ash 1 x8664::fulltag-immheader-0) + (ash 1 x8664::fulltag-immheader-1) + (ash 1 x8664::fulltag-immheader-2))) + (error "~s is not an ivector subtype." element-type)) + (let* ((size-in-octets (ccl::subtag-bytes subtag element-count))) + (multiple-value-bind (vector pointer) + (ccl::%make-heap-ivector subtag size-in-octets element-count) + (values vector pointer size-in-octets))))) + + + + + + + + + +(defvar *elements-per-buffer* 2048) ; default buffer size for file io + +(defmethod streamp ((x t)) + nil) + +(defmethod streamp ((x stream)) + t) + +(defmethod stream-io-error ((stream stream) error-number context) + (error 'simple-stream-error :stream stream + :format-control (format nil "~a during ~a" + (%strerror error-number) context))) + + + +(defmethod stream-write-char ((stream stream) char) + (declare (ignore char)) + (error "stream ~S is not capable of output" stream)) + +(defun stream-write-entire-string (stream string) + (stream-write-string stream string)) + + +(defmethod stream-read-char ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-read-char ((stream stream)) + (error "~s is not capable of input" stream)) + +(defmethod stream-unread-char ((x t) char) + (declare (ignore char)) + (report-bad-arg x 'stream)) + +(defmethod stream-unread-char ((stream stream) char) + (declare (ignore char)) + (error "stream ~S is not capable of input" stream)) + + + +(defmethod stream-force-output ((stream output-stream)) nil) +(defmethod stream-maybe-force-output ((stream stream)) + (stream-force-output stream)) + +(defmethod stream-finish-output ((stream output-stream)) nil) + + + +(defmethod stream-clear-output ((stream output-stream)) nil) + +(defmethod close ((stream stream) &key abort) + (declare (ignore abort)) + (open-stream-p stream)) + +(defmethod close-for-termination ((stream stream) abort) + (close stream :abort abort)) + + +(defmethod open-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod open-stream-p ((stream stream)) + t) + +(defmethod stream-external-format ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-external-format ((s stream)) + nil) + + +(defmethod (setf stream-external-format) (new (s t)) + (normalize-external-format (stream-domain s) new) + (report-bad-arg s 'stream)) + + + + +(defmethod stream-fresh-line ((stream output-stream)) + (terpri stream) + t) + +(defmethod stream-line-length ((stream stream)) + "This is meant to be shadowed by particular kinds of streams, + esp those associated with windows." + 80) + +(defmethod interactive-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod interactive-stream-p ((stream stream)) nil) + +(defmethod stream-clear-input ((x t)) + (report-bad-arg x 'input-stream)) + +(defmethod stream-clear-input ((stream input-stream)) nil) + +(defmethod stream-listen ((stream input-stream)) + (not (eofp stream))) + +(defmethod stream-filename ((stream stream)) + (report-bad-arg stream 'file-stream)) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; For input streams, the IO-BUFFER-COUNT field denotes the number +;;; of elements read from the underlying input source (e.g., the +;;; file system.) For output streams, it's the high-water mark of +;;; elements output to the buffer. + +(defstruct io-buffer + ;; This type is too complex during bootstrapping. + (buffer nil #|:type (or (simple-array * (*)) null)|#) + (bufptr nil :type (or macptr null)) + (size 0 :type fixnum) ; size (in octets) of buffer + (idx 0 :type fixnum) ; index of next element + (count 0 :type fixnum) ; count of active elements + (limit 0 :type fixnum) ; size (in elements) of buffer + (translate nil) ; newline-translation + ) + +(defmethod print-object ((buf io-buffer) out) + (print-unreadable-object (buf out :identity t :type t) + (let* ((buffer (io-buffer-buffer buf))) + (when buffer (format out " ~s " (array-element-type buffer)))) + (format out "~d/~d/~d" + (io-buffer-idx buf) + (io-buffer-count buf) + (io-buffer-limit buf)))) + +(defstruct ioblock + stream ; the stream being buffered + untyi-char ; nil or last value passed to + ; stream-unread-char + (inbuf nil :type (or null io-buffer)) + (outbuf nil :type (or null io-buffer)) + (element-type 'character) + (element-shift 0 :type fixnum) ;element shift count + (charpos 0 :type (or null fixnum)) ;position of cursor + (device -1 :type (or null fixnum)) ;file descriptor + (advance-function 'ioblock-advance) + (listen-function 'ioblock-listen) + (eofp-function 'ioblock-eofp) + (force-output-function 'ioblock-force-output) + (close-function 'ioblock-close) + (inbuf-lock nil) + (eof nil) + (interactive nil) + (dirty nil) + (outbuf-lock nil) + (owner nil) + (read-char-function 'ioblock-no-char-input) + (read-byte-function 'ioblock-no-binary-input) + (write-byte-function 'ioblock-no-binary-output) + (write-char-function 'ioblock-no-char-output) + (encoding nil) + (pending-byte-order-mark nil) + (decode-literal-code-unit-limit 256) + (encode-output-function nil) + (decode-input-function nil) + (read-char-when-locked-function 'ioblock-no-char-input) + (write-simple-string-function 'ioblock-no-char-output) + (character-read-vector-function 'ioblock-no-char-input) + (read-line-function 'ioblock-no-char-input) + (write-char-when-locked-function 'ioblock-no-char-output) + (read-byte-when-locked-function 'ioblock-no-binary-input) + (write-byte-when-locked-function 'ioblock-no-binary-output) + (peek-char-function 'ioblock-no-char-input) + (native-byte-order t) + (read-char-without-translation-when-locked-function 'ioblock-no-char-input) + (write-char-without-translation-when-locked-function 'iblock-no-char-output) + (sharing nil) + (line-termination nil) + (unread-char-function 'ioblock-no-char-input) + (encode-literal-char-code-limit 256) + (input-timeout nil) + (output-timeout nil) + (deadline nil)) + + +;;; Functions on ioblocks. So far, we aren't saying anything +;;; about how streams use them. + +(defun ioblock-no-binary-input (ioblock &rest otters) + (declare (ignore otters)) + (report-bad-arg (ioblock-stream ioblock) '(and binary-stream input-stream))) + +(defun ioblock-no-binary-output (ioblock &rest others) + (declare (ignore others)) + (report-bad-arg (ioblock-stream ioblock) '(and binary-stream output-stream))) + +(defun ioblock-no-char-input (ioblock &rest others) + (declare (ignore others)) + (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream))) + +(defun ioblock-no-char-output (ioblock &rest others) + (declare (ignore others)) + (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream))) + + +(defun ioblock-octets-to-elements (ioblock octets) + (let* ((shift (ioblock-element-shift ioblock))) + (declare (fixnum shift)) + (if (zerop shift) + octets + (ash octets (- shift))))) + +(defun ioblock-elements-to-octets (ioblock elements) + (let* ((shift (ioblock-element-shift ioblock))) + (declare (fixnum shift)) + (if (zerop shift) + elements + (ash elements shift)))) + + + +;;; ioblock must really be an ioblock or you will crash +;;; Also: the expression "ioblock" is evaluated multiple times. + +(declaim (inline check-ioblock-owner)) +(defun check-ioblock-owner (ioblock) + (declare (optimize (speed 3))) + (let* ((owner (ioblock-owner ioblock))) + (if owner + (or (eq owner *current-process*) + (conditional-store (ioblock-owner ioblock) 0 *current-process*) + (error "Stream ~s is private to ~s" (ioblock-stream ioblock) owner))))) + + + +(declaim (inline %ioblock-advance)) +(defun %ioblock-advance (ioblock read-p) + (funcall (ioblock-advance-function ioblock) + (ioblock-stream ioblock) + ioblock + read-p)) + + +(defun %ioblock-surrounding-characters (ioblock) + (let* ((inbuf (ioblock-inbuf ioblock))) + (when inbuf + (let* ((encoding (or (ioblock-encoding ioblock) + (get-character-encoding nil))) + (size (ash (character-encoding-code-unit-size encoding) -3)) + (buffer (io-buffer-buffer inbuf)) + (idx (io-buffer-idx inbuf)) + (count (io-buffer-count inbuf))) + (unless (= count 0) + (let* ((start (max (- idx (* 10 size)) 0)) + (end (min (+ idx (* 10 size)) count)) + (string (make-string (funcall (character-encoding-length-of-vector-encoding-function encoding) buffer start end)))) + (funcall (character-encoding-vector-decode-function encoding) + buffer + start + (- end start) + string) + (if (position #\Replacement_Character string) + (string-trim (string #\Replacement_Character) string) + string))))))) + + + + +(defun %bivalent-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (setf (ioblock-untyi-char ioblock) nil) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %bivalent-ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + + +(declaim (inline %ioblock-read-u8-byte)) +(defun %ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(declaim (inline %ioblock-read-u8-code-unit)) +(defun %ioblock-read-u8-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u8-code-unit :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(declaim (inline %ioblock-read-s8-byte)) +(defun %ioblock-read-s8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-s8-byte ioblock)) + +(defun %locked-ioblock-read-s8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s8-byte ioblock))) + + +(declaim (inline %ioblock-read-u16-byte)) +(defun %ioblock-read-u16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u16-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 16) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u16-byte ioblock)) + +(defun %locked-ioblock-read-u16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u16-byte ioblock))) + +(declaim (inline %ioblock-read-s16-byte)) +(defun %ioblock-read-s16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s16-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 16) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-s16-byte ioblock)) + +(defun %locked-ioblock-read-s16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s16-byte ioblock))) + + +(declaim (inline %ioblock-read-u32-byte)) +(defun %ioblock-read-u32-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u32-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 32) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u32-byte (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-u32-byte ioblock)) + +(defun %locked-ioblock-read-u32-byte (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u32-byte ioblock))) + +(declaim (inline %ioblock-read-s32-byte)) +(defun %ioblock-read-s32-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s32-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 32) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s32-byte (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-s32-byte ioblock)) + +(defun %locked-ioblock-read-s32-byte (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s32-byte ioblock))) + +#+64-bit-target +(progn +(declaim (inline %ioblock-read-u64-byte)) +(defun %ioblock-read-u64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u64-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 64) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u64-byte ioblock)) + +(defun %locked-ioblock-read-u64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u64-byte ioblock))) + +(defun %ioblock-read-s64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s64-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 64) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-s64-byte ioblock)) + +(defun %locked-ioblock-read-s64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s64-byte ioblock))) +) + + +;;; Read a 16-bit code element from a stream with element-type +;;; (UNSIGNED-BYTE 8), in native byte-order. + +(declaim (inline %ioblock-read-u16-code-unit)) +(defun %ioblock-read-u16-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (if (<= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx))))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 2))) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)) + (if (< idx limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (let* ((b1 (aref vector 0))) + (declare (type (unsigned-byte 8) b1)) + (setf (io-buffer-idx buf) 1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)))) + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) 2) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0))))))))) + +(declaim (inline %ioblock-read-swapped-u16-code-unit)) +(defun %ioblock-read-swapped-u16-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (if (<= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx))))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 2))) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)) + (if (< idx limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (let* ((b1 (aref vector 0))) + (declare (type (unsigned-byte 8) b1)) + (setf (io-buffer-idx buf) 1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)))) + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) 2) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0))))))))) + + +(declaim (inline %ioblock-read-u32-code-unit)) +(defun %ioblock-read-u32-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond ((<= (the fixnum (+ idx 4)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (b3 (aref vector (the fixnum (+ idx 3))))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 4))) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))) + ((= (the fixnum (+ idx 3)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1 b2)) + (if (null n) + :eof + (let* ((b3 (aref vector 0))) + (declare (type (unsigned-byte 8) b3)) + (setf (io-buffer-idx buf) 1) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))) + ((= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1)) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b2 (aref vector 0)) + (b3 (aref vector 1))) + (declare (type (unsigned-byte 8) b2 b3)) + (setf (io-buffer-idx buf) 2) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + ((= (the fixnum (1+ idx)) limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (if (< n 3) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b1 (aref vector 0)) + (b2 (aref vector 1)) + (b3 (aref vector 2))) + (setf (io-buffer-idx buf) 3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + (t + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (< n 4) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1)) + (b2 (aref vector 2)) + (b3 (aref vector 3))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) 4) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))))))) + +(declaim (inline %ioblock-read-swapped-u32-code-unit)) +(defun %ioblock-read-swapped-u32-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond ((<= (the fixnum (+ idx 4)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (b3 (aref vector (the fixnum (+ idx 3))))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 4))) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))) + ((= (the fixnum (+ idx 3)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1 b2)) + (if (null n) + :eof + (let* ((b3 (aref vector 0))) + (declare (type (unsigned-byte 8) b3)) + (setf (io-buffer-idx buf) 1) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))) + ((= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1)) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b2 (aref vector 0)) + (b3 (aref vector 1))) + (declare (type (unsigned-byte 8) b2 b3)) + (setf (io-buffer-idx buf) 2) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + ((= (the fixnum (1+ idx)) limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (if (< n 3) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b1 (aref vector 0)) + (b2 (aref vector 1)) + (b3 (aref vector 2))) + (setf (io-buffer-idx buf) 3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + (t + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (< n 4) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1)) + (b2 (aref vector 2)) + (b3 (aref vector 3))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) 4) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))))))) + + +(defun %bivalent-private-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (setf (ioblock-untyi-char ioblock) nil) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %bivalent-private-ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u8-byte ioblock)) + +(defun %bivalent-locked-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (setf (ioblock-untyi-char ioblock) nil) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %bivalent-locked-ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx)))) + +(defun %locked-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u8-byte ioblock))) + +(defun %general-ioblock-read-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-locked (ioblock) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %general-ioblock-read-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (uvref (io-buffer-buffer buf) idx)))) + + +(declaim (inline %ioblock-tyi)) +(defun %ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-tyi :eof)) + (setq idx 0)) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx)))))) + +(defun %private-ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-tyi ioblock)) + +(defun %locked-ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-tyi ioblock))) + +;;; Read a character composed of one or more 8-bit code-units. +(declaim (inline %ioblock-read-u8-encoded-char)) +(defun %ioblock-read-u8-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-u8-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (%code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-u8-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-u8-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u8-encoded-char ioblock)) + +(defun %locked-ioblock-read-u8-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u8-encoded-char ioblock))) + +(declaim (inline %ioblock-read-u16-encoded-char)) +(defun %ioblock-read-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-u16-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-u16-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u16-encoded-char ioblock)) + +(defun %locked-ioblock-read-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u16-encoded-char ioblock))) + +(declaim (inline %ioblock-read-swapped-u16-encoded-char)) +(defun %ioblock-read-swapped-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-swapped-u16-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-swapped-u16-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-swapped-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-swapped-u16-encoded-char ioblock)) + +(defun %locked-ioblock-read-swapped-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-swapped-u16-encoded-char ioblock))) + +(declaim (inline %ioblock-read-u32-encoded-char)) +(defun %ioblock-read-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-u32-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-u32-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u32-encoded-char ioblock)) + +(defun %locked-ioblock-read-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u32-encoded-char ioblock))) + +(declaim (inline %ioblock-read-swapped-u32-encoded-char)) +(defun %ioblock-read-swapped-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-swapped-u32-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-swapped-u32-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-swapped-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-swapped-u32-encoded-char ioblock)) + +(defun %locked-ioblock-read-swapped-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-swapped-u32-encoded-char ioblock))) + +(declaim (inline %ioblock-tyi-no-hang)) +(defun %ioblock-tyi-no-hang (ioblock) + (declare (optimize (speed 3) (safety 0))) + (if (ioblock-untyi-char ioblock) + (prog1 (ioblock-untyi-char ioblock) + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock nil) + (return-from %ioblock-tyi-no-hang (if (ioblock-eof ioblock) :eof)))) + (funcall (ioblock-read-char-when-locked-function ioblock) ioblock)))) + +;;; :iso-8859-1 only. +(defun %ioblock-peek-char (ioblock) + (or (ioblock-untyi-char ioblock) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-peek-char :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx))))) + +(defun %encoded-ioblock-peek-char (ioblock) + (or (ioblock-untyi-char ioblock) + (let* ((ch (funcall (ioblock-read-char-when-locked-function ioblock) ioblock))) + (unless (eq ch :eof) + (setf (ioblock-untyi-char ioblock) ch)) + ch))) + + + + +(defun %ioblock-clear-input (ioblock) + (let* ((buf (ioblock-inbuf ioblock))) + (setf (io-buffer-count buf) 0 + (io-buffer-idx buf) 0 + (ioblock-untyi-char ioblock) nil))) + +(defun %ioblock-untyi (ioblock char) + (if (ioblock-untyi-char ioblock) + (error "Two UNREAD-CHARs without intervening READ-CHAR on ~s" + (ioblock-stream ioblock)) + (setf (ioblock-untyi-char ioblock) char))) + +(declaim (inline ioblock-inpos)) + +(defun ioblock-inpos (ioblock) + (io-buffer-idx (ioblock-inbuf ioblock))) + +(declaim (inline ioblock-outpos)) + +(defun ioblock-outpos (ioblock) + (io-buffer-count (ioblock-outbuf ioblock))) + + + +(declaim (inline %ioblock-force-output)) + +(defun %ioblock-force-output (ioblock finish-p) + (funcall (ioblock-force-output-function ioblock) + (ioblock-stream ioblock) + ioblock + (ioblock-outpos ioblock) + finish-p)) + +;;; ivector should be an ivector. The ioblock should have an +;;; element-shift of 0; start-octet and num-octets should of course +;;; be sane. This is mostly to give the fasdumper a quick way to +;;; write immediate data. +(defun %ioblock-out-ivect (ioblock ivector start-octet num-octets) + (unless (= 0 (the fixnum (ioblock-element-shift ioblock))) + (error "Can't write vector to stream ~s" (ioblock-stream ioblock))) + (let* ((written 0) + (out (ioblock-outbuf ioblock))) + (declare (fixnum written)) + (do* ((pos start-octet (+ pos written)) + (left num-octets (- left written))) + ((= left 0) num-octets) + (declare (fixnum pos left)) + (setf (ioblock-dirty ioblock) t) + (let* ((index (io-buffer-idx out)) + (count (io-buffer-count out)) + (bufsize (io-buffer-size out)) + (avail (- bufsize index)) + (buffer (io-buffer-buffer out))) + (declare (fixnum index avail count bufsize)) + (cond + ((= (setq written avail) 0) + (%ioblock-force-output ioblock nil)) + (t + (if (> written left) + (setq written left)) + (%copy-ivector-to-ivector ivector pos buffer index written) + (setf (ioblock-dirty ioblock) t) + (incf index written) + (if (> index count) + (setf (io-buffer-count out) index)) + (setf (io-buffer-idx out) index) + (if (= index bufsize) + (%ioblock-force-output ioblock nil)))))))) + + +(defun %ioblock-unencoded-write-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) (simple-string string)) + (let* ((written 0) + (col (ioblock-charpos ioblock)) + (out (ioblock-outbuf ioblock))) + (declare (fixnum written col) + (optimize (speed 3) (safety 0))) + (do* ((pos start-char (+ pos written)) + (left num-chars (- left written))) + ((= left 0) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum pos left)) + (setf (ioblock-dirty ioblock) t) + (let* ((index (io-buffer-idx out)) + (count (io-buffer-count out)) + (bufsize (io-buffer-size out)) + (buffer (io-buffer-buffer out)) + (avail (- bufsize index))) + (declare (fixnum index bufsize avail count) + (type (simple-array (unsigned-byte 8) (*)) buffer)) + (cond + ((= (setq written avail) 0) + (%ioblock-force-output ioblock nil)) + (t + (if (> written left) + (setq written left)) + (do* ((p pos (1+ p)) + (i index (1+ i)) + (j 0 (1+ j))) + ((= j written)) + (declare (fixnum p i j)) + (let* ((ch (schar string p)) + (code (char-code ch))) + (declare (type (mod #x110000) code)) + (if (eql ch #\newline) + (setq col 0) + (incf col)) + (setf (aref buffer i) (if (>= code 256) (char-code #\Sub) code)))) + (setf (ioblock-dirty ioblock) t) + (incf index written) + (if (> index count) + (setf (io-buffer-count out) index)) + (setf (io-buffer-idx out) index) + (if (= index bufsize) + (%ioblock-force-output ioblock nil)))))))) + + + +(defun %ioblock-eofp (ioblock) + (let* ((buf (ioblock-inbuf ioblock))) + (and (eql (io-buffer-idx buf) + (io-buffer-count buf)) + (locally (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-locked (ioblock) + (funcall (ioblock-eofp-function ioblock) + (ioblock-stream ioblock) + ioblock)))))) + +(defun %ioblock-listen (ioblock) + (let* ((buf (ioblock-inbuf ioblock))) + (or (< (the fixnum (io-buffer-idx buf)) + (the fixnum (io-buffer-count buf))) + (funcall (ioblock-listen-function ioblock) + (ioblock-stream ioblock) + ioblock)))) + + + +(declaim (inline %ioblock-write-u8-element)) +(defun %ioblock-write-u8-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s8-element)) +(defun %ioblock-write-s8-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u16-element)) +(defun %ioblock-write-u16-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u16-code-unit)) +(defun %ioblock-write-u16-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 16) element)) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+big-endian-target (ldb (byte 8 8) element) + #+little-endian-target (ldb (byte 8 0) element)) + (b1 #+big-endian-target (ldb (byte 8 0) element) + #+little-endian-target (ldb (byte 8 8) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1)) + + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref vector idx) b0) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref vector idx) b1) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-swapped-u16-code-unit)) +(defun %ioblock-write-swapped-u16-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0))) +(let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+big-endian-target (ldb (byte 8 8) element) + #+little-endian-target (ldb (byte 8 0) element)) + (b1 #+big-endian-target (ldb (byte 8 0) element) + #+little-endian-target (ldb (byte 8 8) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1)) + + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b1) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b0) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u32-code-unit)) +(defun %ioblock-write-u32-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 16) element)) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+big-endian-target (ldb (byte 8 24) element) + #+little-endian-target (ldb (byte 8 0) element)) + (b1 #+big-endian-target (ldb (byte 8 16) element) + #+little-endian-target (ldb (byte 8 8) element)) + (b2 #+big-endian-target (ldb (byte 8 8) element) + #+little-endian-target (ldb (byte 8 16) element)) + (b3 #+big-endian-target (ldb (byte 8 0) element) + #+little-endian-target (ldb (byte 8 24) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1 b2 b3)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b0) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b1) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b2) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b3) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-swapped-u32-code-unit)) +(defun %ioblock-write-swapped-u32-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 16) element)) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+little-endian-target (ldb (byte 8 24) element) + #+big-endian-target (ldb (byte 8 0) element)) + (b1 #+little-endian-target (ldb (byte 8 16) element) + #+big-endian-target (ldb (byte 8 8) element)) + (b2 #+little-endian-target (ldb (byte 8 8) element) + #+big-endian-target (ldb (byte 8 16) element)) + (b3 #+little-endian-target (ldb (byte 8 0) element) + #+big-endian-target (ldb (byte 8 24) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1 b2 b3)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b0) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref vector idx) b1) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b2) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf) + vector (io-buffer-buffer buf) + limit (io-buffer-limit buf))) + (setf (aref vector idx) b3) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s16-element)) +(defun %ioblock-write-s16-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf))) + (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u32-element)) +(defun %ioblock-write-u32-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf))) + (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-swapped-u32-element)) +(defun %ioblock-write-swapped-u32-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) + count (io-buffer-count buf))) + (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) + (%swap-u32 element)) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s32-element)) +(defun %ioblock-write-s32-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +#+64-bit-target +(progn +(declaim (inline %ioblock-write-u64-element)) +(defun %ioblock-write-u64-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s64-element)) +(defun %ioblock-write-s64-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx (io-buffer-idx buf) count (io-buffer-count buf))) + (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) +) + +(declaim (inline %ioblock-write-char)) +(defun %ioblock-write-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code 256) + (%ioblock-write-u8-element ioblock code) + (%ioblock-write-u8-element ioblock (char-code #\Sub))))) + +(defun %private-ioblock-write-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-char ioblock char)) + +(defun %locked-ioblock-write-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char ioblock char))) + +(declaim (inline %ioblock-write-u8-encoded-char)) +(defun %ioblock-write-u8-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-u8-element ioblock code) + (funcall (ioblock-encode-output-function ioblock) + char + #'%ioblock-write-u8-element + ioblock)))) + +(defun %private-ioblock-write-u8-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u8-encoded-char ioblock char)) + +(defun %locked-ioblock-write-u8-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u8-encoded-char ioblock char))) + + +(defun %ioblock-write-u8-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-u8-element ioblock code) + (funcall encode-function char #'%ioblock-write-u8-element ioblock))))) + + +(declaim (inline %ioblock-write-u16-encoded-char)) +(defun %ioblock-write-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code)) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-u16-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + char + #'%ioblock-write-u16-code-unit + ioblock)))) + +(defun %private-ioblock-write-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u16-encoded-char ioblock char)) + +(defun %locked-ioblock-write-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u16-encoded-char ioblock char))) + + +(defun %ioblock-write-u16-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code)) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-u16-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock))))) + +(declaim (inline %ioblock-write-swapped-u16-encoded-char)) +(defun %ioblock-write-swapped-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-swapped-u16-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + char + #'%ioblock-write-swapped-u16-code-unit + ioblock)))) + +(defun %private-ioblock-write-swapped-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-swapped-u16-encoded-char ioblock char)) + +(defun %locked-ioblock-write-swapped-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-swapped-u16-encoded-char ioblock char))) + +(defun %ioblock-write-swapped-u16-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (cond ((eq char #\newline) + (setq col 0) + (funcall wcf ioblock char)) + (t + (incf col) + (if (< code limit) + (%ioblock-write-swapped-u16-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock))))))) + + +(declaim (inline %ioblock-write-u32-encoded-char)) +(defun %ioblock-write-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u32-code-unit ioblock byte-order-mark)) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-u32-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + code + #'%ioblock-write-u32-code-unit + ioblock)))) + +(defun %private-ioblock-write-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u32-encoded-char ioblock char)) + +(defun %locked-ioblock-write-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u32-encoded-char ioblock char))) + +(defun %ioblock-write-u32-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u32-code-unit ioblock byte-order-mark-char-code)) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-u32-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-u32-code-unit ioblock))))) + + +(declaim (inline %ioblock-write-swapped-u32-encoded-char)) +(defun %ioblock-write-swapped-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-swapped-u32-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + code + #'%ioblock-write-swapped-u32-code-unit + ioblock)))) + +(defun %private-ioblock-write-swapped-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-swapped-u32-encoded-char ioblock char)) + +(defun %locked-ioblock-write-swapped-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-swapped-u32-encoded-char ioblock char))) + +(defun %ioblock-write-swapped-u32-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-swapped-u32-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-swapped-u32-code-unit ioblock))))) + +(declaim (inline %ioblock-write-u8-byte)) +(defun %ioblock-write-u8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u8-element ioblock (require-type byte '(unsigned-byte 8)))) + +(defun %private-ioblock-write-u8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u8-byte ioblock byte)) + +(defun %locked-ioblock-write-u8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u8-byte ioblock byte))) + +(declaim (inline %ioblock-write-s8-byte)) +(defun %ioblock-write-s8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s8-element ioblock (require-type byte '(signed-byte 8)))) + +(defun %private-ioblock-write-s8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s8-byte ioblock byte)) + +(defun %locked-ioblock-write-s8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s8-byte ioblock byte))) + +(declaim (inline %ioblock-write-u16-byte)) +(defun %ioblock-write-u16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u16-element ioblock (require-type byte '(unsigned-byte 16)))) + +(defun %private-ioblock-write-u16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u16-byte ioblock byte)) + +(defun %locked-ioblock-write-u16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u16-byte ioblock byte))) + +(declaim (inline %ioblock-write-s16-byte)) +(defun %ioblock-write-s16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s16-element ioblock (require-type byte '(signed-byte 16)))) + +(defun %private-ioblock-write-s16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s16-byte ioblock byte)) + +(defun %locked-ioblock-write-s16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s16-byte ioblock byte))) + +(declaim (inline %ioblock-write-u32-byte)) +(defun %ioblock-write-u32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u32-element ioblock (require-type byte '(unsigned-byte 32)))) + +(defun %private-ioblock-write-u32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u32-byte ioblock byte)) + +(defun %locked-ioblock-write-u32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u32-byte ioblock byte))) + +(declaim (inline %ioblock-write-s32-byte)) +(defun %ioblock-write-s32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s32-element ioblock (require-type byte '(signed-byte 32)))) + +(defun %private-ioblock-write-s32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s32-byte ioblock byte)) + +(defun %locked-ioblock-write-s32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s32-byte ioblock byte))) + +#+64-bit-target +(progn +(declaim (inline %ioblock-write-u64-byte)) +(defun %ioblock-write-u64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u64-element ioblock (require-type byte '(unsigned-byte 64)))) + +(defun %private-ioblock-write-u64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u64-byte ioblock byte)) + +(defun %locked-ioblock-write-u64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u64-byte ioblock byte))) + +(declaim (inline %ioblock-write-s64-byte)) +(defun %ioblock-write-s64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s64-element ioblock (require-type byte '(signed-byte 64)))) + +(defun %private-ioblock-write-s64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s64-byte ioblock byte)) + +(defun %locked-ioblock-write-s64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s64-byte ioblock byte))) +) ;#+64-bit-target + +(defun %ioblock-clear-output (ioblock) + (let* ((buf (ioblock-outbuf ioblock))) + (setf (io-buffer-count buf) 0 + (io-buffer-idx buf) 0))) + +(defun %ioblock-unencoded-read-line (ioblock) + (let* ((inbuf (ioblock-inbuf ioblock))) + (let* ((string "") + (len 0) + (eof nil) + (buf (io-buffer-buffer inbuf)) + (newline (char-code #\newline))) + (let* ((ch (ioblock-untyi-char ioblock))) + (when ch + (setf (ioblock-untyi-char ioblock) nil) + (if (eql ch #\newline) + (return-from %ioblock-unencoded-read-line + (values string nil)) + (progn + (setq string (make-string 1) + len 1) + (setf (schar string 0) ch))))) + (loop + (let* ((more 0) + (idx (io-buffer-idx inbuf)) + (count (io-buffer-count inbuf))) + (declare (fixnum idx count more)) + (if (= idx count) + (if eof + (return (values string t)) + (progn + (setq eof t) + (%ioblock-advance ioblock t))) + (progn + (setq eof nil) + (let* ((pos (position newline buf :start idx :end count))) + (when pos + (locally (declare (fixnum pos)) + (setf (io-buffer-idx inbuf) (the fixnum (1+ pos))) + (setq more (- pos idx)) + (unless (zerop more) + (setq string + (%extend-vector + 0 string (the fixnum (+ len more))))) + (%copy-u8-to-string + buf idx string len more) + (return (values string nil)))) + ;; No #\newline in the buffer. Read everything that's + ;; there into the string, and fill the buffer again. + (setf (io-buffer-idx inbuf) count) + (setq more (- count idx) + string (%extend-vector + 0 string (the fixnum (+ len more)))) + (%copy-u8-to-string + buf idx string len more) + (incf len more))))))))) + +;;; There are lots of ways of doing better here, but in the most general +;;; case we can't tell (a) what a newline looks like in the buffer or (b) +;;; whether there's a 1:1 mapping between code units and characters. +(defun %ioblock-encoded-read-line (ioblock) + (let* ((str (make-array 20 :element-type 'base-char + :adjustable t :fill-pointer 0)) + (rcf (ioblock-read-char-when-locked-function ioblock)) + (eof nil)) + (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock))) + ((or (eq ch #\newline) (setq eof (eq ch :eof))) + (values (ensure-simple-string str) eof)) + (vector-push-extend ch str)))) + +(defun %ioblock-unencoded-character-read-vector (ioblock vector start end) + (do* ((i start) + (in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (need (- end start))) + ((= i end) end) + (declare (fixnum i need)) + (let* ((ch (%ioblock-tyi ioblock))) + (if (eq ch :eof) + (return i)) + (setf (schar vector i) ch) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-u8-to-string inbuf idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))) + +;;; Also used when newline translation complicates things. +(defun %ioblock-encoded-character-read-vector (ioblock vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i)) + (rcf (ioblock-read-char-when-locked-function ioblock))) + ((= i end) end) + (declare (fixnum i)) + (let* ((ch (funcall rcf ioblock))) + (if (eq ch :eof) + (return i)) + (setf (schar vector i) ch)))) + + +(defun %ioblock-binary-read-vector (ioblock vector start end) + (declare (fixnum start end)) + (let* ((in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (rbf (ioblock-read-byte-when-locked-function ioblock))) + (setf (ioblock-untyi-char ioblock) nil) + (if (not (= (the fixnum (typecode inbuf)) + (the fixnum (typecode vector)))) + (do* ((i start (1+ i))) + ((= i end) i) + (declare (fixnum i)) + (let* ((b (funcall rbf ioblock))) + (if (eq b :eof) + (return i) + (setf (uvref vector i) b)))) + (do* ((i start) + (need (- end start))) + ((= i end) end) + (declare (fixnum i need)) + (let* ((b (funcall rbf ioblock))) + (if (eq b :eof) + (return i)) + (setf (uvref vector i) b) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-ivector-to-ivector + inbuf + (ioblock-elements-to-octets ioblock idx) + vector + (ioblock-elements-to-octets ioblock i) + (ioblock-elements-to-octets ioblock avail)) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))))) + +;;; About the same, only less fussy about ivector's element-type. +;;; (All fussiness is about the stream's element-type ...). +;;; Whatever the element-type is, elements must be 1 octet in size. +(defun %ioblock-character-in-ivect (ioblock vector start nb) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum start nb) + (optimize (speed 3) (safety 0))) + (unless (= 0 (the fixnum (ioblock-element-shift ioblock))) + (error "Can't read vector from stream ~s" (ioblock-stream ioblock))) + (do* ((i start) + (in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (need nb) + (end (+ start nb))) + ((= i end) end) + (declare (fixnum i end need)) + (let* ((ch (%ioblock-tyi ioblock))) + (if (eq ch :eof) + (return (- i start))) + (setf (aref vector i) (char-code ch)) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-u8-to-string inbuf idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))) + +(defun %ioblock-binary-in-ivect (ioblock vector start nb) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum start nb) + (optimize (speed 3) (safety 0))) + (unless (= 0 (the fixnum (ioblock-element-shift ioblock))) + (error "Can't read vector from stream ~s" (ioblock-stream ioblock))) + (setf (ioblock-untyi-char ioblock) nil) + (do* ((i start) + (rbf (ioblock-read-byte-when-locked-function ioblock)) + (in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (need nb) + (end (+ start nb))) + ((= i end) nb) + (declare (fixnum i end need)) + (let* ((b (funcall rbf ioblock))) + (if (eq b :eof) + (return (- i start))) + (setf (aref vector i) b) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-ivector-to-ivector inbuf idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))) + +;;; Thread must own ioblock lock(s). +(defun %%ioblock-close (ioblock) + (when (ioblock-device ioblock) + (let* ((stream (ioblock-stream ioblock))) + (funcall (ioblock-close-function ioblock) stream ioblock) + (setf (ioblock-device ioblock) nil) + (setf (stream-ioblock stream) nil) + (let* ((in-iobuf (ioblock-inbuf ioblock)) + (out-iobuf (ioblock-outbuf ioblock)) + (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf))) + (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf))) + (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf))) + (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf)))) + (if (and in-buffer in-bufptr) + (%dispose-heap-ivector in-buffer)) + (unless (eq in-buffer out-buffer) + (if (and out-buffer out-bufptr) + (%dispose-heap-ivector out-buffer))) + (when in-iobuf + (setf (io-buffer-buffer in-iobuf) nil + (io-buffer-bufptr in-iobuf) nil + (ioblock-inbuf ioblock) nil)) + (when out-iobuf + (setf (io-buffer-buffer out-iobuf) nil + (io-buffer-bufptr out-iobuf) nil + (ioblock-outbuf ioblock) nil)) + t)))) + +(defun %ioblock-close (ioblock) + (let* ((in-lock (ioblock-inbuf-lock ioblock)) + (out-lock (ioblock-outbuf-lock ioblock))) + (if in-lock + (with-lock-grabbed (in-lock) + (if (and out-lock (not (eq out-lock in-lock))) + (with-lock-grabbed (out-lock) + (%%ioblock-close ioblock)) + (%%ioblock-close ioblock))) + (if out-lock + (with-lock-grabbed (out-lock) + (%%ioblock-close ioblock)) + (progn + (check-ioblock-owner ioblock) + (%%ioblock-close ioblock)))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Character-at-a-time line-termination-translation functions. +;;; It's not always possible to just blast through the buffer, blindly +;;; replacing #xd with #xa (for example), and it's not always desirable +;;; to do that (if we support changing encoding on open streams.) +;;; This is done at a fairly high level; some cases could be done at +;;; a lower level, and some cases are hard even at that lower level. +;;; This approach doesn't slow down the simple case (when no line-termination +;;; translation is used), and hopefully isn't -that- bad. + +(declaim (inline %ioblock-read-char-translating-cr-to-newline)) +(defun %ioblock-read-char-translating-cr-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql ch #\Return) + #\Newline + ch))) + +(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-cr-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-cr-to-newline ioblock))) + +(declaim (inline %ioblock-read-char-translating-crlf-to-newline)) +(defun %ioblock-read-char-translating-crlf-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql ch #\Return) + (let* ((next (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql next #\Linefeed) + next + (progn + (unless (eq next :eof) + (setf (ioblock-untyi-char ioblock) next)) + ch))) + ch))) + +(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-crlf-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-crlf-to-newline ioblock))) + +(declaim (inline %ioblock-read-char-translating-line-separator-to-newline)) +(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql ch #\Line_Separator) + #\Newline + ch))) + +(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-line-separator-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-line-separator-to-newline ioblock))) + +(declaim (inline %ioblock-write-char-translating-newline-to-cr)) +(defun %ioblock-write-char-translating-newline-to-cr (ioblock char) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + (if (eql char #\Newline) #\Return char))) + +(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-cr ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-cr ioblock char))) + +(declaim (inline %ioblock-write-char-translating-newline-to-crlf)) +(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char) + (when (eql char #\Newline) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + #\Return)) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + char)) + +(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-crlf ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-crlf ioblock char))) + +(declaim (inline %ioblock-write-char-translating-newline-to-line-separator)) +(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + (if (eql char #\Newline) #\Line_Separator char))) + +(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-line-separator ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-line-separator ioblock char))) + +;;; If we do newline translation, we probably can't be too clever about reading/writing +;;; strings. +(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars) + (declare (fixnum start-pos num-chars) (simple-string string)) + (let* ((col (ioblock-charpos ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock))) + (declare (fixnum col)) + (do* ((i start-pos (1+ i)) + (n 0 (1+ n))) + ((= n num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (let* ((char (schar string i))) + (if (eql char #\Newline) + (setq col 0) + (incf col)) + (funcall wcf ioblock char))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination) + (setf (ioblock-sharing ioblock) sharing) + (when character-p + (setf (ioblock-unread-char-function ioblock) (select-stream-untyi-function (ioblock-stream ioblock) :input)) + (setf (ioblock-decode-literal-code-unit-limit ioblock) + (if encoding + (character-encoding-decode-literal-code-unit-limit encoding) + 256)) + (if encoding + (let* ((unit-size (character-encoding-code-unit-size encoding))) + (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char) + (setf (ioblock-read-line-function ioblock) + '%ioblock-encoded-read-line) + (setf (ioblock-character-read-vector-function ioblock) + '%ioblock-encoded-character-read-vector) + (setf (ioblock-decode-input-function ioblock) + (character-encoding-stream-decode-function encoding)) + (setf (ioblock-read-char-function ioblock) + (ecase unit-size + (8 + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-u8-encoded-char) + (case sharing + (:private '%private-ioblock-read-u8-encoded-char) + (:lock '%locked-ioblock-read-u8-encoded-char) + (t '%ioblock-read-u8-encoded-char))) + (16 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-u16-encoded-char) + (case sharing + (:private '%private-ioblock-read-u16-encoded-char) + (:lock '%locked-ioblock-read-u16-encoded-char) + (t '%ioblock-read-u16-encoded-char))) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-read-swapped-u16-encoded-char) + (:lock '%locked-ioblock-read-swapped-u16-encoded-char) + (t '%ioblock-read-swapped-u16-encoded-char))))) + (32 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + #'%ioblock-read-u32-encoded-char) + (case sharing + (:private #'%private-ioblock-read-u32-encoded-char) + (:lock #'%locked-ioblock-read-u32-encoded-char) + (t #'%ioblock-read-u32-encoded-char))) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + #'%ioblock-read-swapped-u32-encoded-char) + (case sharing + (:private '#'%private-ioblock-read-swapped-u16-encoded-char) + (:lock #'%locked-ioblock-read-swapped-u32-encoded-char) + (t #'%ioblock-read-swapped-u32-encoded-char)))))))) + (progn + (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char) + (setf (ioblock-read-char-function ioblock) + (case sharing + (:private '%private-ioblock-tyi) + (:lock '%locked-ioblock-tyi) + (t '%ioblock-tyi))) + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-tyi) + (setf (ioblock-character-read-vector-function ioblock) + '%ioblock-unencoded-character-read-vector) + (setf (ioblock-read-line-function ioblock) + '%ioblock-unencoded-read-line))) + (when line-termination + (install-ioblock-input-line-termination ioblock line-termination)) + ) + + (unless (or (eq element-type 'character) + (subtypep element-type 'character)) + (let* ((subtag (element-type-subtype element-type))) + (declare (type (unsigned-byte 8) subtag)) + (setf (ioblock-read-byte-function ioblock) + (cond ((= subtag target::subtag-u8-vector) + (if character-p + ;; The bivalent case, at least for now + (progn + (setf (ioblock-read-byte-when-locked-function ioblock) + '%bivalent-ioblock-read-u8-byte) + (case sharing + (:private '%bivalent-private-ioblock-read-u8-byte) + (:lock '%bivalent-locked-ioblock-read-u8-byte) + (t '%bivalent-ioblock-read-u8-byte))) + (progn + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u8-byte) + (case sharing + (:private '%private-ioblock-read-u8-byte) + (:lock '%locked-ioblock-read-u8-byte) + (t '%ioblock-read-u8-byte))))) + ((= subtag target::subtag-s8-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s8-byte) + (case sharing + (:private '%private-ioblock-read-s8-byte) + (:lock '%locked-ioblock-read-s8-byte) + (t '%ioblock-read-s8-byte))) + ((= subtag target::subtag-u16-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u16-byte) + (case sharing + (:private '%private-ioblock-read-u16-byte) + (:lock '%locked-ioblock-read-u16-byte) + (t '%ioblock-read-u16-byte))) + ((= subtag target::subtag-s16-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s16-byte) + (case sharing + (:private '%private-ioblock-read-s16-byte) + (:lock '%locked-ioblock-read-s16-byte) + (t '%ioblock-read-s16-byte))) + ((= subtag target::subtag-u32-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u32-byte) + (case sharing + (:private '%private-ioblock-read-u32-byte) + (:lock '%locked-ioblock-read-u32-byte) + (t '%ioblock-read-u32-byte))) + ((= subtag target::subtag-s32-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s32-byte) + (case sharing + (:private '%private-ioblock-read-s32-byte) + (:lock '%locked-ioblock-read-s32-byte) + (t '%ioblock-read-s32-byte))) + #+64-bit-target + ((= subtag target::subtag-u64-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u64-byte) + (case sharing + (:private '%private-ioblock-read-u64-byte) + (:lock '%locked-ioblock-read-u64-byte) + (t '%ioblock-read-u64-byte))) + #+64-bit-target + ((= subtag target::subtag-s64-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s64-byte) + (case sharing + (:private '%private-ioblock-read-s64-byte) + (:lock '%locked-ioblock-read-s64-byte) + (t '%ioblock-read-s64-byte))) + ;; Not sure what this means, currently. + (t + (setf (ioblock-read-byte-when-locked-function ioblock) + '%general-ioblock-read-byte) + '%general-ioblock-read-byte)))))) + +(defun install-ioblock-input-line-termination (ioblock line-termination) + (when line-termination + (let* ((sharing (ioblock-sharing ioblock))) + (setf (ioblock-read-char-without-translation-when-locked-function ioblock) + (ioblock-read-char-when-locked-function ioblock) + (ioblock-character-read-vector-function ioblock) + '%ioblock-encoded-character-read-vector + (ioblock-read-line-function ioblock) '%ioblock-encoded-read-line) + (ecase line-termination + (:cr (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-cr-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-cr-to-newline) + (:lock + '%locked-ioblock-read-char-translating-cr-to-newline) + (t '%ioblock-read-char-translating-cr-to-newline)))) + (:crlf (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-crlf-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-crlf-to-newline) + (:lock + '%locked-ioblock-read-char-translating-crlf-to-newline) + (t '%ioblock-read-char-translating-crlf-to-newline)))) + (:unicode (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-line-separator-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-line-separator-to-newline) + (:lock + '%locked-ioblock-read-char-translating-line-separator-to-newline) + (t '%ioblock-read-char-translating-line-separator-to-newline))))) + (setf (ioblock-line-termination ioblock) line-termination)))) + +(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination) + (or (ioblock-sharing ioblock) + (setf (ioblock-sharing ioblock) sharing)) + (when character-p + (setf (ioblock-encode-literal-char-code-limit ioblock) + (if encoding + (character-encoding-encode-literal-char-code-limit encoding) + 256)) + (if encoding + (let* ((unit-size (character-encoding-code-unit-size encoding))) + (setf (ioblock-encode-output-function ioblock) + (character-encoding-stream-encode-function encoding)) + (setf (ioblock-write-char-function ioblock) + (ecase unit-size + (8 + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-u8-encoded-char) + (case sharing + (:private '%private-ioblock-write-u8-encoded-char) + (:lock '%locked-ioblock-write-u8-encoded-char) + (t '%ioblock-write-u8-encoded-char))) + (16 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-u16-encoded-char) + (case sharing + (:private '%private-ioblock-write-u16-encoded-char) + (:lock '%locked-ioblock-write-u16-encoded-char) + (t '%ioblock-write-u16-encoded-char))) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-write-swapped-u16-encoded-char) + (:lock '%locked-ioblock-write-swapped-u16-encoded-char) + (t '%ioblock-write-swapped-u16-encoded-char))))) + (32 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + #'%ioblock-write-u32-encoded-char) + (case sharing + (:private #'%private-ioblock-write-u32-encoded-char) + (:lock #'%locked-ioblock-write-u32-encoded-char) + (t #'%ioblock-write-u32-encoded-char))) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + #'%ioblock-write-swapped-u32-encoded-char) + (case sharing + (:private #'%private-ioblock-write-swapped-u32-encoded-char) + (:lock #'%locked-ioblock-write-swapped-u32-encoded-char) + (t #'%ioblock-write-swapped-u32-encoded-char))))))) + (setf (ioblock-write-simple-string-function ioblock) + (ecase unit-size + (8 '%ioblock-write-u8-encoded-simple-string) + (16 + (if (character-encoding-native-endianness encoding) + '%ioblock-write-u16-encoded-simple-string + '%ioblock-write-swapped-u16-encoded-simple-string)) + (32 + (if (character-encoding-native-endianness encoding) + #'%ioblock-write-u32-encoded-simple-string + #'%ioblock-write-swapped-u32-encoded-simple-string)))) + (when (character-encoding-use-byte-order-mark encoding) + (setf (ioblock-pending-byte-order-mark ioblock) t))) + (progn + (setf (ioblock-write-simple-string-function ioblock) + '%ioblock-unencoded-write-simple-string) + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char) + (setf (ioblock-write-char-function ioblock) + (case sharing + (:private '%private-ioblock-write-char) + (:lock '%locked-ioblock-write-char) + (t '%ioblock-write-char))))) + (when line-termination + (install-ioblock-output-line-termination ioblock line-termination))) + (unless (or (eq element-type 'character) + (subtypep element-type 'character)) + (let* ((subtag (element-type-subtype element-type))) + (declare (type (unsigned-byte 8) subtag)) + (setf (ioblock-write-byte-function ioblock) + (cond ((= subtag target::subtag-u8-vector) + (progn + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u8-byte) + (case sharing + (:private '%private-ioblock-write-u8-byte) + (:lock '%locked-ioblock-write-u8-byte) + (t '%ioblock-write-u8-byte)))) + ((= subtag target::subtag-s8-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-s8-byte) + (case sharing + (:private '%private-ioblock-write-s8-byte) + (:lock '%locked-ioblock-write-s8-byte) + (t '%ioblock-write-s8-byte))) + ((= subtag target::subtag-u16-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u16-byte) + (case sharing + (:private '%private-ioblock-write-u16-byte) + (:lock '%locked-ioblock-write-u16-byte) + (t '%ioblock-write-u16-byte))) + ((= subtag target::subtag-s16-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-s16-byte) + (case sharing + (:private '%private-ioblock-write-s16-byte) + (:lock '%locked-ioblock-write-s16-byte) + (t '%ioblock-write-s16-byte))) + ((= subtag target::subtag-u32-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u32-byte) + (case sharing + (:private '%private-ioblock-write-u32-byte) + (:lock '%locked-ioblock-write-u32-byte) + (t '%ioblock-write-u32-byte))) + ((= subtag target::subtag-s32-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-s32-byte) + (case sharing + (:private '%private-ioblock-write-s32-byte) + (:lock '%locked-ioblock-write-s32-byte) + (t '%ioblock-write-s32-byte))) + #+64-bit-target + ((= subtag target::subtag-u64-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u64-byte) + (case sharing + (:private '%private-ioblock-write-u64-byte) + (:lock '%locked-ioblock-write-u64-byte) + (t '%ioblock-write-u64-byte))) + #+64-bit-target + ((= subtag target::subtag-s64-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u64-byte) + (case sharing + (:private '%private-ioblock-write-s64-byte) + (:lock '%locked-ioblock-write-s64-byte) + (t '%ioblock-write-s64-byte))) + (t + (setf (ioblock-write-byte-when-locked-function ioblock) + '%general-ioblock-write-byte) + '%general-ioblock-write-byte)))))) + +(defun install-ioblock-output-line-termination (ioblock line-termination) + (let* ((sharing (ioblock-sharing ioblock))) + (when line-termination + (setf (ioblock-write-char-without-translation-when-locked-function ioblock) + (ioblock-write-char-when-locked-function ioblock) + (ioblock-write-simple-string-function ioblock) + '%ioblock-write-simple-string-with-newline-translation) + (ecase line-termination + (:cr (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-cr + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-cr) + (:lock + '%locked-ioblock-write-char-translating-newline-to-cr) + (t '%ioblock-write-char-translating-newline-to-cr)))) + (:crlf (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-crlf + (ioblock-write-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-crlf) + (:lock + '%locked-ioblock-write-char-translating-newline-to-crlf) + (t '%ioblock-write-char-translating-newline-to-crlf)))) + (:unicode (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-line-separator + (ioblock-write-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-line-separator) + (:lock + '%locked-ioblock-write-char-translating-newline-to-line-separator) + (t '%ioblock-write-char-translating-newline-to-line-separator))))) + (setf (ioblock-line-termination ioblock) line-termination)))) + + +(defun ensure-reasonable-element-type (element-type) + (let* ((upgraded (upgraded-array-element-type element-type))) + (if (eq upgraded 'bit) + '(unsigned-byte 8) + (if (eq upgraded 'fixnum) + #+64-bit-target '(signed-byte 64) #+32-bit-target '(signed-byte 32) + (if (eq upgraded t) + (error "Stream element-type ~s can't be reasonably supported." element-type) + upgraded))))) + +(defun init-stream-ioblock (stream + &key + insize ; integer to allocate inbuf here, nil + ; otherwise + outsize ; integer to allocate outbuf here, nil + ; otherwise + share-buffers-p ; true if input and output + ; share a buffer + element-type + device + advance-function + listen-function + eofp-function + force-output-function + close-function + element-shift + interactive + (sharing :private) + character-p + encoding + line-termination + input-timeout + output-timeout + deadline + &allow-other-keys) + (declare (ignorable element-shift)) + (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*))) + (when encoding + (unless (typep encoding 'character-encoding) + (setq encoding (get-character-encoding encoding))) + (if (eq encoding (get-character-encoding nil)) + (setq encoding nil))) + (when sharing + (unless (or (eq sharing :private) + (eq sharing :lock)) + (if (eq sharing :external) + (setq sharing nil) + (report-bad-arg sharing '(member nil :private :lock :external))))) + (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil))) + (when ioblock + (setf (ioblock-stream ioblock) stream) + ioblock)) + (stream-create-ioblock stream)))) + (when (eq sharing :private) + (setf (ioblock-owner ioblock) 0)) + (setf (ioblock-encoding ioblock) encoding) + (when insize + (unless (ioblock-inbuf ioblock) + (multiple-value-bind (buffer ptr in-size-in-octets) + (make-heap-ivector insize + (if character-p + '(unsigned-byte 8) + (setq element-type + (ensure-reasonable-element-type element-type)))) + (setf (ioblock-inbuf ioblock) + (make-io-buffer :buffer buffer + :bufptr ptr + :size in-size-in-octets + :limit insize)) + (when (eq sharing :lock) + (setf (ioblock-inbuf-lock ioblock) (make-lock))) + (setf (ioblock-line-termination ioblock) line-termination) + + (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ in-size-in-octets insize) 2)))) + ))) + (when (ioblock-inbuf ioblock) + (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination)) + (if share-buffers-p + (if insize + (progn (setf (ioblock-outbuf ioblock) + (ioblock-inbuf ioblock)) + (setf (ioblock-outbuf-lock ioblock) + (ioblock-inbuf-lock ioblock))) + (error "Can't share buffers unless insize is non-zero and non-null")) + (when outsize + (unless (ioblock-outbuf ioblock) + (multiple-value-bind (buffer ptr out-size-in-octets) + (make-heap-ivector outsize + (if character-p + '(unsigned-byte 8) + (setq element-type (ensure-reasonable-element-type element-type)))) + (setf (ioblock-outbuf ioblock) + (make-io-buffer :buffer buffer + :bufptr ptr + :count 0 + :limit outsize + :size out-size-in-octets)) + (when (eq sharing :lock) + (setf (ioblock-outbuf-lock ioblock) (make-lock))) + (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2)))) + )))) + (when (ioblock-outbuf ioblock) + (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination)) + (when element-type + (setf (ioblock-element-type ioblock) (if character-p 'character element-type))) +; (when element-shift +; (setf (ioblock-element-shift ioblock) element-shift)) + (when device + (setf (ioblock-device ioblock) device)) + (when advance-function + (setf (ioblock-advance-function ioblock) advance-function)) + (when listen-function + (setf (ioblock-listen-function ioblock) listen-function)) + (when eofp-function + (setf (ioblock-eofp-function ioblock) eofp-function)) + (when force-output-function + (setf (ioblock-force-output-function ioblock) force-output-function)) + (when close-function + (setf (ioblock-close-function ioblock) close-function)) + (when interactive + (setf (ioblock-interactive ioblock) interactive)) + (setf (stream-ioblock stream) ioblock) + (when encoding + (setf (ioblock-native-byte-order ioblock) + (character-encoding-native-endianness encoding))) + (let* ((bom-info (and insize encoding (character-encoding-use-byte-order-mark encoding)))) + (when bom-info + (ioblock-check-input-bom ioblock bom-info sharing))) + (setf (ioblock-input-timeout ioblock) input-timeout) + (setf (ioblock-output-timeout ioblock) output-timeout) + (setf (ioblock-deadline ioblock) deadline) + ioblock)) + +;;; If there's a byte-order-mark (or a reversed byte-order-mark) at +;;; the beginning of the input stream, deal with it. If there's any +;;; input present, make sure that we don't write a BOM on output. If +;;; this is a little-endian machine, input data was present, and there +;;; was no BOM in that data, make things big-endian. If there's a +;;; leading BOM or swapped BOM, eat it (consume it so that it doesn't +;;; ordinarily appear as input.) +;;; +(defun ioblock-check-input-bom (ioblock swapped-encoding-name sharing) + (let* ((n (%ioblock-advance ioblock nil))) ; try to read, don't block + (when n + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (let* ((inbuf (ioblock-inbuf ioblock)) + (unit-size (character-encoding-code-unit-size (ioblock-encoding ioblock))) + (min (ash unit-size -3)) + (buf (io-buffer-buffer inbuf)) + (swapped-encoding + (and + (>= n min) + (case (case unit-size + (16 (%native-u8-ref-u16 buf 0)) + (32 (%native-u8-ref-u32 buf 0))) + (#.byte-order-mark-char-code + (setf (io-buffer-idx inbuf) min) + nil) + (#.swapped-byte-order-mark-char-code + (setf (io-buffer-idx inbuf) min) + t) + (t #+little-endian-target t)) + (lookup-character-encoding swapped-encoding-name)))) + (when swapped-encoding + (let* ((output-p (not (null (ioblock-outbuf ioblock))))) + (setf (ioblock-native-byte-order ioblock) + (character-encoding-native-endianness swapped-encoding)) + (ecase unit-size + (16 + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-read-swapped-u16-encoded-char) + (:lock '%locked-ioblock-read-swapped-u16-encoded-char) + (t '%ioblock-read-swapped-u16-encoded-char))) + (32 + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-swapped-u32-encoded-char) + (case sharing + (:private '%private-ioblock-read-swapped-u32-encoded-char) + (:lock '%locked-ioblock-read-swapped-u32-encoded-char) + (t '%ioblock-read-swapped-u16-encoded-char)))) + (when output-p + (ecase unit-size + (16 + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-write-swapped-u16-encoded-char) + (:lock '%locked-ioblock-write-swapped-u16-encoded-char) + (t '%ioblock-write-swapped-u16-encoded-char)) + (setf (ioblock-write-simple-string-function ioblock) + '%ioblock-write-swapped-u16-encoded-simple-string)) + (32 + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-swapped-u32-encoded-char) + (case sharing + (:private '%private-ioblock-write-swapped-u32-encoded-char) + (:lock '%locked-ioblock-write-swapped-u32-encoded-char) + (t '%ioblock-write-swapped-u32-encoded-char)) + (setf (ioblock-write-simple-string-function ioblock) + '%ioblock-write-swapped-u32-encoded-simple-string)))))))))) + + + +;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses +;;; in MCL; of course, calling the structure-class's constructor does +;;; much the same thing (but note that MCL only keeps track of the +;;; default, automatically generated constructor.) +;;; (As fascinating as that may be, that has nothing to do with any +;;; nearby code, though it may have once been relevant.) +(defun make-ioblock-stream (class + &rest initargs + &key + &allow-other-keys) + (declare (dynamic-extent initargs)) + (let* ((s + (if (subtypep class 'basic-stream) + (apply #'make-basic-stream-instance class :allow-other-keys t initargs) + (apply #'make-instance class :allow-other-keys t initargs)))) + (apply #'init-stream-ioblock s initargs) + s)) + + + + + +(defmethod select-stream-class ((s symbol) in-p out-p char-p) + (select-stream-class (class-prototype (find-class s)) in-p out-p char-p)) + +(defmethod select-stream-class ((s structure-class) in-p out-p char-p) + (select-stream-class (class-prototype s) in-p out-p char-p)) + +(defmethod select-stream-class ((s standard-class) in-p out-p char-p) + (select-stream-class (class-prototype s) in-p out-p char-p)) + + +(defparameter *canonical-line-termination-conventions* + '((:unix . nil) + (:macos . :cr) + (:cr . :cr) + (:crlf . :crlf) + (:cp/m . :crlf) + (:msdos . :crlf) + (:dos . :crlf) + (:windows . :crlf) + (:inferred . nil) + (:unicode . :unicode))) + + +(defun optimal-buffer-size (fd element-type) + #+windows-target (declare (ignore fd)) + (let* (#-windows-target (nominal (or (nth-value 6 (%fstat fd)) *elements-per-buffer*)) + (octets #+windows-target #$BUFSIZ + #-windows-target + (case (%unix-fd-kind fd) + (:pipe (#_fpathconf fd #$_PC_PIPE_BUF)) + (:socket + #+linux-target nominal + #-linux-target + (int-getsockopt fd #$SOL_SOCKET + #+solaris-target #$SO_SNDBUF + #-solaris-target #$SO_SNDLOWAT)) + ((:character-special :tty) (#_fpathconf fd #$_PC_MAX_INPUT)) + (t nominal)))) + (case (subtag-bytes (element-type-subtype element-type) 1) + (1 octets) + (2 (ash octets -1)) + (4 (ash octets -2)) + (8 (ash octets -3))))) + + + + + +(defun milliseconds-until-deadline (deadline ioblock) + (let* ((now (get-internal-real-time))) + (if (> now deadline) + (error 'communication-deadline-expired :stream (ioblock-stream ioblock)) + (values (round (- deadline now) (/ internal-time-units-per-second 1000)))))) + + +;;; Note that we can get "bivalent" streams by specifiying :character-p t +;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8)) +(defun make-fd-stream (fd &key + (direction :input) + (interactive t) + (element-type 'character) + (class 'fd-stream) + (sharing :private) + (character-p (or (eq element-type 'character) + (subtypep element-type 'character))) + (basic nil) + encoding + line-termination + auto-close + input-timeout + output-timeout + deadline) + (let* ((elements-per-buffer (optimal-buffer-size fd element-type))) + (when line-termination + (setq line-termination + (cdr (assoc line-termination *canonical-line-termination-conventions*)))) + (when basic + (setq class (map-to-basic-stream-class-name class)) + (setq basic (subtypep (find-class class) 'basic-stream))) + (let* ((in-p (member direction '(:io :input))) + (out-p (member direction '(:io :output))) + (class-name (select-stream-class class in-p out-p character-p)) + (class (find-class class-name)) + (stream + (make-ioblock-stream class + :insize (if in-p elements-per-buffer) + :outsize (if out-p elements-per-buffer) + :device fd + :interactive interactive + :element-type element-type + :advance-function (if in-p + (select-stream-advance-function class direction)) + :listen-function (if in-p 'fd-stream-listen) + :eofp-function (if in-p 'fd-stream-eofp) + :force-output-function (if out-p + (select-stream-force-output-function class direction)) + :close-function 'fd-stream-close + :sharing sharing + :character-p character-p + :encoding encoding + :line-termination line-termination + :input-timeout input-timeout + :output-timeout output-timeout + :deadline deadline))) + (if auto-close + (terminate-when-unreachable stream + (lambda (stream) + (close-for-termination stream t)))) + stream))) + + +;;; Fundamental streams. + +(defclass fundamental-stream (stream) + ()) + +(defclass fundamental-input-stream (fundamental-stream input-stream) + ((shared-resource :initform nil :accessor input-stream-shared-resource))) + +(defclass fundamental-output-stream (fundamental-stream output-stream) + ()) + +(defmethod input-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod input-stream-p ((s input-stream)) + t) + +(defmethod output-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod output-stream-p ((s input-stream)) + (typep s 'output-stream)) + +(defmethod output-stream-p ((s output-stream)) + t) + +(defmethod input-stream-p ((s output-stream)) + (typep s 'input-stream)) + +(defclass binary-stream (stream) + ()) + +(defclass character-stream (stream) + ()) + +(defmethod stream-external-format ((s character-stream)) + (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix)) + + +(defmethod (setf stream-external-format) (new (s character-stream)) + (check-type new external-format) + (stream-external-format s)) + + +(defclass fundamental-character-stream (fundamental-stream character-stream) + ()) + +(defmethod stream-element-type ((s fundamental-character-stream)) + 'character) + +(defclass fundamental-binary-stream (fundamental-stream binary-stream) + ()) + +(defclass character-input-stream (input-stream character-stream) + ()) + +(defclass fundamental-character-input-stream (fundamental-input-stream + fundamental-character-stream + character-input-stream) + ()) + +(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream)) + (stream-read-char s)) + +(defmethod stream-peek-char ((s fundamental-character-input-stream)) + (let* ((ch (stream-read-char s))) + (unless (eq ch :eof) + (stream-unread-char s ch)) + ch)) + +(defmethod stream-listen ((s fundamental-character-input-stream)) + (let* ((ch (stream-read-char-no-hang s))) + (when (and ch (not (eq ch :eof))) + (stream-unread-char s ch)) + ch)) + +(defmethod stream-clear-input ((s fundamental-character-input-stream)) + ) + +(defmethod stream-read-line ((s character-input-stream)) + (generic-read-line s)) + +(defclass character-output-stream (output-stream character-stream) + ()) + +(defclass fundamental-character-output-stream (fundamental-output-stream + fundamental-character-stream + character-output-stream) + ()) + +(defclass binary-input-stream (input-stream binary-stream) + ()) + +(defclass fundamental-binary-input-stream (fundamental-input-stream + fundamental-binary-stream + binary-input-stream) + ()) + +(defclass binary-output-stream (output-stream binary-stream) + ()) + +(defclass fundamental-binary-output-stream (fundamental-output-stream + fundamental-binary-stream + binary-output-stream) + ()) + + + +(defmethod stream-read-byte ((s t)) + (report-bad-arg s '(and input-stream binary-stream))) + +(defmethod stream-write-byte ((s t) b) + (declare (ignore b)) + (report-bad-arg s '(and output-stream binary-stream))) + +(defmethod stream-length ((s stream) &optional new) + (declare (ignore new))) + +(defmethod stream-start-line-p ((s character-output-stream)) + (eql 0 (stream-line-column s))) + +(defmethod stream-terpri ((s character-output-stream)) + (stream-write-char s #\Newline)) + +(defmethod stream-fresh-line ((s character-output-stream)) + (unless (stream-start-line-p s) + (stream-terpri s) + t)) + +;;; The bad news is that this doesn't even bother to do the obvious +;;; (calling STREAM-WRITE-STRING with a longish string of spaces.) +;;; The good news is that this method is pretty useless to (format "~T" ...) +;;; anyhow. +(defmethod stream-advance-to-column ((s fundamental-character-output-stream) + col) + (generic-advance-to-column s col)) + +(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end) + (generic-stream-write-string stream string start end)) + + +;;; The read-/write-vector methods could be specialized for stream classes +;;; that expose the underlying buffering mechanism. +;;; They can assume that the 'vector' argument is a simple one-dimensional +;;; array and that the 'start' and 'end' arguments are sane. + +(defmethod stream-write-vector ((stream character-output-stream) + vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (write-char (uvref vector i) stream))) + +(defmethod stream-write-vector ((stream binary-output-stream) + vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (write-byte (uvref vector i) stream))) + +(defmethod stream-read-vector ((stream character-input-stream) + vector start end) + (generic-character-read-vector stream vector start end)) + + +(defmethod stream-read-vector ((stream binary-input-stream) + vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((b (read-byte stream nil :eof))) + (if (eq b :eof) + (return i) + (setf (uvref vector i) b))))) + + + + + +;;; File streams, in the abstract. + +(defclass file-stream (stream) + ()) + +(defmethod stream-domain ((s file-stream)) + :file) + + + + +;;; "Basic" (non-extensible) streams. + + +(declaim (inline basic-stream-p)) + +(defun basic-stream-p (x) + (= (the fixnum (typecode x)) target::subtag-basic-stream)) + +(setf (type-predicate 'basic-stream) 'basic-stream-p) + +(make-built-in-class 'basic-stream 'stream) +(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream) +(make-built-in-class 'basic-character-stream 'basic-stream 'character-stream) +(make-built-in-class 'basic-binary-stream 'basic-stream 'binary-stream) + +(make-built-in-class 'basic-input-stream 'basic-stream 'input-stream) +(make-built-in-class 'basic-output-stream 'basic-stream 'output-stream) +(make-built-in-class 'basic-io-stream 'basic-input-stream 'basic-output-stream) +(make-built-in-class 'basic-character-input-stream 'basic-input-stream 'basic-character-stream 'character-input-stream) +(make-built-in-class 'basic-character-output-stream 'basic-output-stream 'basic-character-stream 'character-output-stream) +(make-built-in-class 'basic-character-io-stream 'basic-character-input-stream 'basic-character-output-stream) +(make-built-in-class 'basic-binary-input-stream 'basic-input-stream 'basic-binary-stream 'binary-input-stream) +(make-built-in-class 'basic-binary-output-stream 'basic-output-stream 'basic-binary-stream 'binary-output-stream) +(make-built-in-class 'basic-binary-io-stream 'basic-binary-input-stream 'basic-binary-output-stream) + + +(defun %ioblock-external-format (ioblock) + (let* ((encoding (or (ioblock-encoding ioblock) + (get-character-encoding nil))) + (line-termination (or (ioblock-line-termination ioblock) + :unix))) + (make-external-format :character-encoding (character-encoding-name encoding) + :line-termination line-termination))) + +(defmethod input-stream-shared-resource ((s basic-input-stream)) + (getf (basic-stream.info s) :shared-resource)) + +(defmethod (setf input-stream-shared-resource) (new (s basic-input-stream)) + (setf (getf (basic-stream.info s) :shared-resource) new)) + +(defmethod print-object ((s basic-stream) out) + (print-unreadable-object (s out :type t :identity t) + (let* ((ioblock (basic-stream.state s)) + (fd (and ioblock (ioblock-device ioblock))) + (encoding (and ioblock (encoding-name (ioblock-encoding ioblock))))) + (if fd + (format out "~a (~a/~d)" encoding (%unix-fd-kind fd) fd) + (format out "~s" :closed))))) + +(defmethod select-stream-class ((s (eql 'basic-stream)) in-p out-p char-p) + (if char-p + (if in-p + (if out-p + 'basic-character-io-stream + 'basic-character-input-stream) + 'basic-character-output-stream) + (if in-p + (if out-p + 'basic-binary-io-stream + 'basic-binary-input-stream) + 'basic-binary-output-stream))) + + +(defmethod map-to-basic-stream-class-name (name) + name) + +(defmethod map-to-basic-stream-class-name ((name (eql 'fd-stream))) + 'basic-stream) + +(defun allocate-basic-stream (class) + (if (subtypep class 'basic-file-stream) + (gvector :basic-stream (%class-own-wrapper class) 0 nil nil nil nil nil) + (gvector :basic-stream (%class-own-wrapper class) 0 nil nil))) + + +(defmethod initialize-basic-stream ((s basic-stream) &key &allow-other-keys) + ) + +(defmethod initialize-basic-stream :after ((s basic-input-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-input) (basic-stream.flags s)))) + +(defmethod initialize-basic-stream :after ((s basic-output-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-output) (basic-stream.flags s)))) + +(defmethod initialize-basic-stream :after ((s basic-binary-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-binary) (basic-stream.flags s)))) + +(defmethod initialize-basic-stream :after ((s basic-character-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-character) (basic-stream.flags s)))) + +(defun make-basic-stream-instance (class &rest initargs) + (let* ((s (allocate-basic-stream class))) + (apply #'initialize-basic-stream s initargs) + s)) + + + +(defmethod (setf stream-ioblock) (ioblock (s basic-stream)) + (setf (basic-stream.state s) ioblock)) + +(defmethod stream-create-ioblock ((stream basic-stream) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-ioblock :stream stream args)) + + +(defmethod stream-write-list ((stream fundamental-character-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (stream-write-char stream (pop list)))) + +(defmethod stream-write-list ((stream basic-character-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (stream-write-char stream (pop list)))) + +(defmethod stream-read-list ((stream character-input-stream) + list count) + (generic-character-read-list stream list count)) + + +(defmethod stream-write-list ((stream fundamental-binary-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (let* ((element (pop list))) + (if (typep element 'character) + (write-char element stream) + (write-byte element stream))))) + +(defmethod stream-write-list ((stream basic-binary-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (let* ((element (pop list))) + (if (typep element 'character) + (write-char element stream) + (write-byte element stream))))) + +(defmethod stream-read-list ((stream binary-input-stream) + list count) + (declare (fixnum count)) + (do* ((tail list (cdr tail)) + (i 0 (1+ i))) + ((= i count) count) + (declare (fixnum i)) + (let* ((b (read-byte stream nil :eof))) + (if (eq b :eof) + (return i) + (rplaca tail b))))) + + + +(defun stream-is-closed (s) + (error "~s is closed" s)) + +(defmethod stream-read-char ((s basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (funcall (ioblock-read-char-function ioblock) ioblock))) + + +(defmethod stream-read-char-no-hang ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-tyi-no-hang ioblock))))) + +(defmethod stream-peek-char ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (funcall (ioblock-peek-char-function ioblock) ioblock))))) + +(defmethod stream-clear-input ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-clear-input ioblock))))) + +(defmethod stream-unread-char ((s basic-character-input-stream) char) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (values + (funcall (ioblock-unread-char-function ioblock) ioblock char))))) + +(defmethod stream-read-ivector ((s basic-binary-input-stream) + iv start nb) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-binary-in-ivect ioblock iv start nb))))) + +(defmethod stream-read-vector ((stream basic-character-input-stream) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (generic-character-read-vector stream vector start end) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (funcall (ioblock-character-read-vector-function ioblock) + ioblock vector start end)))))) + +(defmethod stream-read-line ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (funcall (ioblock-read-line-function ioblock) ioblock)))) + + +;;; Synonym streams. + +(defclass synonym-stream (fundamental-stream) + ((symbol :initarg :symbol :reader synonym-stream-symbol))) + +(defmethod print-object ((s synonym-stream) out) + (print-unreadable-object (s out :type t :identity t) + (format out "to ~s" (synonym-stream-symbol s)))) + +(macrolet ((synonym-method (name &rest args) + (let* ((stream (make-symbol "STREAM"))) + `(defmethod ,name ((,stream synonym-stream) ,@args) + (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args))))) + (synonym-method stream-read-char) + (synonym-method stream-read-byte) + (synonym-method stream-unread-char c) + (synonym-method stream-read-char-no-hang) + (synonym-method stream-peek-char) + (synonym-method stream-listen) + (synonym-method stream-eofp) + (synonym-method stream-clear-input) + (synonym-method stream-read-line) + (synonym-method stream-read-list l c) + (synonym-method stream-read-vector v start end) + (synonym-method stream-write-char c) + ;(synonym-method stream-write-string str &optional (start 0) end) + (synonym-method stream-write-byte b) + (synonym-method stream-clear-output) + (synonym-method stream-line-column) + (synonym-method stream-set-column new) + (synonym-method stream-advance-to-column new) + (synonym-method stream-start-line-p) + (synonym-method stream-fresh-line) + (synonym-method stream-terpri) + (synonym-method stream-force-output) + (synonym-method stream-finish-output) + (synonym-method stream-write-list l c) + (synonym-method stream-write-vector v start end) + (synonym-method stream-element-type) + (synonym-method input-stream-p) + (synonym-method output-stream-p) + (synonym-method interactive-stream-p) + (synonym-method stream-direction) + (synonym-method stream-device direction) + (synonym-method stream-surrounding-characters) + (synonym-method stream-input-timeout) + (synonym-method stream-output-timeout) + (synonym-method stream-deadline) + (synonym-method stream-eof-transient-p)) + +(defmethod (setf input-stream-timeout) (new (s synonym-stream)) + (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new)) + +(defmethod (setf output-stream-timeout) (new (s synonym-stream)) + (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new)) + + +(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end) + (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end)) + +(defmethod stream-length ((s synonym-stream) &optional new) + (stream-length (symbol-value (synonym-stream-symbol s)) new)) + +(defmethod stream-position ((s synonym-stream) &optional new) + (stream-position (symbol-value (synonym-stream-symbol s)) new)) + +(defun make-synonym-stream (symbol) + (make-instance 'synonym-stream :symbol (require-type symbol 'symbol))) + +;;; +(defclass composite-stream-mixin () + ((open-p :initform t))) + +(defmethod close :after ((stream composite-stream-mixin) &key abort) + (declare (ignore abort)) + (with-slots (open-p) stream + (setq open-p nil))) + +(defmethod open-stream-p ((stream composite-stream-mixin)) + (slot-value stream 'open-p)) + + + +;;; Two-way streams. +(defclass two-way-stream (composite-stream-mixin fundamental-input-stream fundamental-output-stream) + ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream) + (output-stream :initarg :output-stream :accessor two-way-stream-output-stream))) + +(defmethod stream-eof-transient-p ((stream two-way-stream)) + (stream-eof-transient-p (two-way-stream-input-stream stream))) + +(defmethod print-object ((s two-way-stream) out) + (print-unreadable-object (s out :type t :identity t) + (format out "input ~s, output ~s" + (two-way-stream-input-stream s) + (two-way-stream-output-stream s)))) + +(macrolet ((two-way-input-method (name &rest args) + (let* ((stream (make-symbol "STREAM"))) + `(defmethod ,name ((,stream two-way-stream) ,@args) + (,name (two-way-stream-input-stream ,stream) ,@args)))) + (two-way-output-method (name &rest args) + (let* ((stream (make-symbol "STREAM"))) + `(defmethod ,name ((,stream two-way-stream) ,@args) + (,name (two-way-stream-output-stream ,stream) ,@args))))) + (two-way-input-method stream-read-char) + (two-way-input-method stream-read-byte) + (two-way-input-method stream-unread-char c) + (two-way-input-method stream-read-char-no-hang) + (two-way-input-method stream-peek-char) + (two-way-input-method stream-listen) + (two-way-input-method stream-eofp) + (two-way-input-method stream-clear-input) + (two-way-input-method stream-read-line) + (two-way-input-method stream-read-list l c) + (two-way-input-method stream-read-vector v start end) + (two-way-input-method stream-surrounding-characters) + (two-way-input-method stream-input-timeout) + (two-way-input-method interactive-stream-p) + (two-way-output-method stream-write-char c) + (two-way-output-method stream-write-byte b) + (two-way-output-method stream-clear-output) + (two-way-output-method stream-line-column) + (two-way-output-method stream-set-column new) + (two-way-output-method stream-advance-to-column new) + (two-way-output-method stream-start-line-p) + (two-way-output-method stream-fresh-line) + (two-way-output-method stream-terpri) + (two-way-output-method stream-force-output) + (two-way-output-method stream-finish-output) + (two-way-output-method stream-write-list l c) + (two-way-output-method stream-write-vector v start end) + (two-way-output-method stream-output-timeout) + (two-way-output-method stream-deadline)) + +(defmethod (setf stream-input-timeout) (new (s two-way-stream)) + (setf (stream-input-timeout (two-way-stream-input-stream s)) new)) + +(defmethod (setf stream-output-timeout) (new (s two-way-stream)) + (setf (stream-output-timeout (two-way-stream-output-stream s)) new)) + +(defmethod (setf stream-deadline) (new (s two-way-stream)) + (setf (stream-deadline (two-way-stream-output-stream s)) new)) + +(defmethod stream-device ((s two-way-stream) direction) + (case direction + (:input (stream-device (two-way-stream-input-stream s) direction)) + (:output (stream-device (two-way-stream-output-stream s) direction)))) + +(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end) + (stream-write-string (two-way-stream-output-stream s) string start end)) + +(defmethod stream-element-type ((s two-way-stream)) + (let* ((in-type (stream-element-type (two-way-stream-input-stream s))) + (out-type (stream-element-type (two-way-stream-output-stream s)))) + (if (equal in-type out-type) + in-type + `(and ,in-type ,out-type)))) + +(defun make-two-way-stream (in out) + "Return a bidirectional stream which gets its input from INPUT-STREAM and + sends its output to OUTPUT-STREAM." + (unless (input-stream-p in) + (require-type in 'input-stream)) + (unless (output-stream-p out) + (require-type out 'output-stream)) + (make-instance 'two-way-stream :input-stream in :output-stream out)) + +;;; This is intended for use with things like *TERMINAL-IO*, where the +;;; OS echoes interactive input. Whenever we read a character from +;;; the underlying input-stream of such a stream, we need to update +;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN. + +(defclass echoing-two-way-stream (two-way-stream) + ()) + +(defmethod stream-read-char ((s echoing-two-way-stream)) + (let* ((out (two-way-stream-output-stream s)) + (in (two-way-stream-input-stream s))) + (force-output out) + (let* ((ch (stream-read-char in))) + (unless (eq ch :eof) + (if (eq ch #\newline) + (stream-set-column out 0) + (let* ((cur (stream-line-column out))) + (when cur + (stream-set-column out (1+ (the fixnum cur))))))) + ch))) + +(defmethod stream-read-line ((s echoing-two-way-stream)) + (let* ((out (two-way-stream-output-stream s))) + (multiple-value-bind (string eof) + (call-next-method) + (unless eof + (stream-set-column out 0)) + (values string eof)))) + +(defun make-echoing-two-way-stream (in out) + (make-instance 'echoing-two-way-stream :input-stream in :output-stream out)) + +;;;echo streams + +(defclass echo-stream (two-way-stream) + ((did-untyi :initform nil))) + +(defmethod echo-stream-input-stream ((s echo-stream)) + (two-way-stream-input-stream s)) + +(defmethod echo-stream-output-stream ((s echo-stream)) + (two-way-stream-output-stream s)) + +(defmethod stream-read-char ((s echo-stream)) + (let* ((char (stream-read-char (echo-stream-input-stream s)))) + (unless (eq char :eof) + (if (slot-value s 'did-untyi) + (setf (slot-value s 'did-untyi) nil) + (stream-write-char (echo-stream-output-stream s) char))) + char)) + +(defmethod stream-unread-char ((s echo-stream) c) + (call-next-method s c) + (setf (slot-value s 'did-untyi) c)) + +(defmethod stream-read-char-no-hang ((s echo-stream)) + (let* ((char (stream-read-char-no-hang (echo-stream-input-stream s)))) + (unless (eq char :eof) + (if (slot-value s 'did-untyi) + (setf (slot-value s 'did-untyi) nil) + (stream-write-char (echo-stream-output-stream s) char))) + char)) + +(defmethod stream-clear-input ((s echo-stream)) + (call-next-method) + (setf (slot-value s 'did-untyi) nil)) + +(defmethod stream-read-byte ((s echo-stream)) + (let* ((byte (stream-read-byte (echo-stream-input-stream s)))) + (unless (eq byte :eof) + (stream-write-byte (echo-stream-output-stream s) byte)) + byte)) + +(defmethod stream-read-line ((s echo-stream)) + (generic-read-line s)) + +(defmethod stream-read-vector ((s echo-stream) vector start end) + (if (subtypep (stream-element-type s) 'character) + (generic-character-read-vector s vector start end) + (generic-binary-read-vector s vector start end))) + +(defun make-echo-stream (input-stream output-stream) + "Return a bidirectional stream which gets its input from INPUT-STREAM and + sends its output to OUTPUT-STREAM. In addition, all input is echoed to + the output stream." + (make-instance 'echo-stream + :input-stream input-stream + :output-stream output-stream)) + +;;;concatenated-streams + +(defclass concatenated-stream (composite-stream-mixin fundamental-input-stream) + ((streams :initarg :streams :accessor concatenated-stream-streams))) + + +(defun concatenated-stream-current-input-stream (s) + (car (concatenated-stream-streams s))) + +(defun concatenated-stream-next-input-stream (s) + (setf (concatenated-stream-streams s) + (cdr (concatenated-stream-streams s))) + (concatenated-stream-current-input-stream s)) + +(defmethod stream-element-type ((s concatenated-stream)) + (let* ((c (concatenated-stream-current-input-stream s))) + (if c + (stream-element-type c) + nil))) + + + +(defmethod stream-read-char ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((ch (stream-read-char c))) + (unless (eq ch :eof) + (return ch))))) + +(defmethod stream-read-char-no-hang ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((ch (stream-read-char-no-hang c))) + (unless (eq ch :eof) + (return ch))))) + +(defmethod stream-read-byte ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((b (stream-read-byte c))) + (unless (eq b :eof) + (return b))))) + +(defmethod stream-peek-char ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((ch (stream-peek-char c))) + (unless (eq ch :eof) + (return ch))))) + +(defmethod stream-read-line ((s concatenated-stream)) + (generic-read-line s)) + +(defmethod stream-read-list ((s concatenated-stream) list count) + (generic-character-read-list s list count)) + +(defmethod stream-read-vector ((s concatenated-stream) vector start end) + (if (subtypep (stream-element-type s) 'character) + (generic-character-read-vector s vector start end) + (generic-binary-read-vector s vector start end))) + +(defmethod stream-unread-char ((s concatenated-stream) char) + (let* ((c (concatenated-stream-current-input-stream s))) + (if c + (stream-unread-char c char)))) + +(defmethod stream-listen ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c)) + (when (stream-listen c) + (return t)))) + +(defmethod stream-eofp ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) t) + (when (stream-listen c) + (return nil)))) + +(defmethod stream-clear-input ((s concatenated-stream)) + (let* ((c (concatenated-stream-current-input-stream s))) + (when c (stream-clear-input c)))) + + +(defun make-concatenated-stream (&rest streams) + "Return a stream which takes its input from each of the streams in turn, + going on to the next at EOF." + (dolist (s streams (make-instance 'concatenated-stream :streams streams)) + (unless (input-stream-p s) + (error "~S is not an input stream" s)))) + +;;;broadcast-streams + + + +(defclass broadcast-stream (fundamental-output-stream) + ((streams :initarg :streams :reader broadcast-stream-streams))) + +(macrolet ((broadcast-method + (op (stream &rest others ) + &optional + (args (cons stream others))) + (let* ((sub (gensym)) + (result (gensym))) + `(defmethod ,op ((,stream broadcast-stream) ,@others) + (let* ((,result nil)) + (dolist (,sub (broadcast-stream-streams ,stream) ,result) + (setq ,result (,op ,@(cons sub (cdr args)))))))))) + (broadcast-method stream-write-char (s c)) + (broadcast-method stream-write-string + (s str &optional (start 0) end) + (s str start end)) + (broadcast-method stream-write-byte (s b)) + (broadcast-method stream-clear-output (s)) + (broadcast-method stream-line-column (s)) + (broadcast-method stream-set-column (s new)) + (broadcast-method stream-advance-to-column (s new)) + (broadcast-method stream-start-line-p (s)) + (broadcast-method stream-terpri (s)) + (broadcast-method stream-force-output (s)) + (broadcast-method stream-finish-output (s)) + (broadcast-method stream-write-list (s l c)) + (broadcast-method stream-write-vector (s v start end))) + +(defun last-broadcast-stream (s) + (car (last (broadcast-stream-streams s)))) + +(defmethod stream-fresh-line ((s broadcast-stream)) + (let* ((did-output-newline nil)) + (dolist (sub (broadcast-stream-streams s) did-output-newline) + (setq did-output-newline (stream-fresh-line sub))))) + +(defmethod stream-element-type ((s broadcast-stream)) + (let* ((last (last-broadcast-stream s))) + (if last + (stream-element-type last) + t))) + +(defmethod stream-length ((s broadcast-stream) &optional new) + (unless new + (let* ((last (last-broadcast-stream s))) + (if last + (stream-length last) + 0)))) + +(defmethod stream-position ((s broadcast-stream) &optional new) + (unless new + (let* ((last (last-broadcast-stream s))) + (if last + (stream-position last) + 0)))) + +(defun make-broadcast-stream (&rest streams) + (dolist (s streams (make-instance 'broadcast-stream :streams streams)) + (unless (output-stream-p s) + (report-bad-arg s '(satisfies output-stream-p))))) + + + + +;;; String streams. +(make-built-in-class 'string-stream 'basic-character-stream) + +(defmethod print-object ((s string-stream) out) + (print-unreadable-object (s out :type t :identity t) + (unless (open-stream-p s) (format out " ~s" :closed)))) + + + + +(defstruct (string-stream-ioblock (:include ioblock)) + string) + +(defstruct (string-output-stream-ioblock (:include string-stream-ioblock)) + (index 0) + freelist + (line-length 80)) + +(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream)) +(defstatic *string-output-stream-class-wrapper* (%class-own-wrapper *string-output-stream-class*)) + +(defstatic *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream)) + +(def-standard-initial-binding %string-output-stream-ioblocks% (%cons-pool nil)) + +(defmethod stream-force-output ((s string-output-stream)) + nil) + +(defmethod stream-finish-output ((s string-output-stream)) + nil) + +(defmethod stream-clear-output ((s string-output-stream)) + nil) + +(defmethod stream-line-length ((s string-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (string-output-stream-ioblock-line-length ioblock))) + +(defmethod (setf stream-line-length) (newlen (s string-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (setf (string-output-stream-ioblock-line-length ioblock) newlen))) + + +;;; Should only be used for a stream whose class is exactly +;;; *string-output-stream-class* +(defun %close-string-output-stream (stream ioblock) + (let* ((pool %string-output-stream-ioblocks%)) + (when (and pool + (eq (basic-stream.wrapper stream) + *string-output-stream-class-wrapper*) + (eq (string-output-stream-ioblock-freelist ioblock) pool)) + (without-interrupts + (setf (ioblock-stream ioblock) (pool.data pool) + (pool.data pool) ioblock))))) + +;;; If this is the sort of string stream whose ioblock we recycle and +;;; there's a thread-local binding of the variable we use for a freelist, +;;; return the value of that binding. +(defun %string-stream-ioblock-freelist (stream) + (and stream + (eq (basic-stream.wrapper stream) + *string-output-stream-class-wrapper*) + (let* ((loc (%tcr-binding-location (%current-tcr) '%string-output-stream-ioblocks%))) + (and loc (%fixnum-ref loc))))) + + +(defun create-string-output-stream-ioblock (&rest keys &key stream &allow-other-keys) + (declare (dynamic-extent keys)) + (let* ((recycled (and stream + (eq (basic-stream.wrapper stream) + *string-output-stream-class-wrapper*) + (without-interrupts + (let* ((data (pool.data %string-output-stream-ioblocks%))) + (when data + (setf (pool.data %string-output-stream-ioblocks%) + (ioblock-stream data) + (ioblock-stream data) stream + (ioblock-device data) -1 + (ioblock-charpos data) 0 + (string-output-stream-ioblock-index data) 0 + (string-output-stream-ioblock-line-length data) 80)) + data))))) + (or recycled (apply #'make-string-output-stream-ioblock keys)))) + + + +(defun %%make-string-output-stream (class string write-char-function write-string-function) + (let* ((stream (allocate-basic-stream class))) + (initialize-basic-stream stream :element-type 'character) + (let* ((ioblock (create-string-output-stream-ioblock + :stream stream + :string string + :element-type 'character + :write-char-function write-char-function + :write-char-when-locked-function write-char-function + :write-simple-string-function write-string-function + :force-output-function #'false + :freelist (%string-stream-ioblock-freelist stream) + :close-function #'%close-string-output-stream))) + (setf (basic-stream.state stream) ioblock) + stream))) + +(declaim (inline %string-push-extend)) +(defun %string-push-extend (char string) + (let* ((fill (%svref string target::vectorH.logsize-cell)) + (size (%svref string target::vectorH.physsize-cell))) + (declare (fixnum fill size)) + (if (< fill size) + (multiple-value-bind (data offset) (array-data-and-offset string) + (declare (simple-string data) (fixnum offset)) + (setf (schar data (the fixnum (+ offset fill))) char + (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill)))) + (vector-push-extend char string)))) + + +(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char) + ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here. + (if (eql char #\Newline) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (%string-push-extend char (string-stream-ioblock-string ioblock))) + +(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (let* ((end (+ start-char num-chars)) + (nlpos (position #\Newline string :start start-char :end end :from-end t))) + (if nlpos + (setf (ioblock-charpos ioblock) (- end nlpos)) + (incf (ioblock-charpos ioblock) num-chars)) + (let* ((out (string-stream-ioblock-string ioblock))) + (do* ((n 0 (1+ n)) + (i start-char (1+ i))) + ((= n num-chars) num-chars) + (%string-push-extend (schar string i) out))))) + +(defmethod stream-position ((s fill-pointer-string-output-stream) &optional newpos) + (let* ((string (string-stream-string s))) + (if newpos + (setf (fill-pointer string) newpos) + (fill-pointer string)))) + +;;; If the stream's string is adjustable, it doesn't really have a meaningful +;;; "maximum size". +(defmethod stream-length ((s string-output-stream) &optional newlen) + (unless newlen + (array-total-size (string-stream-string s)))) + +;;; This creates a FILL-POINTER-STRING-OUTPUT-STREAM. +(defun %make-string-output-stream (string) + (unless (and (typep string 'string) + (array-has-fill-pointer-p string)) + (error "~S must be a string with a fill pointer." string)) + (%%make-string-output-stream *fill-pointer-string-output-stream-class* string 'fill-pointer-string-output-stream-ioblock-write-char 'fill-pointer-string-output-stream-ioblock-write-simple-string)) + +(defun string-output-stream-ioblock-write-char (ioblock char) + (let* ((string (string-output-stream-ioblock-string ioblock)) + (index (string-output-stream-ioblock-index ioblock)) + (len (length string))) + (declare (simple-string string) + (fixnum index len)) + (if (eql char #\Newline) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (if (= index len) + (let* ((newlen (if (zerop len) 20 (+ len len))) ;non-zero ! + (new (make-string newlen))) + (%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2))) + (setq string new) + (setf (string-output-stream-ioblock-string ioblock) new))) + (setf (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index)) + (schar string index) char))) + +(defun string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (declare (simple-string string) + (fixnum start-char num-chars) + (optimize (speed 3) (safety 0))) + (let* ((out (string-output-stream-ioblock-string ioblock)) + (index (string-output-stream-ioblock-index ioblock)) + (len (length out)) + (need (+ index num-chars))) + (declare (simple-string out) + (fixnum index len need)) + (if (< len need) + (let* ((newlen (+ need need)) + (new (make-string newlen))) + (declare (fixnum newlen) (simple-string new)) + (dotimes (i len) + (setf (schar new i) (schar out i))) + (setq out new) + (setf (string-output-stream-ioblock-string ioblock) new))) + (do* ((src start-char (1+ src)) + (dest index (1+ dest)) + (nlpos nil) + (end (+ start-char num-chars))) + ((= src end) + (setf (string-output-stream-ioblock-index ioblock) need) + (if nlpos + (setf (ioblock-charpos ioblock) (the fixnum (- end (the fixnum nlpos)))) + (incf (ioblock-charpos ioblock) num-chars)) + num-chars) + (declare (fixnum src dest end)) + (let* ((char (schar string src))) + (if (eql char #\Newline) + (setq nlpos (the fixnum (1+ src)))) + (setf (schar out dest) char))))) + + +(defmethod stream-position ((stream string-output-stream) &optional newpos) + (let* ((ioblock (basic-stream-ioblock stream))) + (if (null newpos) + (string-output-stream-ioblock-index ioblock) + (if (and (typep newpos 'fixnum) + (>= (the fixnum newpos) 0) + (<= (the fixnum newpos) (length (string-output-stream-ioblock-string ioblock)))) + (setf (string-output-stream-ioblock-index ioblock) newpos))))) + +(defun make-simple-string-output-stream () + ;; There's a good chance that we'll get a recycled ioblock + ;; that already has a string; if not, we defer actually + ;; creating a usable string until write-char + (%%make-string-output-stream *string-output-stream-class* + "" + 'string-output-stream-ioblock-write-char + 'string-output-stream-ioblock-write-simple-string)) + +(defun make-string-output-stream (&key (element-type 'character element-type-p)) + "Return an output stream which will accumulate all output given it for + the benefit of the function GET-OUTPUT-STREAM-STRING." + (when (and element-type-p + (not (member element-type '(base-character character + standard-char)))) + (unless (subtypep element-type 'character) + (error "~S argument ~S is not a subtype of ~S." + :element-type element-type 'character))) + (make-simple-string-output-stream)) + + +;;;"Bounded" string output streams. +(defstatic *truncating-string-output-stream-class* (make-built-in-class 'truncating-string-stream 'string-output-stream)) + +(defun truncating-string-output-stream-ioblock-write-char (ioblock char) + (let* ((stream (ioblock-stream ioblock)) + (string (string-output-stream-ioblock-string ioblock)) + (index (string-output-stream-ioblock-index ioblock))) + (declare (fixnum index) (simple-string string)) + (if (< index (the fixnum (length string))) + (progn + (setf (schar string index) char + (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index))) + (if (eql char #\Newline) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock)))) + (setf (getf (basic-stream.info stream) :truncated) t)))) + +(defun truncating-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (let* ((stream (ioblock-stream ioblock))) + (do* ((n 0 (1+ n)) + (i start-char (1+ i))) + ((= n num-chars) num-chars) + (truncating-string-output-stream-ioblock-write-char ioblock (schar string i)) + (if (getf (basic-stream.info stream) :truncated) + (return n))))) + +(defun truncating-string-output-stream-truncated-p (stream) + (getf (basic-stream.info stream) :truncated)) + +(defun make-truncating-string-stream (len) + (%%make-string-output-stream *truncating-string-output-stream-class* + (make-string len) + 'truncating-string-output-stream-ioblock-write-char + 'truncating-string-output-stream-ioblock-write-simple-string)) + + +;;;One way to indent on newlines: + +(defstatic *indenting-string-output-stream-class* (make-built-in-class 'indenting-string-output-stream 'string-output-stream)) +(defstatic *indenting-string-output-stream-class-wrapper* (%class-own-wrapper *indenting-string-output-stream-class*)) + + +(defun indenting-string-stream-ioblock-write-char (ioblock c) + (string-output-stream-ioblock-write-char ioblock c) + (if (eql c #\newline) + (let* ((stream (ioblock-stream ioblock)) + (info (basic-stream.info stream)) + (indent (getf info 'indent)) + (prefixlen 0) + (prefixchar (getf info 'prefixchar))) + (when prefixchar + (if (typep prefixchar 'character) + (progn + (setq prefixlen 1) + (string-output-stream-ioblock-write-char ioblock prefixchar)) + (dotimes (i (setq prefixlen (length prefixchar))) + (string-output-stream-ioblock-write-char ioblock (schar prefixchar i))))) + (when indent + (dotimes (i (the fixnum (- indent prefixlen))) + (string-output-stream-ioblock-write-char ioblock #\Space))))) + c) + +(defun indenting-string-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (do* ((n 0 (1+ n)) + (i start-char (1+ i))) + ((= n num-chars) num-chars) + (indenting-string-stream-ioblock-write-char ioblock (schar string i)))) + +(defun make-indenting-string-output-stream (prefixchar indent) + (let* ((stream (%%make-string-output-stream + *indenting-string-output-stream-class* + (make-string 10) + 'indenting-string-stream-ioblock-write-char + 'indenting-string-stream-ioblock-write-simple-string))) + (setf (getf (basic-stream.info stream) 'indent) indent + (getf (basic-stream.info stream) 'prefixchar) prefixchar) + stream)) + +(defun (setf indenting-string-output-stream-indent) (new stream) + (if (and (typep stream 'basic-stream) + (eq (basic-stream.wrapper stream) *indenting-string-output-stream-class-wrapper*)) + (setf (getf (basic-stream.info stream) 'indent) new) + (report-bad-arg stream 'indenting-string-output-stream))) + + +(defun get-output-stream-string (s) + (let* ((class (if (typep s 'basic-stream) (%wrapper-class (basic-stream.wrapper s))))) + (or (eq class *string-output-stream-class*) + (eq class *truncating-string-output-stream-class*) + (eq class *indenting-string-output-stream-class*) + (eq class *fill-pointer-string-output-stream-class*) + (report-bad-arg s 'string-output-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (string (string-stream-ioblock-string ioblock))) + (if (eq class *fill-pointer-string-output-stream-class*) + (prog1 (ensure-simple-string string) + (setf (fill-pointer string) 0)) + (let* ((index (string-output-stream-ioblock-index ioblock)) + (result (make-string index))) + (declare (fixnum index)) + (%copy-ivector-to-ivector string 0 result 0 (the fixnum (ash index 2))) + (setf (string-output-stream-ioblock-index ioblock) 0) + result))))) + +;;; String input streams. +(defstatic *string-input-stream-class* (make-built-in-class 'string-input-stream 'string-stream 'basic-character-input-stream)) +(defstatic *string-input-stream-class-wrapper* (%class-own-wrapper *string-input-stream-class*)) +(defstruct (string-input-stream-ioblock (:include string-stream-ioblock)) + (start 0) + index + end + (offset 0)) + + + +(defun string-input-stream-index (s) + (if (and (typep s 'basic-stream) + (eq *string-input-stream-class-wrapper* (basic-stream.wrapper s))) + (let* ((ioblock (basic-stream-ioblock s))) + (- (string-input-stream-ioblock-index ioblock) + (string-input-stream-ioblock-offset ioblock))) + (report-bad-arg s 'string-input-stream))) + + +(defmethod stream-surrounding-characters ((s string-input-stream)) + (let* ((ioblock (basic-stream.state s))) + (when ioblock + (let* ((start (string-input-stream-ioblock-start ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock)) + (string (string-stream-ioblock-string ioblock))) + (subseq string (max (- idx 10) start) (min (+ idx 10) end)))))) + + +(defmethod stream-position ((s string-input-stream) &optional newpos) + (let* ((ioblock (basic-stream-ioblock s)) + (start (string-input-stream-ioblock-start ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum end idx start)) + (if newpos + (let* ((limit (- end start))) + (declare (fixnum limit)) + (if (and (typep newpos 'fixnum) + (>= (the fixnum newpos) 0) + (<= (the fixnum newpos) limit)) + (progn + (setf (string-input-stream-ioblock-index ioblock) + (the fixnum (+ start (the fixnum newpos)))) + newpos) + (report-bad-arg newpos `(integer 0 ,limit)))) + (the fixnum (- idx start))))) + + + +(defun string-input-stream-ioblock-read-char (ioblock) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end) + (simple-string string)) + (if (< idx end) + (progn (setf (string-input-stream-ioblock-index ioblock) + (the fixnum (1+ idx))) + (schar string idx)) + :eof))) + +(defun string-input-stream-ioblock-read-line (ioblock) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end) + (simple-string string)) + (if (>= idx end) + (values "" t) + (let* ((pos (position #\Newline string :start idx :end end))) + (if pos + (locally (declare (type index pos)) + (let* ((new (make-string (the fixnum (- pos idx))))) + (declare (simple-base-string new)) + (setf (string-input-stream-ioblock-index ioblock) + (the fixnum (1+ pos))) + (do* ((src idx (1+ src)) + (dest 0 (1+ dest))) + ((= src pos) (values new nil)) + (declare (fixnum src dest)) + (setf (schar new dest) (schar string src))))) + (let* ((new (make-string (the fixnum (- end idx))))) + (declare (simple-base-string new)) + (setf (string-input-stream-ioblock-index ioblock) end) + (do* ((src idx (1+ src)) + (dest 0 (1+ dest))) + ((= src end) (values new t)) + (declare (fixnum src dest)) + (setf (schar new dest) (schar string src))))))))) + + +(defun string-input-stream-ioblock-peek-char (ioblock) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end) + (simple-string string)) + (if (< idx end) + (schar string idx) + :eof))) + +(defun string-input-stream-ioblock-unread-char (ioblock char) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (start (string-input-stream-ioblock-start ioblock))) + (declare (fixnum idx start) + (simple-string string)) + (unless (> idx start) + (error "Nothing has been read from ~s yet." (ioblock-stream ioblock))) + (decf idx) + (unless (eq char (schar string idx)) + (error "~a was not the last character read from ~s" char (ioblock-stream ioblock))) + (setf (string-input-stream-ioblock-index ioblock) idx) + char)) + + +(defmethod stream-eofp ((s string-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end)) + (>= idx end))) + +(defmethod stream-listen ((s string-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end)) + (< idx end))) + +(defmethod stream-clear-input ((s string-input-stream)) + (basic-stream-ioblock s) + nil) + +(defun string-input-stream-character-read-vector (ioblock vector start end) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (limit (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx limit)) + (do* ((i start (1+ i))) + ((= i end) (setf (string-input-stream-ioblock-index ioblock) idx) end) + (declare (fixnum i)) + (if (< idx limit) + (setf (uvref vector i) (schar string idx) + idx (1+ idx)) + (progn + (setf (string-input-stream-ioblock-index ioblock) idx) + (return i)))))) + + + +(defun make-string-input-stream (string &optional (start 0) + (end nil)) + "Return an input stream which will supply the characters of STRING between + START and END in order." + (setq end (check-sequence-bounds string start end)) + (multiple-value-bind (data offset) (array-data-and-offset string) + (unless (typep data 'simple-base-string) + (report-bad-arg string 'string)) + (incf start offset) + (incf end offset) + (let* ((stream (make-basic-stream-instance + *string-input-stream-class* + :element-type 'character)) + (ioblock (make-string-input-stream-ioblock + :stream stream + :offset offset + :string data + :start start + :index start + :end end + :read-char-function 'string-input-stream-ioblock-read-char + :read-char-when-locked-function 'string-input-stream-ioblock-read-char + :peek-char-function 'string-input-stream-ioblock-peek-char + :character-read-vector-function 'string-input-stream-character-read-vector + :close-function #'false + :unread-char-function 'string-input-stream-ioblock-unread-char + :read-line-function 'string-input-stream-ioblock-read-line + ))) + (setf (basic-stream.state stream) ioblock) + stream))) + +(defun string-stream-string (s) + (let* ((class (if (typep s 'basic-stream) (%wrapper-class (basic-stream.wrapper s))))) + (or (eq class *string-output-stream-class*) + (eq class *truncating-string-output-stream-class*) + (eq class *indenting-string-output-stream-class*) + (report-bad-arg s 'string-output-stream))) + (string-stream-ioblock-string (basic-stream-ioblock s))) + + + + +;;; A mixin to be used with FUNDAMENTAL-STREAMs that want to use ioblocks +;;; to buffer I/O. + +(defclass buffered-stream-mixin () + ((ioblock :reader %stream-ioblock :writer (setf stream-ioblock) :initform nil))) + +(defmethod open-stream-p ((s buffered-stream-mixin)) + (with-slots (ioblock) s + (not (null ioblock)))) + +(declaim (inline stream-ioblock)) + +(defun stream-ioblock (stream error-if-nil) + (or (if (typep stream 'basic-stream) + (basic-stream.state stream) + (%stream-ioblock stream)) + (when error-if-nil + (stream-is-closed stream)))) + +(defmethod stream-device ((s buffered-stream-mixin) direction) + (declare (ignore direction)) + (let* ((ioblock (stream-ioblock s nil))) + (and ioblock (ioblock-device ioblock)))) + +(defmethod stream-device ((s basic-stream) direction) + (declare (ignore direction)) + (let* ((ioblock (basic-stream.state s))) + (and ioblock (ioblock-device ioblock)))) + +(defmethod stream-element-type ((s buffered-stream-mixin)) + (ioblock-element-type (stream-ioblock s t))) + +(defmethod stream-element-type ((s basic-stream)) + (ioblock-element-type (basic-stream-ioblock s))) + + +(defmethod stream-create-ioblock ((stream buffered-stream-mixin) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-ioblock :stream stream args)) + +(defmethod stream-owner ((stream stream)) + ) + +(defmethod stream-owner ((stream buffered-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (let* ((owner (ioblock-owner ioblock))) + (unless (eql owner 0) owner))))) + +(defmethod stream-owner ((stream basic-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (let* ((owner (ioblock-owner ioblock))) + (unless (eql owner 0) owner))))) + + +(defclass buffered-input-stream-mixin + (buffered-stream-mixin fundamental-input-stream) + ()) + +(defclass buffered-output-stream-mixin + (buffered-stream-mixin fundamental-output-stream) + ()) + +(defclass buffered-io-stream-mixin + (buffered-input-stream-mixin buffered-output-stream-mixin) + ()) + +(defclass buffered-character-input-stream-mixin + (buffered-input-stream-mixin fundamental-character-input-stream) + ()) + +(defclass buffered-character-output-stream-mixin + (buffered-output-stream-mixin fundamental-character-output-stream) + ()) + +(defclass buffered-character-io-stream-mixin + (buffered-character-input-stream-mixin buffered-character-output-stream-mixin) + ()) + +(defclass buffered-binary-input-stream-mixin + (buffered-input-stream-mixin fundamental-binary-input-stream) + ()) + +(defclass buffered-binary-output-stream-mixin + (buffered-output-stream-mixin fundamental-binary-output-stream) + ()) + +(defclass buffered-binary-io-stream-mixin + (buffered-binary-input-stream-mixin + buffered-binary-output-stream-mixin) + ()) + +(defmethod close :after ((stream buffered-stream-mixin) &key abort) + (declare (ignore abort)) + (let* ((ioblock (stream-ioblock stream nil))) + (when ioblock + (%ioblock-close ioblock)))) + +(defmethod close :before ((stream buffered-output-stream-mixin) &key abort) + (unless abort + (when (open-stream-p stream) + (stream-force-output stream)))) + +(defmethod close-for-termination ((stream buffered-output-stream-mixin) abort) + ;; This method should only be invoked via the termination mechanism, + ;; so it can safely assume that there's no contention for the stream. + (let* ((ioblock (stream-ioblock stream nil))) + (when ioblock (setf (ioblock-owner ioblock) nil))) + (close stream :abort abort)) + + +(defmethod interactive-stream-p ((stream buffered-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (ioblock-interactive ioblock)))) + +(defmethod interactive-stream-p ((stream basic-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (ioblock-interactive ioblock)))) + + +(defmethod close :after ((stream basic-stream) &key abort) + (declare (ignore abort)) + (let* ((ioblock (basic-stream.state stream))) + (when ioblock + (%ioblock-close ioblock)))) + +(defmethod close-for-termination ((stream basic-stream) abort) + (let* ((ioblock (basic-stream.state stream))) + (when ioblock (setf (ioblock-owner ioblock) nil))) + (close stream :abort abort)) + + + +(defmethod open-stream-p ((stream basic-stream)) + (not (null (basic-stream.state stream)))) + +(defmethod close :before ((stream basic-output-stream) &key abort) + (unless abort + (when (open-stream-p stream) + (stream-force-output stream)))) + +(defmethod stream-surrounding-characters ((stream buffered-character-input-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (%ioblock-surrounding-characters ioblock)))) + +(defmethod stream-surrounding-characters ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (%ioblock-surrounding-characters ioblock)))) + + +#| +(defgeneric ioblock-advance (stream ioblock readp) + (:documentation + "Called when the current input buffer is empty (or non-existent). + readp true means the caller expects to return a byte now. + Return value is meaningless unless readp is true, in which case + it means that there is input ready")) + +(defgeneric ioblock-listen (stream ioblock) + (:documentation + "Called in response to stream-listen when the current + input buffer is empty. + Returns a boolean")) + +(defgeneric ioblock-eofp (stream ioblock) + (:documentation + "Called in response to stream-eofp when the input buffer is empty. + Returns a boolean.")) + +(defgeneric ioblock-force-output (stream ioblock count finish-p) + (:documentation + "Called in response to stream-force-output. + Write count bytes from ioblock-outbuf. + Finish the I/O if finish-p is true.")) + +(defgeneric ioblock-close (stream ioblock) + (:documentation + "May free some resources associated with the ioblock.")) +|# + +(defmethod ioblock-close ((stream buffered-stream-mixin) ioblock) + (declare (ignore ioblock))) + +(defmethod ioblock-force-output ((stream buffered-output-stream-mixin) + ioblock + count + finish-p) + (declare (ignore ioblock count finish-p))) + + + + +(defmethod stream-read-char ((stream buffered-character-input-stream-mixin)) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-read-char-function ioblock) ioblock))) + +(defmethod stream-read-char-no-hang ((stream buffered-character-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (%ioblock-tyi-no-hang ioblock))) + +(defmethod stream-peek-char ((stream buffered-character-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-peek-char ioblock)))) + +(defmethod stream-clear-input ((stream buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-clear-input ioblock)))) + +(defmethod stream-unread-char ((stream buffered-character-input-stream-mixin) char) + (with-stream-ioblock-input (ioblock stream :speedy t) + (funcall (ioblock-unread-char-function ioblock) ioblock char)) + char) + +(defmethod stream-read-byte ((stream buffered-binary-input-stream-mixin)) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-read-byte-function ioblock) ioblock))) + +(defmethod stream-read-byte ((stream basic-binary-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-read-byte-function ioblock) ioblock))) + +(defmethod stream-eofp ((stream buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-eofp ioblock)))) + +(defmethod stream-eofp ((stream basic-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (%ioblock-eofp ioblock)))) + +(defmethod stream-listen ((stream buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-listen ioblock)))) + +(defmethod stream-listen ((stream basic-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-listen ioblock))))) + + +(defmethod stream-write-byte ((stream buffered-binary-output-stream-mixin) + byte) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-write-byte-function ioblock) ioblock byte))) + +(defmethod stream-write-byte ((stream basic-binary-output-stream) byte) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-byte-function ioblock) ioblock byte))) + +(defmethod stream-write-char ((stream buffered-character-output-stream-mixin) char) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-write-char-function ioblock) ioblock char))) + +(defmethod stream-write-char ((stream basic-character-output-stream) char) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-char-function ioblock) ioblock char))) + + +(defmethod stream-clear-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-clear-output ioblock)) + nil) + +(defmethod stream-clear-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-clear-output ioblock)) + nil)) + +(defmethod stream-line-column ((stream buffered-character-output-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (ioblock-charpos ioblock)))) + +(defmethod stream-line-column ((stream basic-character-output-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (ioblock-charpos ioblock)))) + + + +(defmethod stream-set-column ((stream buffered-character-output-stream-mixin) + new) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (setf (ioblock-charpos ioblock) new)))) + +(defmethod stream-set-column ((stream basic-character-output-stream) + new) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (setf (ioblock-charpos ioblock) new)))) + +(defmethod stream-force-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-force-output ioblock nil) + nil)) + +(defmethod stream-force-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-force-output ioblock nil) + nil))) + +(defmethod maybe-stream-force-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output-maybe (ioblock stream :speedy t) + (%ioblock-force-output ioblock nil) + nil)) + +(defmethod maybe-stream-force-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked-maybe (ioblock) + (%ioblock-force-output ioblock nil) + nil))) + +(defmethod stream-finish-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-force-output ioblock t) + nil)) + +(defmethod stream-finish-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-force-output ioblock t) + nil))) + + + +(defmethod stream-write-string ((stream buffered-character-output-stream-mixin) + string &optional (start 0 start-p) end) + + (with-stream-ioblock-output (ioblock stream :speedy t) + (if (and (typep string 'simple-string) + (not start-p)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string)) + (progn + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (arr offset) + (if (typep string 'simple-string) + (values string 0) + (array-data-and-offset (require-type string 'string))) + (unless (eql 0 offset) + (incf start offset) + (incf end offset)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock arr start (the fixnum (- end start)))))))) + string) + +(defmethod stream-write-string ((stream basic-character-output-stream) + string &optional (start 0 start-p) end) + + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (if (and (typep string 'simple-string) + (not start-p)) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string))) + (progn + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (arr offset) + (if (typep string 'simple-string) + (values string 0) + (array-data-and-offset (require-type string 'string))) + (unless (eql 0 offset) + (incf start offset) + (incf end offset)) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock arr start (the fixnum (- end start)))))))))) + string) + + +(defmethod stream-write-ivector ((s buffered-output-stream-mixin) + iv start length) + (with-stream-ioblock-output (ioblock s :speedy t) + (values + (%ioblock-out-ivect ioblock iv start length)))) + +(defmethod stream-write-ivector ((s basic-output-stream) + iv start length) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (values + (%ioblock-out-ivect ioblock iv start length))))) + + +#+bad-idea +(defmethod stream-read-ivector ((s buffered-character-input-stream-mixin) + iv start nb) + (with-stream-ioblock-input (ioblock s :speedy t) + (values + (%ioblock-character-in-ivect ioblock iv start nb)))) + +(defmethod stream-read-ivector ((s buffered-binary-input-stream-mixin) + iv start nb) + (with-stream-ioblock-input (ioblock s :speedy t) + (values + (%ioblock-binary-in-ivect ioblock iv start nb)))) + + +(defmethod stream-write-vector ((stream buffered-character-output-stream-mixin) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (call-next-method) + (with-stream-ioblock-output (ioblock stream :speedy t) + (let* ((total (- end start))) + (declare (fixnum total)) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock vector start total)))))) + +(defmethod stream-write-vector ((stream basic-character-output-stream) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (call-next-method) + (let* ((ioblock (basic-stream-ioblock stream)) + (total (- end start))) + (declare (fixnum total)) + (with-ioblock-output-locked (ioblock) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock vector start total)))))) + +;;; bivalence: we don't actually have a "bivalent stream" class; +;;; all actual (potentially) bivalent streams (sockets) include binary streams +;;; before character streams in their CPLs. That effectively means that +;;; binary-stream methods for reading and writing sequences have to +;;; handle character I/O in some cases. That may slow some things down +;;; (at least in theory), but the case where the stream's element-type +;;; matches the sequence's element-type isn't affected. +(defun %ioblock-binary-stream-write-vector (ioblock vector start end) + (declare (fixnum start end)) + (let* ((out (ioblock-outbuf ioblock)) + (buf (io-buffer-buffer out)) + (written 0) + (limit (io-buffer-limit out)) + (total (- end start)) + (buftype (typecode buf))) + (declare (fixnum buftype written total limit)) + (if (not (= (the fixnum (typecode vector)) buftype)) + (if (typep vector 'string) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock + vector + start + (- end start)) + (do* ((i start (1+ i)) + (wbf (ioblock-write-byte-when-locked-function ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock))) + ((= i end)) + (let ((byte (uvref vector i))) + (if (characterp byte) + (funcall wcf ioblock byte) + (funcall wbf ioblock byte))))) + (do* ((pos start (+ pos written)) + (left total (- left written))) + ((= left 0)) + (declare (fixnum pos left)) + (setf (ioblock-dirty ioblock) t) + (let* ((index (io-buffer-idx out)) + (count (io-buffer-count out)) + (avail (- limit index))) + (declare (fixnum index avail count)) + (cond + ((= (setq written avail) 0) + (%ioblock-force-output ioblock nil)) + (t + (if (> written left) + (setq written left)) + (%copy-ivector-to-ivector + vector + (ioblock-elements-to-octets ioblock pos) + buf + (ioblock-elements-to-octets ioblock index) + (ioblock-elements-to-octets ioblock written)) + (setf (ioblock-dirty ioblock) t) + (incf index written) + (if (> index count) + (setf (io-buffer-count out) index)) + (setf (io-buffer-idx out) index) + (if (= index limit) + (%ioblock-force-output ioblock nil))))))))) + +(defmethod stream-write-vector ((stream buffered-binary-output-stream-mixin) + vector start end) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-binary-stream-write-vector ioblock vector start end))) + + +(defmethod stream-write-vector ((stream basic-binary-output-stream) + vector start end) + (declare (fixnum start end)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-binary-stream-write-vector ioblock vector start end)))) + + + +(defmethod stream-read-vector ((stream basic-binary-input-stream) + vector start end) + (declare (fixnum start end)) + (if (typep vector 'simple-base-string) + (call-next-method) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-binary-read-vector ioblock vector start end)))))) + +(defmethod stream-read-vector ((stream buffered-character-input-stream-mixin) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (call-next-method) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (funcall (ioblock-character-read-vector-function ioblock) + ioblock vector start end))))) + + + +(defmethod stream-read-vector ((stream buffered-binary-input-stream-mixin) + vector start end) + (declare (fixnum start end)) + (if (typep vector 'simple-base-string) + (call-next-method) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-binary-read-vector ioblock vector start end))))) + + + +(defloadvar *fd-set-size* + (ff-call (%kernel-import target::kernel-import-fd-setsize-bytes) + :unsigned-fullword)) + +(defun unread-data-available-p (fd) + #+(or freebsd-target windows-target) + (fd-input-available-p fd 0) + #-(or freebsd-target windows-target) + (rlet ((arg (* :char) (%null-ptr))) + (when (zerop (int-errno-call (#_ioctl fd #$FIONREAD :address arg))) + (let* ((avail (pref arg :long))) + (and (> avail 0) avail))))) + +;;; Read and discard any available unread input. +(defun %fd-drain-input (fd) + (%stack-block ((buf 1024)) + (do* ((avail (unread-data-available-p fd) (unread-data-available-p fd))) + ((or (null avail) (eql avail 0))) + (do* ((max (min avail 1024) (min avail 1024))) + ((zerop avail)) + (let* ((count (fd-read fd buf max))) + (if (< count 0) + (return) + (decf avail count))))))) + +(defun fd-zero (fdset) + (ff-call (%kernel-import target::kernel-import-do-fd-zero) + :address fdset + :void)) + +(defun fd-set (fd fdset) + (ff-call (%kernel-import target::kernel-import-do-fd-set) + :unsigned-fullword fd + :address fdset + :void)) + +(defun fd-clr (fd fdset) + (ff-call (%kernel-import target::kernel-import-do-fd-clr) + :unsigned-fullword fd + :address fdset + :void)) + +(defun fd-is-set (fd fdset) + (not (= 0 (the fixnum (ff-call (%kernel-import target::kernel-import-do-fd-is-set) + :unsigned-fullword fd + :address fdset + :unsigned-fullword))))) + +(defun process-input-would-block (fd) + #+windows-target (declare (ignore fd)) + #+windows-target t + #-windows-target + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-input-wait fd) + (- #$ETIMEDOUT))) + +(defun process-input-wait (fd &optional timeout) + "Wait until input is available on a given file-descriptor." + (rlet ((now :timeval)) + (let* ((wait-end + (when timeout + (gettimeofday now) + (+ (timeval->milliseconds now) timeout)))) + (loop + (multiple-value-bind (win error) + (fd-input-available-p fd (or timeout -1)) + (when win + (return (values t nil nil))) + (when (eql error 0) ;timed out + (return (values nil t nil))) + ;; If it returned and a timeout was specified, check + ;; to see if it's been exceeded. If so, return NIL; + ;; otherwise, adjust the remaining timeout. + ;; If there was no timeout, continue to wait forever. + (unless (eql error (- #$EINTR)) + (return (values nil nil error))) + (when timeout + (gettimeofday now) + (setq timeout (- wait-end (timeval->milliseconds now))) + (if (<= timeout 0) + (return (values nil t nil))))))))) + + +(defun process-output-would-block (fd) + #+windows-target (declare (ignore fd)) + #+windows-target t + #-windows-target + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-output-wait fd) + (- #$ETIMEDOUT))) + +(defun process-output-wait (fd &optional timeout) + "Wait until output is possible on a given file descriptor." + (rlet ((now :timeval)) + (let* ((wait-end + (when timeout + (gettimeofday now) + (+ (timeval->milliseconds now) timeout)))) + (loop + (multiple-value-bind (win error) + (fd-ready-for-output-p fd (or timeout -1)) + (when win + (return (values t nil nil))) + (when (eql error 0) + (return (values nil t nil))) + (unless (eql error (- #$EINTR)) + (return (values nil nil error))) + ;; If it returned and a timeout was specified, check + ;; to see if it's been exceeded. If so, return NIL; + ;; otherwise, adjust the remaining timeout. + ;; If there was no timeout, continue to wait forever. + (when timeout + (gettimeofday now) + (setq timeout (- wait-end (timeval->milliseconds now))) + (if (<= timeout 0) + (return (values nil t nil))))))))) + + + +(defun ticks-to-timeval (ticks tv) + (when ticks + (let* ((total-us (* ticks (/ 1000000 *ticks-per-second*)))) + (multiple-value-bind (seconds us) (floor total-us 1000000) + (setf (pref tv :timeval.tv_sec) seconds + (pref tv :timeval.tv_usec) us))))) + +(defun fd-input-available-p (fd &optional milliseconds) + #+windows-target + (case (%unix-fd-kind fd) + (:socket + (rlet ((infds #>fd_set) + (tv :timeval :tv_sec 0 :tv_usec 0)) + (fd-zero infds) + (fd-set fd infds) + (when milliseconds + (multiple-value-bind (seconds millis) + (floor milliseconds 1000) + (setf (pref tv :timeval.tv_sec) seconds + (pref tv :timeval.tv_usec) (* 1000 millis)))) + (let* ((result (#_select 1 infds (%null-ptr) (%null-ptr) (if milliseconds tv (%null-ptr))))) + (cond ((> result 0) (values t 0)) + ((= result 0) (values nil 0)) + (t (values nil (- (#_GetLastError)))))))) + (:pipe (if (data-available-on-pipe-p fd) + (values t 0) + (if (and milliseconds (> milliseconds 0)) + (values (process-wait-with-timeout "input-wait" milliseconds #'data-available-on-pipe-p fd) 0) + (values nil 0)))) + (:file (let* ((curpos (fd-tell fd)) + (eofpos (%stack-block ((peofpos 8)) + (#_GetFileSizeEx (%int-to-ptr fd) peofpos) + (%%get-unsigned-longlong peofpos 0)))) + (values (< curpos eofpos) 0))) + ;;(:character-special (windows-tty-input-available-p fd milliseconds)) + + (t (values nil 0))) + #-windows-target + (rlet ((pollfds (:array (:struct :pollfd) 1))) + (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd + (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLIN) + (let* ((res (int-errno-call (#_poll pollfds 1 (or milliseconds -1))))) + (declare (fixnum res)) + (values (> res 0) res)))) + + +(defun fd-ready-for-output-p (fd &optional milliseconds) + #+windows-target + (case (%unix-fd-kind fd) + (:socket + (rlet ((tv :timeval :tv_sec 0 :tv_usec 0) + (outfds :fd_set)) + (fd-zero outfds) + (fd-set fd outfds) + (when milliseconds + (multiple-value-bind (seconds millis) + (floor milliseconds 1000) + (setf (pref tv #>timeval.tv_sec) seconds + (pref tv #>timeval.tv_usec) (* millis 1000)))) + (let* ((res (#_select 1 (%null-ptr) outfds (%null-ptr) (if milliseconds tv (%null-ptr))))) + (cond ((> res 0) (values t 0)) + ((= res 0) (values nil 0)) + (t (values 0 (- (#_GetLastError)))))))) + (t (values t 0))) + #-windows-target + (rlet ((pollfds (:array (:struct :pollfd) 1))) + (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd + (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLOUT) + (let* ((res (int-errno-call (#_poll pollfds 1 (or milliseconds -1))))) + (declare (fixnum res)) + (values (> res 0) res)))) + + + +;;; FD-streams, built on top of the ioblock mechanism. +(defclass fd-stream (buffered-stream-mixin fundamental-stream) ()) + + +(defmethod select-stream-advance-function ((s symbol) direction) + (select-stream-advance-function (find-class s) direction)) + +(defmethod select-stream-advance-function ((c class) direction) + (select-stream-advance-function (class-prototype c) direction)) + +(defmethod select-stream-advance-function ((s fd-stream) (direction t)) + 'fd-stream-advance) + +(defmethod select-stream-advance-function ((s basic-stream) (direction t)) + 'fd-stream-advance) + + +(defmethod select-stream-force-output-function ((s symbol) direction) + (select-stream-force-output-function (find-class s) direction)) + +(defmethod select-stream-force-output-function ((c class) direction) + (select-stream-force-output-function (class-prototype c) direction)) + +(defmethod select-stream-force-output-function ((f fd-stream) (direction t)) + 'fd-stream-force-output) + +(defmethod select-stream-force-output-function ((f basic-stream) (direction t)) + 'fd-stream-force-output) + +(defmethod print-object ((s fd-stream) out) + (print-unreadable-object (s out :type t :identity t) + (let* ((ioblock (stream-ioblock s nil)) + (fd (and ioblock (ioblock-device ioblock))) + (encoding (and ioblock (encoding-name (ioblock-encoding ioblock))))) + (if fd + (format out "~s (~a/~d)" encoding (%unix-fd-kind fd) fd) + (format out "~s" :closed))))) + +(defclass fd-input-stream (fd-stream buffered-input-stream-mixin) + ()) + +(defclass fd-output-stream (fd-stream buffered-output-stream-mixin) + ()) + +(defclass fd-io-stream (fd-stream buffered-io-stream-mixin) + ()) + +(defclass fd-character-input-stream (fd-input-stream + buffered-character-input-stream-mixin) + ()) + +(defclass fd-character-output-stream (fd-output-stream + buffered-character-output-stream-mixin) + ()) + +(defclass fd-character-io-stream (fd-io-stream + buffered-character-io-stream-mixin) + ()) + +(defclass fd-binary-input-stream (fd-input-stream + buffered-binary-input-stream-mixin) + ()) + +(defclass fd-binary-output-stream (fd-output-stream + buffered-binary-output-stream-mixin) + ()) + +(defclass fd-binary-io-stream (fd-io-stream buffered-binary-io-stream-mixin) + ()) + +(defun fd-stream-advance (s ioblock read-p) + (let* ((fd (ioblock-device ioblock)) + (buf (ioblock-inbuf ioblock)) + (bufptr (io-buffer-bufptr buf)) + (size (io-buffer-size buf)) + (avail nil)) + (setf (io-buffer-idx buf) 0 + (io-buffer-count buf) 0 + (ioblock-eof ioblock) nil) + (when (or read-p (setq avail (stream-listen s))) + (unless avail + (let* ((deadline (ioblock-deadline ioblock)) + (timeout + (if deadline + (milliseconds-until-deadline deadline ioblock) + (ioblock-input-timeout ioblock)))) + (when timeout + (multiple-value-bind (win timedout error) + (process-input-wait fd timeout) + (unless win + (if timedout + (error (if deadline + 'communication-deadline-expired + 'input-timeout) + :stream s) + (stream-io-error s (- error) "read"))))))) + (let* ((n (with-eagain fd :input + (fd-read fd bufptr size)))) + (declare (fixnum n)) + (if (< n 0) + (stream-io-error s (- n) "read") + (if (> n 0) + (setf (io-buffer-count buf) + (ioblock-octets-to-elements ioblock n)) + (progn (setf (ioblock-eof ioblock) t) + nil))))))) + +(defun fd-stream-eofp (s ioblock) + (declare (ignore s)) + (ioblock-eof ioblock)) + +(defun fd-stream-listen (s ioblock) + (declare (ignore s)) + (unread-data-available-p (ioblock-device ioblock))) + +(defun fd-stream-close (s ioblock) + (cancel-terminate-when-unreachable s) + (when (ioblock-dirty ioblock) + (stream-force-output s)) + (let* ((fd (ioblock-device ioblock))) + (when fd + (setf (ioblock-device ioblock) nil) + (if (>= fd 0) (fd-close fd))))) + +(defun fd-stream-force-output (s ioblock count finish-p) + (when (or (ioblock-dirty ioblock) finish-p) + (setf (ioblock-dirty ioblock) nil) + (let* ((fd (ioblock-device ioblock)) + (io-buffer (ioblock-outbuf ioblock)) + (buf (%null-ptr)) + (octets-to-write (ioblock-elements-to-octets ioblock count)) + (octets octets-to-write)) + (declare (fixnum octets)) + (declare (dynamic-extent buf)) + (%setf-macptr buf (io-buffer-bufptr io-buffer)) + (setf (io-buffer-idx io-buffer) 0 + (io-buffer-count io-buffer) 0) + (do* () + ((= octets 0) + (when finish-p + (case (%unix-fd-kind fd) + (:file (fd-fsync fd)))) + octets-to-write) + (let* ((deadline (ioblock-deadline ioblock)) + (timeout + (if deadline + (milliseconds-until-deadline deadline ioblock) + (ioblock-output-timeout ioblock)))) + (when timeout + (multiple-value-bind (win timedout error) + (process-output-wait fd timeout) + (unless win + (if timedout + (error (if deadline + 'communication-deadline-expired + 'output-timeout) + :stream s) + (stream-io-error s (- error) "write")))))) + (let* ((written (with-eagain fd :output + (fd-write fd buf octets)))) + (declare (fixnum written)) + (if (< written 0) + (stream-io-error s (- written) "write")) + (decf octets written) + (unless (zerop octets) + (%incf-ptr buf written))))))) + +(defmethod stream-read-line ((s buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock s :speedy t) + (funcall (ioblock-read-line-function ioblock) ioblock))) + +(defmethod stream-clear-input ((s fd-input-stream)) + (call-next-method) + (with-stream-ioblock-input (ioblock s :speedy t) + (let* ((fd (ioblock-device ioblock))) + (when fd (%fd-drain-input fd))))) + +(defmethod select-stream-class ((class (eql 'fd-stream)) in-p out-p char-p) + (if char-p + (if in-p + (if out-p + 'fd-character-io-stream + 'fd-character-input-stream) + 'fd-character-output-stream) + (if in-p + (if out-p + 'fd-binary-io-stream + 'fd-binary-input-stream) + 'fd-binary-output-stream))) + +(defstruct (input-selection (:include dll-node)) + (package nil :type (or null string package)) + (source-file nil :type (or null string pathname)) + (string-stream nil :type (or null string-input-stream))) + +(defstruct (input-selection-queue (:include locked-dll-header))) + +(defclass selection-input-stream (fd-character-input-stream) + ((package :initform nil :reader selection-input-stream-package) + (pathname :initform nil :reader selection-input-stream-pathname) + (peer-fd :reader selection-input-stream-peer-fd))) + +(defmethod select-stream-class ((class (eql 'selection-input-stream)) + in-p out-p char-p) + (if (and in-p char-p (not out-p)) + 'selection-input-stream + (error "Can't create that type of stream."))) + +(defun make-selection-input-stream (fd &key peer-fd encoding) + (let* ((s (make-fd-stream fd + :class 'selection-input-stream + :sharing :lock + :encoding encoding))) + (setf (slot-value s 'peer-fd) peer-fd) + s)) + + +;;; Very simple protocol: +;;; ^ppackage-name#\newline +;;; ^vpathname#\newline +;;; ^q quotes next character +;;; else raw data +(defmethod stream-read-char ((s selection-input-stream)) + (with-slots (package pathname) s + (let* ((quoted nil)) + (loop + (let* ((ch (call-next-method))) + (if quoted + (return ch) + (case ch + (#\^p (setq package nil) + (let* ((p (read-line s nil nil))) + (unless (zerop (length p)) + (setq package p)))) + (#\^v (setq pathname nil) + (let* ((p (read-line s nil nil))) + (unless (zerop (length p)) + (setq pathname p)))) + (#\^q (setq quoted t)) + (t (return ch))))))))) + +(defmethod stream-peek-char ((s selection-input-stream)) + (let* ((ch (stream-read-char s))) + (unless (eq ch :eof) + (stream-unread-char s ch)) + ch)) + +(defmethod stream-read-line ((s selection-input-stream)) + (generic-read-line s)) + +(defmethod stream-read-list ((stream selection-input-stream) + list count) + (generic-character-read-list stream list count)) + +(defmethod stream-read-vector ((stream selection-input-stream) + vector start end) + (generic-character-read-vector stream vector start end)) + + +;;;File streams. + +(let* ((open-file-streams ()) + (open-file-streams-lock (make-lock))) + (defun open-file-streams () + (with-lock-grabbed (open-file-streams-lock) + (copy-list open-file-streams))) + (defun note-open-file-stream (f) + (with-lock-grabbed (open-file-streams-lock) + (push f open-file-streams)) + t) + (defun remove-open-file-stream (f) + (with-lock-grabbed (open-file-streams-lock) + (setq open-file-streams (nremove f open-file-streams))) + t) + (defun clear-open-file-streams () + (with-lock-grabbed (open-file-streams-lock) + (setq open-file-streams nil)))) + + +(defun open (filename &key (direction :input) + (element-type 'base-char) + (if-exists (if (eq (pathname-version filename) :newest) + :new-version + :error)) + (if-does-not-exist (cond ((eq direction :probe) + nil) + ((or (eq direction :input) + (eq if-exists :overwrite) + (eq if-exists :append)) + :error) + (t :create))) + (external-format :default) + (class 'file-stream) + (sharing :private) + (basic t)) + "Return a stream which reads from or writes to FILENAME. + Defined keywords: + :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE + :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR + :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, + :OVERWRITE, :APPEND, :SUPERSEDE or NIL + :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL + See the manual for details." + (loop + (restart-case + (return + (make-file-stream filename + direction + element-type + if-exists + if-does-not-exist + class + external-format + sharing + basic)) + (retry-open () + :report (lambda (stream) (format stream "Retry opening ~s" filename)) + nil)))) + + + + + +(defun gen-file-name (path) + (let* ((base (random (ash target::target-most-positive-fixnum -1))) + (tem-path (merge-pathnames (make-pathname :name (%integer-to-string base) :type "tem" :defaults nil) path))) + (loop + (when (%create-file tem-path :if-exists nil) (return tem-path)) + (setf (%pathname-name tem-path) (%integer-to-string (setq base (1+ base))))))) + +(defun probe-file-x (path) + (%probe-file-x (native-translated-namestring path))) + +(defun file-length (stream) + (typecase stream + ;; Don't use an OR type here + (file-stream (stream-length stream)) + (synonym-stream (file-length + (symbol-value (synonym-stream-symbol stream)))) + (broadcast-stream (let* ((last (last-broadcast-stream stream))) + (if last + (file-length last) + 0))) + (otherwise (report-bad-arg stream 'file-stream)))) + +(defun file-position (stream &optional position) + (when position + (if (eq position :start) + (setq position 0) + (if (eq position :end) + (setq position (file-length stream)) + (unless (typep position 'unsigned-byte) + (report-bad-arg position '(or + null + (eql :start) + (eql :end) + unsigned-byte)))))) + (stream-position stream position)) + + +(defun %request-terminal-input () + (let* ((shared-resource + (if (typep *terminal-io* 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream *terminal-io*))))) + (if shared-resource (%acquire-shared-resource shared-resource t)))) + + + + +(defun %%yield-terminal-to (&optional process) + (let* ((stream (if (typep *terminal-io* 'synonym-stream) + (symbol-value (synonym-stream-symbol *terminal-io*)) + *terminal-io*)) + (shared-resource + (if (typep stream 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream stream))))) + (when shared-resource (%yield-shared-resource shared-resource process)))) + +(defun %restore-terminal-input (&optional took-it) + (let* ((shared-resource + (if took-it + (if (typep *terminal-io* 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream *terminal-io*)))))) + (when shared-resource + (%release-shared-resource shared-resource)))) + +;;; Initialize the global streams +;;; These are defparameters because they replace the ones that were in l1-init +;;; while bootstrapping. + +(defparameter *terminal-io* nil "terminal I/O stream") +(defparameter *debug-io* nil "interactive debugging stream") +(defparameter *query-io* nil "query I/O stream") +(defparameter *error-output* nil "error output stream") +(defparameter *standard-input* nil "default input stream") +(defparameter *standard-output* nil "default output stream") +(defparameter *trace-output* nil "trace output stream") + +(proclaim '(stream + *query-io* *debug-io* *error-output* *standard-input* + *standard-output* *trace-output*)) + +;;; Interaction with the REPL. READ-TOPLEVEL-FORM should return 3 +;;; values: a form, a (possibly null) pathname, and a boolean that +;;; indicates whether or not the result(s) of evaluating the form +;;; should be printed. (The last value has to do with how selections +;;; that contain multiple forms are handled; see *VERBOSE-EVAL-SELECTION* +;;; and the SELECTION-INPUT-STREAM method below.) + +(defmethod read-toplevel-form ((stream synonym-stream) &rest keys) + (apply #'read-toplevel-form (symbol-value (synonym-stream-symbol stream)) keys)) + +(defmethod read-toplevel-form ((stream two-way-stream) &rest keys) + (if (typep stream 'echo-stream) + (call-next-method) + (apply #'read-toplevel-form (two-way-stream-input-stream stream) keys))) + +(defmethod read-toplevel-form :after ((stream echoing-two-way-stream) &key &allow-other-keys) + (stream-set-column (two-way-stream-output-stream stream) 0)) + +(defmethod read-toplevel-form ((stream input-stream) &key eof-value file-name start-offset map) + (loop + (let* ((*in-read-loop* nil) + (first-char (peek-char t stream nil eof-value)) + (form + (let ((*read-suppress* nil)) + (cond ((eq first-char #\:) + (read-command-or-keyword stream eof-value)) + ((eq first-char eof-value) eof-value) + (t (multiple-value-bind (form note) + (read-recording-source stream :eofval eof-value + :file-name file-name + :start-offset start-offset + :map map + :save-source-text t) + (setq *loading-toplevel-location* note) + form)))))) + (if (eq form eof-value) + (return (values form nil t)) + (progn + (let ((ch)) ;Trim whitespace + (while (and (listen stream) + (setq ch (read-char stream nil nil)) + (whitespacep cH)) + (setq ch nil)) + (when ch (unread-char ch stream))) + (when *listener-indent* + (write-char #\space stream) + (write-char #\space stream)) + (return (values (process-single-selection form) nil t))))))) + +(defparameter *verbose-eval-selection* nil + "When true, the results of evaluating all forms in an input selection +are printed. When false, only the results of evaluating the last form +are printed.") + +(defmethod read-toplevel-form ((stream selection-input-stream) + &key eof-value &allow-other-keys) + (if (eq (stream-peek-char stream) :eof) + (values eof-value nil t) + (let* ((*package* *package*) + (pkg-name (selection-input-stream-package stream))) + (when pkg-name (setq *package* (pkg-arg pkg-name))) + (let* ((form (call-next-method)) + (last-form-in-selection (not (listen stream)))) + (values form + (selection-input-stream-pathname stream) + (or last-form-in-selection *verbose-eval-selection*)))))) + + +(defun (setf %ioblock-external-format) (ef ioblock) + (let* ((encoding (get-character-encoding (external-format-character-encoding ef))) + (line-termination (external-format-line-termination ef))) + (when (eq encoding (get-character-encoding nil)) + (setq encoding nil)) + (setq line-termination (cdr (assoc line-termination + *canonical-line-termination-conventions*))) + (setf (ioblock-encoding ioblock) encoding) + (when (ioblock-inbuf ioblock) + (setup-ioblock-input ioblock t (ioblock-element-type ioblock) (ioblock-sharing ioblock) encoding line-termination)) + (when (ioblock-outbuf ioblock) + (setup-ioblock-output ioblock t (ioblock-element-type ioblock) (ioblock-sharing ioblock) encoding line-termination)) + ef)) + +(defmethod stream-external-format ((s basic-character-stream)) + (%ioblock-external-format (basic-stream-ioblock s))) + +(defmethod (setf stream-external-format) (new (s basic-character-stream)) + (setf (%ioblock-external-format (basic-stream-ioblock s)) + (normalize-external-format (stream-domain s) new))) + +(defmethod stream-external-format ((s buffered-stream-mixin)) + (%ioblock-external-format (stream-ioblock s t))) + +(defmethod (setf stream-external-format) (new (s buffered-stream-mixin)) + (setf (%ioblock-external-format (stream-ioblock s t)) + (normalize-external-format (stream-domain s) new))) + +(defmethod stream-input-timeout ((s basic-input-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (let* ((timeout (ioblock-input-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-input-timeout) (new (s basic-input-stream)) + (setq new (check-io-timeout new)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (setf (ioblock-input-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-output-timeout ((s basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (let* ((timeout (ioblock-output-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-output-timeout) (new (s basic-output-stream)) + (setq new (check-io-timeout new)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-output-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-deadline ((s basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (ioblock-deadline ioblock)))) + +(defmethod (setf stream-deadline) (new (s basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-deadline ioblock) new) + new))) + + + +(defmethod stream-input-timeout ((s buffered-input-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-input-locked (ioblock) + (let* ((timeout (ioblock-input-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-input-timeout) (new (s buffered-input-stream-mixin)) + (setq new (check-io-timeout new)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-input-locked (ioblock) + (setf (ioblock-input-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-output-timeout ((s buffered-output-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (let* ((timeout (ioblock-output-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-output-timeout) (new (s buffered-output-stream-mixin)) + (setq new (check-io-timeout new)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-output-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-deadline ((s buffered-output-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (ioblock-deadline ioblock)))) + +(defmethod (setf stream-deadline) (new (s buffered-output-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-deadline ioblock) new) + new))) + + +(defmethod select-stream-untyi-function ((s symbol) direction) + (select-stream-untyi-function (find-class s) direction)) + +(defmethod select-stream-untyi-function ((c class) direction) + (select-stream-untyi-function (class-prototype c) direction)) + +(defmethod select-stream-untyi-function ((s fd-stream) (direction t)) + '%ioblock-untyi) + +(defmethod select-stream-untyi-function ((s basic-stream) (direction t)) + '%ioblock-untyi) + + + + + +(defparameter *vector-output-stream-default-initial-allocation* 64 "Default size of the vector created by (MAKE-VECTOR-OUTPUT-STREAM), in octets.") + +;;; Bivalent vector streams. +(make-built-in-class 'vector-stream 'basic-binary-stream 'basic-character-stream) + +(defmethod print-object ((s vector-stream) out) + (print-unreadable-object (s out :type t :identity t) + (unless (open-stream-p s) (format out " ~s" :closed)))) + + +(defstruct (vector-stream-ioblock (:include ioblock)) + (displacement 0) ;displaced-index-offset + ) + +(defstruct (vector-output-stream-ioblock (:include vector-stream-ioblock)) + (line-length 80) ;for pretty-printer + displaced ;original vector if fill-pointer case + ) + +(defstatic *vector-output-stream-class* (make-built-in-class 'vector-output-stream 'vector-stream 'basic-binary-output-stream 'basic-character-output-stream)) +(defstatic *vector-output-stream-class-wrapper* (%class-own-wrapper *vector-output-stream-class*)) +(defstatic *vector-input-stream-class* (make-built-in-class 'vector-input-stream 'vector-stream 'basic-binary-input-stream 'basic-character-input-stream)) +(defstatic *vector-input-stream-class-wrapper* (%class-own-wrapper *vector-input-stream-class*)) + +(defmethod initialize-basic-stream :after ((s vector-stream) &key ioblock &allow-other-keys) + (setf (basic-stream.state s) ioblock)) + +(defmethod stream-force-output ((s vector-output-stream))) + +(defmethod stream-finish-output ((s vector-output-stream))) + + + +(defun %extend-vector-output-stream (s ioblock count finish-p) + (declare (ignore s count finish-p)) + (check-ioblock-owner ioblock) + (let* ((displaced (vector-output-stream-ioblock-displaced ioblock)) + (outbuf (ioblock-outbuf ioblock))) + (cond (displaced + (let* ((flags (%svref displaced target::arrayH.flags-cell))) + (declare (fixnum flags)) + (unless (logbitp $arh_adjp_bit flags) + (%err-disp $XMALADJUST displaced)) + (let* ((len (%svref displaced target::vectorH.physsize-cell)) + (newlen (max (the fixnum (+ len len)) (+ len *vector-output-stream-default-initial-allocation*))) + (new (%alloc-misc newlen target::subtag-u8-vector))) + (declare (fixnum len newlen) + ((simple-array (unsigned-byte 8) (*)) new)) + (multiple-value-bind (data offset) + (%array-header-data-and-offset displaced) + (declare ((simple-array (unsigned-byte 8) (*)) data) + (fixnum offset)) + (%copy-ivector-to-ivector new 0 data offset len) + (setf (vector-output-stream-ioblock-displacement ioblock) 0) + (unless (= 0 offset) + (setf (io-buffer-idx outbuf) len + (io-buffer-count outbuf) len)) + (setf (io-buffer-limit outbuf) newlen + (io-buffer-size outbuf) newlen + (io-buffer-buffer outbuf) new) + ;; Adjust the displaced vector. + (setf (%svref displaced target::vectorH.data-vector-cell) new + (%svref displaced target::vectorH.displacement-cell) 0 + (%svref displaced target::vectorH.physsize-cell) newlen + (%svref displaced target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags) + (%svref displaced target::vectorH.logsize-cell) len))))) + (t + ;; Simpler. Honest. + (let* ((old (io-buffer-buffer outbuf)) + (len (length old)) + (newlen (max (the fixnum (+ len len)) 16)) + (new (%alloc-misc newlen target::subtag-u8-vector))) + (declare (fixnum len newlen) + ((simple-array (unsigned-byte 8) (*)) old new)) + (%copy-ivector-to-ivector new 0 old 0 len) + (setf (io-buffer-buffer outbuf) new + (io-buffer-size outbuf) newlen + (io-buffer-limit outbuf) newlen)))))) + +(defun %vector-output-stream-close (s ioblock) + (declare (ignore s)) + ;; If there's a displaced vector, fix its fill pointer. + (let* ((displaced (vector-output-stream-ioblock-displaced ioblock))) + (when displaced + (setf (%svref displaced target::vectorH.logsize-cell) + (the fixnum (- (the fixnum (io-buffer-count (ioblock-outbuf ioblock))) + (the fixnum (vector-output-stream-ioblock-displacement ioblock)))))))) + +(defmethod stream-line-length ((s vector-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (string-output-stream-ioblock-line-length ioblock))) + +(defmethod (setf stream-line-length) (newlen (s vector-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (setf (vector-output-stream-ioblock-line-length ioblock) newlen))) + +(defun get-output-stream-vector (s) + (unless (and (typep s 'basic-stream) + (eq *vector-output-stream-class-wrapper* + (basic-stream.wrapper s))) + (report-bad-arg s 'vector-output-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (outbuf (progn + (check-ioblock-owner ioblock) + (ioblock-outbuf ioblock))) + (v (io-buffer-buffer outbuf)) + (offset (vector-output-stream-ioblock-displacement ioblock)) + (len (the fixnum (- (the fixnum (io-buffer-count outbuf)) offset))) + (new (%alloc-misc len target::subtag-u8-vector))) + (declare (fixnum offset len)) + (%copy-ivector-to-ivector v offset new 0 len) + (setf (io-buffer-idx outbuf) offset + (io-buffer-count outbuf) offset) + new)) + + +(defun unsigned-integer-to-binary (value len s) + (declare (fixnum len)) + (unless (and (typep s 'basic-stream) + (eq *vector-output-stream-class-wrapper* + (basic-stream.wrapper s))) + (report-bad-arg s 'vector-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (outbuf (progn + (check-ioblock-owner ioblock) + (ioblock-outbuf ioblock))) + (idx (io-buffer-idx outbuf)) + (limit (io-buffer-limit outbuf)) + (buffer (io-buffer-buffer outbuf))) + (declare (fixnum idx limit) + ((simple-array (unsigned-byte 8) (*)) buffer) + (optimize (speed 3) (safety 0))) + (etypecase value + (fixnum + (if (< (the fixnum value) 0) + (report-bad-arg value 'unsigned-byte)) + (do* ((shift (ash (the fixnum (1- len)) 3) (- shift 8))) + ((< shift 0) (progn + (setf (io-buffer-idx outbuf) idx) + (if (> idx (the fixnum (io-buffer-count outbuf))) + (setf (io-buffer-count outbuf) idx)) + value)) + (declare (fixnum shift)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq limit (io-buffer-limit outbuf) + buffer (io-buffer-buffer outbuf))) + (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value)))) + (incf idx))) + (bignum + (locally + (declare ((simple-array (unsigned-byte 8) (*)) value)) + (let* ((nbytes (ash (uvsize value) 2)) + (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00))) + (declare (fixnum nbytes) + ((unsigned-byte 8) sign-byte)) + (unless (zerop sign-byte) + (report-bad-arg value 'unsigned-byte)) + (do* ((n (1- len) (1- n))) + ((< n 0) (progn + (setf (io-buffer-idx outbuf) idx) + (if (> idx (the fixnum (io-buffer-count outbuf))) + (setf (io-buffer-count outbuf) idx)) + value)) + (declare (fixnum n)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq limit (io-buffer-limit outbuf) + buffer (io-buffer-buffer outbuf))) + (setf (aref buffer idx) + (if (>= n nbytes) + 0 + (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3))))) + (incf idx)))))))) + +(defun signed-integer-to-binary (value len s) + (declare (fixnum len)) + (unless (and (typep s 'basic-stream) + (eq *vector-output-stream-class-wrapper* + (basic-stream.wrapper s))) + (report-bad-arg s 'vector-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (outbuf (progn + (check-ioblock-owner ioblock) + (ioblock-outbuf ioblock))) + (idx (io-buffer-idx outbuf)) + (limit (io-buffer-limit outbuf)) + (buffer (io-buffer-buffer outbuf))) + (declare (fixnum idx limit) + ((simple-array (unsigned-byte 8) (*)) buffer) + (optimize (speed 3) (safety 0))) + (do* ((newidx (+ idx len))) + ((< newidx limit)) + (declare (fixnum newidx)) + (%ioblock-force-output ioblock nil) + (setq limit (io-buffer-limit outbuf) + buffer (io-buffer-buffer outbuf))) + (etypecase value + (fixnum + (do* ((shift (ash (the fixnum (1- len)) 3) (- shift 8))) + ((< shift 0) (progn + (setf (io-buffer-idx outbuf) idx) + (if (> idx (the fixnum (io-buffer-count outbuf))) + (setf (io-buffer-count outbuf) idx)) + value)) + (declare (fixnum shift)) + (setf (aref buffer idx) (logand #xff (the fixnum (%iasr shift value)))) + (incf idx))) + (bignum + (locally + (declare ((simple-array (unsigned-byte 8) (*)) value)) + (let* ((nbytes (ash (uvsize value) 2)) + (sign-byte (if (logbitp 7 (the (unsigned-byte 8) (aref value (the fixnum (- nbytes #+big-endian-target 4 #+little-endian-target 1))))) #xff #x00))) + (declare (fixnum nbytes) + ((unsigned-byte 8) sign-byte)) + (do* ((n (1- len) (1- n))) + ((< n 0) (progn + (setf (io-buffer-idx outbuf) idx) + (if (> idx (the fixnum (io-buffer-count outbuf))) + (setf (io-buffer-count outbuf) idx)) + value)) + (declare (fixnum n)) + (setf (aref buffer idx) + (if (>= n nbytes) + sign-byte + (aref value #+little-endian-target n #+big-endian-target (the fixnum (logxor n 3))))) + (incf idx)))))))) + + + + + + +(defun %make-vector-output-stream (vector external-format) + (let* ((data nil) + (len nil) + (offset 0) + (start 0) + (displaced nil) + (external-format (normalize-external-format t external-format)) + (encoding (external-format-character-encoding external-format)) + (line-termination (external-format-line-termination external-format))) + (cond ((typep vector '(simple-array (unsigned-byte 8) (*))) + (setq data vector len (length vector))) + (t + (multiple-value-setq (data offset) (array-data-and-offset vector)) + (unless (eql (typecode data) target::subtag-u8-vector) + (report-bad-arg vector '(vector (unsigned-byte 8)))) + (unless (array-has-fill-pointer-p vector) + (error "~S must be a vector with a fill pointer." vector)) + (setq start (+ (fill-pointer vector) offset) + len (+ (array-total-size vector) offset) + displaced vector))) + (make-ioblock-stream *vector-output-stream-class* + :ioblock (make-vector-output-stream-ioblock + :outbuf (make-io-buffer :buffer data + :idx start + :count start + :limit len + :size len) + :displaced displaced + :displacement offset) + :encoding encoding + :character-p t + :element-type '(unsigned-byte 8) + :line-termination line-termination + :force-output-function '%extend-vector-output-stream + :close-function '%vector-output-stream-close))) + + +(defun make-vector-output-stream (&key (external-format :default)) + (%make-vector-output-stream (make-array *vector-output-stream-default-initial-allocation* :element-type '(unsigned-byte 8)) external-format)) + +(defmethod stream-position ((s vector-output-stream) &optional newpos) + (let* ((ioblock (basic-stream-ioblock s)) + (outbuf (ioblock-outbuf ioblock)) + (origin (vector-stream-ioblock-displacement ioblock))) + (declare (fixnum origin)) + (if newpos + (if (and (typep newpos 'fixnum) + (> (the fixnum newpos) -1) + (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit outbuf)))))) + (let* ((scaled-new (+ origin (the fixnum newpos)))) + (declare (fixnum scaled-new)) + (setf (io-buffer-idx outbuf) scaled-new) + (if (> (the fixnum (io-buffer-count outbuf)) scaled-new) + (setf (io-buffer-count outbuf) scaled-new)) + (let* ((displaced (vector-output-stream-ioblock-displaced ioblock))) + (when displaced + (setf (fill-pointer displaced) newpos))) + newpos) + (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit outbuf)) origin))))) + (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin))))) + +(defun vector-input-stream-index (s) + (unless (and (typep s 'basic-stream) + (eq *vector-input-stream-class-wrapper* + (basic-stream.wrapper s))) + (report-bad-arg s 'vector-input-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (check-ioblock-owner ioblock) + (the fixnum (- (the fixnum (io-buffer-idx (ioblock-inbuf ioblock))) + (the fixnum (vector-stream-ioblock-displacement ioblock)))))) + + +(defun %vector-input-stream-untyi (ioblock char) + (check-ioblock-owner ioblock) + (let* ((inbuf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx inbuf)) + (encoding (ioblock-encoding ioblock)) + (noctets (if encoding + (funcall (character-encoding-character-size-in-octets-function encoding) char) + 1)) + (newidx (- idx noctets))) + (declare (fixnum idx noctets newidx)) + (if (>= newidx (the fixnum (vector-stream-ioblock-displacement ioblock))) + (setf (io-buffer-idx inbuf) newidx) + (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock))))) + + + +(defmethod select-stream-untyi-function ((s vector-input-stream) (direction t)) + '%vector-input-stream-untyi) + + + + +(defun %make-vector-input-stream (vector start end external-format) + (setq end (check-sequence-bounds vector start end)) + (let* ((data nil) + (offset 0) + (external-format (normalize-external-format t external-format)) + (encoding (external-format-character-encoding external-format)) + (line-termination (external-format-line-termination external-format))) + + (cond ((typep vector '(simple-array (unsigned-byte 8) (*))) + (setq data vector offset start)) + (t (multiple-value-setq (data offset) (array-data-and-offset vector)) + (unless (typep data '(simple-array (unsigned-byte 8) (*))) + (report-bad-arg vector '(vector (unsigned-byte 8)))) + (incf start offset) + (incf end offset))) + (make-ioblock-stream *vector-input-stream-class* + :ioblock (make-vector-stream-ioblock + :inbuf (make-io-buffer + :buffer data + :idx start + :count end + :limit end + :size end) + :displacement start) + :direction :input + :character-p t + :element-type '(unsigned-byte 8) + :encoding encoding + :line-termination line-termination + :listen-function 'false + :eofp-function 'true + :advance-function 'false + :close-function 'false))) + +(defun make-vector-input-stream (vector &key (start 0) end external-format) + (%make-vector-input-stream vector start end external-format)) + + + + +(defun pui-stream (s count) + (declare (fixnum count)) + (unless (and (typep s 'basic-stream) + (eq *vector-input-stream-class-wrapper* + (basic-stream.wrapper s))) + (report-bad-arg s 'vector-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (inbuf (progn + (check-ioblock-owner ioblock) + (ioblock-inbuf ioblock))) + (idx (io-buffer-idx inbuf)) + (end (+ idx count)) + (limit (io-buffer-limit inbuf)) + (vector (io-buffer-buffer inbuf))) + (declare (fixnum idx limit end) + ((simple-array (unsigned-byte 8) (*)) vector)) + (if (< limit end) + (error "Integer decoding error")) + (let* ((result (%parse-unsigned-integer vector idx end))) + (setf (io-buffer-idx inbuf) end) + result))) + +(defun psi-stream (s count) + (declare (fixnum count)) + (unless (and (typep s 'basic-stream) + (eq *vector-input-stream-class-wrapper* + (basic-stream.wrapper s))) + (report-bad-arg s 'vector-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (inbuf (progn + (check-ioblock-owner ioblock) + (ioblock-inbuf ioblock))) + (idx (io-buffer-idx inbuf)) + (end (+ idx count)) + (limit (io-buffer-limit inbuf)) + (vector (io-buffer-buffer inbuf))) + (declare (fixnum idx limit end)) + (if (< limit end) + (error "Integer decoding error")) + (let* ((result (%parse-signed-integer vector idx end))) + (setf (io-buffer-idx inbuf) end) + result))) + +(defmethod stream-position ((s vector-input-stream) &optional newpos) + (let* ((ioblock (basic-stream-ioblock s)) + (inbuf (ioblock-inbuf ioblock)) + (origin (vector-stream-ioblock-displacement ioblock))) + (declare (fixnum origin)) + (if newpos + (if (and (typep newpos 'fixnum) + (> (the fixnum newpos) -1) + (< (the fixnum newpos) (the fixnum (+ origin (the fixnum (io-buffer-limit inbuf)))))) + (progn + (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos)))) + newpos) + (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit inbuf)) origin))))) + (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin))))) + +; end of L1-streams.lisp Index: /branches/qres/ccl/level-1/l1-symhash.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-symhash.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-symhash.lisp (revision 13564) @@ -0,0 +1,865 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(declaim (special %all-packages%)) +(declaim (list %all-package%)) +(declaim (type package *package*)) + + + +(defun dereference-base-string-or-symbol (s) + (if (symbolp s) + (dereference-base-string (symbol-name s)) + (dereference-base-string s))) + +(defun dereference-base-string-or-symbol-or-char (s) + (if (typep s 'character) + (values (make-string 1 :element-type 'base-char :initial-element s) 0 1) + (dereference-base-string-or-symbol s))) + + +(defun %string= (string1 string2 start1 end1) + (declare (optimize (speed 3) (safety 0)) + (fixnum start1 end1)) + (when (eq (length string2) (%i- end1 start1)) + (do* ((i start1 (1+ i)) + (j 0 (1+ j))) + ((>= i end1)) + (declare (fixnum i j)) + (when (not (eq (%scharcode string1 i)(%scharcode string2 j))) + (return-from %string= nil))) + t)) + + + + +(defun export (sym-or-syms &optional (package *package*)) + "Exports SYMBOLS from PACKAGE, checking that no name conflicts result." + (setq package (pkg-arg package)) + (if (atom sym-or-syms) + (let* ((temp (cons sym-or-syms nil))) + (declare (dynamic-extent temp)) + (export temp package)) + (progn + (dolist (sym sym-or-syms) + (unless (symbolp sym) (return (setq sym-or-syms (mapcar #'(lambda (s) (require-type s 'symbol)) sym-or-syms))))) + ;; First, see if any packages used by the package being + ;; "exported from" already contain a distinct non-shadowing + ;; symbol that conflicts with one of those that we're trying to + ;; export. + (let* ((conflicts (check-export-conflicts sym-or-syms package))) + (if conflicts + (progn + (resolve-export-conflicts conflicts package) + (export sym-or-syms package)) + (let* ((missing nil) (need-import nil)) + (dolist (s sym-or-syms) + (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) package) + (if (not (and foundp (eq s foundsym))) + (push s missing) + (if (eq foundp :inherited) + (push s need-import))))) + (when missing + (cerror "Import missing symbols before exporting them from ~S." + 'export-requires-import + :package package + :to-be-imported missing) + (import missing package)) + (if need-import (import need-import package)) + ; Can't lose now: symbols are all directly present in package. + ; Ensure that they're all external; do so with interrupts disabled + (without-interrupts + (let* ((etab (pkg.etab package)) + (ivec (car (pkg.itab package)))) + (dolist (s sym-or-syms t) + (multiple-value-bind (foundsym foundp internal-offset) + (%findsym (symbol-name s) package) + (when (eq foundp :internal) + (setf (%svref ivec internal-offset) (package-deleted-marker)) + (let* ((pname (symbol-name foundsym))) + (%htab-add-symbol foundsym etab (nth-value 2 (%get-htab-symbol pname (length pname) etab))))))))))))))) + +(defun check-export-conflicts (symbols package) + (let* ((conflicts nil)) + (with-package-lock (package) + (dolist (user (pkg.used-by package) conflicts) + (with-package-lock (user) + (dolist (s symbols) + (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) user) + (if (and foundp (neq foundsym s) (not (memq foundsym (pkg.shadowed user)))) + (push (list (eq foundp :inherited) s user foundsym) conflicts))))))))) + + + +(defun keywordp (x) + "Return true if Object is a symbol in the \"KEYWORD\" package." + (and (symbolp x) (eq (symbol-package x) *keyword-package*))) + +;;;No type/range checking. For DO-SYMBOLS and friends. +(defun %htab-symbol (array index) + (let* ((sym (%svref array index))) + (if (symbolp sym) + (values (%symptr->symbol sym) t) + (values nil nil)))) + +(defun find-all-symbols (name) + "Return a list of all symbols in the system having the specified name." + (let* ((syms ()) + (pname (ensure-simple-string (string name))) + (len (length pname))) + (with-package-list-read-lock + (dolist (p %all-packages% syms) + (with-package-lock (p) + (multiple-value-bind (sym foundp) (%find-package-symbol pname p len) + (if foundp (pushnew sym syms :test #'eq)))))))) + + +(defun list-all-packages () + "Return a list of all existing packages." + (with-package-list-read-lock (copy-list %all-packages%))) + +(defun rename-package (package new-name &optional new-nicknames) + "Changes the name and nicknames for a package." + (setq package (pkg-arg package) + new-name (ensure-simple-string (string new-name))) + (with-package-lock (package) + (let* ((names (pkg.names package))) + (declare (type cons names)) + (dolist (n names) + (let* ((ref (register-package-ref n))) + (setf (package-ref.pkg ref) nil))) + (rplaca names (new-package-name new-name package)) + (let* ((ref (register-package-ref (car names)))) + (setf (package-ref.pkg ref) package)) + (rplacd names nil)) + (%add-nicknames new-nicknames package))) + +;;; Someday, this should become LISP:IN-PACKAGE. +(defun old-in-package (name &key + nicknames + (use nil use-p) + (internal-size 60) + (external-size 10)) + (let ((pkg (find-package (setq name (string name))))) + (if pkg + (progn + (use-package use pkg) + (%add-nicknames nicknames pkg)) + (setq pkg + (make-package name + :nicknames nicknames + :use (if use-p use *make-package-use-defaults*) + :internal-size internal-size + :external-size external-size))) + (setq *package* pkg))) + + +(defvar *make-package-use-defaults* '("COMMON-LISP" "CCL")) + +;;; On principle, this should get exported here. Unfortunately, we +;;; can't execute calls to export quite yet. + + +(defun make-package (name &key + nicknames + (use *make-package-use-defaults*) + (internal-size 60) + (external-size 10)) + "Make a new package having the specified NAME, NICKNAMES, and + USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are + estimates for the number of internal and external symbols which + will ultimately be present in the package. The default value of + USE is implementation-dependent, and in this implementation + it is NIL." + (setq internal-size (require-type internal-size 'fixnum) + external-size (require-type external-size 'fixnum)) + (let* ((pkg-name (new-package-name name)) + (pkg (gvector :package + (%new-package-hashtable internal-size) + (%new-package-hashtable external-size) + nil + nil + (list pkg-name) + nil + (make-read-write-lock) + nil))) + (let* ((ref (register-package-ref pkg-name))) + (setf (package-ref.pkg ref) pkg)) + (use-package use pkg) + (%add-nicknames nicknames pkg) + (with-package-list-write-lock + (push pkg %all-packages%)) + pkg)) + +(defun new-package-name (name &optional package) + (do* ((prompt "Enter package name to use instead of ~S .")) + ((let* ((found (find-package (setq name (ensure-simple-string (string name)))))) + (or (not found) + (eq package found))) + name) + (restart-case (%error "Package name ~S is already in use." (list name) (%get-frame-ptr)) + (new-name (new-name) + :report (lambda (s) (format s prompt name)) + :interactive + (lambda () + (list (block nil (catch-cancel (return (get-string-from-user + (format nil prompt name)))) + nil))) + (if new-name (setq name new-name)))))) + +(defun new-package-nickname (name package) + (setq name (string name)) + (let* ((other (find-package name)) + (prompt "Enter package name to use instead of ~S .")) + (if other + (unless (eq other package) + (let* ((conflict-with-proper-name (string= (package-name other) name)) + (condition (make-condition 'package-name-conflict-error + :package package + :format-arguments (list name other) + :format-control (%str-cat "~S is already " + (if conflict-with-proper-name + "the " + "a nick") + "name of ~S.")))) + (restart-case (%error condition nil (%get-frame-ptr)) + (continue () + :report (lambda (s) (format s "Don't make ~S a nickname for ~S" name package))) + (new-name (new-name) + :report (lambda (s) (format s prompt name)) + :interactive + (lambda () + (list (block nil (catch-cancel (return (get-string-from-user + (format nil prompt name)))) + nil))) + (if new-name (new-package-nickname new-name package))) + (remove-conflicting-nickname () + :report (lambda (s) + (format s "Remove conflicting-nickname ~S from ~S." name other)) + :test (lambda (&rest ignore) (declare (ignore ignore)) (not conflict-with-proper-name)) + (rplacd (pkg.names other) + (delete name (cdr (pkg.names other)) :test #'string=)) + name)))) + name))) + +(defun %add-nicknames (nicknames package) + (let ((names (pkg.names package))) + (dolist (name nicknames package) + (let* ((ok-name (new-package-nickname name package))) + (when ok-name + (let* ((ref (register-package-ref ok-name))) + (setf (package-ref.pkg ref) package) + (push ok-name (cdr names)))))))) + +(defun find-symbol (string &optional package) + "Return the symbol named STRING in PACKAGE. If such a symbol is found + then the second value is :INTERNAL, :EXTERNAL or :INHERITED to indicate + how the symbol is accessible. If no symbol is found then both values + are NIL." + (multiple-value-bind (sym flag) + (%findsym (ensure-simple-string string) (pkg-arg (or package *package*))) + (values sym flag))) + +(defun %pkg-ref-find-symbol (string ref) + (multiple-value-bind (sym flag) + (%findsym (ensure-simple-string string) + (or (package-ref.pkg ref) + (%kernel-restart $xnopkg (package-ref.name ref)))) + (values sym flag))) + +;;; Somewhat saner interface to %find-symbol +(defun %findsym (string package) + (%find-symbol string (length string) package)) + +(eval-when (:compile-toplevel) + (declaim (inline %intern))) + +(defun %intern (str package) + (setq str (ensure-simple-string str)) + (with-package-lock (package) + (multiple-value-bind (symbol where internal-offset external-offset) + (%find-symbol str (length str) package) + (if where + (values symbol where) + (values (%add-symbol str package internal-offset external-offset) nil))))) + + +(defun intern (str &optional (package *package*)) + "Return a symbol in PACKAGE having the specified NAME, creating it + if necessary." + (%intern str (pkg-arg package))) + +(defun %pkg-ref-intern (str ref) + (%intern str (or (package-ref.pkg ref) + (%kernel-restart $xnopkg (package-ref.name ref))))) + +(defun unintern (symbol &optional (package *package*)) + "Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present + then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home + package, then it is made uninterned." + (setq package (pkg-arg package)) + (setq symbol (require-type symbol 'symbol)) + (multiple-value-bind (foundsym table index) (%find-package-symbol (symbol-name symbol) package) + (when (and table (eq symbol foundsym)) + (when (memq symbol (pkg.shadowed package)) + ;; A conflict is possible if more than one distinct + ;; similarly-named external symbols exist in the packages used + ;; by this one. Grovel around looking for such conflicts; if + ;; any are found, signal an error (via %kernel-restart) which + ;; offers to either shadowing-import one of the conflicting + ;; symbols into the current package or abandon the attempt to + ;; unintern in the first place. + (let* ((first nil) + (first-p nil) + (name (symbol-name symbol)) + (len (length name)) + (others nil)) + (declare (dynamic-extent first)) + (with-package-lock (package) + (dolist (pkg (pkg.used package)) + (with-package-lock (pkg) + (multiple-value-bind (found conflicting-sym) (%get-htab-symbol name len (pkg.etab pkg)) + (when found + (if first-p + (unless (or (eq conflicting-sym first) + (memq conflicting-sym others)) + (push conflicting-sym others)) + (setq first-p t first conflicting-sym))))))) + (when others + ;;If this returns, it will have somehow fixed things. + (return-from unintern (%kernel-restart $xunintc symbol package (cons first others))))) + ;; No conflicts found, but symbol was on shadowing-symbols list. Remove it atomically. + (do* ((head (cons nil (pkg.shadowed package))) + (prev head next) + (next (cdr prev) (cdr next))) + ((null next)) ; Should never happen + (declare (dynamic-extent head) + (list head prev next) + (optimize (speed 3) (safety 0))) + (when (eq (car next) symbol) + (setf (cdr prev) (cdr next) + (pkg.shadowed package) (cdr head)) + (return)))) + ;; Now remove the symbol from package; if package was its home + ;; package, set its package to NIL. If we get here, the "table" + ;; and "index" values returned above are still valid. + (%svset (car table) index (package-deleted-marker)) + (when (eq (symbol-package symbol) package) + (%set-symbol-package symbol nil)) + t))) + +(defun import-1 (package sym) + (multiple-value-bind (conflicting-sym type internal-offset external-offset) (%findsym (symbol-name sym) package) + (if (and type (neq conflicting-sym sym)) + (let* ((external-p (eq type :inherited)) + (condition (make-condition 'import-conflict-error + :package package + :imported-sym sym + :conflicting-sym conflicting-sym + :conflict-external external-p))) + (restart-case (error condition) + (continue () + :report (lambda (s) (format s "Ignore attempt to import ~S to ~S." sym package))) + (resolve-conflict () + :report (lambda (s) + (let* ((package-name (package-name package))) + (if external-p + (format s "~A ~s in package ~s ." 'shadowing-import sym package-name) + (format s "~A ~s from package ~s ." 'unintern conflicting-sym package-name)))) + (if external-p + (shadowing-import-1 package sym) + (progn + (unintern conflicting-sym package) + (import-1 package sym)))))) + (unless (or (eq type :external) (eq type :internal)) + (%insert-symbol sym package internal-offset external-offset))))) + + +(defun import (sym-or-syms &optional package) + "Make SYMBOLS accessible as internal symbols in PACKAGE. If a symbol + is already accessible then it has no effect. If a name conflict + would result from the importation, then a correctable error is signalled." + (setq package (pkg-arg (or package *package*))) + (if (listp sym-or-syms) + (dolist (sym sym-or-syms) + (import-1 package sym)) + (import-1 package sym-or-syms)) + t) + +(defun shadow-1 (package sym) + (let* ((pname (ensure-simple-string (string sym))) + (len (length pname))) + (without-interrupts + (multiple-value-bind (symbol where internal-idx external-idx) (%find-symbol pname len package) + (if (or (eq where :internal) (eq where :external)) + (pushnew symbol (pkg.shadowed package)) + (push (%add-symbol pname package internal-idx external-idx) (pkg.shadowed package))))) + nil)) + +(defun shadow (sym-or-symbols-or-string-or-strings &optional package) + "Make an internal symbol in PACKAGE with the same name as each of + the specified SYMBOLS. If a symbol with the given name is already + present in PACKAGE, then the existing symbol is placed in the + shadowing symbols list if it is not already present." + (setq package (pkg-arg (or package *package*))) + (if (listp sym-or-symbols-or-string-or-strings) + (dolist (s sym-or-symbols-or-string-or-strings) + (shadow-1 package s)) + (shadow-1 package sym-or-symbols-or-string-or-strings)) + t) + +(defun unexport (sym-or-symbols &optional package) + "Makes SYMBOLS no longer exported from PACKAGE." + (setq package (pkg-arg (or package *package*))) + (if (listp sym-or-symbols) + (dolist (sym sym-or-symbols) + (unexport-1 package sym)) + (unexport-1 package sym-or-symbols)) + t) + +(defun unexport-1 (package sym) + (when (eq package *keyword-package*) + (error "Can't unexport ~S from ~S ." sym package)) + (multiple-value-bind (foundsym foundp internal-offset external-offset) + (%findsym (symbol-name sym) package) + (unless foundp + (error 'symbol-name-not-accessible + :symbol-name (symbol-name sym) + :package package)) + (when (eq foundp :external) + (let* ((evec (car (pkg.etab package))) + (itab (pkg.itab package)) + (ivec (car itab)) + (icount&limit (cdr itab))) + (declare (type cons itab icount&limit)) + (setf (svref evec external-offset) (package-deleted-marker)) + (setf (svref ivec internal-offset) (%symbol->symptr foundsym)) + (if (eql (setf (car icount&limit) + (the fixnum (1+ (the fixnum (car icount&limit))))) + (the fixnum (cdr icount&limit))) + (%resize-htab itab))))) + nil) + +;;; Both args must be packages. +(defun %use-package-conflict-check (using-package package-to-use) + (let ((already-used (pkg.used using-package))) + (unless (or (eq using-package package-to-use) + (memq package-to-use already-used)) + ;; There are two types of conflict that can potentially occur: + ;; 1) An external symbol in the package being used conflicts + ;; with a symbol present in the using package + ;; 2) An external symbol in the package being used conflicts + ;; with an external symbol in some other package that's + ;; already used. + (let* ((ext-ext-conflicts nil) + (used-using-conflicts nil) + (shadowed-in-using (pkg.shadowed using-package)) + (to-use-etab (pkg.etab package-to-use))) + (without-interrupts + (dolist (already already-used) + (let ((user (if (memq package-to-use (pkg.used-by already)) + package-to-use + (if (memq package-to-use (pkg.used already)) + already)))) + (if user + (let* ((used (if (eq user package-to-use) already package-to-use)) + (user-etab (pkg.etab user)) + (used-etab (pkg.etab used))) + (dolist (shadow (pkg.shadowed user)) + (let ((sname (symbol-name shadow))) + (unless (member sname shadowed-in-using :test #'string=) + (let ((len (length sname))) + (when (%get-htab-symbol sname len user-etab) ; external in user + (multiple-value-bind (external-in-used used-sym) (%get-htab-symbol sname len used-etab) + (when (and external-in-used (neq used-sym shadow)) + (push (list shadow used-sym) ext-ext-conflicts))))))))) + ;; Remember what we're doing here ? + ;; Neither of the two packages use the other. Iterate + ;; over the external symbols in the package that has + ;; the fewest external symbols and note conflicts with + ;; external symbols in the other package. + (let* ((smaller (if (%i< (%cadr to-use-etab) (%cadr (pkg.etab already))) + package-to-use + already)) + (larger (if (eq smaller package-to-use) already package-to-use)) + (larger-etab (pkg.etab larger)) + (smaller-v (%car (pkg.etab smaller)))) + (dotimes (i (uvsize smaller-v)) + (declare (fixnum i)) + (let ((symptr (%svref smaller-v i))) + (when (symbolp symptr) + (let* ((sym (%symptr->symbol symptr)) + (symname (symbol-name sym))) + (unless (member symname shadowed-in-using :test #'string=) + (multiple-value-bind (found-in-larger sym-in-larger) + (%get-htab-symbol symname (length symname) larger-etab) + (when (and found-in-larger (neq sym-in-larger sym)) + (push (list sym sym-in-larger) ext-ext-conflicts)))))))))))) + ;; Now see if any non-shadowed, directly present symbols in + ;; the using package conflicts with an external symbol in the + ;; package being used. There are two ways of doing this; one + ;; of them -may- be much faster than the other. + (let* ((to-use-etab-size (%cadr to-use-etab)) + (present-symbols-size (%i+ (%cadr (pkg.itab using-package)) (%cadr (pkg.etab using-package))))) + (unless (eql 0 present-symbols-size) + (if (%i< present-symbols-size to-use-etab-size) + ;; Faster to look up each present symbol in to-use-etab. + (let ((htabvs (list (%car (pkg.etab using-package)) (%car (pkg.itab using-package))))) + (declare (dynamic-extent htabvs)) + (dolist (v htabvs) + (dotimes (i (the fixnum (uvsize v))) + (declare (fixnum i)) + (let ((symptr (%svref v i))) + (when (symbolp symptr) + (let* ((sym (%symptr->symbol symptr))) + (unless (memq sym shadowed-in-using) + (let* ((name (symbol-name symptr))) + (multiple-value-bind (found-p to-use-sym) (%get-htab-symbol name (length name) to-use-etab) + (when (and found-p (neq to-use-sym sym)) + (push (list sym to-use-sym) used-using-conflicts))))))))))) + ;; See if any external symbol present in the package + ;; being used conflicts with any symbol present in the + ;; using package. + (let ((v (%car to-use-etab))) + (dotimes (i (uvsize v)) + (declare (fixnum i)) + (let ((symptr (%svref v i))) + (when (symbolp symptr) + (let* ((sym (%symptr->symbol symptr))) + (multiple-value-bind (using-sym found-p) (%find-package-symbol (symbol-name sym) using-package) + (when (and found-p + (neq sym using-sym) + (not (memq using-sym shadowed-in-using))) + (push (list using-sym sym) used-using-conflicts)))))))))))) + (values ext-ext-conflicts used-using-conflicts))))) + +(defun use-package-1 (using-package package-to-use) + (if (eq (setq package-to-use (pkg-arg package-to-use)) + *keyword-package*) + (error "~S can't use ~S." using-package package-to-use)) + (do* ((used-external-conflicts nil) + (used-using-conflicts nil)) + ((and (null (multiple-value-setq (used-external-conflicts used-using-conflicts) + (%use-package-conflict-check using-package package-to-use))) + (null used-using-conflicts))) + (if used-external-conflicts + (%kernel-restart $xusecX package-to-use using-package used-external-conflicts) + (if used-using-conflicts + (%kernel-restart $xusec package-to-use using-package used-using-conflicts)))) + (unless (memq using-package (pkg.used-by package-to-use)) ; Not already used in break loop/restart, etc. + (push using-package (pkg.used-by package-to-use)) + (push package-to-use (pkg.used using-package)))) + +(defun use-package (packages-to-use &optional package) + "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that + the external symbols of the used packages are accessible as internal + symbols in PACKAGE." + (setq package (pkg-arg (or package *package*))) + (if (listp packages-to-use) + (dolist (to-use packages-to-use) + (use-package-1 package to-use)) + (use-package-1 package packages-to-use)) + t) + +(defun shadowing-import-1 (package sym) + (let* ((pname (symbol-name sym)) + (len (length pname)) + (need-add t)) + (without-interrupts + (multiple-value-bind (othersym htab offset) (%find-package-symbol pname package) + (if htab + (if (eq othersym sym) + (setq need-add nil) + (progn ; Delete conflicting symbol + (if (eq (symbol-package othersym) package) + (%set-symbol-package othersym nil)) + (setf (%svref (car htab) offset) (package-deleted-marker)) + (setf (pkg.shadowed package) (delete othersym (pkg.shadowed package) :test #'eq))))) + (if need-add ; No symbols with same pname; intern & shadow + (multiple-value-bind (xsym foundp internal-offset external-offset) + (%find-symbol pname len package) + (declare (ignore xsym foundp)) + (%insert-symbol sym package internal-offset external-offset))) + (pushnew sym (pkg.shadowed package)) + nil)))) + +(defun shadowing-import (sym-or-syms &optional (package *package*)) + "Import SYMBOLS into package, disregarding any name conflict. If + a symbol of the same name is present, then it is uninterned." + (setq package (pkg-arg package)) + (if (listp sym-or-syms) + (dolist (sym sym-or-syms) + (shadowing-import-1 package sym)) + (shadowing-import-1 package sym-or-syms)) + t) + +(defun unuse-package (packages-to-unuse &optional package) + "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE." + (let ((p (pkg-arg (or package *package*)))) + (flet ((unuse-one-package (unuse) + (setq unuse (pkg-arg unuse)) + (setf (pkg.used p) (nremove unuse (pkg.used p)) + (pkg.used-by unuse) (nremove p (pkg.used-by unuse))))) + (declare (dynamic-extent #'unuse-one-package)) + (if (listp packages-to-unuse) + (dolist (u packages-to-unuse) (unuse-one-package u)) + (unuse-one-package packages-to-unuse)) + t))) + +(defun delete-package (package) + "Delete the package designated by PACKAGE-DESIGNATOR from the package + system data structures." + (unless (packagep package) + (setq package (or (find-package package) + (progn + (cerror "Do nothing" 'no-such-package :package package) + (return-from delete-package nil))))) + (with-package-list-read-lock + (unless (memq package %all-packages%) + (return-from delete-package nil))) + (when (pkg.used-by package) + (cerror "unuse ~S" 'package-is-used-by :package package + :using-packages (pkg.used-by package))) + (while (pkg.used-by package) + (unuse-package package (car (pkg.used-by package)))) + (while (pkg.used package) + (unuse-package (car (pkg.used package)) package)) + (setf (pkg.shadowed package) nil) + (with-package-list-write-lock + (setq %all-packages% (nremove package %all-packages%))) + (dolist (n (pkg.names package)) + (let* ((ref (register-package-ref n))) + (setf (package-ref.pkg ref) nil))) + (setf (pkg.names package) nil) + (let* ((ivec (car (pkg.itab package))) + (evec (car (pkg.etab package))) + (deleted (package-deleted-marker))) + (dotimes (i (the fixnum (length ivec))) + (let* ((sym (%svref ivec i))) + (setf (%svref ivec i) deleted) ; in case it's in STATIC space + (when (symbolp sym) + (if (eq (symbol-package sym) package) + (%set-symbol-package sym nil))))) + (dotimes (i (the fixnum (length evec))) + (let* ((sym (%svref evec i))) + (setf (%svref evec i) deleted) ; in case it's in STATIC space + (when (symbolp sym) + (if (eq (symbol-package sym) package) + (%set-symbol-package sym nil)))))) + (let ((itab (pkg.itab package)) (etab (pkg.etab package)) (v '#(nil nil nil))) + (%rplaca itab v) (%rplaca etab v) + (%rplaca (%cdr itab) 0) (%rplaca (%cdr etab) 0) + (%rplacd (%cdr itab) #x4000) (%rplacd (%cdr etab) #x4000)) + t) + +(defun %find-package-symbol (string package &optional (len (length string))) + (let* ((etab (pkg.etab package)) + (itab (pkg.itab package))) + (multiple-value-bind (foundp sym offset) (%get-htab-symbol string len itab) + (if foundp + (values sym itab offset) + (progn + (multiple-value-setq (foundp sym offset) + (%get-htab-symbol string len etab)) + (if foundp + (values sym etab offset) + (values nil nil nil))))))) + +;;;For the inspector, number of symbols in pkg. +(defun %pkgtab-count (pkgtab) + (let* ((n 0)) + (declare (fixnum n)) + (dovector (x (pkgtab-table pkgtab) n) + (when (symbolp x) + (incf n))))) + + +(defun %resize-package (pkg) + (%resize-htab (pkg.itab pkg)) + (%resize-htab (pkg.etab pkg)) + pkg) + +;These allow deleted packages, so can't use pkg-arg which doesn't. +;Of course, the wonderful world of optional arguments comes in handy. +(defun pkg-arg-allow-deleted (pkg) + (pkg-arg pkg t)) + + +(defun package-name (pkg) (%car (pkg.names (pkg-arg-allow-deleted pkg)))) +;;>> Shouldn't these copy-list their result so that the user +;;>> can't cause a crash through evil rplacding? +;Of course that would make rplacding less evil, and then how would they ever learn? +(defun package-nicknames (pkg) (%cdr (pkg.names (pkg-arg-allow-deleted pkg)))) +(defun package-use-list (pkg) (pkg.used (pkg-arg-allow-deleted pkg))) +(defun package-used-by-list (pkg) (pkg.used-by (pkg-arg-allow-deleted pkg))) +(defun package-shadowing-symbols (pkg) (pkg.shadowed (pkg-arg-allow-deleted pkg))) + +;;; This assumes that all symbol-names and package-names are strings. +(defun %define-package (name size + external-size ; extension (may be nil.) + nicknames + shadow + shadowing-import-from-specs + use + import-from-specs + intern + export + &optional doc) + (if (eq use :default) (setq use *make-package-use-defaults*)) + (let* ((pkg (find-package name))) + (if pkg + ;; Restarts could offer several ways of fixing this. + (unless (string= (package-name pkg) name) + (cerror "Redefine ~*~S" + "~S is already a nickname for ~S" name pkg)) + (setq pkg (make-package name + :use nil + :internal-size (or size 60) + :external-size (or external-size + (max (length export) 1))))) + (unuse-package (package-use-list pkg) pkg) + (rename-package pkg name nicknames) + (flet ((operation-on-all-specs (function speclist) + (let ((to-do nil)) + (dolist (spec speclist) + (let ((from (pop spec))) + (dolist (str spec) + (multiple-value-bind (sym win) (find-symbol str from) + (if win + (push sym to-do) + ; This should (maybe) be a PACKAGE-ERROR. + (cerror "Ignore attempt to ~s ~s from package ~s" + "Cannot ~s ~s from package ~s" function str from)))))) + (when to-do (funcall function to-do pkg))))) + + (dolist (sym shadow) (shadow sym pkg)) + (operation-on-all-specs 'shadowing-import shadowing-import-from-specs) + (use-package use pkg) + (operation-on-all-specs 'import import-from-specs) + (dolist (str intern) (intern str pkg)) + (when export + (let* ((syms nil)) + (dolist (str export) + (multiple-value-bind (sym found) (find-symbol str pkg) + (unless found (setq sym (intern str pkg))) + (push sym syms))) + (export syms pkg))) + (when (and doc *save-doc-strings*) + (set-documentation pkg t doc)) + pkg))) + +(defun %setup-pkg-iter-state (pkg-list types) + (collect ((steps)) + (flet ((cons-pkg-iter-step (package type table &optional shadowed) + (steps (vector package type table shadowed nil nil)))) + (let* ((pkgs (if (listp pkg-list) + (mapcar #'pkg-arg pkg-list) + (list (pkg-arg pkg-list))))) + (dolist (pkg pkgs) + (dolist (type types) + (case type + (:internal (cons-pkg-iter-step pkg type (pkg.itab pkg))) + (:external (cons-pkg-iter-step pkg type (pkg.etab pkg))) + (:inherited + (let* ((shadowed (pkg.shadowed pkg)) + (used (pkg.used pkg))) + (dolist (u used) + (cons-pkg-iter-step pkg type (pkg.etab u) shadowed))))))))) + (vector nil (steps)))) + +(defun %pkg-iter-next (state) + (flet ((get-step () + (let* ((step (pkg-iter.step state))) + (loop + (if (and step (> (pkg-iter-step.index step) 0)) + (return step)) + (when (setq step (pop (pkg-iter.remaining-steps state))) + (setf (pkg-iter.step state) step) + (setf (pkg-iter-step.index step) + (length (setf (pkg-iter-step.vector step) + (pkgtab-table (pkg-iter-step.table step)))))) + (unless step + (return)))))) + (loop + (let* ((step (get-step))) + (when (null step) (return)) + (multiple-value-bind (symbol found) + (%htab-symbol (pkg-iter-step.vector step) + (decf (pkg-iter-step.index step))) + (when (and found + (not (member symbol (pkg-iter-step.shadowed step) + :test #'string=))) + (return (values t + symbol + (pkg-iter-step.type step) + (pkg-iter-step.pkg step))))))))) + + +;;; For do-symbols and with-package-iterator +;;; string must be a simple string +;;; package must be a package +;;; Wouldn't it be nice if this distinguished "not found" from "found NIL" ? +(defun %name-present-in-package-p (string package) + (values (%find-package-symbol string package))) + +;;; This is supposed to be (somewhat) like the lisp machine's MAKE-PACKAGE. +;;; Accept and ignore some keyword arguments, accept and process some others. + +(defun lispm-make-package (name &key + (use *make-package-use-defaults*) + nicknames + ;prefix-name + ;invisible + (shadow nil shadow-p) + (export nil export-p) + (shadowing-import nil shadowing-import-p) + (import nil import-p) + (import-from nil import-from-p) + ;relative-names + ;relative-names-for-me + ;size + ;hash-inherited-symbols + ;external-only + ;include + ;new-symbol-function + ;colon-mode + ;prefix-intern-function + &allow-other-keys) + ; (declare (ignore prefix-name invisible relative-names relative-names-for-me + ; size hash-inherited-symbols external-only include + ; new-symbol-function colon-mode prefix-intern-function)) + (let ((pkg (make-package name :use NIL :nicknames nicknames))) + (when shadow-p (shadow shadow pkg)) + (when shadowing-import-p (shadowing-import shadowing-import pkg)) + (use-package use pkg) + (when import-from-p + (let ((from-pkg (pop import-from))) + (dolist (name import-from) + (multiple-value-bind (sym win) (find-symbol (string name) from-pkg) + (when win (import-1 pkg sym)))))) + (when import-p (import import pkg)) + (when export-p + (let* ((syms nil)) + (dolist (name export) + (multiple-value-bind (sym win) (find-symbol (string name) pkg) + (unless win (setq sym (intern (string name) pkg))) + (push sym syms))) + (export syms pkg))) + pkg)) + Index: /branches/qres/ccl/level-1/l1-sysio.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-sysio.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-sysio.lisp (revision 13564) @@ -0,0 +1,928 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defstruct (file-ioblock (:include ioblock)) + (octet-pos 0 ) ; current io position in octets + (fileeof 0 ) ; file length in elements + ) + + + + +;;; The file-ioblock-octet-pos field is the (octet) position +;;; at which the next I/O operation will begin (e.g., where the +;;; input came from and/or where the output's going.) There are +;;; cases (e.g., after a STREAM-CLEAR-INPUT) when this can't be +;;; determined (based on its previous value and the logical size +;;; of the buffer) so we'll have to ask the OS. + +(defun file-octet-filepos (file-ioblock) + (fd-tell (file-ioblock-device file-ioblock))) + +(defun synch-file-octet-filepos (file-ioblock) + (setf (file-ioblock-octet-pos file-ioblock) + (file-octet-filepos file-ioblock))) + +(defun infer-line-termination (file-ioblock) + (let* ((encoding (or (file-ioblock-encoding file-ioblock) + (get-character-encoding nil))) + (inbuf (file-ioblock-inbuf file-ioblock)) + (buffer (io-buffer-buffer inbuf)) + (n (io-buffer-count inbuf))) + (when (zerop n) + (setq n (or (fd-stream-advance (file-ioblock-stream file-ioblock) + file-ioblock + t) + 0))) + (multiple-value-bind (nchars last) + (funcall (character-encoding-length-of-vector-encoding-function encoding) + buffer + 0 + n) + (declare (fixnum nchars last)) + (let* ((string (make-string nchars))) + (declare (dynamic-extent string)) + (decode-character-encoded-vector encoding buffer 0 last string) + (let* ((line-termination + (do* ((i 0 (1+ i)) + (last-was-cr nil)) + ((= i nchars) (if last-was-cr :cr)) + (declare (fixnum i)) + (let* ((char (schar string i))) + (if last-was-cr + (if (eq char #\Linefeed) + (return :crlf) + (return :cr)) + (case char + (#\Newline (return nil)) + (#\Line_Separator (return :unicode)) + (#\Return (setq last-was-cr t)))))))) + (when line-termination + (install-ioblock-input-line-termination file-ioblock line-termination) + (when (file-ioblock-outbuf file-ioblock) + (install-ioblock-output-line-termination file-ioblock line-termination)))))) + (when (eq (ioblock-owner file-ioblock) *current-process*) + (setf (ioblock-owner file-ioblock) 0)))) + + + +(defvar *default-external-format* :unix) + +(defvar *default-file-character-encoding* nil) + +(defmethod default-character-encoding ((domain (eql :file))) + *default-file-character-encoding*) + +(defvar *default-line-termination* :unix + "The value of this variable is used when :EXTERNAL-FORMAT is +unspecified or specified as :DEFAULT. It can meaningfully be given any +of the values :UNIX, :MACOS, :MSDOS, :UNICODE or :INFERRED, each of which is +interpreted as described in the documentation. + +Because there's some risk that unsolicited newline translation could have +undesirable consequences, the initial value of this variable in Clozure CL +is :UNIX.") + +(defstruct (external-format (:constructor %make-external-format) + (:copier nil)) + (character-encoding :default :read-only t) + (line-termination :default :read-only t)) + +(defmethod print-object ((ef external-format) stream) + (print-unreadable-object (ef stream :type t :identity t) + (format stream "~s/~s" (external-format-character-encoding ef) (external-format-line-termination ef)))) + + + +(defvar *external-formats* (make-hash-table :test #'equal)) + +(defun make-external-format (&key (domain t) + (character-encoding :default) + (line-termination :default)) + (if (eq line-termination :default) + (setq line-termination *default-line-termination*)) + (unless (assq line-termination *canonical-line-termination-conventions*) + (error "~S is not a known line-termination format." line-termination)) + + (if (eq character-encoding :default) + (setq character-encoding + (default-character-encoding domain))) + (unless (lookup-character-encoding character-encoding) + (error "~S is not the name of a known character encoding." + character-encoding)) + (let* ((pair (cons character-encoding line-termination))) + (declare (dynamic-extent pair)) + (or (gethash pair *external-formats*) + (setf (gethash (cons character-encoding line-termination) *external-formats*) + (%make-external-format :character-encoding character-encoding + :line-termination line-termination))))) + + + +(defun normalize-external-format (domain external-format) + (cond ((listp external-format) + (unless (plistp external-format) + (error "External-format ~s is not a property list." external-format)) + (normalize-external-format domain (apply #'make-external-format :domain domain external-format))) + ((typep external-format 'external-format) + external-format) + ((eq external-format :default) + (normalize-external-format domain *default-external-format*)) + ((lookup-character-encoding external-format) + (normalize-external-format domain `(:character-encoding ,external-format))) + ((assq external-format *canonical-line-termination-conventions*) + (normalize-external-format domain `(:line-termination ,external-format))) + (t + (error "Invalid external-format: ~s" external-format)))) + + + + + + + +;;; Establish a new position for the specified file-stream. +(defun file-ioblock-seek (file-ioblock newoctetpos) + (let* ((result (fd-lseek + (file-ioblock-device file-ioblock) newoctetpos #$SEEK_SET))) + (if (< result 0) + (error 'simple-stream-error + :stream (file-ioblock-stream file-ioblock) + :format-control (format nil "Can't set file position to ~d: ~a" + newoctetpos (%strerror result))) + newoctetpos))) + +;;; For input streams, getting/setting the position is fairly simple. +;;; Getting the position is a simple matter of adding the buffer +;;; origin to the current position within the buffer. +;;; Setting the position involves either adjusting the buffer index +;;; (if the new position is within the current buffer) or seeking +;;; to a new position. + +(defun %ioblock-input-file-position (file-ioblock newpos) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (inbuf (file-ioblock-inbuf file-ioblock)) + (curpos (+ element-base (io-buffer-idx inbuf)))) + (if (null newpos) + curpos + (progn + (if (and (>= newpos element-base) + (< newpos (+ element-base (io-buffer-count inbuf)))) + (setf (io-buffer-idx inbuf) (- newpos element-base)) + (file-ioblock-seek-and-reset file-ioblock + (ioblock-elements-to-octets + file-ioblock + newpos))) + newpos)))) + +;;; For (pure) output streams, it's a little more complicated. If we +;;; have to seek to a new origin, we may need to flush the buffer +;;; first. + +(defun %ioblock-output-file-position (file-ioblock newpos) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (outbuf (file-ioblock-outbuf file-ioblock)) + (curpos (+ element-base (io-buffer-idx outbuf))) + (maxpos (+ element-base (io-buffer-count outbuf)))) + (if (null newpos) + curpos + (progn + (unless (= newpos 0) + (setf (ioblock-pending-byte-order-mark file-ioblock) nil)) + (if (and (>= newpos element-base) + (<= newpos maxpos)) + ;; Backing up is easy. Skipping forward (without flushing + ;; and seeking) would be hard, 'cause we can't tell what + ;; we're skipping over. + (let* ((newidx (- newpos element-base))) + (setf (io-buffer-idx outbuf) newidx)) + (progn + (when (file-ioblock-dirty file-ioblock) + (fd-stream-force-output (file-ioblock-stream file-ioblock) + file-ioblock + (io-buffer-count outbuf) + nil) + ;; May have just extended the file; may need to update + ;; fileeof. + (when (> maxpos (file-ioblock-fileeof file-ioblock)) + (setf (file-ioblock-fileeof file-ioblock) maxpos))) + (file-ioblock-seek-and-reset file-ioblock + (ioblock-elements-to-octets + file-ioblock + newpos)))) + newpos)))) + +;;; For I/O file streams, there's an additional complication: if we +;;; back up within the (shared) buffer and the old position was beyond +;;; the buffer's input count, we have to set the input count to the +;;; old position. (Consider the case of writing a single element at +;;; the end-of-file, backing up one element, then reading the element +;;; we wrote.) We -can- skip forward over stuff that's been read; +;;; if the buffer's dirty, we'll eventually write it back out. + +(defun %ioblock-io-file-position (file-ioblock newpos) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (outbuf (file-ioblock-outbuf file-ioblock)) ; outbuf = inbuf + (curidx (io-buffer-idx outbuf)) + (curpos (+ element-base curidx))) + (if (null newpos) + curpos + (let* ((incount (io-buffer-count outbuf))) + (unless (= newpos 0) + (setf (ioblock-pending-byte-order-mark file-ioblock) nil)) + (cond + ((and (>= newpos element-base) + (<= newpos curpos)) + ;; If we've read less than we've written, make what's + ;; been written available for subsequent input. + (when (> curidx incount) + (setf (io-buffer-count outbuf) curidx)) + (setf (io-buffer-idx outbuf) (- newpos element-base))) + ((and (>= newpos element-base) + (< newpos (+ element-base incount))) + (setf (io-buffer-idx outbuf) (- newpos element-base))) + (t + (let* ((maxpos (+ element-base (io-buffer-count outbuf)))) + (when (> maxpos (file-ioblock-fileeof file-ioblock)) + (setf (file-ioblock-fileeof file-ioblock) maxpos))) + (when (file-ioblock-dirty file-ioblock) + (file-ioblock-seek file-ioblock octet-base) + (fd-stream-force-output (file-ioblock-stream file-ioblock) + file-ioblock + (io-buffer-count outbuf) + nil)) + (file-ioblock-seek-and-reset file-ioblock + (ioblock-elements-to-octets + file-ioblock newpos)))) + newpos)))) + +;;; Again, it's simplest to define this in terms of the stream's direction. +;;; Note that we can't change the size of file descriptors open for input +;;; only. + +(defun %ioblock-input-file-length (file-ioblock newlen) + (unless newlen + (file-ioblock-fileeof file-ioblock))) + +(defun %ioblock-output-file-length (file-ioblock newlen) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (outbuf (file-ioblock-outbuf file-ioblock)) + (curidx (io-buffer-idx outbuf)) + (maxpos (+ element-base (io-buffer-count outbuf))) + (curlen (file-ioblock-fileeof file-ioblock))) + (if (> maxpos curlen) + (setf (file-ioblock-fileeof file-ioblock) (setq curlen maxpos))) + (if (null newlen) + curlen + (let* ((fd (file-ioblock-device file-ioblock)) + (new-octet-eof (ioblock-elements-to-octets file-ioblock newlen)) + (cur-octet-pos (fd-tell fd))) + (cond ((> newlen curlen) + ;; Extend the file; maintain the current position. + ;; ftruncate isn't guaranteed to extend a file past + ;; its current EOF. Seeking to the new EOF, then + ;; writing, is guaranteed to do so. Seek to the + ;; new EOF, write a random byte, truncate to the + ;; specified length, then seek back to where we + ;; were and pretend that nothing happened. + (file-ioblock-seek file-ioblock new-octet-eof) + (%stack-block ((buf 1)) + (fd-write fd buf 1)) + (fd-ftruncate fd new-octet-eof) + (file-ioblock-seek file-ioblock cur-octet-pos)) + ((> newlen maxpos) + ;; Make the file shorter. Doesn't affect + ;; our position or anything that we have buffered. + (fd-ftruncate fd new-octet-eof)) + ((< newlen element-base) + ;; Discard any buffered output. Truncate the + ;; file, then seek to the new EOF. + (fd-ftruncate fd new-octet-eof) + (file-ioblock-seek-and-reset file-ioblock new-octet-eof)) + (t + (fd-ftruncate fd new-octet-eof) + (let* ((newidx (- newlen element-base))) + (when (> maxpos newlen) + (setf (io-buffer-count outbuf) newidx)) + (when (> curidx newidx) + (setf (io-buffer-idx outbuf) newidx))))) + (setf (file-ioblock-fileeof file-ioblock) newlen))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defclass fundamental-file-stream (fd-stream file-stream) + ((filename :initform nil :initarg :filename :accessor file-stream-filename) + (actual-filename :initform nil :initarg :actual-filename) + (external-format :initform :default :initarg :external-format + :accessor file-stream-external-format))) + + + +(defmethod stream-filename ((s fundamental-file-stream)) + (file-stream-filename s)) + +(defmethod stream-actual-filename ((s file-stream)) + (slot-value s 'actual-filename)) + +(defmethod (setf stream-filename) (new (s fundamental-file-stream)) + (setf (file-stream-filename s) new)) + +(defmethod (setf stream-actual-filename) (new (s fundamental-file-stream)) + (setf (slot-value s 'actual-filename) new)) + +(defun print-file-stream (s out) + (print-unreadable-object (s out :type t :identity t) + (let* ((file-ioblock (stream-ioblock s nil))) + (format out "(~s/" (stream-filename s)) + (if file-ioblock + (format out "~d ~a)" (file-ioblock-device file-ioblock) (encoding-name (ioblock-encoding file-ioblock))) + (format out ":closed"))))) + +(defmethod print-object ((s fundamental-file-stream) out) + (print-file-stream s out)) + +(make-built-in-class 'basic-file-stream 'file-stream 'basic-stream) + +(defmethod stream-filename ((s basic-file-stream)) + (basic-file-stream.filename s)) + +(defmethod stream-actual-filename ((s basic-file-stream)) + (basic-file-stream.actual-filename s)) + +(defmethod (setf stream-filename) (new (s basic-file-stream)) + (setf (basic-file-stream.filename s) new)) + +(defmethod (setf stream-actual-filename) (new (s basic-file-stream)) + (setf (basic-file-stream.actual-filename s) new)) + +(defmethod print-object ((s basic-file-stream) out) + (print-file-stream s out)) + + +(defmethod initialize-basic-stream ((s basic-file-stream) &key element-type external-format &allow-other-keys) + (setf (getf (basic-stream.info s) :element-type) element-type) + (setf (basic-file-stream.external-format s) external-format)) + +(defmethod stream-create-ioblock ((stream fundamental-file-stream) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-file-ioblock :stream stream args)) + +(defmethod stream-create-ioblock ((stream basic-file-stream) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-file-ioblock :stream stream args)) + +(defclass fundamental-file-input-stream (fundamental-file-stream fd-input-stream) + ()) + +(make-built-in-class 'basic-file-input-stream 'basic-file-stream 'basic-input-stream) + + +(defclass fundamental-file-output-stream (fundamental-file-stream fd-output-stream) + ()) + +(make-built-in-class 'basic-file-output-stream 'basic-file-stream 'basic-output-stream) + +(defclass fundamental-file-io-stream (fundamental-file-stream fd-io-stream) + ()) + +(make-built-in-class 'basic-file-io-stream 'basic-file-stream 'basic-io-stream) + + +(defclass fundamental-file-character-input-stream (fundamental-file-input-stream + fd-character-input-stream) + ()) + +(make-built-in-class 'basic-file-character-input-stream 'basic-file-input-stream 'basic-character-input-stream) + + +(defclass fundamental-file-character-output-stream (fundamental-file-output-stream + fd-character-output-stream) + ()) + +(make-built-in-class 'basic-file-character-output-stream 'basic-file-output-stream 'basic-character-output-stream) + +(defclass fundamental-file-character-io-stream (fundamental-file-io-stream + fd-character-io-stream) + ()) + +(make-built-in-class 'basic-file-character-io-stream 'basic-file-io-stream 'basic-character-io-stream) + +(defclass fundamental-file-binary-input-stream (fundamental-file-input-stream + fd-binary-input-stream) + ()) + +(make-built-in-class 'basic-file-binary-input-stream 'basic-file-input-stream 'basic-binary-input-stream) + +(defclass fundamental-file-binary-output-stream (fundamental-file-output-stream + fd-binary-output-stream) + ()) + +(make-built-in-class 'basic-file-binary-output-stream 'basic-file-output-stream 'basic-binary-output-stream) + +(defclass fundamental-file-binary-io-stream (fundamental-file-io-stream fd-binary-io-stream) + ()) + +(make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream) + + + + +;;; This stuff is a lot simpler if we restrict the hair to the +;;; case of file streams opened in :io mode (which have to worry +;;; about flushing the shared buffer before filling it, and things +;;; like that.) + +(defmethod stream-clear-input ((f fundamental-file-input-stream)) + (with-stream-ioblock-input (file-ioblock f :speedy t) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil)) + + +(defmethod stream-clear-input ((f basic-file-input-stream)) + (let* ((file-ioblock (basic-stream-ioblock f))) + (with-ioblock-input-locked (file-ioblock) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil))) + + +(defmethod stream-clear-input ((f fundamental-file-io-stream)) + (with-stream-ioblock-input (file-ioblock f :speedy t) + (stream-force-output f) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil)) + +(defmethod stream-clear-input ((f basic-file-io-stream)) + (let* ((file-ioblock (basic-stream-ioblock f))) + (with-ioblock-input-locked (file-ioblock) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil))) + +(defmethod stream-clear-output ((f fundamental-file-output-stream)) + (with-stream-ioblock-output (file-ioblock f :speedy t) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil)) + +(defmethod stream-clear-output ((f basic-file-output-stream)) + (let* ((file-ioblock (basic-stream-ioblock f))) + (with-ioblock-input-locked (file-ioblock) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil))) + + + +;;; If we've been reading, the file position where we're going +;;; to read this time is (+ where-it-was-last-time what-we-read-last-time.) +(defun input-file-ioblock-advance (stream file-ioblock read-p) + (let* ((newpos (+ (file-ioblock-octet-pos file-ioblock) + (io-buffer-count (file-ioblock-inbuf file-ioblock))))) + (setf (file-ioblock-octet-pos file-ioblock) newpos) + (fd-stream-advance stream file-ioblock read-p))) + +;;; If the buffer's dirty, we have to back up and rewrite it before +;;; reading in a new buffer. +(defun io-file-ioblock-advance (stream file-ioblock read-p) + (let* ((curpos (file-ioblock-octet-pos file-ioblock)) + (count (io-buffer-count (file-ioblock-inbuf file-ioblock))) + (newpos (+ curpos + (ioblock-elements-to-octets file-ioblock count)))) + (when (ioblock-dirty file-ioblock) + (file-ioblock-seek file-ioblock curpos) + (fd-stream-force-output stream file-ioblock count nil)) + (unless (eql newpos (file-octet-filepos file-ioblock)) + (error "Expected newpos to be ~d, fd is at ~d" + newpos (file-octet-filepos file-ioblock))) + (setf (file-ioblock-octet-pos file-ioblock) newpos) + (fd-stream-advance stream file-ioblock read-p))) + + +(defun output-file-force-output (stream file-ioblock count finish-p) + (let* ((pos (%ioblock-output-file-position file-ioblock nil)) + (n (fd-stream-force-output stream file-ioblock count finish-p))) + (incf (file-ioblock-octet-pos file-ioblock) (or n 0)) + (%ioblock-output-file-position file-ioblock pos) + n)) + +;;; Can't be sure where the underlying fd is positioned, so seek first. +(defun io-file-force-output (stream file-ioblock count finish-p) + (let* ((pos (%ioblock-io-file-position file-ioblock nil))) + (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock)) + (let* ((n (fd-stream-force-output stream file-ioblock count finish-p))) + (incf (file-ioblock-octet-pos file-ioblock) (or n 0)) + (%ioblock-io-file-position file-ioblock pos) + n))) + + +;;; Invalidate both buffers and seek to the new position. The output +;;; buffer's been flushed already if it needed to be. + +(defun file-ioblock-seek-and-reset (file-ioblock newoctetpos) + (let* ((inbuf (file-ioblock-inbuf file-ioblock)) + (outbuf (file-ioblock-outbuf file-ioblock))) + (setf (file-ioblock-dirty file-ioblock) nil) + (when inbuf + (setf (io-buffer-count inbuf) 0 + (io-buffer-idx inbuf) 0)) + (when outbuf + (setf (io-buffer-count outbuf) 0 + (io-buffer-idx outbuf) 0)) + (setf (file-ioblock-octet-pos file-ioblock) newoctetpos) + (file-ioblock-seek file-ioblock newoctetpos))) + +(defmethod stream-position ((stream fundamental-file-input-stream) &optional newpos) + (with-stream-ioblock-input (file-ioblock stream :speedy t) + (%ioblock-input-file-position file-ioblock newpos))) + + +(defmethod stream-position ((stream basic-file-input-stream) &optional newpos) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (%ioblock-input-file-position file-ioblock newpos)))) + +(defmethod stream-position ((stream fundamental-file-output-stream) &optional newpos) + (with-stream-ioblock-output (file-ioblock stream :speedy t) + (%ioblock-output-file-position file-ioblock newpos))) + +(defmethod stream-position ((stream basic-file-output-stream) &optional newpos) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (file-ioblock) + (%ioblock-output-file-position file-ioblock newpos)))) + + +(defmethod stream-position ((stream fundamental-file-io-stream) &optional newpos) + (with-stream-ioblock-input (file-ioblock stream :speedy t) + (%ioblock-io-file-position file-ioblock newpos))) + +(defmethod stream-position ((stream basic-file-io-stream) &optional newpos) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (%ioblock-io-file-position file-ioblock newpos)))) + + +(defmethod stream-length ((stream fundamental-file-input-stream) &optional newlen) + (with-stream-ioblock-input (file-ioblock stream :speedy t) + (let* ((res (%ioblock-input-file-length file-ioblock newlen))) + (and res (>= res 0) res)))) + + +(defmethod stream-length ((stream basic-file-input-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (let* ((res (%ioblock-input-file-length file-ioblock newlen))) + (and res (>= res 0) res))))) + + +(defmethod stream-length ((s fundamental-file-output-stream) &optional newlen) + (with-stream-ioblock-output (file-ioblock s :speedy t) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res)))) + + +(defmethod stream-length ((stream basic-file-output-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (file-ioblock) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res))))) + +(defmethod stream-length ((s fundamental-file-io-stream) &optional newlen) + (with-stream-ioblock-input (file-ioblock s :speedy t) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res)))) + +(defmethod stream-length ((stream basic-file-io-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res))))) + +(defun close-file-stream (s abort) + (when (open-stream-p s) + (let* ((ioblock (stream-ioblock s t)) + (filename (stream-filename s)) + (actual-filename (stream-actual-filename s))) + (when actual-filename ; t => created when opened + (if abort + (progn + (setf (ioblock-dirty ioblock) nil) + (fd-stream-close s ioblock) + (if (eq actual-filename t) + (delete-file filename) + (unix-rename (namestring actual-filename) (probe-file-x filename)))) + (unless (eq actual-filename t) + (delete-file actual-filename)))) + (remove-open-file-stream s)))) + + +(defmethod close ((s fundamental-file-stream) &key abort) + (close-file-stream s abort) + (call-next-method)) + +(defmethod close ((s basic-file-stream) &key abort) + (close-file-stream s abort) + (call-next-method)) + +(defmethod select-stream-class ((class fundamental-file-stream) in-p out-p char-p) + (if char-p + (if (and in-p out-p) + 'fundamental-file-character-io-stream + (if in-p + 'fundamental-file-character-input-stream + (if out-p + 'fundamental-file-character-output-stream + 'fundamental-file-stream))) + (if (and in-p out-p) + 'fundamental-file-binary-io-stream + (if in-p + 'fundamental-file-binary-input-stream + (if out-p + 'fundamental-file-binary-output-stream + 'fundamental-file-stream))))) + +(defmethod select-stream-class ((class file-stream) in-p out-p char-p) + (if char-p + (if (and in-p out-p) + 'fundamental-file-character-io-stream + (if in-p + 'fundamental-file-character-input-stream + (if out-p + 'fundamental-file-character-output-stream + 'fundamental-file-stream))) + (if (and in-p out-p) + 'fundamental-file-binary-io-stream + (if in-p + 'fundamental-file-binary-input-stream + (if out-p + 'fundamental-file-binary-output-stream + 'fundamental-file-stream))))) + +(defmethod map-to-basic-stream-class-name ((name (eql 'fundamental-file-stream))) + 'basic-file-stream) + +(defmethod map-to-basic-stream-class-name ((name (eql 'file-stream))) + 'basic-file-stream) + +(defmethod select-stream-class ((class (eql 'basic-file-stream)) in-p out-p char-p) + (if char-p + (if (and in-p out-p) + 'basic-file-character-io-stream + (if in-p + 'basic-file-character-input-stream + (if out-p + 'basic-file-character-output-stream + 'basic-file-stream))) + (if (and in-p out-p) + 'basic-file-binary-io-stream + (if in-p + 'basic-file-binary-input-stream + (if out-p + 'basic-file-binary-output-stream + 'basic-file-stream))))) + + +(defmethod select-stream-advance-function ((s file-stream) direction) + (ecase direction + (:io 'io-file-ioblock-advance) + (:input 'input-file-ioblock-advance))) + +(defmethod select-stream-force-output-function ((s file-stream) direction) + (ecase direction + (:io 'io-file-force-output) + (:output 'output-file-force-output))) + +(defmethod select-stream-untyi-function ((s file-stream) (direction t)) + '%file-ioblock-untyi) + +;;; Conceptually, decrement the stream's position by the number of octets +;;; needed to encode CHAR. +;;; Since we don't use IOBLOCK-UNTYI-CHAR, it's hard to detect the error +;;; of calling UNREAD-CHAR twice in a row. +(defun %file-ioblock-untyi (ioblock char) + (let* ((inbuf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx inbuf)) + (encoding (ioblock-encoding ioblock)) + (noctets (if encoding + (funcall (character-encoding-character-size-in-octets-function encoding) char) + 1))) + (declare (fixnum idx noctets)) + (if (>= idx noctets) + (setf (io-buffer-idx inbuf) (the fixnum (- idx noctets))) + (let* ((stream (ioblock-stream ioblock)) + (pos (stream-position stream)) + (newpos (- pos noctets))) + (if (< newpos 0) + (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock)) + (stream-position stream newpos)))) + char)) + + + +(defun make-file-stream (filename + direction + element-type + if-exists + if-does-not-exist + class + external-format + sharing + basic) + (let* ((temp-name nil) + (created nil) + (dir (pathname-directory filename)) + (filename (if (eq (car dir) :relative) + (full-pathname filename) + filename)) + (pathname (pathname filename))) + (block open + (if (or (memq element-type '(:default character base-char)) + (subtypep element-type 'character)) + (if (eq element-type :default)(setq element-type 'character)) + (progn + (setq element-type (type-expand element-type)) + (cond ((equal element-type '#.(type-expand 'signed-byte)) + (setq element-type '(signed-byte 8))) + ((equal element-type '#.(type-expand 'unsigned-byte)) + (setq element-type '(unsigned-byte 8)))))) + (case direction + (:probe (setq if-exists :ignored)) + (:input (setq if-exists :ignored)) + ((:io :output) nil) + (t (report-bad-arg direction '(member :input :output :io :probe)))) + (check-pathname-not-wild filename) ;; probe-file-x misses wild versions.... + (multiple-value-bind (native-truename kind)(probe-file-x filename) + (if native-truename + (if (eq kind :directory) + (if (eq direction :probe) + (return-from open nil) + (signal-file-error (- #$EISDIR) filename)) + (if (setq filename (if-exists if-exists filename "Open ...")) + (progn + (multiple-value-setq (native-truename kind) (probe-file-x filename)) + (cond + ((not native-truename) + (setq native-truename (%create-file filename) + created t)) + ((memq direction '(:output :io)) + (when (eq if-exists :supersede) + (let ((truename (native-to-pathname native-truename))) + (setq temp-name (gen-file-name truename)) + (unix-rename native-truename (native-untranslated-namestring temp-name)) + (%create-file native-truename)))))) + (return-from open nil))) + (if (setq filename (if-does-not-exist if-does-not-exist filename)) + (progn + (unless (setq native-truename (%create-file filename :if-exists if-exists)) + (return-from open nil)) + (setq created t)) + (return-from open nil))) + (let* ((fd (fd-open native-truename (case direction + ((:probe :input) #$O_RDONLY) + (:output #$O_WRONLY) + (:io #$O_RDWR))))) + (when (< fd 0) (signal-file-error fd filename)) + (let* ((fd-kind (%unix-fd-kind fd))) + (if (not (eq fd-kind :file)) + (make-fd-stream fd :direction direction + :element-type element-type + :sharing sharing + :basic basic) + (progn + (when basic + (setq class (map-to-basic-stream-class-name class)) + (setq basic (subtypep (find-class class) 'basic-stream))) + (let* ((in-p (member direction '(:io :input))) + (out-p (member direction '(:io :output))) + (io-p (eq direction :io)) + (char-p (or (eq element-type 'character) + (subtypep element-type 'character))) + (elements-per-buffer (optimal-buffer-size fd element-type)) + (real-external-format + (if char-p + (normalize-external-format :file external-format) + )) + (line-termination (if char-p (external-format-line-termination real-external-format))) + (encoding (if char-p (external-format-character-encoding real-external-format))) + (class-name (select-stream-class class in-p out-p char-p)) + (class (find-class class-name)) + (fstream (make-ioblock-stream + class + :insize (if in-p elements-per-buffer) + :outsize (if (and out-p (not io-p)) + elements-per-buffer) + :share-buffers-p io-p + :interactive nil + :direction direction + :element-type element-type + :direction direction + :listen-function 'fd-stream-listen + :close-function 'fd-stream-close + :advance-function + (if in-p (select-stream-advance-function class direction)) + :force-output-function + (if out-p (select-stream-force-output-function + class direction)) + :device fd + :encoding encoding + :external-format (or real-external-format :binary) + :sharing sharing + :line-termination line-termination + :character-p (or (eq element-type 'character) + (subtypep element-type 'character)))) + (ioblock (stream-ioblock fstream t))) + (setf (stream-filename fstream) (namestring pathname) + (stream-actual-filename fstream) (or temp-name created)) + (setf (file-ioblock-fileeof ioblock) + (ioblock-octets-to-elements ioblock (fd-size fd))) + (when (and in-p (eq line-termination :inferred)) + (infer-line-termination ioblock)) + (cond ((eq if-exists :append) + (file-position fstream :end)) + ((and (memq direction '(:io :output)) + (neq if-exists :overwrite)) + (stream-length fstream 0))) + (if (eq direction :probe) + (close fstream) + (note-open-file-stream fstream)) + fstream))))))))) + + + + + + +(defmethod stream-external-format ((s broadcast-stream)) + (let* ((last (last-broadcast-stream s))) + (if last + (stream-external-format s) + :default))) + +;;; Under the circumstances, this is a very slow way of saying +;;; "we don't support EXTENDED-CHARs". +(defun file-string-length (stream object) + "Return the delta in STREAM's FILE-POSITION that would be caused by writing + OBJECT to STREAM. Non-trivial only in implementations that support + international character sets." + (if (typep stream 'broadcast-stream) + (let* ((last (last-broadcast-stream stream))) + (if last + (file-string-length last object) + 1)) + (progn + (unless (and (typep stream 'file-stream) + (let* ((eltype (stream-element-type stream))) + (or (eq 'character eltype) + (eq 'base-char eltype) + (subtypep eltype 'character)))) + (error "~S is not a file stream capable of character output" stream)) + (if (typep object 'character) + (setq object (make-string 1 :initial-element object)) + (progn + (require-type object 'string))) + (let* ((start 0) + (end (length object))) + (multiple-value-bind (data offset) (array-data-and-offset object) + (unless (eq data object) + (setq object data) + (incf start offset) + (incf end offset))) + (let* ((external-format (stream-external-format stream)) + (encoding (get-character-encoding (external-format-character-encoding external-format))) + (line-termination (external-format-line-termination external-format))) + (- + (+ (funcall (character-encoding-octets-in-string-function encoding) + object + start + end) + (if (eq line-termination :crlf) + (* (count #\Newline object :start start :end end) + (file-string-length stream #\Return)) + 0)) + (if (eql (file-position stream) 0) + 0 + (length (character-encoding-bom-encoding encoding))))))))) + Index: /branches/qres/ccl/level-1/l1-typesys.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-typesys.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-typesys.lisp (revision 13564) @@ -0,0 +1,4393 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; This is a hacked-up version of the CMU CL type system. + +(in-package "CCL") + + + +;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that +;;; compiler warnings can be emitted as appropriate. +;;; +(define-condition parse-unknown-type (condition) + ((specifier :reader parse-unknown-type-specifier :initarg :specifier)) + (:report (lambda (c s) (print-unreadable-object (c s :type t) + (format s "unknown type ~A" (parse-unknown-type-specifier c)))))) + +(defun parse-lambda-list (list) + (let* ((required) + (optional) + (keys) + (aux)) + (let ((restp nil) + (rest nil) + (keyp nil) + (allowp nil) + (state :required)) + (dolist (arg list) + (if (and (symbolp arg) + (let ((name (symbol-name arg))) + (and (/= (length name) 0) + (char= (char name 0) #\&)))) + (case arg + (&optional + (unless (eq state :required) + (error "Misplaced &optional in lambda-list: ~S." list)) + (setq state '&optional)) + (&rest + (unless (member state '(:required &optional)) + (error "Misplaced &rest in lambda-list: ~S." list)) + (setq state '&rest)) + (&key + (unless (member state '(:required &optional :post-rest + )) + (error "Misplaced &key in lambda-list: ~S." list)) + (setq keyp t) + (setq state '&key)) + (&allow-other-keys + (unless (eq state '&key) + (error "Misplaced &allow-other-keys in lambda-list: ~S." list)) + (setq allowp t state '&allow-other-keys)) + (&aux + (when (member state '(&rest)) + (error "Misplaced &aux in lambda-list: ~S." list)) + (setq state '&aux)) + (t + (error "Unknown &keyword in lambda-list: ~S." arg))) + (case state + (:required (push arg required)) + (&optional (push arg optional)) + (&rest + (setq restp t rest arg state :post-rest)) + (&key (push arg keys)) + (&aux (push arg aux)) + (t + (error "Found garbage in lambda-list when expecting a keyword: ~S." arg))))) + + (values (nreverse required) (nreverse optional) restp rest keyp (nreverse keys) allowp (nreverse aux))))) + +(defvar %deftype-expanders% (make-hash-table :test #'eq)) +(defvar *type-translators* (make-hash-table :test #'eq)) +(defvar *builtin-type-info* (make-hash-table :test #'equal)) +(defvar %builtin-type-cells% (make-hash-table :test 'equal)) + +(defvar *use-implementation-types* t) + +(defun info-type-builtin (name) + (gethash name *builtin-type-info*)) + +(defun (setf info-type-builtin) (val name) + (setf (gethash name *builtin-type-info*) val)) + +(defun info-type-translator (name) + (gethash name *type-translators*)) + + + + +;;; Allow bootstrapping: mostly, allow us to bootstrap the type system +;;; by having DEFTYPE expanders defined on built-in classes (the user +;;; shouldn't be allowed to do so, at least not easily. + +;(defvar *type-system-initialized* nil) + +(defun %deftype (name fn doc) + (clear-type-cache) + (cond ((null fn) + (remhash name %deftype-expanders%)) + ((and *type-system-initialized* + (or (built-in-type-p name) + (let ((c (find-class name nil))) + (and c (eq (class-name c) name))))) + (error "Cannot redefine type ~S because ~:[it is the name of a class~;it is a built-in type~]" name (built-in-type-p name))) + ((memq name *nx-known-declarations*) + (check-declaration-redefinition name 'deftype)) + (t (setf (gethash name %deftype-expanders%) fn) + (record-source-file name 'type))) + (set-documentation name 'type doc) ; nil clears it. + name) + +(defun %define-type-translator (name fn doc) + (declare (ignore doc)) + (setf (gethash name *type-translators*) fn) + name) + +;;;(defun %deftype-expander (name) +;;; (or (gethash name %deftype-expanders%) +;;; (and *compiling-file* (%cdr (assq name *compile-time-deftype-expanders*))))) +(defun %deftype-expander (name) + (gethash name %deftype-expanders%)) + +(defun process-deftype-arglist (arglist &aux (in-optional? nil)) + "Returns a NEW list similar to arglist except + inserts * as the default default for &optional args." + (mapcar #'(lambda (item) + (cond ((eq item '&optional) (setq in-optional? t) item) + ((memq item lambda-list-keywords) (setq in-optional? nil) item) + ((and in-optional? (symbolp item)) (list item ''*)) + (t item))) + arglist)) + + +(defun expand-type-macro (definer name arglist body env) + (setq name (require-type name 'symbol)) + (multiple-value-bind (lambda doc) + (parse-macro-internal name arglist body env '*) + `(progn + (eval-when (:compile-toplevel) + (note-type-info ',name 'macro ,env)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (,definer ',name + (nfunction ,name ,lambda) + ,doc))))) + +(defmacro deftype (name arglist &body body &environment env) + "Define a new type, with syntax like DEFMACRO." + (expand-type-macro '%deftype name arglist body env)) + +(defmacro def-type-translator (name arglist &body body &environment env) + (expand-type-macro '%define-type-translator name arglist body env)) + + +(defun type-expand (form &optional env &aux def) + (while (setq def (cond ((symbolp form) + (gethash form %deftype-expanders%)) + ((and (consp form) (symbolp (%car form))) + (gethash (%car form) %deftype-expanders%)) + (t nil))) + (setq form (funcall def (if (consp form) form (list form)) env))) + form) + +(defmethod print-object ((tc type-class) stream) + (print-unreadable-object (tc stream :type t :identity t) + (format stream "~s" (type-class-name tc)))) + +(defmethod print-object ((c ctype) stream) + (print-unreadable-object (c stream :type t) + (format stream "~S" (type-specifier c)))) + +(defmethod make-load-form ((c ctype) &optional env) + (declare (ignore env)) + `(specifier-type ',(type-specifier c))) + +(defmethod make-load-form ((cell type-cell) &optional env) + (declare (ignore env)) + `(register-type-cell `,(type-cell-type-specifier cell))) + +(defmethod print-object ((cell type-cell) stream) + (print-unreadable-object (cell stream :type t :identity t) + (format stream "for ~s" (type-cell-type-specifier cell)))) + +(defun make-key-info (&key name type) + (%istruct 'key-info name type)) + +(defun type-class-or-lose (name) + (or (cdr (assq name *type-classes*)) + (error "~S is not a defined type class." name))) + +(eval-when (:compile-toplevel :execute) + +(defconstant type-class-function-slots + '((:simple-subtypep . #.type-class-simple-subtypep) + (:complex-subtypep-arg1 . #.type-class-complex-subtypep-arg1) + (:complex-subtypep-arg2 . #.type-class-complex-subtypep-arg2) + (:simple-union . #.type-class-simple-union) + (:complex-union . #.type-class-complex-union) + (:simple-intersection . #.type-class-simple-intersection) + (:complex-intersection . #.type-class-complex-intersection) + (:simple-= . #.type-class-simple-=) + (:complex-= . #.type-class-complex-=) + (:unparse . #.type-class-unparse))) + +) + +(defun class-typep (form class) + (memq class (%inited-class-cpl (class-of form)))) + +;;; CLASS-FUNCTION-SLOT-OR-LOSE -- Interface +;;; +(defun class-function-slot-or-lose (name) + (or (cdr (assoc name type-class-function-slots)) + (error "~S is not a defined type class method." name))) + + +(eval-when (:compile-toplevel :execute) + +;;; INVOKE-TYPE-METHOD -- Interface +;;; +;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same +;;; class, invoke the simple method. Otherwise, invoke any complex method. If +;;; there isn't a distinct complex-arg1 method, then swap the arguments when +;;; calling type1's method. If no applicable method, return DEFAULT. +;;; + +(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key + (default '(values nil t)) + complex-arg1) + (let ((simple (class-function-slot-or-lose simple)) + (cslot1 (class-function-slot-or-lose (or complex-arg1 complex-arg2))) + (cslot2 (class-function-slot-or-lose complex-arg2))) + (once-only ((n-type1 type1) + (n-type2 type2)) + (once-only ((class1 `(ctype-class-info ,n-type1)) + (class2 `(ctype-class-info ,n-type2))) + `(if (eq ,class1 ,class2) + (funcall (%svref ,class1 ,simple) ,n-type1 ,n-type2) + ,(once-only ((complex1 `(%svref ,class1 ,cslot1)) + (complex2 `(%svref ,class2 ,cslot2))) + `(cond (,complex2 (funcall ,complex2 ,n-type1 ,n-type2)) + (,complex1 + ,(if complex-arg1 + `(funcall ,complex1 ,n-type1 ,n-type2) + `(funcall ,complex1 ,n-type2 ,n-type1))) + (t ,default)))))))) + + + +;;;; Utilities: + +;;; ANY-TYPE-OP, EVERY-TYPE-OP -- Interface +;;; +;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates. +;;; If the result is uncertain, then we return Default from the block PUNT. +;;; If LIST-FIRST is true, then the list element is the first arg, otherwise +;;; the second. +;;; +(defmacro any-type-op (op thing list &key (default '(values nil nil)) + list-first) + (let ((n-this (gensym)) + (n-thing (gensym)) + (n-val (gensym)) + (n-win (gensym)) + (n-uncertain (gensym))) + `(let ((,n-thing ,thing) + (,n-uncertain nil)) + (dolist (,n-this ,list + (if ,n-uncertain + (return-from PUNT ,default) + nil)) + (multiple-value-bind (,n-val ,n-win) + ,(if list-first + `(,op ,n-this ,n-thing) + `(,op ,n-thing ,n-this)) + (unless ,n-win (setq ,n-uncertain t)) + (when ,n-val (return t))))))) +;;; +(defmacro every-type-op (op thing list &key (default '(values nil nil)) + list-first) + (let ((n-this (gensym)) + (n-thing (gensym)) + (n-val (gensym)) + (n-win (gensym))) + `(let ((,n-thing ,thing)) + (dolist (,n-this ,list t) + (multiple-value-bind (,n-val ,n-win) + ,(if list-first + `(,op ,n-this ,n-thing) + `(,op ,n-thing ,n-this)) + (unless ,n-win (return-from PUNT ,default)) + (unless ,n-val (return nil))))))) + +) + + +;;; VANILLA-INTERSECTION -- Interface +;;; +;;; Compute the intersection for types that intersect only when one is a +;;; hierarchical subtype of the other. +;;; +(defun vanilla-intersection (type1 type2) + (multiple-value-bind (stp1 win1) + (csubtypep type1 type2) + (multiple-value-bind (stp2 win2) + (csubtypep type2 type1) + (cond (stp1 (values type1 t)) + (stp2 (values type2 t)) + ((and win1 win2) (values *empty-type* t)) + (t + (values type1 nil)))))) + + +;;; VANILLA-UNION -- Interface +;;; +(defun vanilla-union (type1 type2) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t nil))) + +(defun hierarchical-intersection2 (type1 type2) + (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) + (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) + (cond (subtypep1 type1) + (subtypep2 type2) + ((and win1 win2) *empty-type*) + (t nil))))) + +(defun hierarchical-union2 (type1 type2) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t nil))) + +;;; DELEGATE-COMPLEX-{SUBTYPEP-ARG2,INTERSECTION} -- Interface +;;; +;;; These functions are used as method for types which need a complex +;;; subtypep method to handle some superclasses, but cover a subtree of the +;;; type graph (i.e. there is no simple way for any other type class to be a +;;; subtype.) There are always still complex ways, namely UNION and MEMBER +;;; types, so we must give TYPE1's method a chance to run, instead of +;;; immediately returning NIL, T. +;;; +(defun delegate-complex-subtypep-arg2 (type1 type2) + (let ((subtypep-arg1 + (type-class-complex-subtypep-arg1 + (ctype-class-info type1)))) + (if subtypep-arg1 + (funcall subtypep-arg1 type1 type2) + (values nil t)))) +;;; +(defun delegate-complex-intersection (type1 type2) + (let ((method (type-class-complex-intersection (ctype-class-info type1)))) + (if (and method (not (eq method #'delegate-complex-intersection))) + (funcall method type2 type1) + (hierarchical-intersection2 type1 type2)))) + +;;; HAS-SUPERCLASSES-COMPLEX-SUBTYPEP-ARG1 -- Internal +;;; +;;; Used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 method. Info is +;;; a list of conses (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). Will +;;; never be called with a hairy type as type2, since the hairy type type2 +;;; method gets first crack. +;;; +#| +(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) + (values + (and (typep type2 'class) + (dolist (x info nil) + (when (or (not (cdr x)) + (csubtypep type1 (specifier-type (cdr x)))) + (return + (or (eq type2 (car x)) + (let ((inherits (layout-inherits (class-layout (car x))))) + (dotimes (i (length inherits) nil) + (when (eq type2 (layout-class (svref inherits i))) + (return t))))))))) + t)) +|# + +(eval-when (:compile-toplevel :execute) +;;; DEFINE-SUPERCLASSES -- Interface +;;; +;;; Takes a list of specs of the form (superclass &optional guard). +;;; Consider one spec (with no guard): any instance of type-class is also a +;;; subtype of SUPERCLASS and of any of its superclasses. If there are +;;; multiple specs, then some will have guards. We choose the first spec whose +;;; guard is a supertype of TYPE1 and use its superclass. In effect, a +;;; sequence of guards G0, G1, G2 is actually G0, (and G1 (not G0)), +;;; (and G2 (not (or G0 G1))). +;;; +#| +(defmacro define-superclasses (type-class &rest specs) + (let ((info + (mapcar #'(lambda (spec) + (destructuring-bind (super &optional guard) + spec + (cons (find-class super) guard))) + specs))) + `(progn + (setf (type-class-complex-subtypep-arg1 + (type-class-or-lose ',type-class)) + #'(lambda (type1 type2) + (has-superclasses-complex-subtypep-arg1 type1 type2 ',info))) + + (setf (type-class-complex-subtypep-arg2 + (type-class-or-lose ',type-class)) + #'delegate-complex-subtypep-arg2) + + (setf (type-class-complex-intersection + (type-class-or-lose ',type-class)) + #'delegate-complex-intersection)))) +|# + +); eval-when (compile eval) + + +(defun reparse-unknown-ctype (type) + (if (unknown-ctype-p type) + (specifier-type (type-specifier type)) + type)) + +(defun swapped-args-fun (f) + #'(lambda (x y) + (funcall f y x))) + +(defun equal-but-no-car-recursion (x y) + (cond ((eql x y) t) + ((consp x) + (and (consp y) + (eql (car x) (car y)) + (equal-but-no-car-recursion (cdr x) (cdr y)))) + (t nil))) + +(defun any/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (values nil certain?)) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (when sub-value (return (values t t))) + (setf certain? nil)))))) + +(defun every/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (if certain? (values t t) (values nil nil))) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (unless sub-value (return (values nil t))) + (setf certain? nil)))))) + +(defun invoke-complex-=-other-method (type1 type2) + (let* ((type-class (ctype-class-info type1)) + (method-fun (type-class-complex-= type-class))) + (if method-fun + (funcall (the function method-fun) type2 type1) + (values nil t)))) + +(defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win) + (let* ((type-class (ctype-class-info type1)) + (method-fun (type-class-complex-subtypep-arg1 type-class))) + (if method-fun + (funcall (the function method-fun) type1 type2) + (values subtypep win)))) + +(defun type-might-contain-other-types-p (type) + (or (hairy-ctype-p type) + (negation-ctype-p type) + (union-ctype-p type) + (intersection-ctype-p type))) + + +(eval-when (:compile-toplevel :execute) + +(defmacro define-type-method ((class method &rest more-methods) + lambda-list &body body) + `(progn + (let* ((fn (nfunction (,class ,method ,@more-methods) + (lambda ,lambda-list ,@body)))) + ,@(mapcar #'(lambda (method) + `(setf (%svref + (type-class-or-lose ',class) + ,(class-function-slot-or-lose method)) + fn)) + (cons method more-methods))) + nil)) + +) + + +(defun ctype-p (x) + (and (eql (typecode x) target::subtag-istruct) + (memq (istruct-type-name x) + '#.(cons 'ctype + (cons 'unknown-ctype + (append (mapcar #'class-name + (class-direct-subclasses (find-class 'args-ctype))) + (mapcar #'class-name + (class-direct-subclasses (find-class 'ctype))))))))) + + +(setf (type-predicate 'ctype) 'ctype-p) + + +;;;; Function and Values types. +;;; +;;; Pretty much all of the general type operations are illegal on VALUES +;;; types, since we can't discriminate using them, do SUBTYPEP, etc. FUNCTION +;;; types are acceptable to the normal type operations, but are generally +;;; considered to be equivalent to FUNCTION. These really aren't true types in +;;; any type theoretic sense, but we still parse them into CTYPE structures for +;;; two reasons: +;;; -- Parsing and unparsing work the same way, and indeed we can't tell +;;; whether a type is a function or values type without parsing it. +;;; -- Many of the places that can be annotated with real types can also be +;;; annotated function or values types. + +;; Methods on the VALUES type class. + +(defun make-values-ctype (&key + required + optional + rest + keyp + keywords + allowp) + (%istruct 'values-ctype + (type-class-or-lose 'values) + nil + required + optional + rest + keyp + keywords + allowp + )) + +(defun values-ctype-p (x) (istruct-typep x 'values-ctype)) +(setf (type-predicate 'values-ctype) 'values-ctype-p) + + +(define-type-method (values :simple-subtypep :complex-subtypep-arg1) + (type1 type2) + (declare (ignore type2)) + (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1))) + +(define-type-method (values :complex-subtypep-arg2) + (type1 type2) + (declare (ignore type1)) + (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) + + +(define-type-method (values :unparse) (type) + (cons 'values (unparse-args-types type))) + + +;;; TYPE=-LIST -- Internal +;;; +;;; Return true if List1 and List2 have the same elements in the same +;;; positions according to TYPE=. We return NIL, NIL if there is an uncertain +;;; comparison. +;;; +(defun type=-list (list1 list2) + (declare (list list1 list2)) + (do ((types1 list1 (cdr types1)) + (types2 list2 (cdr types2))) + ((or (null types1) (null types2)) + (if (or types1 types2) + (values nil t) + (values t t))) + (multiple-value-bind (val win) + (type= (first types1) (first types2)) + (unless win + (return (values nil nil))) + (unless val + (return (values nil t)))))) + +(define-type-method (values :simple-=) (type1 type2) + (let ((rest1 (args-ctype-rest type1)) + (rest2 (args-ctype-rest type2))) + (cond ((or (args-ctype-keyp type1) (args-ctype-keyp type2) + (args-ctype-allowp type1) (args-ctype-allowp type2)) + (values nil nil)) + ((and rest1 rest2 (type/= rest1 rest2)) + (type= rest1 rest2)) + ((or rest1 rest2) + (values nil t)) + (t + (multiple-value-bind (req-val req-win) + (type=-list (values-ctype-required type1) + (values-ctype-required type2)) + (multiple-value-bind (opt-val opt-win) + (type=-list (values-ctype-optional type1) + (values-ctype-optional type2)) + (values (and req-val opt-val) (and req-win opt-win)))))))) + + +;; Methods on the FUNCTION type class. + + +(defun make-function-ctype (&key + required + optional + rest + keyp + keywords + allowp + wild-args + returns) + (%istruct 'function-ctype + (type-class-or-lose 'function) + nil + required + optional + rest + keyp + keywords + allowp + wild-args + returns + )) + +(defun function-ctype-p (x) (istruct-typep x 'function-ctype)) +(setf (type-predicate 'function-ctype) 'function-ctype-p) + +;;; A flag that we can bind to cause complex function types to be unparsed as +;;; FUNCTION. Useful when we want a type that we can pass to TYPEP. +;;; +(defvar *unparse-function-type-simplify* nil) + +(define-type-method (function :unparse) (type) + (if *unparse-function-type-simplify* + 'function + (list 'function + (if (function-ctype-wild-args type) + '* + (unparse-args-types type)) + (type-specifier + (function-ctype-returns type))))) + +;;; Since all function types are equivalent to FUNCTION, they are all subtypes +;;; of each other. +;;; + +(define-type-method (function :simple-subtypep) (type1 type2) + (flet ((fun-type-simple-p (type) + (not (or (function-ctype-rest type) + (function-ctype-keyp type)))) + (every-csubtypep (types1 types2) + (loop + for a1 in types1 + for a2 in types2 + do (multiple-value-bind (res sure-p) + (csubtypep a1 a2) + (unless res (return (values res sure-p)))) + finally (return (values t t))))) + (macrolet ((3and (x y) + `(multiple-value-bind (val1 win1) ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) ,y + (if (and val1 val2) + (values t t) + (values nil (and win2 (not val2))))))))) + (3and (values-subtypep (function-ctype-returns type1) + (function-ctype-returns type2)) + (cond ((function-ctype-wild-args type2) (values t t)) + ((function-ctype-wild-args type1) + (cond ((function-ctype-keyp type2) (values nil nil)) + ((not (function-ctype-rest type2)) (values nil t)) + ((not (null (function-ctype-required type2))) (values nil t)) + (t (3and (type= *universal-type* (function-ctype-rest type2)) + (every/type #'type= *universal-type* + (function-ctype-optional type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (function-type-nargs type1) + (multiple-value-bind (min2 max2) (function-type-nargs type2) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (3and (every-csubtypep (function-ctype-required type1) + (function-ctype-required type2)) + (every-csubtypep (function-ctype-optional type1) + (function-ctype-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (function-ctype-required type1) + (function-ctype-optional type1)) + (concatenate 'list + (function-ctype-required type2) + (function-ctype-optional type2))))))))))))) + + + +;(define-superclasses function (function)) + + +;;; The union or intersection of two FUNCTION types is FUNCTION. +;;; (unless the types are type=) +;;; +(define-type-method (function :simple-union) (type1 type2) + (if (type= type1 type2) + type1 + (specifier-type 'function))) + +;;; +(define-type-method (function :simple-intersection) (type1 type2) + (if (type= type1 type2) + type1 + (specifier-type 'function))) + + +(define-type-method (function :complex-intersection) (type1 type2) + (declare (type function-ctype type2)) + (let ((function (specifier-type 'function))) + (if (eq type1 function) + type2 + (type-intersection2 type1 function)))) + + + +;;; ### Not very real, but good enough for redefining transforms according to +;;; type: +;;; +(define-type-method (function :simple-=) (type1 type2) + (values (equalp type1 type2) t)) + +;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARGUMENT "type +;;; specifier", which is only meaningful in function argument type specifiers +;;; used within the compiler. +;;; + +(defun clone-type-class-methods (src-tc dest-tc) + (do* ((n (uvsize src-tc)) + (i 2 (1+ i))) + ((= i n) dest-tc) + (declare (fixnum i n)) + (setf (%svref dest-tc i) + (%svref src-tc i)))) + +(clone-type-class-methods (type-class-or-lose 'values) (type-class-or-lose 'constant)) + +(defun make-constant-ctype (&key type) + (%istruct 'constant-ctype + (type-class-or-lose 'constant) + nil + type)) + +(defun constant-ctype-p (x) (istruct-typep x 'constant-ctype)) +(setf (type-predicate 'constant-ctype) 'constant-ctype-p) + +(define-type-method (constant :unparse) (type) + `(constant-argument ,(type-specifier (constant-ctype-type type)))) + +(define-type-method (constant :simple-=) (type1 type2) + (type= (constant-ctype-type type1) (constant-ctype-type type2))) + +(def-type-translator constant-argument (type &environment env) + (make-constant-ctype :type (specifier-type type env))) + + +;;; Parse-Args-Types -- Internal +;;; +;;; Given a lambda-list like values type specification and a Args-Type +;;; structure, fill in the slots in the structure accordingly. This is used +;;; for both FUNCTION and VALUES types. +;;; + +(defun parse-args-types (lambda-list result &optional env) + (multiple-value-bind (required optional restp rest keyp keys allowp aux) + (parse-lambda-list lambda-list) + (when aux + (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list)) + (flet ((parse (spec) (specifier-type spec env))) + (setf (args-ctype-required result) (mapcar #'parse required)) + (setf (args-ctype-optional result) (mapcar #'parse optional)) + (setf (args-ctype-rest result) (if restp (parse rest) nil)) + (setf (args-ctype-keyp result) keyp) + (let* ((key-info ())) + (dolist (key keys) + (when (or (atom key) (/= (length key) 2)) + (signal-program-error "Keyword type description is not a two-list: ~S." key)) + (let ((kwd (first key))) + (when (member kwd key-info :test #'eq :key #'(lambda (x) (key-info-name x))) + (signal-program-error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list)) + (push (make-key-info :name kwd + :type (parse (second key))) key-info))) + (setf (args-ctype-keywords result) (nreverse key-info))) + (setf (args-ctype-allowp result) allowp)))) + +;;; Unparse-Args-Types -- Internal +;;; +;;; Return the lambda-list like type specification corresponding +;;; to a Args-Type. +;;; +(defun unparse-args-types (type) + (let* ((result ())) + + (dolist (arg (args-ctype-required type)) + (push (type-specifier arg) result)) + + (when (args-ctype-optional type) + (push '&optional result) + (dolist (arg (args-ctype-optional type)) + (push (type-specifier arg) result))) + + (when (args-ctype-rest type) + (push '&rest result) + (push (type-specifier (args-ctype-rest type)) result)) + + (when (args-ctype-keyp type) + (push '&key result) + (dolist (key (args-ctype-keywords type)) + (push (list (key-info-name key) + (type-specifier (key-info-type key))) result))) + + (when (args-ctype-allowp type) + (push '&allow-other-keys result)) + + (nreverse result))) + +(def-type-translator function (&optional (args '*) (result '*) &environment env) + (let ((res (make-function-ctype + :returns (values-specifier-type result env)))) + (if (eq args '*) + (setf (function-ctype-wild-args res) t) + (parse-args-types args res env)) + res)) + +(def-type-translator values (&rest values &environment env) + (let ((res (make-values-ctype))) + (parse-args-types values res env) + (when (or (values-ctype-keyp res) (values-ctype-allowp res)) + (signal-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s" + res)) + res)) + +;;; Single-Value-Type -- Interface +;;; +;;; Return the type of the first value indicated by Type. This is used by +;;; people who don't want to have to deal with values types. +;;; +(defun single-value-type (type) + (declare (type ctype type)) + (cond ((values-ctype-p type) + (or (car (args-ctype-required type)) + (if (args-ctype-optional type) + (type-union (car (args-ctype-optional type)) + (specifier-type 'null))) + (args-ctype-rest type) + (specifier-type 'null))) + ((eq type *wild-type*) + *universal-type*) + (t + type))) + + +;;; FUNCTION-TYPE-NARGS -- Interface +;;; +;;; Return the minmum number of arguments that a function can be called +;;; with, and the maximum number or NIL. If not a function type, return +;;; NIL, NIL. +;;; +(defun function-type-nargs (type) + (declare (type ctype type)) + (if (function-ctype-p type) + (let ((fixed (length (args-ctype-required type)))) + (if (or (args-ctype-rest type) + (args-ctype-keyp type) + (args-ctype-allowp type)) + (values fixed nil) + (values fixed (+ fixed (length (args-ctype-optional type)))))) + (values nil nil))) + + +;;; Values-Types -- Interface +;;; +;;; Determine if Type corresponds to a definite number of values. The first +;;; value is a list of the types for each value, and the second value is the +;;; number of values. If the number of values is not fixed, then return NIL +;;; and :Unknown. +;;; +(defun values-types (type) + (declare (type ctype type)) + (cond ((eq type *wild-type*) + (values nil :unknown)) + ((not (values-ctype-p type)) + (values (list type) 1)) + ((or (args-ctype-optional type) + (args-ctype-rest type) + (args-ctype-keyp type) + (args-ctype-allowp type)) + (values nil :unknown)) + (t + (let ((req (args-ctype-required type))) + (values (mapcar #'single-value-type req) (length req)))))) + + +;;; Values-Type-Types -- Internal +;;; +;;; Return two values: +;;; 1] A list of all the positional (fixed and optional) types. +;;; 2] The rest type (if any). If keywords allowed, *universal-type*. If no +;;; keywords or rest, *empty-type*. +;;; +(defun values-type-types (type &optional (default-type *empty-type*)) + (declare (type values-ctype type)) + (values (append (args-ctype-required type) + (args-ctype-optional type)) + (cond ((args-ctype-keyp type) *universal-type*) + ((args-ctype-rest type)) + (t default-type)))) + + +;;; Fixed-Values-Op -- Internal +;;; +;;; Return a list of Operation applied to the types in Types1 and Types2, +;;; padding with Rest2 as needed. Types1 must not be shorter than Types2. The +;;; second value is T if Operation always returned a true second value. +;;; +(defun fixed-values-op (types1 types2 rest2 operation) + (declare (list types1 types2) (type ctype rest2) (type function operation)) + (let ((exact t)) + (values (mapcar #'(lambda (t1 t2) + (multiple-value-bind (res win) + (funcall operation t1 t2) + (unless win (setq exact nil)) + res)) + types1 + (append types2 + (make-list (- (length types1) (length types2)) + :initial-element rest2))) + exact))) + +;;; Coerce-To-Values -- Internal +;;; +;;; If Type isn't a values type, then make it into one: +;;; ==> (values type &rest t) +;;; +(defun coerce-to-values (type) + (declare (type ctype type)) + (if (values-ctype-p type) + type + (make-values-ctype :required (list type)))) + + +;;; Args-Type-Op -- Internal +;;; +;;; Do the specified Operation on Type1 and Type2, which may be any type, +;;; including Values types. With values types such as: +;;; (values a0 a1) +;;; (values b0 b1) +;;; +;;; We compute the more useful result: +;;; (values ( a0 b0) ( a1 b1)) +;;; +;;; Rather than the precise result: +;;; ( (values a0 a1) (values b0 b1)) +;;; +;;; This has the virtue of always keeping the values type specifier outermost, +;;; and retains all of the information that is really useful for static type +;;; analysis. We want to know what is always true of each value independently. +;;; It is worthless to know that IF the first value is B0 then the second will +;;; be B1. +;;; +;;; If the values count signatures differ, then we produce result with the +;;; required value count chosen by Nreq when applied to the number of required +;;; values in type1 and type2. Any &key values become &rest T (anyone who uses +;;; keyword values deserves to lose.) +;;; +;;; The second value is true if the result is definitely empty or if Operation +;;; returned true as its second value each time we called it. Since we +;;; approximate the intersection of values types, the second value being true +;;; doesn't mean the result is exact. +;;; +(defun args-type-op (type1 type2 operation nreq default-type) + (declare (type ctype type1 type2 default-type) + (type function operation nreq)) + (if (eq type1 type2) + (values type1 t) + (if (or (values-ctype-p type1) (values-ctype-p type2)) + (let ((type1 (coerce-to-values type1)) + (type2 (coerce-to-values type2))) + (multiple-value-bind (types1 rest1) + (values-type-types type1 default-type) + (multiple-value-bind (types2 rest2) + (values-type-types type2 default-type) + (multiple-value-bind (rest rest-exact) + (funcall operation rest1 rest2) + (multiple-value-bind + (res res-exact) + (if (< (length types1) (length types2)) + (fixed-values-op types2 types1 rest1 operation) + (fixed-values-op types1 types2 rest2 operation)) + (let* ((req (funcall nreq + (length (args-ctype-required type1)) + (length (args-ctype-required type2)))) + (required (subseq res 0 req)) + (opt (subseq res req)) + (opt-last (position rest opt :test-not #'type= + :from-end t))) + (if (find *empty-type* required :test #'type=) + (values *empty-type* t) + (values (make-values-ctype + :required required + :optional (if opt-last + (subseq opt 0 (1+ opt-last)) + ()) + :rest (if (eq rest *empty-type*) nil rest)) + (and rest-exact res-exact))))))))) + (funcall operation type1 type2)))) + +;;; Values-Type-Union, Values-Type-Intersection -- Interface +;;; +;;; Do a union or intersection operation on types that might be values +;;; types. The result is optimized for utility rather than exactness, but it +;;; is guaranteed that it will be no smaller (more restrictive) than the +;;; precise result. +;;; + +(defun values-type-union (type1 type2) + (declare (type ctype type1 type2)) + (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*) + ((eq type1 *empty-type*) type2) + ((eq type2 *empty-type*) type1) + (t + (values (args-type-op type1 type2 #'type-union #'min *empty-type*))))) + +(defun values-type-intersection (type1 type2) + (declare (type ctype type1 type2)) + (cond ((eq type1 *wild-type*) (values type2 t)) + ((eq type2 *wild-type*) (values type1 t)) + (t + (args-type-op type1 type2 #'type-intersection #'max + (specifier-type 'null))))) + + +;;; Values-Types-Intersect -- Interface +;;; +;;; Like Types-Intersect, except that it sort of works on values types. +;;; Note that due to the semantics of Values-Type-Intersection, this might +;;; return {T, T} when there isn't really any intersection (?). +;;; +(defun values-types-intersect (type1 type2) + (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) + (values t t)) + ((or (values-ctype-p type1) (values-ctype-p type2)) + (multiple-value-bind (res win) + (values-type-intersection type1 type2) + (values (not (eq res *empty-type*)) + win))) + (t + (types-intersect type1 type2)))) + +;;; Values-Subtypep -- Interface +;;; +;;; A subtypep-like operation that can be used on any types, including +;;; values types. +;;; + +(defun values-subtypep (type1 type2) + (declare (type ctype type1 type2)) + (cond ((eq type2 *wild-type*) (values t t)) + ((eq type1 *wild-type*) + (values (eq type2 *universal-type*) t)) + ((not (values-types-intersect type1 type2)) + (values nil t)) + (t + (if (or (values-ctype-p type1) (values-ctype-p type2)) + (let ((type1 (coerce-to-values type1)) + (type2 (coerce-to-values type2))) + (multiple-value-bind (types1 rest1) + (values-type-types type1) + (multiple-value-bind (types2 rest2) + (values-type-types type2) + (cond ((< (length (values-ctype-required type1)) + (length (values-ctype-required type2))) + (values nil t)) + ((< (length types1) (length types2)) + (values nil nil)) + ((or (values-ctype-keyp type1) + (values-ctype-keyp type2)) + (values nil nil)) + (t + (do ((t1 types1 (rest t1)) + (t2 types2 (rest t2))) + ((null t2) + (csubtypep rest1 rest2)) + (multiple-value-bind + (res win-p) + (csubtypep (first t1) (first t2)) + (unless win-p + (return (values nil nil))) + (unless res + (return (values nil t)))))))))) + (csubtypep type1 type2))))) + + + +;;;; Type method interfaces: + +;;; Csubtypep -- Interface +;;; +;;; Like subtypep, only works on Type structures. +;;; +(defun csubtypep (type1 type2) + (declare (type ctype type1 type2)) + (unless (typep type1 'ctype) + (report-bad-arg type1 'ctype)) + (unless (typep type2 'ctype) + (report-bad-arg type2 'ctype)) + (cond ((or (eq type1 type2) + (eq type1 *empty-type*) + (eq type2 *wild-type*)) + (values t t)) + (t + (invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1)))) + +;;; Type1 is a type-epecifier; type2 is a TYPE-CELL which may cache +;;; a mapping between a type-specifier and a CTYPE. +(defun cell-csubtypep-2 (type-specifier type-cell) + (let* ((type1 (specifier-type type-specifier)) + (type2 (or (type-cell-ctype type-cell) + (let* ((ctype (specifier-type + (type-cell-type-specifier type-cell)))) + (when (cacheable-ctype-p ctype) + (setf (type-cell-ctype type-cell) ctype)) + ctype)))) + (cond ((or (eq type1 type2) + (eq type1 *empty-type*) + (eq type2 *wild-type*)) + (values t t)) + (t + (invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1))))) + + + +;;; Type= -- Interface +;;; +;;; If two types are definitely equivalent, return true. The second value +;;; indicates whether the first value is definitely correct. This should only +;;; fail in the presence of Hairy types. +;;; + +(defun type= (type1 type2) + (declare (type ctype type1 type2)) + (if (eq type1 type2) + (values t t) + (invoke-type-method :simple-= :complex-= type1 type2))) + +;;; TYPE/= -- Interface +;;; +;;; Not exactly the negation of TYPE=, since when the relationship is +;;; uncertain, we still return NIL, NIL. This is useful in cases where the +;;; conservative assumption is =. +;;; +(defun type/= (type1 type2) + (declare (type ctype type1 type2)) + (multiple-value-bind (res win) + (type= type1 type2) + (if win + (values (not res) t) + (values nil nil)))) + +;;; Type-Union -- Interface +;;; +;;; Find a type which includes both types. Any inexactness is represented +;;; by the fuzzy element types; we return a single value that is precise to the +;;; best of our knowledge. This result is simplified into the canonical form, +;;; thus is not a UNION type unless there is no other way to represent the +;;; result. +;;; + +(defun type-union (&rest input-types) + (%type-union input-types)) + +(defun %type-union (input-types) + (let* ((simplified (simplify-unions input-types))) + (cond ((null simplified) *empty-type*) + ((null (cdr simplified)) (car simplified)) + (t (make-union-ctype simplified))))) + +(defun simplify-unions (types) + (when types + (multiple-value-bind (first rest) + (if (union-ctype-p (car types)) + (values (car (union-ctype-types (car types))) + (append (cdr (union-ctype-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (simplify-unions rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (type-union2 first r)) + (return (simplify-unions (nsubstitute u r rest))))))))) + +(defun type-union2 (type1 type2) + (declare (type ctype type1 type2)) + (setq type1 (reparse-unknown-ctype type1)) + (setq type2 (reparse-unknown-ctype type2)) + (cond ((eq type1 type2) type1) + ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t + (flet ((1way (x y) + (invoke-type-method :simple-union :complex-union + x y + :default nil))) + (or (1way type1 type2) + (1way type2 type1)))))) + +;;; Return as restrictive and simple a type as we can discover that is +;;; no more restrictive than the intersection of TYPE1 and TYPE2. At +;;; worst, we arbitrarily return one of the arguments as the first +;;; value (trying not to return a hairy type). +(defun type-approx-intersection2 (type1 type2) + (declare (type ctype type1 type2)) + (cond ((type-intersection2 type1 type2)) + ((hairy-ctype-p type1) type2) + (t type1))) + + +;;; Type-Intersection -- Interface +;;; +;;; Return as restrictive a type as we can discover that is no more +;;; restrictive than the intersection of Type1 and Type2. The second value is +;;; true if the result is exact. At worst, we randomly return one of the +;;; arguments as the first value (trying not to return a hairy type). +;;; + +(defun type-intersection (&rest input-types) + (%type-intersection input-types)) + +(defun %type-intersection (input-types) + (let ((simplified (simplify-intersections input-types))) + ;;(declare (type (vector ctype) simplified)) + ;; We want to have a canonical representation of types (or failing + ;; that, punt to HAIRY-TYPE). Canonical representation would have + ;; intersections inside unions but not vice versa, since you can + ;; always achieve that by the distributive rule. But we don't want + ;; to just apply the distributive rule, since it would be too easy + ;; to end up with unreasonably huge type expressions. So instead + ;; we try to generate a simple type by distributing the union; if + ;; the type can't be made simple, we punt to HAIRY-TYPE. + (if (and (cdr simplified) (some #'union-ctype-p simplified)) + (let* ((first-union (find-if #'union-ctype-p simplified)) + (other-types (remove first-union simplified)) + (distributed (maybe-distribute-one-union first-union other-types))) + (if distributed + (apply #'type-union distributed) + (make-hairy-ctype + :specifier `(and ,@(mapcar #'type-specifier simplified))))) + (cond + ((null simplified) *universal-type*) + ((null (cdr simplified)) (car simplified)) + (t (make-intersection-ctype + (some #'(lambda (c) (ctype-enumerable c)) simplified) + simplified)))))) + +(defun simplify-intersections (types) + (when types + (let ((first (if (typep (car types) 'ctype) + (%car types) + (specifier-type (%car types))))) + (multiple-value-bind (first rest) + (if (intersection-ctype-p first) + (values (car (intersection-ctype-types first)) + (append (cdr (intersection-ctype-types first)) + (cdr types))) + (values first (cdr types))) + (let ((rest (simplify-intersections rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (type-intersection2 first r)) + (return (simplify-intersections (nsubstitute u r rest)))))))))) + +(defun type-intersection2 (type1 type2) + (declare (type ctype type1 type2)) + (setq type1 (reparse-unknown-ctype type1)) + (setq type2 (reparse-unknown-ctype type2)) + (cond ((eq type1 type2) + type1) + ((or (intersection-ctype-p type1) + (intersection-ctype-p type2)) + ;; Intersections of INTERSECTION-TYPE should have the + ;; INTERSECTION-CTYPE-TYPES values broken out and intersected + ;; separately. The full TYPE-INTERSECTION function knows how + ;; to do that, so let it handle it. + (type-intersection type1 type2)) + ;; + ;; (AND (FUNCTION (T) T) GENERIC-FUNCTION) for instance, but + ;; not (AND (FUNCTION (T) T) (FUNCTION (T) T)). + ((let ((function (specifier-type 'function))) + (or (and (function-ctype-p type1) + (not (function-ctype-p type2)) + (neq function type2) + (csubtypep type2 function) + (not (csubtypep function type2))) + (and (function-ctype-p type2) + (not (function-ctype-p type1)) + (neq function type1) + (csubtypep type1 function) + (not (csubtypep function type1))))) + nil) + (t + (flet ((1way (x y) + (invoke-type-method :simple-intersection + :complex-intersection + x y + :default :no-type-method-found))) + (let ((xy (1way type1 type2))) + (or (and (not (eql xy :no-type-method-found)) xy) + (let ((yx (1way type2 type1))) + (or (and (not (eql yx :no-type-method-found)) yx) + (cond ((and (eql xy :no-type-method-found) + (eql yx :no-type-method-found)) + *empty-type*) + (t + nil)))))))))) + + + +(defun maybe-distribute-one-union (union-type types) + (let* ((intersection (apply #'type-intersection types)) + (union (mapcar (lambda (x) (type-intersection x intersection)) + (union-ctype-types union-type)))) + (if (notany (lambda (x) + (or (hairy-ctype-p x) + (intersection-ctype-p x))) + union) + union + nil))) + +;;; Types-Intersect -- Interface +;;; +;;; The first value is true unless the types don't intersect. The second +;;; value is true if the first value is definitely correct. NIL is considered +;;; to intersect with any type. If T is a subtype of either type, then we also +;;; return T, T. This way we consider hairy types to intersect with T. +;;; +(defun types-intersect (type1 type2) + (declare (type ctype type1 type2)) + (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) + (values t t) + (let ((intersection2 (type-intersection2 type1 type2))) + (cond ((not intersection2) + (if (or (csubtypep *universal-type* type1) + (csubtypep *universal-type* type2)) + (values t t) + (values t nil))) + ((eq intersection2 *empty-type*) (values nil t)) + (t (values t t)))))) + +;;; Type-Specifier -- Interface +;;; +;;; Return a Common Lisp type specifier corresponding to this type. +;;; +(defun type-specifier (type) + (unless (ctype-p type) + (setq type (require-type type 'ctype))) + (locally + (declare (type ctype type)) + (funcall (type-class-unparse (ctype-class-info type)) type))) + + +(defconstant compound-only-type-specifiers + ;; See CLHS Figure 4-4. + '(and mod satisfies eql not values member or)) + + +;;; VALUES-SPECIFIER-TYPE -- Interface +;;; +;;; Return the type structure corresponding to a type specifier. We pick +;;; off Structure types as a special case. +;;; + +(defun values-specifier-type-internal (orig env) + (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes + + ;; Now that we have our hands on the environment, we could pass it into type-expand, + ;; but we'd have no way of knowing whether the expansion depended on the env, so + ;; we wouldn't know if the result is safe to cache. So for now don't let type + ;; expanders see the env, which just means they won't see compile-time types. + (let ((spec (type-expand orig #+not-yet env))) + (cond + ((and (not (eq spec orig)) + (info-type-builtin spec))) + ((or (eq (info-type-kind spec) :instance) + (and (symbolp spec) + (typep (find-class spec nil env) 'compile-time-class))) + (let* ((class-ctype (%class.ctype (find-class spec t env)))) + (or (class-ctype-translation class-ctype) + class-ctype))) + ((typep spec 'class) + (let* ((class-ctype (%class.ctype spec))) + (or (class-ctype-translation class-ctype) + class-ctype))) + ((let ((cell (find-builtin-cell spec nil))) + (and cell (cdr cell)))) + (t + (when (member spec compound-only-type-specifiers) + (error 'invalid-type-specifier :typespec spec)) + (let* ((lspec (if (atom spec) (list spec) spec)) + (fun (info-type-translator (car lspec)))) + (cond (fun (funcall fun lspec env)) + ((or (and (consp spec) + (symbolp (car spec)) + (not (or (find-class (car spec) nil env) + (info-type-builtin (car spec))))) + (symbolp spec)) + (when *type-system-initialized* + (signal 'parse-unknown-type :specifier spec)) + ;; + ;; Inhibit caching... + nil) + (t + (error 'invalid-type-specifier :typespec spec))))))))) + +(eval-when (:compile-toplevel :execute) + (defconstant type-cache-size (ash 1 12)) + (defconstant type-cache-mask (1- type-cache-size))) + +(defun compile-time-ctype-p (ctype) + (and (typep ctype 'class-ctype) + (typep (class-ctype-class ctype) 'compile-time-class))) + + +;;; We can get in trouble if we try to cache certain kinds of ctypes, +;;; notably MEMBER types which refer to objects which might +;;; be stack-allocated or might be EQUAL without being EQL. +(defun cacheable-ctype-p (ctype) + (case (istruct-cell-name (%svref ctype 0)) + (member-ctype + (dolist (m (member-ctype-members ctype) t) + (when (or (typep m 'cons) + (typep m 'array)) + (return nil)))) + (union-ctype + (every #'cacheable-ctype-p (union-ctype-types ctype))) + (intersection-ctype + (every #'cacheable-ctype-p (intersection-ctype-types ctype))) + (array-ctype + (cacheable-ctype-p (array-ctype-element-type ctype))) + ((values-ctype function-ctype) + (and (every #'cacheable-ctype-p (values-ctype-required ctype)) + (every #'cacheable-ctype-p (values-ctype-optional ctype)) + (let* ((rest (values-ctype-rest ctype))) + (or (null rest) (cacheable-ctype-p rest))) + (every #'(lambda (info) + (cacheable-ctype-p (key-info-type info))) + (values-ctype-keywords ctype)) + (or (not (eq (istruct-cell-name (%svref ctype 0)) 'function-ctype)) + (let* ((result (function-ctype-returns ctype))) + (or (null result) + (cacheable-ctype-p result)))))) + (negation-ctype + (cacheable-ctype-p (negation-ctype-type ctype))) + (cons-ctype + (and (cacheable-ctype-p (cons-ctype-car-ctype ctype)) + (cacheable-ctype-p (cons-ctype-cdr-ctype ctype)))) + (unknown-ctype nil) + (class-ctype + (not (typep (class-ctype-class ctype) 'compile-time-class))) + ;; Anything else ? Simple things (numbers, classes) can't lose. + (t t))) + + + + +(defun hash-type-specifier (spec) + (logand (sxhash spec) type-cache-mask)) + + +(let* ((type-cache-specs (make-array type-cache-size)) + (type-cache-ctypes (make-array type-cache-size)) + (probes 0) + (hits 0) + (ncleared 0) + (locked nil) + (lock (make-lock))) + + (defun clear-type-cache () + (with-lock-grabbed (lock) + (%init-misc 0 type-cache-specs) + (%init-misc 0 type-cache-ctypes) + (incf ncleared)) + nil) + + (defun values-specifier-type (spec &optional env) + (if (typep spec 'class) + (let* ((class-ctype (%class.ctype spec))) + (or (class-ctype-translation class-ctype) class-ctype)) + (handler-case + (with-lock-grabbed (lock) + (if locked + (or (values-specifier-type-internal spec env) + (make-unknown-ctype :specifier spec)) + (unwind-protect + (progn + (setq locked t) + (if (or (symbolp spec) + (and (consp spec) + (symbolp (car spec)) + ;; hashing scheme uses equal, so only use when equivalent to eql + (not (and (eq (car spec) 'member) + (some (lambda (x) + (typep x '(or cons string bit-vector pathname))) + (cdr spec)))))) + (let* ((idx (hash-type-specifier spec))) + (incf probes) + (if (equal (svref type-cache-specs idx) spec) + (progn + (incf hits) + (svref type-cache-ctypes idx)) + (let* ((ctype (values-specifier-type-internal spec env))) + (if ctype + (progn + (when (cacheable-ctype-p ctype) + (setf (svref type-cache-specs idx) (copy-tree spec) ; in case it was stack-consed + (svref type-cache-ctypes idx) ctype)) + ctype) + (make-unknown-ctype :specifier spec))))) + (values-specifier-type-internal spec env))) + (setq locked nil)))) + (error (condition) (error condition))))) + + (defun type-cache-hit-rate () + (values hits probes)) + + (defun type-cache-locked-p () + locked) + + (defun lock-type-cache () + (setq locked t))) + + + + +;;; SPECIFIER-TYPE -- Interface +;;; +;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never return a +;;; VALUES type. +;;; +(defun specifier-type (x &optional env) + (let ((res (values-specifier-type x env))) + (when (values-ctype-p res) + (signal-program-error "VALUES type illegal in this context:~% ~S" x)) + res)) + +(defun single-value-specifier-type (x &optional env) + (let ((res (specifier-type x env))) + (if (eq res *wild-type*) + *universal-type* + res))) + +(defun standardized-type-specifier (spec &optional env) + (handler-case + (type-specifier (specifier-type spec env)) + (program-error () spec) + (parse-unknown-type () spec))) + +(defun modified-numeric-type (base + &key + (class (numeric-ctype-class base)) + (format (numeric-ctype-format base)) + (complexp (numeric-ctype-complexp base)) + (low (numeric-ctype-low base)) + (high (numeric-ctype-high base)) + (enumerable (ctype-enumerable base))) + (make-numeric-ctype :class class + :format format + :complexp complexp + :low low + :high high + :enumerable enumerable)) + +;;; Precompute-Types -- Interface +;;; +;;; Take a list of type specifiers, compute the translation and define it as +;;; a builtin type. +;;; + +(defun precompute-types (specs) + (dolist (spec specs) + (let ((res (specifier-type spec))) + (when (numeric-ctype-p res) + (let ((pred (make-numeric-ctype-predicate res))) + (when pred (setf (numeric-ctype-predicate res) pred)))) + (unless (unknown-ctype-p res) + (setf (info-type-builtin spec) res) + (setf (info-type-kind spec) :primitive))))) + +;;;; Builtin types. + +;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be +;;; super or sub types of all types, not just classes and * & NIL aren't +;;; classes anyway, so it wouldn't make much sense to make them built-in +;;; classes. +;;; + +(defun define-named-ctype (name) + (let* ((ctype (%istruct 'named-ctype + (type-class-or-lose 'named) + nil + name))) + (setf (info-type-kind name) :builtin + (info-type-builtin name) ctype))) + + +(defvar *wild-type* (define-named-ctype '*)) +(defvar *empty-type* (define-named-ctype nil)) +(defvar *universal-type* (define-named-ctype t)) + +(defun named-ctype-p (x) + (istruct-typep x 'named-ctype)) + +(setf (type-predicate 'named-ctype) 'named-ctype-p) + +(define-type-method (named :simple-=) (type1 type2) + (values (eq type1 type2) t)) + +(define-type-method (named :complex-=) (type1 type2) + (cond + ((and (eq type2 *empty-type*) + (intersection-ctype-p type1) + ;; not allowed to be unsure on these... FIXME: keep the list + ;; of CL types that are intersection types once and only + ;; once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) + ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION + ;; STREAM) can get here. In general, we can't really tell + ;; whether these are equal to NIL or not, so + (values nil nil)) + ((type-might-contain-other-types-p type1) + (invoke-complex-=-other-method type1 type2)) + (t (values nil t)))) + + +(define-type-method (named :simple-subtypep) (type1 type2) + (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) + +(define-type-method (named :complex-subtypep-arg1) (type1 type2) + (cond ((eq type1 *empty-type*) + t) + (;; When TYPE2 might be the universal type in disguise + (type-might-contain-other-types-p type2) + ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods + ;; can delegate to us (more or less as CALL-NEXT-METHOD) when + ;; they're uncertain, we can't just barf on COMPOUND-TYPE and + ;; HAIRY-TYPEs as we used to. Instead we deal with the + ;; problem (where at least part of the problem is cases like + ;; (SUBTYPEP T '(SATISFIES FOO)) + ;; or + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) + ;; where the second type is a hairy type like SATISFIES, or + ;; is a compound type which might contain a hairy type) by + ;; returning uncertainty. + (values nil nil)) + (t + ;; By elimination, TYPE1 is the universal type. + (assert (or (eq type1 *wild-type*) (eq type1 *universal-type*))) + ;; This case would have been picked off by the SIMPLE-SUBTYPEP + ;; method, and so shouldn't appear here. + (assert (not (eq type2 *universal-type*))) + ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the + ;; universal type in disguise, TYPE2 is not a superset of TYPE1. + (values nil t)))) + + +(define-type-method (named :complex-subtypep-arg2) (type1 type2) + (assert (not (eq type2 *wild-type*))) ; * isn't really a type. + (cond ((eq type2 *universal-type*) + (values t t)) + ((type-might-contain-other-types-p type1) + ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in + ;; disguise. So we'd better delegate. + (invoke-complex-subtypep-arg1-method type1 type2)) + (t + ;; FIXME: This seems to rely on there only being 2 or 3 + ;; NAMED-TYPE values, and the exclusion of various + ;; possibilities above. It would be good to explain it and/or + ;; rewrite it so that it's clearer. + (values (not (eq type2 *empty-type*)) t)))) + + +(define-type-method (named :complex-intersection) (type1 type2) + (hierarchical-intersection2 type1 type2)) + +(define-type-method (named :unparse) (x) + (named-ctype-name x)) + + + +;;;; Hairy and unknown types: + +;;; The Hairy-Type represents anything too wierd to be described +;;; reasonably or to be useful, such as SATISFIES. We just remember +;;; the original type spec. +;;; + +(defun make-hairy-ctype (&key specifier (enumerable t)) + (%istruct 'hairy-ctype + (type-class-or-lose 'hairy) + enumerable + specifier)) + +(defun hairy-ctype-p (x) + (or (istruct-typep x 'hairy-ctype) + (istruct-typep x 'unknown-ctype))) + +(setf (type-predicate 'hairy-ctype) 'hairy-ctype-p) + +(define-type-method (hairy :unparse) (x) (hairy-ctype-specifier x)) + +(define-type-method (hairy :simple-subtypep) (type1 type2) + (let ((hairy-spec1 (hairy-ctype-specifier type1)) + (hairy-spec2 (hairy-ctype-specifier type2))) + (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) + (values t t)) + (t + (values nil nil))))) + +(define-type-method (hairy :complex-subtypep-arg2) (type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) + +(define-type-method (hairy :complex-subtypep-arg1) (type1 type2) + (declare (ignore type1 type2)) + (values nil nil)) + +(define-type-method (hairy :complex-=) (type1 type2) + (if (and (unknown-ctype-p type2) + (let* ((specifier2 (unknown-ctype-specifier type2)) + (name2 (if (consp specifier2) + (car specifier2) + specifier2))) + (info-type-kind name2))) + (let ((type2 (specifier-type (unknown-ctype-specifier type2)))) + (if (unknown-ctype-p type2) + (values nil nil) + (type= type1 type2))) + (values nil nil))) + +(define-type-method (hairy :simple-intersection :complex-intersection) + (type1 type2) + (if (type= type1 type2) + type1 + nil)) + + +(define-type-method (hairy :simple-union) + (type1 type2) + (if (type= type1 type2) + type1 + nil)) + +(define-type-method (hairy :simple-=) (type1 type2) + (if (equal-but-no-car-recursion (hairy-ctype-specifier type1) + (hairy-ctype-specifier type2)) + (values t t) + (values nil nil))) + + + +(def-type-translator satisfies (&whole x fun) + (unless (symbolp fun) + (report-bad-arg fun 'symbol)) + (make-hairy-ctype :specifier x)) + + + +;;; Negation Ctypes +(defun make-negation-ctype (&key type (enumerable t)) + (%istruct 'negation-ctype + (type-class-or-lose 'negation) + enumerable + type)) + +(defun negation-ctype-p (x) + (istruct-typep x 'negation-ctype)) + +(setf (type-predicate 'negation-ctype) 'negation-ctype-p) + +(define-type-method (negation :unparse) (x) + `(not ,(type-specifier (negation-ctype-type x)))) + +(define-type-method (negation :simple-subtypep) (type1 type2) + (csubtypep (negation-ctype-type type2) (negation-ctype-type type1))) + +(define-type-method (negation :complex-subtypep-arg2) (type1 type2) + (let* ((complement-type2 (negation-ctype-type type2)) + (intersection2 (type-intersection type1 complement-type2))) + (if intersection2 + ;; FIXME: if uncertain, maybe try arg1? + (type= intersection2 *empty-type*) + (invoke-complex-subtypep-arg1-method type1 type2)))) + +(define-type-method (negation :complex-subtypep-arg1) (type1 type2) + (block nil + ;; (Several logical truths in this block are true as long as + ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a + ;; case with b=T where we actually reach this type method, but + ;; we'll test for and exclude this case anyway, since future + ;; maintenance might make it possible for it to end up in this + ;; code.) + (multiple-value-bind (equal certain) + (type= type2 *universal-type*) + (unless certain + (return (values nil nil))) + (when equal + (return (values t t)))) + (let ((complement-type1 (negation-ctype-type type1))) + ;; Do the special cases first, in order to give us a chance if + ;; subtype/supertype relationships are hairy. + (multiple-value-bind (equal certain) + (type= complement-type1 type2) + ;; If a = b, ~a is not a subtype of b (unless b=T, which was + ;; excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; KLUDGE: ANSI requires that the SUBTYPEP result between any + ;; two built-in atomic type specifiers never be uncertain. This + ;; is hard to do cleanly for the built-in types whose + ;; definitions include (NOT FOO), i.e. CONS and RATIO. However, + ;; we can do it with this hack, which uses our global knowledge + ;; that our implementation of the type system uses disjoint + ;; implementation types to represent disjoint sets (except when + ;; types are contained in other types). (This is a KLUDGE + ;; because it's fragile. Various changes in internal + ;; representation in the type system could make it start + ;; confidently returning incorrect results.) -- WHN 2002-03-08 + (unless (or (type-might-contain-other-types-p complement-type1) + (type-might-contain-other-types-p type2)) + ;; Because of the way our types which don't contain other + ;; types are disjoint subsets of the space of possible values, + ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B + ;; is not T, as checked above). + (return (values nil t))) + ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as + ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, + ;; and then the :SIMPLE-SUBTYPEP method would be used instead. + ;; But a CSUBTYPEP relationship might still hold: + (multiple-value-bind (equal certain) + (csubtypep complement-type1 type2) + ;; If a is a subtype of b, ~a is not a subtype of b (unless + ;; b=T, which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + (multiple-value-bind (equal certain) + (csubtypep type2 complement-type1) + ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: + ;; That's not true if a=T. Do we know at this point that a is + ;; not T?) + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? + ;; KLUDGE case above: Other cases here would rely on being able + ;; to catch all possible cases, which the fragility of this type + ;; system doesn't inspire me; for instance, if a is type= to ~b, + ;; then we want T, T; if this is not the case and the types are + ;; disjoint (have an intersection of *empty-type*) then we want + ;; NIL, T; else if the union of a and b is the *universal-type* + ;; then we want T, T. So currently we still claim to be unsure + ;; about e.g. (subtypep '(not fixnum) 'single-float). + ;; + ;; OTOH we might still get here: + (values nil nil)))) + +(define-type-method (negation :complex-=) (type1 type2) + ;; (NOT FOO) isn't equivalent to anything that's not a negation + ;; type, except possibly a type that might contain it in disguise. + (declare (ignore type2)) + (if (type-might-contain-other-types-p type1) + (values nil nil) + (values nil t))) + +(define-type-method (negation :simple-intersection) (type1 type2) + (let ((not1 (negation-ctype-type type1)) + (not2 (negation-ctype-type type2))) + (cond + ((csubtypep not1 not2) type2) + ((csubtypep not2 not1) type1) + ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2 + ;; method, below? The clause would read + ;; + ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*) + ;; + ;; but with proper canonicalization of negation types, there's + ;; no way of constructing two negation types with union of their + ;; negations being the universal type. + (t + nil)))) + +(define-type-method (negation :complex-intersection) (type1 type2) + (cond + ((csubtypep type1 (negation-ctype-type type2)) *empty-type*) + ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) + type1) + (t nil))) + +(define-type-method (negation :simple-union) (type1 type2) + (let ((not1 (negation-ctype-type type1)) + (not2 (negation-ctype-type type2))) + (cond + ((csubtypep not1 not2) type1) + ((csubtypep not2 not1) type2) + ((eq (type-intersection not1 not2) *empty-type*) + *universal-type*) + (t nil)))) + +(define-type-method (negation :complex-union) (type1 type2) + (cond + ((csubtypep (negation-ctype-type type2) type1) *universal-type*) + ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) + type2) + (t nil))) + +(define-type-method (negation :simple-=) (type1 type2) + (type= (negation-ctype-type type1) (negation-ctype-type type2))) + +(def-type-translator not (typespec &environment env) + (let* ((not-type (specifier-type typespec env)) + (spec (type-specifier not-type))) + (cond + ;; canonicalize (NOT (NOT FOO)) + ((and (listp spec) (eq (car spec) 'not)) + (specifier-type (cadr spec) env)) + ;; canonicalize (NOT NIL) and (NOT T) + ((eq not-type *empty-type*) *universal-type*) + ((eq not-type *universal-type*) *empty-type*) + ((and (numeric-ctype-p not-type) + (null (numeric-ctype-low not-type)) + (null (numeric-ctype-high not-type))) + (make-negation-ctype :type not-type)) + ((numeric-ctype-p not-type) + (type-union + (make-negation-ctype + :type (modified-numeric-type not-type :low nil :high nil)) + (cond + ((null (numeric-ctype-low not-type)) + (modified-numeric-type + not-type + :low (let ((h (numeric-ctype-high not-type))) + (if (consp h) (car h) (list h))) + :high nil)) + ((null (numeric-ctype-high not-type)) + (modified-numeric-type + not-type + :low nil + :high (let ((l (numeric-ctype-low not-type))) + (if (consp l) (car l) (list l))))) + (t (type-union + (modified-numeric-type + not-type + :low nil + :high (let ((l (numeric-ctype-low not-type))) + (if (consp l) (car l) (list l)))) + (modified-numeric-type + not-type + :low (let ((h (numeric-ctype-high not-type))) + (if (consp h) (car h) (list h))) + :high nil)))))) + ((intersection-ctype-p not-type) + (apply #'type-union + (mapcar #'(lambda (x) + (specifier-type `(not ,(type-specifier x)) env)) + (intersection-ctype-types not-type)))) + ((union-ctype-p not-type) + (apply #'type-intersection + (mapcar #'(lambda (x) + (specifier-type `(not ,(type-specifier x)) env)) + (union-ctype-types not-type)))) + ((member-ctype-p not-type) + (let ((members (member-ctype-members not-type))) + (if (some #'floatp members) + (let (floats) + (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0))) + (when (member (car pair) members) + (assert (not (member (cdr pair) members))) + (push (cdr pair) floats) + (setf members (remove (car pair) members))) + (when (member (cdr pair) members) + (assert (not (member (car pair) members))) + (push (car pair) floats) + (setf members (remove (cdr pair) members)))) + (apply #'type-intersection + (if (null members) + *universal-type* + (make-negation-ctype + :type (make-member-ctype :members members))) + (mapcar + (lambda (x) + (let ((type (ctype-of x))) + (type-union + (make-negation-ctype + :type (modified-numeric-type type + :low nil :high nil)) + (modified-numeric-type type + :low nil :high (list x)) + (make-member-ctype :members (list x)) + (modified-numeric-type type + :low (list x) :high nil)))) + floats))) + (make-negation-ctype :type not-type)))) + ((and (cons-ctype-p not-type) + (eq (cons-ctype-car-ctype not-type) *universal-type*) + (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) + (make-negation-ctype :type not-type)) + ((cons-ctype-p not-type) + (type-union + (make-negation-ctype :type (specifier-type 'cons env)) + (cond + ((and (not (eq (cons-ctype-car-ctype not-type) *universal-type*)) + (not (eq (cons-ctype-cdr-ctype not-type) *universal-type*))) + (type-union + (make-cons-ctype + (specifier-type `(not ,(type-specifier + (cons-ctype-car-ctype not-type))) env) + *universal-type*) + (make-cons-ctype + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-ctype-cdr-ctype not-type))) env)))) + ((not (eq (cons-ctype-car-ctype not-type) *universal-type*)) + (make-cons-ctype + (specifier-type `(not ,(type-specifier + (cons-ctype-car-ctype not-type))) env) + *universal-type*)) + ((not (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) + (make-cons-ctype + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-ctype-cdr-ctype not-type))) env))) + (t (error "Weird CONS type ~S" not-type))))) + (t (make-negation-ctype :type not-type))))) + + +;;;; Numeric types. + +;;; A list of all the float formats, in order of decreasing precision. +;;; +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant float-formats + '(long-float double-float single-float short-float))) + +;;; The type of a float format. +;;; +(deftype float-format () `(member ,@float-formats)) + +(defun type-bound-number (x) + (if (consp x) + (destructuring-bind (result) x result) + x)) + +(defun make-numeric-ctype (&key class + format + (complexp :real) + low + high + enumerable + predicate) + ;; if interval is empty + (if (and low + high + (if (or (consp low) (consp high)) ; if either bound is exclusive + (>= (type-bound-number low) (type-bound-number high)) + (> low high))) + *empty-type* + (multiple-value-bind (canonical-low canonical-high) + (case class + (integer + ;; INTEGER types always have their LOW and HIGH bounds + ;; represented as inclusive, not exclusive values. + (values (if (consp low) + (1+ (type-bound-number low)) + low) + (if (consp high) + (1- (type-bound-number high)) + high))) + (t + ;; no canonicalization necessary + (values low high))) + (when (and (eq class 'rational) + (integerp canonical-low) + (integerp canonical-high) + (= canonical-low canonical-high)) + (setf class 'integer)) + (%istruct 'numeric-ctype + (type-class-or-lose 'number) + enumerable + class + format + complexp + canonical-low + canonical-high + predicate)))) + + +(defun make-numeric-ctype-predicate (ctype) + (let ((class (numeric-ctype-class ctype)) + (lo (numeric-ctype-low ctype)) + (hi (numeric-ctype-high ctype))) + (if (eq class 'integer) + (if (and hi + lo + (<= hi target::target-most-positive-fixnum) + (>= lo target::target-most-negative-fixnum)) + #'(lambda (n) + (and (fixnump n) + (locally (declare (fixnum n hi lo)) + (and (%i>= n lo) + (%i<= n hi))))))))) + +(defun numeric-ctype-p (x) + (istruct-typep x 'numeric-ctype)) + +(setf (type-predicate 'numeric-ctype) 'numeric-ctype-p) + +(define-type-method (number :simple-=) (type1 type2) + (values + (and (eq (numeric-ctype-class type1) (numeric-ctype-class type2)) + (eq (numeric-ctype-format type1) (numeric-ctype-format type2)) + (eq (numeric-ctype-complexp type1) (numeric-ctype-complexp type2)) + (equalp (numeric-ctype-low type1) (numeric-ctype-low type2)) + (equalp (numeric-ctype-high type1) (numeric-ctype-high type2))) + t)) + +(define-type-method (number :unparse) (type) + (let* ((complexp (numeric-ctype-complexp type)) + (low (numeric-ctype-low type)) + (high (numeric-ctype-high type)) + (base (case (numeric-ctype-class type) + (integer 'integer) + (rational 'rational) + (float (or (numeric-ctype-format type) 'float)) + (t 'real)))) + (let ((base+bounds + (cond ((and (eq base 'integer) high low) + (let ((high-count (logcount high)) + (high-length (integer-length high))) + (cond ((= low 0) + (cond ((= high 0) '(integer 0 0)) + ((= high 1) 'bit) + ((and (= high-count high-length) + (plusp high-length)) + `(unsigned-byte ,high-length)) + (t + `(mod ,(1+ high))))) + ((and (= low target::target-most-negative-fixnum) + (= high target::target-most-positive-fixnum)) + 'fixnum) + ((and (= low (lognot high)) + (= high-count high-length) + (> high-count 0)) + `(signed-byte ,(1+ high-length))) + (t + `(integer ,low ,high))))) + (high `(,base ,(or low '*) ,high)) + (low + (if (and (eq base 'integer) (= low 0)) + 'unsigned-byte + `(,base ,low))) + (t base)))) + (ecase complexp + (:real + base+bounds) + (:complex + (if (eq base+bounds 'real) + 'complex + `(complex ,base+bounds))) + ((nil) + (assert (eq base+bounds 'real)) + 'number))))) + +;;; Numeric-Bound-Test -- Internal +;;; +;;; Return true if X is "less than or equal" to Y, taking open bounds into +;;; consideration. Closed is the predicate used to test the bound on a closed +;;; interval (e.g. <=), and Open is the predicate used on open bounds (e.g. <). +;;; Y is considered to be the outside bound, in the sense that if it is +;;; infinite (NIL), then the test suceeds, whereas if X is infinite, then the +;;; test fails (unless Y is also infinite). +;;; +;;; This is for comparing bounds of the same kind, e.g. upper and upper. +;;; Use Numeric-Bound-Test* for different kinds of bounds. +;;; +(defmacro numeric-bound-test (x y closed open) + `(cond ((not ,y) t) + ((not ,x) nil) + ((consp ,x) + (if (consp ,y) + (,closed (car ,x) (car ,y)) + (,closed (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) + +;;; Numeric-Bound-Test* -- Internal +;;; +;;; Used to compare upper and lower bounds. This is different from the +;;; same-bound case: +;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we return true +;;; if *either* arg is NIL. +;;; -- an open inner bound is "greater" and also squeezes the interval, causing +;;; us to use the Open test for those cases as well. +;;; +(defmacro numeric-bound-test* (x y closed open) + `(cond ((not ,y) t) + ((not ,x) t) + ((consp ,x) + (if (consp ,y) + (,open (car ,x) (car ,y)) + (,open (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) + +;;; Numeric-Bound-Max -- Internal +;;; +;;; Return whichever of the numeric bounds X and Y is "maximal" according to +;;; the predicates Closed (e.g. >=) and Open (e.g. >). This is only meaningful +;;; for maximizing like bounds, i.e. upper and upper. If Max-P is true, then +;;; we return NIL if X or Y is NIL, otherwise we return the other arg. +;;; +(defmacro numeric-bound-max (x y closed open max-p) + (once-only ((n-x x) + (n-y y)) + `(cond + ((not ,n-x) ,(if max-p nil n-y)) + ((not ,n-y) ,(if max-p nil n-x)) + ((consp ,n-x) + (if (consp ,n-y) + (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) + (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) + (t + (if (consp ,n-y) + (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) + (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) + + +(define-type-method (number :simple-subtypep) (type1 type2) + (let ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (complexp2 (numeric-ctype-complexp type2)) + (format2 (numeric-ctype-format type2)) + (low1 (numeric-ctype-low type1)) + (high1 (numeric-ctype-high type1)) + (low2 (numeric-ctype-low type2)) + (high2 (numeric-ctype-high type2))) + ;; + ;; If one is complex and the other isn't, they are disjoint. + (cond ((not (or (eq (numeric-ctype-complexp type1) complexp2) + (null complexp2))) + (values nil t)) + ;; + ;; If the classes are specified and different, the types are + ;; disjoint unless type2 is rational and type1 is integer. + ((not (or (eq class1 class2) (null class2) + (and (eq class1 'integer) (eq class2 'rational)))) + (values nil t)) + ;; + ;; If the float formats are specified and different, the types + ;; are disjoint. + ((not (or (eq (numeric-ctype-format type1) format2) + (null format2))) + (values nil t)) + ;; + ;; Check the bounds. + ((and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test high1 high2 <= <)) + (values t t)) + (t + (values nil t))))) + +;(define-superclasses number (generic-number)) + +;;; NUMERIC-TYPES-ADJACENT -- Internal +;;; +;;; If the high bound of Low is adjacent to the low bound of High, then +;;; return T, otherwise NIL. +;;; +(defun numeric-types-adjacent (low high) + (let ((low-bound (numeric-ctype-high low)) + (high-bound (numeric-ctype-low high))) + (cond ((not (and low-bound high-bound)) nil) + ((consp low-bound) + (eql (car low-bound) high-bound)) + ((consp high-bound) + (eql (car high-bound) low-bound)) + ((and (eq (numeric-ctype-class low) 'integer) + (eq (numeric-ctype-class high) 'integer)) + (eql (1+ low-bound) high-bound)) + (t + nil)))) + +;;; +;;; Return a numeric type that is a supertype for both type1 and type2. +;;; +(define-type-method (number :simple-union) (type1 type2) + (declare (type numeric-ctype type1 type2)) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t + (let ((class1 (numeric-ctype-class type1)) + (format1 (numeric-ctype-format type1)) + (complexp1 (numeric-ctype-complexp type1)) + (class2 (numeric-ctype-class type2)) + (format2 (numeric-ctype-format type2)) + (complexp2 (numeric-ctype-complexp type2))) + (cond + ((and (eq class1 class2) + (eq format1 format2) + (eq complexp1 complexp2) + (or (numeric-types-intersect type1 type2) + (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-ctype + :class class1 + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-ctype-low type1) + (numeric-ctype-low type2) + <= < t) + :high (numeric-bound-max (numeric-ctype-high type1) + (numeric-ctype-high type2) + >= > t))) + ;; FIXME: These two clauses are almost identical, and the + ;; consequents are in fact identical in every respect. + ((and (eq class1 'rational) + (eq class2 'integer) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-ctype-low type2)) + (integerp (numeric-ctype-high type2)) + (= (numeric-ctype-low type2) (numeric-ctype-high type2)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-ctype + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-ctype-low type1) + (numeric-ctype-low type2) + <= < t) + :high (numeric-bound-max (numeric-ctype-high type1) + (numeric-ctype-high type2) + >= > t))) + ((and (eq class1 'integer) + (eq class2 'rational) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-ctype-low type1)) + (integerp (numeric-ctype-high type1)) + (= (numeric-ctype-low type1) (numeric-ctype-high type1)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-ctype + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-ctype-low type1) + (numeric-ctype-low type2) + <= < t) + :high (numeric-bound-max (numeric-ctype-high type1) + (numeric-ctype-high type2) + >= > t))) + (t nil)))))) + +(setf (info-type-kind 'number) :primitive + (info-type-builtin 'number) (make-numeric-ctype :complexp nil)) + +(def-type-translator complex (&optional spec &environment env) + (if (eq spec '*) + (make-numeric-ctype :complexp :complex) + (labels ((not-numeric () + (error "Component type for Complex is not numeric: ~S." spec)) + (not-real () + (error "Component type for Complex is not a subtype of real: ~S." spec)) + (complex1 (component-type) + (unless (numeric-ctype-p component-type) + (not-numeric)) + (when (eq (numeric-ctype-complexp component-type) :complex) + (not-real)) + (let ((res (copy-uvector component-type))) + (setf (numeric-ctype-complexp res) :complex) + (setf (numeric-ctype-predicate res) nil) ; << + res)) + (do-complex (ctype) + (cond + ((eq ctype *empty-type*) *empty-type*) + ((eq ctype *universal-type*) (not-real)) + ((numeric-ctype-p ctype) (complex1 ctype)) + ((union-ctype-p ctype) + (apply #'type-union + (mapcar #'do-complex (union-ctype-types ctype)))) + ((member-ctype-p ctype) + (apply #'type-union + (mapcar (lambda (x) (do-complex (ctype-of x))) + (member-ctype-members ctype)))) + ((and (intersection-ctype-p ctype) + ;; just enough to handle simple types like RATIO. + (let ((numbers (remove-if-not + #'numeric-ctype-p + (intersection-ctype-types ctype)))) + (and (car numbers) + (null (cdr numbers)) + (eq (numeric-ctype-complexp (car numbers)) :real) + (complex1 (car numbers)))))) + (t ; punt on harder stuff for now + (not-real))))) + (let ((ctype (specifier-type spec env))) + (do-complex ctype))))) + +;;; Check-Bound -- Internal +;;; +;;; Check that X is a well-formed numeric bound of the specified Type. +;;; If X is *, return NIL, otherwise return the bound. +;;; +(defmacro check-bound (x type) + `(cond ((eq ,x '*) nil) + ((or (typep ,x ',type) + (and (consp ,x) (typep (car ,x) ',type) (null (cdr ,x)))) + ,x) + (t + (error "Bound is not *, a ~A or a list of a ~A: ~S" ',type ',type ,x)))) + +(def-type-translator integer (&optional low high) + (let* ((l (check-bound low integer)) + (lb (if (consp l) (1+ (car l)) l)) + (h (check-bound high integer)) + (hb (if (consp h) (1- (car h)) h))) + (if (and hb lb (< hb lb)) + *empty-type* + (make-numeric-ctype :class 'integer :complexp :real + :enumerable (not (null (and l h))) + :low lb + :high hb)))) + +(deftype mod (n) + (unless (and (integerp n) (> n 0)) + (error "Bad N specified for MOD type specifier: ~S." n)) + `(integer 0 ,(1- n))) + + +(defmacro def-bounded-type (type class format) + `(def-type-translator ,type (&optional low high) + (let ((lb (check-bound low ,type)) + (hb (check-bound high ,type))) + (unless (numeric-bound-test* lb hb <= <) + (error "Lower bound ~S is not less than upper bound ~S." low high)) + (make-numeric-ctype :class ',class :format ',format :low lb :high hb)))) + +(def-bounded-type rational rational nil) + +(defun coerce-bound (bound type inner-coerce-bound-fun) + (declare (type function inner-coerce-bound-fun)) + (cond ((eql bound '*) + bound) + ((consp bound) + (destructuring-bind (inner-bound) bound + (list (funcall inner-coerce-bound-fun inner-bound type)))) + (t + (funcall inner-coerce-bound-fun bound type)))) + +(defun inner-coerce-real-bound (bound type) + (ecase type + (rational (rationalize bound)) + (float (if (floatp bound) + bound + ;; Coerce to the widest float format available, to + ;; avoid unnecessary loss of precision: + (coerce bound 'long-float))))) + +(defun coerced-real-bound (bound type) + (coerce-bound bound type #'inner-coerce-real-bound)) + +(defun coerced-float-bound (bound type) + (coerce-bound bound type #'coerce)) + +#| +(def-type-translator real (&optional (low '*) (high '*)) + (specifier-type `(or (float ,(coerced-real-bound low 'float) + ,(coerced-real-bound high 'float)) + (rational ,(coerced-real-bound low 'rational) + ,(coerced-real-bound high 'rational))))) + +(def-type-translator float (&optional (low '*) (high '*)) + (specifier-type + `(or (single-float ,(coerced-float-bound low 'single-float) + ,(coerced-float-bound high 'single-float)) + (double-float ,(coerced-float-bound low 'double-float) + ,(coerced-float-bound high 'double-float))))) +|# + +(def-bounded-type float float nil) +(def-bounded-type real nil nil) + +(defmacro define-float-format (f) + `(def-bounded-type ,f float ,f)) + +(define-float-format short-float) +(define-float-format single-float) +(define-float-format double-float) +(define-float-format long-float) + +(defun numeric-types-intersect (type1 type2) + (declare (type numeric-ctype type1 type2)) + (let* ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (complexp1 (numeric-ctype-complexp type1)) + (complexp2 (numeric-ctype-complexp type2)) + (format1 (numeric-ctype-format type1)) + (format2 (numeric-ctype-format type2)) + (low1 (numeric-ctype-low type1)) + (high1 (numeric-ctype-high type1)) + (low2 (numeric-ctype-low type2)) + (high2 (numeric-ctype-high type2))) + ;; + ;; If one is complex and the other isn't, then they are disjoint. + (cond ((not (or (eq complexp1 complexp2) + (null complexp1) (null complexp2))) + nil) + ;; + ;; If either type is a float, then the other must either be specified + ;; to be a float or unspecified. Otherwise, they are disjoint. + ((and (eq class1 'float) (not (member class2 '(float nil)))) nil) + ((and (eq class2 'float) (not (member class1 '(float nil)))) nil) + ;; + ;; If the float formats are specified and different, the types + ;; are disjoint. + ((not (or (eq format1 format2) (null format1) (null format2))) + nil) + (t + ;; + ;; Check the bounds. This is a bit odd because we must always have + ;; the outer bound of the interval as the second arg. + (if (numeric-bound-test high1 high2 <= <) + (or (and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test* low1 high2 <= <)) + (and (numeric-bound-test low2 low1 >= >) + (numeric-bound-test* low2 high1 <= <))) + (or (and (numeric-bound-test* low2 high1 <= <) + (numeric-bound-test low2 low1 >= >)) + (and (numeric-bound-test high2 high1 <= <) + (numeric-bound-test* high2 low1 >= >)))))))) + +;;; Round-Numeric-Bound -- Internal +;;; +;;; Take the numeric bound X and convert it into something that can be used +;;; as a bound in a numeric type with the specified Class and Format. If up-p +;;; is true, then we round up as needed, otherwise we round down. Up-p true +;;; implies that X is a lower bound, i.e. (N) > N. +;;; +;;; This is used by Numeric-Type-Intersection to mash the bound into the +;;; appropriate type number. X may only be a float when Class is Float. +;;; +;;; ### Note: it is possible for the coercion to a float to overflow or +;;; underflow. This happens when the bound doesn't fit in the specified +;;; format. In this case, we should really return the appropriate +;;; {Most | Least}-{Positive | Negative}-XXX-Float float of desired format. +;;; But these conditions aren't currently signalled in any useful way. +;;; +;;; Also, when converting an open rational bound into a float we should +;;; probably convert it to a closed bound of the closest float in the specified +;;; format. In general, open float bounds are fucked. +;;; +(defun round-numeric-bound (x class format up-p) + (if x + (let ((cx (if (consp x) (car x) x))) + (ecase class + ((nil rational) x) + (integer + (if (and (consp x) (integerp cx)) + (if up-p (1+ cx) (1- cx)) + (if up-p (ceiling cx) (floor cx)))) + (float + (let ((res (if format (coerce cx format) (float cx)))) + (if (consp x) (list res) res))))) + nil)) + +;;; Number :Simple-Intersection type method -- Internal +;;; +;;; Handle the case of Type-Intersection on two numeric types. We use +;;; Types-Intersect to throw out the case of types with no intersection. If an +;;; attribute in Type1 is unspecified, then we use Type2's attribute, which +;;; must be at least as restrictive. If the types intersect, then the only +;;; attributes that can be specified and different are the class and the +;;; bounds. +;;; +;;; When the class differs, we use the more restrictive class. The only +;;; interesting case is rational/integer, since rational includes integer. +;;; +;;; We make the result lower (upper) bound the maximum (minimum) of the +;;; argument lower (upper) bounds. We convert the bounds into the +;;; appropriate numeric type before maximizing. This avoids possible confusion +;;; due to mixed-type comparisons (but I think the result is the same). +;;; +(define-type-method (number :simple-intersection) (type1 type2) + (declare (type numeric-ctype type1 type2)) + (if (numeric-types-intersect type1 type2) + (let* ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (class (ecase class1 + ((nil) class2) + ((integer float) class1) + (rational (if (eq class2 'integer) 'integer 'rational)))) + (format (or (numeric-ctype-format type1) + (numeric-ctype-format type2)))) + (make-numeric-ctype + :class class + :format format + :complexp (or (numeric-ctype-complexp type1) + (numeric-ctype-complexp type2)) + :low (numeric-bound-max + (round-numeric-bound (numeric-ctype-low type1) + class format t) + (round-numeric-bound (numeric-ctype-low type2) + class format t) + > >= nil) + :high (numeric-bound-max + (round-numeric-bound (numeric-ctype-high type1) + class format nil) + (round-numeric-bound (numeric-ctype-high type2) + class format nil) + < <= nil))) + *empty-type*)) + +;;; Float-Format-Max -- Interface +;;; +;;; Given two float formats, return the one with more precision. If either +;;; one is null, return NIL. +;;; +(defun float-format-max (f1 f2) + (when (and f1 f2) + (dolist (f float-formats (error "Bad float format: ~S." f1)) + (when (or (eq f f1) (eq f f2)) + (return f))))) + + +;;; Numeric-Contagion -- Interface +;;; +;;; Return the result of an operation on Type1 and Type2 according to the +;;; rules of numeric contagion. This is always NUMBER, some float format +;;; (possibly complex) or RATIONAL. Due to rational canonicalization, there +;;; isn't much we can do here with integers or rational complex numbers. +;;; +;;; If either argument is not a Numeric-Type, then return NUMBER. This is +;;; useful mainly for allowing types that are technically numbers, but not a +;;; Numeric-Type. +;;; +(defun numeric-contagion (type1 type2) + (if (and (numeric-ctype-p type1) (numeric-ctype-p type2)) + (let ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (format1 (numeric-ctype-format type1)) + (format2 (numeric-ctype-format type2)) + (complexp1 (numeric-ctype-complexp type1)) + (complexp2 (numeric-ctype-complexp type2))) + (cond ((or (null complexp1) + (null complexp2)) + (specifier-type 'number)) + ((eq class1 'float) + (make-numeric-ctype + :class 'float + :format (ecase class2 + (float (float-format-max format1 format2)) + ((integer rational) format1) + ((nil) + ;; A double-float with any real number is a + ;; double-float. + (if (eq format1 'double-float) + 'double-float + nil))) + :complexp (if (or (eq complexp1 :complex) + (eq complexp2 :complex)) + :complex + :real))) + ((eq class2 'float) (numeric-contagion type2 type1)) + ((and (eq complexp1 :real) (eq complexp2 :real)) + (make-numeric-ctype + :class (and class1 class2 'rational) + :complexp :real)) + (t + (specifier-type 'number)))) + (specifier-type 'number))) + + + + + +;;;; Array types: + +;;; The Array-Type is used to represent all array types, including things such +;;; as SIMPLE-STRING. +;;; + +(defun make-array-ctype (&key + (dimensions '*) + (complexp '*) + element-type + (specialized-element-type *wild-type*)) + (%istruct 'array-ctype + (type-class-or-lose 'array) + nil + dimensions + complexp + element-type + specialized-element-type + (unless (eq specialized-element-type *wild-type*) + (ctype-subtype specialized-element-type)))) + +(defun array-ctype-p (x) (istruct-typep x 'array-ctype)) +(setf (type-predicate 'array-ctype) 'array-ctype-p) + +;;; Specialized-Element-Type-Maybe -- Internal +;;; +;;; What this does depends on the setting of the +;;; *use-implementation-types* switch. If true, return the specialized element +;;; type, otherwise return the original element type. +;;; +(defun specialized-element-type-maybe (type) + (declare (type array-ctype type)) + (if *use-implementation-types* + (array-ctype-specialized-element-type type) + (array-ctype-element-type type))) + +(define-type-method (array :simple-=) (type1 type2) + (if (or (unknown-ctype-p (array-ctype-element-type type1)) + (unknown-ctype-p (array-ctype-element-type type2))) + (multiple-value-bind (equalp certainp) + (type= (array-ctype-element-type type1) + (array-ctype-element-type type2)) + (assert (not (and (not equalp) certainp))) + (values equalp certainp)) + (values (and (equal (array-ctype-dimensions type1) + (array-ctype-dimensions type2)) + (eq (array-ctype-complexp type1) + (array-ctype-complexp type2)) + (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2))) + t))) + +(define-type-method (array :unparse) (type) + (let ((dims (array-ctype-dimensions type)) + (eltype (type-specifier (array-ctype-element-type type))) + (complexp (array-ctype-complexp type))) + (cond ((eq dims '*) + (if (eq eltype '*) + (if complexp 'array 'simple-array) + (if complexp `(array ,eltype) `(simple-array ,eltype)))) + ((= (length dims) 1) + (if complexp + (if (eq (car dims) '*) + (case eltype + (bit 'bit-vector) + ((character base-char) 'base-string) + (* 'vector) + (t `(vector ,eltype))) + (case eltype + (bit `(bit-vector ,(car dims))) + ((character base-char) `(base-string ,(car dims))) + (t `(vector ,eltype ,(car dims))))) + (if (eq (car dims) '*) + (case eltype + (bit 'simple-bit-vector) + ((base-char character) 'simple-base-string) + ((t) 'simple-vector) + (t `(simple-array ,eltype (*)))) + (case eltype + (bit `(simple-bit-vector ,(car dims))) + ((base-char character) `(simple-base-string ,(car dims))) + ((t) `(simple-vector ,(car dims))) + (t `(simple-array ,eltype ,dims)))))) + (t + (if complexp + `(array ,eltype ,dims) + `(simple-array ,eltype ,dims)))))) + +(define-type-method (array :simple-subtypep) (type1 type2) + (let ((dims1 (array-ctype-dimensions type1)) + (dims2 (array-ctype-dimensions type2)) + (complexp2 (array-ctype-complexp type2))) + (cond (;; not subtypep unless dimensions are compatible + (not (or (eq dims2 '*) + (and (not (eq dims1 '*)) + (= (length (the list dims1)) + (length (the list dims2))) + (every (lambda (x y) + (or (eq y '*) (eql x y))) + (the list dims1) + (the list dims2))))) + (values nil t)) + ;; not subtypep unless complexness is compatible + ((not (or (eq complexp2 :maybe) + (eq (array-ctype-complexp type1) complexp2))) + (values nil t)) + ;; Since we didn't fail any of the tests above, we win + ;; if the TYPE2 element type is wild. + ((eq (array-ctype-element-type type2) *wild-type*) + (values t t)) + (;; Since we didn't match any of the special cases above, we + ;; can't give a good answer unless both the element types + ;; have been defined. + (or (unknown-ctype-p (array-ctype-element-type type1)) + (unknown-ctype-p (array-ctype-element-type type2))) + (values nil nil)) + (;; Otherwise, the subtype relationship holds iff the + ;; types are equal, and they're equal iff the specialized + ;; element types are identical. + t + (values (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2)) + t))))) + +; (define-superclasses array (string string) (vector vector) (array)) + + +(defun array-types-intersect (type1 type2) + (declare (type array-ctype type1 type2)) + (let ((dims1 (array-ctype-dimensions type1)) + (dims2 (array-ctype-dimensions type2)) + (complexp1 (array-ctype-complexp type1)) + (complexp2 (array-ctype-complexp type2))) + ;; See whether dimensions are compatible. + (cond ((not (or (eq dims1 '*) (eq dims2 '*) + (and (= (length dims1) (length dims2)) + (every (lambda (x y) + (or (eq x '*) (eq y '*) (= x y))) + dims1 dims2)))) + (values nil t)) + ;; See whether complexpness is compatible. + ((not (or (eq complexp1 :maybe) + (eq complexp2 :maybe) + (eq complexp1 complexp2))) + (values nil t)) + ((or (eq (array-ctype-specialized-element-type type1) *wild-type*) + (eq (array-ctype-specialized-element-type type2) *wild-type*) + (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2))) + (values t t)) + (t + (values nil t))))) + +(define-type-method (array :simple-intersection) (type1 type2) + (declare (type array-ctype type1 type2)) + (if (array-types-intersect type1 type2) + (let ((dims1 (array-ctype-dimensions type1)) + (dims2 (array-ctype-dimensions type2)) + (complexp1 (array-ctype-complexp type1)) + (complexp2 (array-ctype-complexp type2)) + (eltype1 (array-ctype-element-type type1)) + (eltype2 (array-ctype-element-type type2))) + (specialize-array-type + (make-array-ctype + :dimensions (cond ((eq dims1 '*) dims2) + ((eq dims2 '*) dims1) + (t + (mapcar #'(lambda (x y) (if (eq x '*) y x)) + dims1 dims2))) + :complexp (if (eq complexp1 :maybe) complexp2 complexp1) + :element-type (cond + ((eq eltype1 *wild-type*) eltype2) + ((eq eltype2 *wild-type*) eltype1) + (t (type-intersection eltype1 eltype2)))))) + *empty-type*)) + +;;; Check-Array-Dimensions -- Internal +;;; +;;; Check a supplied dimension list to determine if it is legal. +;;; +(defun check-array-dimensions (dims) + (typecase dims + ((member *) dims) + (integer + (when (minusp dims) + (signal-program-error "Arrays can't have a negative number of dimensions: ~D." dims)) + (when (>= dims array-rank-limit) + (signal-program-error "Array type has too many dimensions: ~S." dims)) + (make-list dims :initial-element '*)) + (list + (when (>= (length dims) array-rank-limit) + (signal-program-error "Array type has too many dimensions: ~S." dims)) + (dolist (dim dims) + (unless (eq dim '*) + (unless (and (integerp dim) + (>= dim 0) (< dim array-dimension-limit)) + (signal-program-error "Bad dimension in array type: ~S." dim)))) + dims) + (t + (signal-program-error "Array dimensions is not a list, integer or *:~% ~S" + dims)))) + +(def-type-translator array (&optional element-type dimensions &environment env) + (specialize-array-type + (make-array-ctype :dimensions (check-array-dimensions dimensions) + :complexp :maybe + :element-type (specifier-type element-type env)))) + +(def-type-translator simple-array (&optional element-type dimensions &environment env) + (specialize-array-type + (make-array-ctype :dimensions (check-array-dimensions dimensions) + :element-type (specifier-type element-type env) + :complexp nil))) + +;;; Order matters here. +(defparameter specialized-array-element-types + '(nil bit (unsigned-byte 8) (signed-byte 8) (unsigned-byte 16) + (signed-byte 16) (unsigned-byte 32) #+32-bit-target fixnum (signed-byte 32) + #+64-bit-target (unsigned-byte 64) + #+64-bit-target fixnum + #+64-bit-target (signed-byte 64) + character short-float double-float)) + +(defun specialize-array-type (type) + (let* ((eltype (array-ctype-element-type type)) + (specialized-type (if (eq eltype *wild-type*) + *wild-type* + (dolist (stype-name specialized-array-element-types + *universal-type*) + (let ((stype (specifier-type stype-name))) + (when (csubtypep eltype stype) + (return stype))))))) + + (setf (array-ctype-specialized-element-type type) specialized-type + (array-ctype-typecode type) (unless (eq specialized-type *wild-type*) + (ctype-subtype specialized-type))) + type)) + + + +;;;; Member types. + +;;; The Member-Type represents uses of the MEMBER type specifier. We bother +;;; with this at this level because MEMBER types are fairly important and union +;;; and intersection are well defined. + +(defun %make-member-ctype (members) + (%istruct 'member-ctype + (type-class-or-lose 'member) + t + members)) + +(defun make-member-ctype (&key members) + (let* ((singlep (subsetp '(-0.0f0 0.0f0) members)) + (doublep (subsetp '(-0.0d0 0.0d0) members)) + (union-types + (if singlep + (if doublep + (list *ctype-of-single-float-0* *ctype-of-double-float-0*) + (list *ctype-of-single-float-0*)) + (if doublep + (list *ctype-of-double-float-0*))))) + (if union-types + (progn + (if singlep + (setq members (set-difference '(-0.0f0 0.0f0) members))) + (if doublep + (setq members (set-difference '(-0.d00 0.0d0) members))) + (make-union-ctype (if (null members) + union-types + (cons (%make-member-ctype members) union-types)))) + (%make-member-ctype members)))) + + +(defun member-ctype-p (x) (istruct-typep x 'member-ctype)) +(setf (type-predicate 'member-ctype) 'member-ctype-p) + +(define-type-method (member :unparse) (type) + (if (type= type (specifier-type 'standard-char)) + 'standard-char + (let ((members (member-ctype-members type))) + (if (equal members '(nil)) + 'null + `(member ,@members))))) + +(define-type-method (member :simple-subtypep) (type1 type2) + (values (subsetp (member-ctype-members type1) (member-ctype-members type2)) + t)) + + +(define-type-method (member :complex-subtypep-arg1) (type1 type2) + (every/type (swapped-args-fun #'ctypep) + type2 + (member-ctype-members type1))) + +;;; We punt if the odd type is enumerable and intersects with the member type. +;;; If not enumerable, then it is definitely not a subtype of the member type. +;;; +(define-type-method (member :complex-subtypep-arg2) (type1 type2) + (cond ((not (ctype-enumerable type1)) (values nil t)) + ((types-intersect type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) + (t + (values nil t)))) + +(define-type-method (member :simple-intersection) (type1 type2) + (let ((mem1 (member-ctype-members type1)) + (mem2 (member-ctype-members type2))) + (values (cond ((subsetp mem1 mem2) type1) + ((subsetp mem2 mem1) type2) + (t + (let ((res (intersection mem1 mem2))) + (if res + (make-member-ctype :members res) + *empty-type*)))) + t))) + +(define-type-method (member :complex-intersection) (type1 type2) + (block PUNT + (collect ((members)) + (let ((mem2 (member-ctype-members type2))) + (dolist (member mem2) + (multiple-value-bind (val win) (ctypep member type1) + (unless win + (return-from punt nil)) + (when val (members member)))) + (cond ((subsetp mem2 (members)) type2) + ((null (members)) *empty-type*) + (t + (make-member-ctype :members (members)))))))) + +;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union +;;; type, and the member/union interaction is handled by the union type +;;; method. +(define-type-method (member :simple-union) (type1 type2) + (let ((mem1 (member-ctype-members type1)) + (mem2 (member-ctype-members type2))) + (cond ((subsetp mem1 mem2) type2) + ((subsetp mem2 mem1) type1) + (t + (make-member-ctype :members (union mem1 mem2)))))) + + +(define-type-method (member :simple-=) (type1 type2) + (let ((mem1 (member-ctype-members type1)) + (mem2 (member-ctype-members type2))) + (values (and (subsetp mem1 mem2) (subsetp mem2 mem1)) + t))) + +(define-type-method (member :complex-=) (type1 type2) + (if (ctype-enumerable type1) + (multiple-value-bind (val win) + (csubtypep type2 type1) + (if (or val (not win)) + (values nil nil) + (values nil t))) + (values nil t))) + +(def-type-translator member (&rest members) + (if members + (collect ((non-numbers) (numbers)) + (dolist (m (remove-duplicates members)) + (if (and (numberp m) + (not (and (floatp m) (zerop m)))) + (numbers (ctype-of m)) + (non-numbers m))) + (apply #'type-union + (if (non-numbers) + (make-member-ctype :members (non-numbers)) + *empty-type*) + (numbers))) + *empty-type*)) + + + + +;;;; Union types: + +;;; The Union-Type represents uses of the OR type specifier which can't be +;;; canonicalized to something simpler. Canonical form: +;;; +;;; 1] There is never more than one Member-Type component. +;;; 2] There are never any Union-Type components. +;;; + +(defun make-union-ctype (types) + (declare (list types)) + (%istruct 'union-ctype + (type-class-or-lose 'union) + (every #'(lambda (x) (ctype-enumerable x)) types) + types)) + +(defun union-ctype-p (x) (istruct-typep x 'union-ctype)) +(setf (type-predicate 'union-ctype) 'union-ctype-p) + + +;;; If List, then return that, otherwise the OR of the component types. +;;; +(define-type-method (union :unparse) (type) + (declare (type ctype type)) + (cond + ((type= type (specifier-type 'list)) 'list) + ((type= type (specifier-type 'float)) 'float) + ((type= type (specifier-type 'real)) 'real) + ((type= type (specifier-type 'sequence)) 'sequence) + ((type= type (specifier-type 'bignum)) 'bignum) + (t `(or ,@(mapcar #'type-specifier (union-ctype-types type)))))) + + + +(define-type-method (union :simple-=) (type1 type2) + (multiple-value-bind (subtype certain?) + (csubtypep type1 type2) + (if subtype + (csubtypep type2 type1) + (if certain? + (values nil t) + (multiple-value-bind (subtype certain?) + (csubtypep type2 type1) + (declare (ignore subtype)) + (values nil certain?)))))) + + +(define-type-method (union :complex-=) (type1 type2) + (declare (ignore type1)) + (if (some #'type-might-contain-other-types-p + (union-ctype-types type2)) + (values nil nil) + (values nil t))) + + +(defun union-simple-subtypep (type1 type2) + (every/type (swapped-args-fun #'union-complex-subtypep-arg2) + type2 + (union-ctype-types type1))) + +(define-type-method (union :simple-subtypep) (type1 type2) + (union-simple-subtypep type1 type2)) + +(defun union-complex-subtypep-arg1 (type1 type2) + (every/type (swapped-args-fun #'csubtypep) + type2 + (union-ctype-types type1))) + +(define-type-method (union :complex-subtypep-arg1) (type1 type2) + (union-complex-subtypep-arg1 type1 type2)) + +(defun union-complex-subtypep-arg2 (type1 type2) + (multiple-value-bind (sub-value sub-certain?) + (progn + (assert (union-ctype-p type2)) + (assert (not (union-ctype-p type1))) + (type= type1 + (apply #'type-union + (mapcar (lambda (x) (type-intersection type1 x)) + (union-ctype-types type2))))) + (if sub-certain? + (values sub-value sub-certain?) + (invoke-complex-subtypep-arg1-method type1 type2)))) + +(define-type-method (union :complex-subtypep-arg2) (type1 type2) + (union-complex-subtypep-arg2 type1 type2)) + +(define-type-method (union :simple-intersection :complex-intersection) + (type1 type2) + (assert (union-ctype-p type2)) + (cond ((and (union-ctype-p type1) + (union-simple-subtypep type1 type2)) type1) + ((and (union-ctype-p type1) + (union-simple-subtypep type2 type1)) type2) + ((and (not (union-ctype-p type1)) + (union-complex-subtypep-arg2 type1 type2)) + type1) + ((and (not (union-ctype-p type1)) + (union-complex-subtypep-arg1 type2 type1)) + type2) + (t + (let ((accumulator *empty-type*)) + (dolist (t2 (union-ctype-types type2) accumulator) + (setf accumulator + (type-union accumulator + (type-intersection type1 t2)))))))) + + + +(def-type-translator or (&rest type-specifiers &environment env) + (apply #'type-union + (mapcar #'(lambda (spec) (specifier-type spec env)) type-specifiers))) + + + +;;; Intersection types +(defun make-intersection-ctype (enumerable types) + (%istruct 'intersection-ctype + (type-class-or-lose 'intersection) + enumerable + types)) + +(defun intersection-ctype-p (x) + (istruct-typep x 'intersection-ctype)) +(setf (type-predicate 'intersection-ctype) 'intersection-ctype-p) + +(define-type-method (intersection :unparse) (type) + (declare (type ctype type)) + (or (find type '(ratio keyword) :key #'specifier-type :test #'type=) + `(and ,@(mapcar #'type-specifier (intersection-ctype-types type))))) + +;;; shared machinery for type equality: true if every type in the set +;;; TYPES1 matches a type in the set TYPES2 and vice versa +(defun type=-set (types1 types2) + (flet (;; true if every type in the set X matches a type in the set Y + (type<=-set (x y) + (declare (type list x y)) + (every (lambda (xelement) + (position xelement y :test #'type=)) + x))) + (values (and (type<=-set types1 types2) + (type<=-set types2 types1)) + t))) + +(define-type-method (intersection :simple-=) (type1 type2) + (type=-set (intersection-ctype-types type1) + (intersection-ctype-types type2))) + +(defun %intersection-complex-subtypep-arg1 (type1 type2) + (type= type1 (type-intersection type1 type2))) + +(defun %intersection-simple-subtypep (type1 type2) + (every/type #'%intersection-complex-subtypep-arg1 + type1 + (intersection-ctype-types type2))) + +(define-type-method (intersection :simple-subtypep) (type1 type2) + (%intersection-simple-subtypep type1 type2)) + +(define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (%intersection-complex-subtypep-arg1 type1 type2)) + +(defun %intersection-complex-subtypep-arg2 (type1 type2) + (every/type #'csubtypep type1 (intersection-ctype-types type2))) + +(define-type-method (intersection :complex-subtypep-arg2) (type1 type2) + (%intersection-complex-subtypep-arg2 type1 type2)) + +(define-type-method (intersection :simple-union :complex-union) + (type1 type2) + (assert (intersection-ctype-p type2)) + (cond ((and (intersection-ctype-p type1) + (%intersection-simple-subtypep type1 type2)) type2) + ((and (intersection-ctype-p type1) + (%intersection-simple-subtypep type2 type1)) type1) + ((and (not (intersection-ctype-p type1)) + (%intersection-complex-subtypep-arg2 type1 type2)) + type2) + ((and (not (intersection-ctype-p type1)) + (%intersection-complex-subtypep-arg1 type2 type1)) + type1) + ((and (csubtypep type2 (specifier-type 'ratio)) + (numeric-ctype-p type1) + (csubtypep type1 (specifier-type 'integer)) + (csubtypep type2 + (make-numeric-ctype + :class 'rational + :complexp nil + :low (if (null (numeric-ctype-low type1)) + nil + (list (1- (numeric-ctype-low type1)))) + :high (if (null (numeric-ctype-high type1)) + nil + (list (1+ (numeric-ctype-high type1))))))) + (type-union type1 + (apply #'type-intersection + (remove (specifier-type '(not integer)) + (intersection-ctype-types type2) + :test #'type=)))) + (t + (let ((accumulator *universal-type*)) + (do ((t2s (intersection-ctype-types type2) (cdr t2s))) + ((null t2s) accumulator) + (let ((union (type-union type1 (car t2s)))) + (when (union-ctype-p union) + (if (and (eq accumulator *universal-type*) + (null (cdr t2s))) + (return union) + (return nil))) + (setf accumulator + (type-intersection accumulator union)))))))) + +(def-type-translator and (&rest type-specifiers &environment env) + (apply #'type-intersection + (mapcar #'(lambda (spec) (specifier-type spec env)) + type-specifiers))) + +;;; cons-ctype +(defun wild-ctype-to-universal-ctype (c) + (if (type= c *wild-type*) + *universal-type* + c)) + +(defun make-cons-ctype (car-ctype-value cdr-ctype-value) + (if (or (eq car-ctype-value *empty-type*) + (eq cdr-ctype-value *empty-type*)) + *empty-type* + (%istruct 'cons-ctype + (type-class-or-lose 'cons) + nil + (wild-ctype-to-universal-ctype car-ctype-value) + (wild-ctype-to-universal-ctype cdr-ctype-value)))) + +(defun cons-ctype-p (x) + (istruct-typep x 'cons-ctype)) + +(setf (type-predicate 'cons-ctype) 'cons-ctype-p) + +(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*) &environment env) + (make-cons-ctype (specifier-type car-type-spec env) + (specifier-type cdr-type-spec env))) + +(define-type-method (cons :unparse) (type) + (let* ((car-spec (type-specifier (cons-ctype-car-ctype type))) + (cdr-spec (type-specifier (cons-ctype-cdr-ctype type)))) + (if (and (member car-spec '(t *)) + (member cdr-spec '(t *))) + 'cons + `(cons ,car-spec ,cdr-spec)))) + +(define-type-method (cons :simple-=) (type1 type2) + (declare (cons-ctype type1 type2)) + (and (type= (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2)) + (type= (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2)))) + +(define-type-method (cons :simple-subtypep) (type1 type2) + (declare (cons-ctype type1 type2)) + (multiple-value-bind (val-car win-car) + (csubtypep (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2)) + (multiple-value-bind (val-cdr win-cdr) + (csubtypep (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2)) + (if (and val-car val-cdr) + (values t (and win-car win-cdr)) + (values nil (or win-car win-cdr)))))) + +(define-type-method (cons :simple-union) (type1 type2) + (declare (type cons-ctype type1 type2)) + (let ((car-type1 (cons-ctype-car-ctype type1)) + (car-type2 (cons-ctype-car-ctype type2)) + (cdr-type1 (cons-ctype-cdr-ctype type1)) + (cdr-type2 (cons-ctype-cdr-ctype type2)) + (car-not1) + (car-not2)) + (macrolet ((frob-car (car1 car2 cdr1 cdr2 + &optional (not1 nil not1p)) + `(type-union + (make-cons-ctype ,car1 (type-union ,cdr1 ,cdr2)) + (make-cons-ctype + (type-intersection + ,car2 + ,(if not1p + not1 + `(specifier-type + `(not ,(type-specifier ,car1))))) + ,cdr2)))) + (cond ((type= car-type1 car-type2) + (make-cons-ctype car-type1 + (type-union cdr-type1 cdr-type2))) + ((type= cdr-type1 cdr-type2) + (make-cons-ctype (type-union car-type1 car-type2) + cdr-type1)) + ((csubtypep car-type1 car-type2) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) + ((csubtypep car-type2 car-type1) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) + ;; more general case of the above, but harder to compute + ((progn + (setf car-not1 (specifier-type + `(not ,(type-specifier car-type1)))) + (not (csubtypep car-type2 car-not1))) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) + ((progn + (setf car-not2 (specifier-type + `(not ,(type-specifier car-type2)))) + (not (csubtypep car-type1 car-not2))) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)))))) + +(define-type-method (cons :simple-intersection) (type1 type2) + (declare (type cons-ctype type1 type2)) + (let ((car-int2 (type-intersection2 (cons-ctype-car-ctype type1) + (cons-ctype-car-ctype type2))) + (cdr-int2 (type-intersection2 (cons-ctype-cdr-ctype type1) + (cons-ctype-cdr-ctype type2)))) + (cond ((and car-int2 cdr-int2) + (make-cons-ctype car-int2 cdr-int2)) + (car-int2 + (make-cons-ctype car-int2 + (type-intersection (cons-ctype-cdr-ctype type1) + (cons-ctype-cdr-ctype type2)))) + (cdr-int2 + (make-cons-ctype (type-intersection (cons-ctype-car-ctype type1) + (cons-ctype-car-ctype type2)) + cdr-int2))))) + + + +;;; An UNKNOWN-TYPE is a type not known to the type system (not yet defined). +;;; We make this distinction since we don't want to complain about types that +;;; are hairy but defined. +;;; + +(defun make-unknown-ctype (&key specifier (enumerable t)) + (%istruct 'unknown-ctype + (type-class-or-lose 'hairy) + enumerable + specifier)) + +(defun unknown-ctype-p (x) + (istruct-typep x 'unknown-ctype)) + +(setf (type-predicate 'unknown-ctype) 'unknown-ctype-p) + + + + + +;;;; foreign-type types + + +(defun %make-foreign-ctype (foreign-type) + (%istruct 'foreign-ctype + (type-class-or-lose 'foreign) + nil + foreign-type)) + +(defun foreign-ctype-p (x) (istruct-typep x 'foreign-ctype)) +(setf (type-predicate 'foreign-ctype) 'foreign-ctype-p) + +(define-type-method (foreign :unparse) (type) + `(foreign ,(unparse-foreign-type (foreign-ctype-foreign-type type)))) + +(define-type-method (foreign :simple-subtypep) (type1 type2) + (values (foreign-subtype-p (foreign-ctype-foreign-type type1) + (foreign-ctype-foreign-type type2)) + t)) + +;(define-superclasses foreign (foreign-value)) + +(define-type-method (foreign :simple-=) (type1 type2) + (let ((foreign-type-1 (foreign-ctype-foreign-type type1)) + (foreign-type-2 (foreign-ctype-foreign-type type2))) + (values (or (eq foreign-type-1 foreign-type-2) + (foreign-type-= foreign-type-1 foreign-type-2)) + t))) + +(def-type-translator foreign (&optional (foreign-type nil)) + (typecase foreign-type + (null + (make-foreign-ctype)) + (foreign-type + (make-foreign-ctype foreign-type)) + (t + (make-foreign-ctype (parse-foreign-type foreign-type))))) + +(defun make-foreign-ctype (&optional foreign-type) + (if foreign-type + (let ((lisp-rep-type (compute-lisp-rep-type foreign-type))) + (if lisp-rep-type + (specifier-type lisp-rep-type) + (%make-foreign-ctype foreign-type))) + *universal-type*)) + + +;;; CLASS-CTYPES are supposed to help integrate CLOS and the CMU type system. +;;; They mostly just contain a backpointer to the CLOS class; the CPL is then +;;; used to resolve type relationships. + +(defun class-ctype-p (x) (istruct-typep x 'class-ctype)) +(setf (type-predicate 'class-ctype) 'class-ctype-p) + +(defun args-ctype-p (x) (and (eql (typecode x) target::subtag-istruct) + (member (istruct-type-name x) + '(args-ctype values-ctype function-ctype)))) + +(setf (type-predicate 'args-ctype) 'args-ctype-p + (type-predicate 'function-ctype) 'function-ctype-p + (type-predicate 'values-ctype) 'values-ctype-p) + + +;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two +;;; classes are equal, since there are EQ checks in those operations. +;;; +(define-type-method (class :simple-=) (type1 type2) + (assert (not (eq type1 type2))) + (values nil t)) + +(define-type-method (class :simple-subtypep) (type1 type2) + (assert (not (eq type1 type2))) + (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1))) + (class2 (if (class-ctype-p type2) (class-ctype-class type2)))) + (if (and class1 class2) + (let* ((ordinal2 (%class-ordinal class2)) + (wrapper1 (%class.own-wrapper class1)) + (bits1 (if wrapper1 (%wrapper-cpl-bits wrapper1)))) + (if bits1 + (locally (declare (simple-bit-vector bits1) + (optimize (speed 3) (safety 0))) + (values (if (< ordinal2 (length bits1)) + (not (eql 0 (sbit bits1 ordinal2)))) + t)) + (if (%standard-instance-p class1) + (if (memq class2 (%class.local-supers class1)) + (values t t) + (if (eq (%class-of-instance class1) + *forward-referenced-class-class*) + (values nil nil) + ;; %INITED-CLASS-CPL will return NIL if class1 can't + ;; be finalized; in that case, we don't know the answer. + (let ((supers (%inited-class-cpl class1))) + (if (memq class2 supers) + (values t t) + (values nil (not (null supers))))))) + (values nil t)))) + (values nil t)))) + +(defun find-class-intersection (c1 c2) + (labels ((walk-subclasses (class f) + (dolist (sub (class-direct-subclasses class)) + (walk-subclasses sub f)) + (funcall f class))) + (let* ((intersection nil)) + (walk-subclasses c1 #'(lambda (c) + (when (subclassp c c2) + (pushnew (%class.ctype c) intersection)))) + (when intersection + (%type-union intersection))))) + +(define-type-method (class :simple-intersection) (type1 type2) + (assert (not (eq type1 type2))) + (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1))) + (class2 (if (class-ctype-p type2) (class-ctype-class type2)))) + (if (and class1 + (not (typep class1 'compile-time-class)) + class2 + (not (typep class2 'compile-time-class))) + (cond ((subclassp class1 class2) + type1) + ((subclassp class2 class1) + type2) + ;;; In the STANDARD-CLASS case where neither's + ;;; a subclass of the other, there may be + ;;; one or mor classes that're a subclass of both. We + ;;; -could- try to find all such classes, but + ;;; punt instead. + (t (or (find-class-intersection class1 class2) + *empty-type*))) + nil))) + +(define-type-method (class :complex-subtypep-arg2) (type1 class2) + (if (and (intersection-ctype-p type1) + (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1)) + (values nil nil) + (if (function-ctype-p type1) + (csubtypep (specifier-type 'function) class2) + (invoke-complex-subtypep-arg1-method type1 class2 nil t)))) + +(define-type-method (class :complex-subtypep-arg1) (type1 type2) + (if (and (function-ctype-p type2) + (eq type1 (specifier-type 'function)) + (function-ctype-wild-args type2) + (eq *wild-type* (function-ctype-returns type2))) + (values t t) + (values nil t))) + +(define-type-method (class :unparse) (type) + (class-name (class-ctype-class type))) + + + +;;; TYPE-DIFFERENCE -- Interface +;;; +;;; Return the type that describes all objects that are in X but not in Y. +;;; If we can't determine this type, then return NIL. +;;; +;;; For now, we only are clever dealing with union and member types. If +;;; either type is not a union type, then we pretend that it is a union of just +;;; one type. What we do is remove from X all the types that are a subtype any +;;; type in Y. If any type in X intersects with a type in Y but is not a +;;; subtype, then we give up. +;;; +;;; We must also special-case any member type that appears in the union. We +;;; remove from X's members all objects that are TYPEP to Y. If Y has any +;;; members, we must be careful that none of those members are CTYPEP to any +;;; of Y's non-member types. We give up in this case, since to compute that +;;; difference we would have to break the type from X into some collection of +;;; types that represents the type without that particular element. This seems +;;; too hairy to be worthwhile, given its low utility. +;;; +(defun type-difference (x y) + (let ((x-types (if (union-ctype-p x) (union-ctype-types x) (list x))) + (y-types (if (union-ctype-p y) (union-ctype-types y) (list y)))) + (collect ((res)) + (dolist (x-type x-types) + (if (member-ctype-p x-type) + (collect ((members)) + (dolist (mem (member-ctype-members x-type)) + (multiple-value-bind (val win) (ctypep mem y) + (unless win (return-from type-difference nil)) + (unless val + (members mem)))) + (when (members) + (res (make-member-ctype :members (members))))) + (dolist (y-type y-types (res x-type)) + (multiple-value-bind (val win) (csubtypep x-type y-type) + (unless win (return-from type-difference nil)) + (when val (return)) + (when (types-intersect x-type y-type) + (return-from type-difference nil)))))) + (let ((y-mem (find-if #'member-ctype-p y-types))) + (when y-mem + (let ((members (member-ctype-members y-mem))) + (dolist (x-type x-types) + (unless (member-ctype-p x-type) + (dolist (member members) + (multiple-value-bind (val win) (ctypep member x-type) + (when (or (not win) val) + (return-from type-difference nil))))))))) + (apply #'type-union (res))))) + +;;; CTypep -- Interface +;;; +;;; If Type is a type that we can do a compile-time test on, then return the +;;; whether the object is of that type as the first value and second value +;;; true. Otherwise return NIL, NIL. +;;; +;;; We give up on unknown types, pick off FUNCTION and UNION types. For +;;; structure types, we require that the type be defined in both the current +;;; and compiler environments, and that the INCLUDES be the same. +;;; +(defun ctypep (obj type) + (declare (type ctype type)) + (etypecase type + ((or numeric-ctype named-ctype member-ctype array-ctype cons-ctype) + (values (%typep obj type) t)) + (class-ctype + (values (not (null (class-typep obj (class-ctype-class type)))) t) +) + (union-ctype + (any/type #'ctypep obj (union-ctype-types type))) + (intersection-ctype + (every/type #'ctypep obj (intersection-ctype-types type))) + (function-ctype + (values (functionp obj) t)) + (unknown-ctype + (values nil nil)) + (foreign-ctype + (values (foreign-typep obj (foreign-ctype-foreign-type type)) t)) + (negation-ctype + (multiple-value-bind (res win) + (ctypep obj (negation-ctype-type type)) + (if win + (values (not res) t) + (values nil nil)))) + (hairy-ctype + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-ctype-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and ; how would this get there ? + (if (atom hairy-spec) + (values t t) + (dolist (spec (cdr hairy-spec) (values t t)) + (multiple-value-bind (res win) + (ctypep obj (specifier-type spec)) + (unless win (return (values nil nil))) + (unless res (return (values nil t))))))) + (not ; how would this get there ? + (multiple-value-bind + (res win) + (ctypep obj (specifier-type (cadr hairy-spec))) + (if win + (values (not res) t) + (values nil nil)))) + (satisfies + (let ((fun (second hairy-spec))) + (cond ((and (symbolp fun) (fboundp fun)) + ;; Binding *BREAK-ON-SIGNALS* here is a modularity + ;; violation intended to improve the signal-to-noise + ;; ratio on a mailing list. + (values (not (null (let* ((*break-on-signals* nil)) + (ignore-errors (funcall fun obj))))) t)) + (t + (values nil nil)))))))))) + +;;; %TYPEP -- internal. +;;; +;;; The actual typep engine. The compiler only generates calls to this +;;; function when it can't figure out anything more intelligent to do. +;;; +; lose 1 function call -MAYBE +(defun %typep (object specifier) + (%%typep object + (if (typep specifier 'ctype) + specifier + (specifier-type specifier)))) + +(eval-when (:compile-toplevel) + (declaim (inline numeric-%%typep + array-%%typep + member-%%typep + cons-%%typep))) + +(defun numeric-%%typep (object type) + (let ((pred (numeric-ctype-predicate type))) + (if pred + (funcall pred object) + (and (numberp object) + (let ((num (if (complexp object) (realpart object) object))) + (ecase (numeric-ctype-class type) + (integer (integerp num)) + (rational (rationalp num)) + (float + (ecase (numeric-ctype-format type) + (single-float (typep num 'single-float)) + (double-float (typep num 'double-float)) + ((nil) (floatp num)))) + ((nil) t))) + (flet ((bound-test (val) + (let ((low (numeric-ctype-low type)) + (high (numeric-ctype-high type))) + (and (cond ((null low) t) + ((listp low) (> val (car low))) + (t (>= val low))) + (cond ((null high) t) + ((listp high) (< val (car high))) + (t (<= val high))))))) + (ecase (numeric-ctype-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (bound-test (realpart object)) + (bound-test (imagpart object)))) + (:real + (and (not (complexp object)) + (bound-test object))))))))) + +(defun array-%%typep (object type) + (let* ((typecode (typecode object))) + (declare (type (unsigned-byte 8) typecode)) + (and (>= typecode target::subtag-arrayH) + (ecase (array-ctype-complexp type) + ((t) (not (simple-array-p object))) + ((nil) (simple-array-p object)) + ((* :maybe) t)) + (let* ((ctype-dimensions (array-ctype-dimensions type))) + (or (eq ctype-dimensions '*) + (if (eql typecode target::subtag-arrayH) + (let* ((rank (%svref object target::arrayH.rank-cell))) + (declare (fixnum rank)) + (and (eql rank (length ctype-dimensions)) + (do* ((i 0 (1+ i)) + (dim target::arrayH.dim0-cell (1+ dim)) + (want (array-ctype-dimensions type) (cdr want)) + (got (%svref object dim) (%svref object dim))) + ((eql i rank) t) + (unless (or (eq (car want) '*) + (eql (%car want) (the fixnum got))) + (return nil))))) + (and (null (cdr ctype-dimensions)) + (or (eq (%car ctype-dimensions) '*) + (eql (%car ctype-dimensions) + (if (eql typecode target::subtag-vectorH) + (%svref object target::vectorH.physsize-cell) + (uvsize object)))))))) + (or (eq (array-ctype-element-type type) *wild-type*) + (eql (array-ctype-typecode type) + (if (> typecode target::subtag-vectorH) + typecode + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell))))) + (type= (array-ctype-specialized-element-type type) + (specifier-type (array-element-type object))))))) + + +(defun member-%%typep (object type) + (not (null (member object (member-ctype-members type))))) + +(defun cons-%%typep (object type) + (and (consp object) + (%%typep (car object) (cons-ctype-car-ctype type)) + (%%typep (cdr object) (cons-ctype-cdr-ctype type)))) + + +(defun %%typep (object type) + ;(if (not (typep type 'ctype))(setq type (specifier-type type))) + (locally (declare (type ctype type)) + (etypecase type + (named-ctype + (ecase (named-ctype-name type) + ((* t) t) + ((nil) nil))) + (numeric-ctype + (numeric-%%typep object type)) + (array-ctype + (array-%%typep object type)) + (member-ctype + (member-%%typep object type)) + (class-ctype + (not (null (class-typep object (class-ctype-class type))))) + (union-ctype + (dolist (type (union-ctype-types type)) + (when (%%typep object type) + (return t)))) + (intersection-ctype + (dolist (type (intersection-ctype-types type) t) + (unless (%%typep object type) (return nil)))) + (cons-ctype + (cons-%%typep object type)) + (unknown-ctype + ;; Parse it again to make sure it's really undefined. + (let ((reparse (specifier-type (unknown-ctype-specifier type)))) + (if (typep reparse 'unknown-ctype) + (error "Unknown type specifier: ~S" + (unknown-ctype-specifier reparse)) + (%%typep object reparse)))) + (negation-ctype + (not (%%typep object (negation-ctype-type type)))) + (hairy-ctype + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-ctype-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and + (or (atom hairy-spec) + (dolist (spec (cdr hairy-spec) t) + (unless (%%typep object (specifier-type spec)) + (return nil))))) + (not + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (not (%%typep object (specifier-type (cadr hairy-spec))))) + (satisfies + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (let ((fn (cadr hairy-spec))) + (if (funcall (typecase fn + (function fn) + (symbol (symbol-function fn)) + (t + (coerce fn 'function))) + object) + t + nil)))))) + #| + (foreign-ctype + (foreign-typep object (foreign-ctype-foreign-type type))) +|# + (function-ctype + (error "Function types are not a legal argument to TYPEP:~% ~S" + (type-specifier type)))))) + + +;;; Ctype-Of -- Interface +;;; +;;; Like Type-Of, only returns a Type structure instead of a type +;;; specifier. We try to return the type most useful for type checking, rather +;;; than trying to come up with the one that the user might find most +;;; informative. +;;; + +(defun float-format-name (x) + (declare (float x)) + (etypecase x + (single-float "SINGLE-FLOAT") + (double-float "DOUBLE-FLOAT"))) + +(defun ctype-of-number (x) + (let ((num (if (complexp x) (realpart x) x))) + (multiple-value-bind (complexp low high) + (if (complexp x) + (let ((imag (imagpart x))) + (values :complex (min num imag) (max num imag))) + (values :real num num)) + (make-numeric-ctype :class (etypecase num + (integer (if (complexp x) + (if (integerp (imagpart x)) + 'integer + 'rational) + 'integer)) + (rational 'rational) + (float 'float)) + :format (and (floatp num) + (if (typep num 'double-float) + 'double-float + 'single-float)) + :complexp complexp + :low low + :high high)))) + +(defun ctype-of (x) + (typecase x + (function (specifier-type 'function)) ; GFs .. + (symbol + (make-member-ctype :members (list x))) + (number (ctype-of-number x)) + (array + (let ((etype (specifier-type (array-element-type x)))) + (make-array-ctype :dimensions (array-dimensions x) + :complexp (not (typep x 'simple-array)) + :element-type etype + :specialized-element-type etype))) + (t + (%class.ctype (class-of x))))) + +(defvar *ctype-of-double-float-0* (ctype-of 0.0d0)) +(defvar *ctype-of-single-float-0* (ctype-of 0.0f0)) + + + + +; These DEFTYPES should only happen while initializing. + +(progn +(let-globally ((*type-system-initialized* nil)) + + +(deftype bit () '(integer 0 1)) + +(deftype eql (val) `(member ,val)) + +(deftype signed-byte (&optional s) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 0)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(1- bound)))) + (t + (signal-program-error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + +(deftype unsigned-byte (&optional s) + (cond ((eq s '*) '(integer 0)) + ((and (integerp s) (> s 0)) + `(integer 0 ,(1- (ash 1 s)))) + (t + (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s)))) + +(deftype vector (&optional element-type size) + `(array ,element-type (,size))) + +(deftype simple-vector (&optional size) + `(simple-array t (,size))) + +(deftype base-string (&optional size) + `(array base-char (,size))) +(deftype simple-base-string (&optional size) + `(simple-array base-char (,size))) + + + +(deftype string (&optional size) + `(array character (,size))) + +(deftype simple-string (&optional size) + `(simple-array character (,size))) + +(deftype bit-vector (&optional size) + `(array bit (,size))) + +(deftype simple-bit-vector (&optional size) + `(simple-array bit (,size))) + +; TYPE-OF sometimes returns random symbols that aren't really type specifiers. + +(deftype simple-unsigned-word-vector (&optional size) + `(simple-array (unsigned-byte 16) (,size))) + +(deftype simple-unsigned-byte-vector (&optional size) + `(simple-array (unsigned-byte 8) (,size))) + +(deftype simple-unsigned-long-vector (&optional size) + `(simple-array (unsigned-byte 32) (,size))) + +(deftype simple-signed-word-vector (&optional size) + `(simple-array (signed-byte 16) (,size))) + +(deftype simple-signed-byte-vector (&optional size) + `(simple-array (signed-byte 8) (,size))) + +(deftype simple-signed-long-vector (&optional size) + `(simple-array (signed-byte 32) (,size))) + + + +(deftype simple-short-float-vector (&optional size) + `(simple-array short-float (,size))) + +(deftype unsigned-word-vector (&optional size) + `(vector (unsigned-byte 16) ,size)) + +(deftype single-float-vector (&optional size) + `(vector short-float ,size)) + +(deftype unsigned-byte-vector (&optional size) + `(vector (unsigned-byte 8) ,size)) + +(deftype unsigned-long-vector (&optional size) + `(vector (unsigned-byte 32) ,size)) + +(deftype long-float-vector (&optional size) + `(vector double-float ,size)) + +(deftype long-vector (&optional size) + `(vector (signed-byte 32) ,size)) + +(deftype double-float-vector (&optional size) + `(vector double-float ,size)) + +(deftype byte-vector (&optional size) + `(vector (signed-byte 8) ,size)) + +(deftype general-vector (&optional size) + `(vector t ,size)) + +(deftype word-vector (&optional size) + `(vector (signed-byte 16) ,size)) + +(deftype short-float-vector (&optional size) + `(vector single-float ,size)) + +(deftype simple-1d-array (&optional size) + `(simple-array * (,size))) + +(deftype simple-long-vector (&optional size) + `(simple-array (signed-byte 32) (,size))) + +(deftype simple-word-vector (&optional size) + `(simple-array (signed-byte 16) (,size))) + +(deftype simple-short-float-vector (&optional size) + `(simple-array single-float (,size))) + +(deftype simple-byte-vector (&optional size) + `(simple-array (signed-byte 8) (,size))) + +(deftype simple-double-float-vector (&optional size) + `(simple-array double-float (,size))) + +(deftype simple-single-float-vector (&optional size) + `(simple-array single-float (,size))) + +(deftype simple-long-float-vector (&optional size) + `(simple-array double-float (,size))) + +(deftype simple-fixnum-vector (&optional size) + `(simple-array fixnum (,size))) + +(deftype fixnum-vector (&optional size) + `(array fixnum (,size))) + +#+64-bit-target +(deftype simple-doubleword-vector (&optional size) + `(simple-array (signed-byte 64) (,size))) + +#+64-bit-target +(deftype simple-unsigned-doubleword-vector (&optional size) + `(simple-array (unsigned-byte 64) (,size))) + + +(deftype short-float (&optional low high) + `(single-float ,low ,high)) + +(deftype long-float (&optional low high) + `(double-float ,low ,high)) + +#|| +;;; As empty a type as you're likely to find ... +(deftype extended-char () + "Type of CHARACTERs that aren't BASE-CHARs." + nil) +||# + +(deftype natural () + `(unsigned-byte ,target::nbits-in-word)) + +(deftype signed-natural () + `(signed-byte ,target::nbits-in-word)) +) + + +(let* ((builtin-translations + `((array . array) + (simple-array . simple-array) + (cons . cons) + (vector . vector) + (null . (member nil)) + (list . (or cons null)) + (sequence . (or list vector)) + (simple-vector . simple-vector) + (bit-vector . bit-vector) + (simple-bit-vector . simple-bit-vector) + (simple-string . simple-string) + (simple-base-string . simple-base-string) + (string . string) + (base-string . base-string) + (real . real) + (complex . complex) + (float . float) + (double-float . double-float) + (long-float . double-float) + (single-float . single-float) + (short-float . single-float) + + (rational . rational) + (integer . integer) + (ratio . (and rational (not integer))) + (fixnum . (integer ,target::target-most-negative-fixnum + ,target::target-most-positive-fixnum)) + (bignum . (or (integer * (,target::target-most-negative-fixnum)) + (integer (,target::target-most-positive-fixnum) *))) + + ))) + (dolist (spec builtin-translations) + (setf (info-type-kind (car spec)) :primitive + (info-type-builtin (car spec)) (specifier-type (cdr spec))))) + + + + + + +(precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000) + #-cross-compiling + (mod #x100000000) + (unsigned-byte 1) + (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) + (unsigned-byte 64) + (signed-byte 8) (signed-byte 16) (signed-byte 32) + (signed-byte 64) + (or function symbol) + )) + + +(precompute-types *cl-types*) + +;;; Treat CHARACTER and BASE-CHAR as equivalent. +(setf (info-type-builtin 'character) (info-type-builtin 'base-char)) +;;; And EXTENDED-CHAR as empty. +(setf (info-type-builtin 'extended-char) *empty-type*) + +(defparameter *null-type* (specifier-type 'null)) + + +(flet ((set-builtin-class-type-translation (thing) + (let* ((class-name (if (atom thing) thing (car thing))) + (spec (if (atom thing) thing (cadr thing))) + (spectype (specifier-type spec))) + (setf (class-ctype-translation + (%class.ctype (find-class class-name))) spectype)))) + (mapc #'set-builtin-class-type-translation + '( + ;; Root Of All Evil + t + ;; Numbers: + number real ratio complex rational fixnum + ;; Integers: + signed-byte unsigned-byte bit bignum integer + ;; Floats + float double-float single-float + ;; Arrays + array + ;; Simple Arrays + simple-array + ;; Vectors + vector string base-string bit-vector + unsigned-byte-vector unsigned-word-vector unsigned-long-vector + byte-vector word-vector long-vector + single-float-vector double-float-vector + general-vector + fixnum-vector + #+64-bit-target + doubleword-vector + #+64-bit-target + unsigned-doubleword-vector + ;; Simple 1-Dimensional Arrays + simple-1d-array simple-string simple-base-string simple-bit-vector + simple-unsigned-byte-vector + simple-unsigned-long-vector + simple-unsigned-word-vector + simple-byte-vector + simple-word-vector + simple-long-vector + simple-single-float-vector + simple-double-float-vector + simple-vector + simple-fixnum-vector + #+64-bit-target + simple-doubleword-vector + #+64-bit-target + simple-unsigned-doubleword-vector + ;; Sequence types + sequence list cons null + + ) + + )) +) +;(setq *type-system-initialized* t) + + + + +; These deftypes help the CMUCL compiler; the type system doesn't depend on them. + +;;; Since Clozure CL's DEFTYPE tries to globally define the type +;;; at compile-time as well as load- and execute time, hide +;;; the definition of these "built-in" types. (It'd be cleaner +;;; to make DEFTYPE do something saner at compile-time.) +(let* () ; make the following be non-toplevel +(deftype boolean () '(member t nil)) + +(deftype atom () '(not cons)) +;;; +;;; A type specifier. +(deftype type-specifier () '(or list symbol class)) +;;; +;;; An index into an array. Also used for sequence index. +(deftype index () `(integer 0 (,array-dimension-limit))) +;;; +;;; Array rank, total size... +(deftype array-rank () `(integer 0 (,array-rank-limit))) +(deftype array-total-size () `(integer 0 (,array-total-size-limit))) +;;; +;;; Some thing legal in an evaluated context. +(deftype form () t) +;;; +;;; Maclisp compatibility... +(deftype stringlike () '(or string symbol)) +(deftype stringable () '(or string symbol character)) +;;; +;;; Save a little typing... +(deftype truth () '(member t)) +;;; +;;; A thing legal in places where we want the name of a file. +(deftype filename () '(or string pathname)) +;;; +;;; A legal arg to pathname functions. +(deftype pathnamelike () '(or string pathname stream)) +;;; +;;; A thing returned by the irrational functions. We assume that they never +;;; compute a rational result. +(deftype irrational () '(or float (complex float))) +;;; +;;; Character components: +(deftype char-code () `(integer 0 (,char-code-limit))) +;;; +;;; A consed sequence result. If a vector, is a simple array. +(deftype consed-sequence () '(or list (simple-array * (*)))) +;;; +;;; The :end arg to a sequence... +(deftype sequence-end () '(or null index)) +;;; +;;; A valid argument to a stream function... +(deftype streamlike () '(or stream (member nil t))) +;;; +;;; A thing that can be passed to funcall & friends. +(deftype callable () '(or function symbol)) + +;;; Until we decide if and how to wedge this into the type system, make it +;;; equivalent to t. +;;; +(deftype void () t) +;;; +;;; An index into an integer. +(deftype bit-index () `(integer 0 ,target::target-most-positive-fixnum)) +;;; +;;; Offset argument to Ash (a signed bit index). +(deftype ash-index () 'fixnum) + +;;; Not sure how to do this without SATISFIES. +(deftype setf-function-name () `(satisfies setf-function-name-p)) + +;;; Better than nothing, arguably. +(deftype function-name () `(or symbol setf-function-name)) + +(deftype valid-char-code () `(satisfies valid-char-code-p)) + +) ; end of LET* sleaze + +(defun array-or-union-ctype-element-type (ctype) + (if (typep ctype 'array-ctype) + (type-specifier (array-ctype-element-type ctype)) + (if (typep ctype 'union-ctype) + `(or ,@(mapcar #'array-or-union-ctype-element-type + (union-ctype-types ctype)))))) + + +(defvar *simple-predicate-function-prototype* + #'(lambda (thing) + (%%typep thing #.(specifier-type t)))) + +(defun make-simple-type-predicate (function datum) + #+ppc-target + (gvector :function + (uvref *simple-predicate-function-prototype* 0) + datum + function + nil + (dpb 1 $lfbits-numreq 0)) + #+x86-target + (%clone-x86-function + *simple-predicate-function-prototype* + datum + function + nil + (dpb 1 $lfbits-numreq 0))) + +(defun check-ctypep (thing ctype) + (multiple-value-bind (win sure) (ctypep thing ctype) + (or win (not sure)))) + + +(defun generate-predicate-for-ctype (ctype) + (typecase ctype + (numeric-ctype + (or (numeric-ctype-predicate ctype) + (make-simple-type-predicate 'numeric-%%typep ctype))) + (array-ctype + (make-simple-type-predicate 'array-%%typep ctype)) + (member-ctype + (make-simple-type-predicate 'member-%%typep ctype)) + (named-ctype + (case (named-ctype-name ctype) + ((* t) #'true) + (t #'false))) + (cons-ctype + (make-simple-type-predicate 'cons-%%typep ctype)) + (function-ctype + #'functionp) + (class-ctype + (make-simple-type-predicate 'class-cell-typep (find-class-cell (class-name (class-ctype-class ctype)) t))) + (t + (make-simple-type-predicate 'check-ctypep ctype)))) + + + + + +;;; Ensure that standard EFFECTIVE-SLOT-DEFINITIONs have a meaningful +;;; type predicate, if we can. +(defmethod shared-initialize :after ((spec effective-slot-definition) + slot-names + &key + &allow-other-keys) + (declare (ignore slot-names)) + (let* ((type (slot-definition-type spec))) + (setf (slot-value spec 'type-predicate) + (or (and (typep type 'symbol) + (not (eq type 't)) + (type-predicate type)) + (handler-case + (let* ((ctype (specifier-type type))) + (unless (eq ctype *universal-type*) + (generate-predicate-for-ctype ctype))) + (program-error () + (warn "Invalid type specifier ~s in slot definition for ~s in class ~s." type (slot-definition-name spec) (slot-definition-class spec)) + (lambda (v) + (cerror "Allow the assignment or initialization." + "Can't determine whether or not the value ~s should be used to initialize or assign to the slot ~&named ~s in an instance of ~s, because the slot is declared ~&to be of the invalid type ~s." + v (slot-definition-name spec) (slot-definition-class spec) (slot-definition-type spec)) + ;; Suppress further checking, at least for things that use this effective slotd. + ;; (It's hard to avoid this, and more trouble than it's worth to do better.) + (setf (slot-value spec 'type-predicate) nil) + t)) + (parse-unknown-type (c) + (declare (ignore c)) + #'(lambda (value) + ;; If the type's now known, install a new predicate. + (let* ((nowctype (specifier-type type))) + (unless (typep nowctype 'unknown-ctype) + (setf (slot-value spec 'type-predicate) + (generate-predicate-for-ctype nowctype))) + (multiple-value-bind (win sure) + (ctypep value nowctype) + (or (not sure) win)))))))))) + Index: /branches/qres/ccl/level-1/l1-unicode.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-unicode.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-unicode.lisp (revision 13564) @@ -0,0 +1,6402 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;; Unicode translation stuff, mostly in support of I/O. + +(in-package "CCL") + + +(defvar *character-encodings* (make-hash-table :test #'eq)) + +(defun lookup-character-encoding (name) + (gethash name *character-encodings*)) + +(defun get-character-encoding (name) + (or (lookup-character-encoding name) + (error "Unknown character encoding: ~s." name))) + +(defun (setf get-character-encoding) (new name) + (setf (gethash name *character-encodings*) new)) + +(defun ensure-character-encoding (thing) + (if (typep thing 'character-encoding) + thing + (or (lookup-character-encoding thing) + (error "~s is not a character-encoding or the name of a character-encoding." + thing)))) + + +(defun character-encoded-in-single-octet (c) + (declare (ignore c)) + 1) + +(defstruct character-encoding + (name ()) ;canonical name + (code-unit-size 8) ;in bits: 8, 16, 32 + (native-endianness t) ;if nil, need to swap 16,32-bit units + (max-units-per-char 1) ;usually 1-4 + + ;; Writes CHAR (or a replacement character if CHAR can't be encoded) + ;; to STREAM and returns the number of code-units written. + stream-encode-function ;(CHAR WRITE-FUNCTION STREAM) + + ;; Returns a charcter (possibly #\Replacement_Character) or :EOF. + stream-decode-function ;(1ST-UNIT NEXT-UNIT STREAM) + + ;; Sets 1 or more units in a vector argument and returns a value 1 + ;; greater than the index of the last octet written to the vector + vector-encode-function ;(STRING VECTOR INDEX START END) + + ;; Returns a value 1 greater than the last octet index consumed from + ;; the vector argument. + vector-decode-function ;(VECTOR INDEX NOCTETS STRING) + + ;; Sets one or more units in memory at the address denoted by + ;; the pointer and index arguments and returns (+ idx number of + ;; units written to memory), else returns NIL if any character + ;; can't be encoded. + memory-encode-function ;(STRING POINTER INDEX START END) + + + ;; Returns (as multiple values) the string encoded in memory + ;; at the address denoted by the address and index args and the + ;; sum of the index arg and the number of octets consumed. + memory-decode-function ;(POINTER NOCTETS INDEX STRING) + + ;; Returns the number of octets needed to encode STRING between START and END + octets-in-string-function ;(STRING START END) + + ;; Returns the number of (full) characters encoded in VECTOR, and + ;; the index the index of the first octet not used to encode + ;; them. (The second value may be less than END. + length-of-vector-encoding-function ;(VECTOR START END) + + ;; Returns the number of (full) characters encoded in memory at (+ POINTER START) + ;; and the number of octets used to encode them. (The second value may be less + ;; than NOCTETS.) + length-of-memory-encoding-function ;(POINTER NOCTETS START) + + ;; Code units less than this value map to themselves on input. + (decode-literal-code-unit-limit 0) + + ;; Does a byte-order-mark determine the endianness of input ? + ;; Should we prepend a BOM to output ? + ;; If non-nil, the value should be the name of the an encoding + ;; that implements this encoding with swapped byte order. + (use-byte-order-mark nil) + ;; What alternate line-termination conventions can be encoded ? (This basically + ;; means "can #\Line_Separator be encoded?", since :CR and :CRLF can always + ;; be encoded.) + (alternate-line-termination-conventions '(:cr :crlf)) + ;; By what other MIME names is this encoding known ? + (aliases nil) + (documentation nil) + ;; What does a native byte-order-mark look like (as a sequence of octets) + ;; in this encoding ? (NIL if a BOM can't be encoded.) + (bom-encoding nil) + ;; How is #\NUL encoded, as a sequence of octets ? (Typically, as a minimal- + ;; length sequenve of 0s, but there are exceptions.) + (nul-encoding #(0)) + ;; Char-codes less than this value map to themselves on output. + (encode-literal-char-code-limit 0) + (character-size-in-octets-function 'character-encoded-in-single-octet) + ) + +(defconstant byte-order-mark #\u+feff) +(defconstant byte-order-mark-char-code (char-code byte-order-mark)) +(defconstant swapped-byte-order-mark-char-code #xfffe) + + +(defmethod default-character-encoding ((domain t)) + (character-encoding-name (get-character-encoding nil))) + +(defun decode-character-encoded-vector (encoding vector start-index noctets string) + (setq encoding (ensure-character-encoding encoding)) + (unless (= (the (unsigned-byte 8) (typecode vector)) + target::subtag-u8-vector) + (report-bad-arg vector '(simple-array (unsigned-byte 8) (*)))) + (unless (= (the (unsigned-byte 8) (typecode string)) + target::subtag-simple-base-string) + (report-bad-arg vector 'simple-string)) + (let* ((len (length vector))) + (declare (type index len)) + (unless (and (typep start-index 'fixnum) + (>= (the fixnum start-index) 0) + (< (the fixnum start-index) len)) + (error "~s is an invalid start index for ~s" start-index vector)) + (unless (and (typep noctets 'fixnum) + (>= (the fixnum noctets) 0) + (<= (+ (the fixnum start-index) (the fixnum noctets)) len)) + (error "~S is an invalid octet count for ~s at ~s" noctets vector start-index)) + (funcall (character-encoding-vector-decode-function encoding) + vector + start-index + noctets + string))) + + +(defmethod print-object ((ce character-encoding) stream) + (print-unreadable-object (ce stream :type t :identity t) + (format stream "~a" (character-encoding-name ce)))) + +;;; N.B. (ccl:nfunction (lambda (...) ...)) is just like +;;; (cl:function (lambda (...) ...)), except that the resulting +;;; function will have "name" (this is often helpful when debugging.) + +(defmacro define-character-encoding (name doc &rest args &key &allow-other-keys) + (setq name (intern (string name) "KEYWORD")) + (let* ((encoding (gensym)) + (alias (gensym))) + `(let* ((,encoding (make-character-encoding :name ,name :documentation ,doc ,@args))) + (setf (get-character-encoding ,name) ,encoding) + (dolist (,alias (character-encoding-aliases ,encoding)) + (setf (get-character-encoding ,alias) ,encoding)) + ',name))) + +(defun encoding-name (encoding) + (character-encoding-name (or encoding (get-character-encoding nil)))) + +;;; ISO-8859-1 is trivial, though of course it can't really encode characters +;;; whose CHAR-CODE is >= 256 + +(defun 8-bit-fixed-width-octets-in-string (string start end) + (declare (ignore string)) + (if (>= end start) + (- end start) + 0)) + +(defun 8-bit-fixed-width-length-of-vector-encoding (vector start end) + (declare (ignore vector)) + (if (>= end start) + (values (- end start) end) + (values 0 start))) + +(defun 8-bit-fixed-width-length-of-memory-encoding (pointer noctets start) + (declare (ignore pointer start)) + (values noctets noctets)) + +(define-character-encoding :iso-8859-1 + "An 8-bit, fixed-width character encoding in which all character +codes map to their Unicode equivalents. Intended to support most +characters used in most Western European languages." + + ;; The NIL alias is used internally to mean that ISO-8859-1 is + ;; the "null" 8-bit encoding + :aliases '(nil :iso_8859-1 :latin1 :l1 :ibm819 :cp819 :csISOLatin1) + :stream-encode-function + (nfunction + iso-8859-1-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code 256) + (setq code (char-code #\Sub))) + (funcall write-function stream code) + 1))) + :stream-decode-function + (nfunction + iso-8859-1-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (code-char 1st-unit))) + :vector-encode-function + (nfunction + iso-8859-1-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code 256) + (setq code (char-code #\Sub))) + (progn + (setf (aref vector idx) code) + (incf idx)))))) + :vector-decode-function + (nfunction + iso-8859-1-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (setf (schar string i) (code-char (the (unsigned-byte 8) + (aref vector index))))))) + :memory-encode-function + (nfunction + iso-8859-1-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (if (>= code 256) + (setq code (char-code #\Sub))) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-1-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (setf (schar string i) (code-char (the (unsigned-byte 8) + (%get-unsigned-byte pointer index))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit 256 + :encode-literal-char-code-limit 256 + ) + +(define-character-encoding :us-ascii + "A 7-bit, fixed-width character encoding in which all character +codes map to their Unicode equivalents." + + :aliases '(:csASCII :cp637 :IBM637 :us :ISO646-US :ascii :ISO-ir-6) + :stream-encode-function + (nfunction + ascii-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code 128) + (setq code (char-code #\Sub))) + (funcall write-function stream code) + 1))) + :stream-decode-function + (nfunction + ascii-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit 128) + (code-char 1st-unit) + #\Replacement_Character))) + :vector-encode-function + (nfunction + ascii-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code 128) + (setq code (char-code #\Sub))) + (setf (aref vector idx) code) + (incf idx))))) + :vector-decode-function + (nfunction + ascii-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((code (aref vector index))) + (declare (type (unsigned-byte 8) code)) + (when (>= code 128) + (setq code (char-code #\Sub))) + (setf (schar string i) (code-char code)))))) + :memory-encode-function + (nfunction + ascii-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (if (>= code 128) + (setq code (char-code #\Sub))) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx))))) + :memory-decode-function + (nfunction + ascii-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((code (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) code)) + (if (>= code 128) + (setf (schar string i) #\sub) + (setf (schar string i) (code-char code))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit 128 + :encode-literal-char-code-limit 128 + ) + + + +;;; Other 1-byte, fixed-width encodings. Typically, codes in the range +;;; #x00-#x9f maps straight through, while codes #xa0-#xff select arbitrary +;;; Unicode characters that are commonly used in some locale. (Sometimes +;;; the break is at #x80 instead of #xa0). + +(defstatic *iso-8859-2-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+02d8 #\u+0141 #\u+00a4 #\u+013d #\u+015a #\u+00a7 + #\u+00a8 #\u+0160 #\u+015e #\u+0164 #\u+0179 #\u+00ad #\u+017d #\u+017b + ;; #xb0 + #\u+00b0 #\u+0105 #\u+02db #\u+0142 #\u+00b4 #\u+013e #\u+015b #\u+02c7 + #\u+00b8 #\u+0161 #\u+015f #\u+0165 #\u+017a #\u+02dd #\u+017e #\u+017c + ;; #xc0 + #\u+0154 #\u+00c1 #\u+00c2 #\u+0102 #\u+00c4 #\u+0139 #\u+0106 #\u+00c7 + #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+011a #\u+00cd #\u+00ce #\u+010e + ;; #xd0 + #\u+0110 #\u+0143 #\u+0147 #\u+00d3 #\u+00d4 #\u+0150 #\u+00d6 #\u+00d7 + #\u+0158 #\u+016e #\u+00da #\u+0170 #\u+00dc #\u+00dd #\u+0162 #\u+00df + ;; #xe0 + #\u+0155 #\u+00e1 #\u+00e2 #\u+0103 #\u+00e4 #\u+013a #\u+0107 #\u+00e7 + #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+011b #\u+00ed #\u+00ee #\u+010f + ;; #xf0 + #\u+0111 #\u+0144 #\u+0148 #\u+00f3 #\u+00f4 #\u+0151 #\u+00f6 #\u+00f7 + #\u+0159 #\u+016f #\u+00fa #\u+0171 #\u+00fc #\u+00fd #\u+0163 #\u+02d9 +)) + +(defstatic *unicode-00a0-0180-to-iso-8859-2* + #( + #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 + #xa8 nil nil nil nil #xad nil nil ; #xa8-#xaf + #xb0 nil nil nil #xb4 nil nil nil ; #xb0-#xb7 + #xb8 nil nil nil nil nil nil nil ; #xb8-#xbf + nil #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7 + nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf + nil nil nil #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7 + nil nil #xda nil #xdc #xdd nil #xdf ; #xd8-#xdf + nil #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7 + nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef + nil nil nil #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7 + nil nil #xfa nil #xfc #xfd nil nil ; #xf8-#xff + ;; #x0100 + nil nil #xc3 #xe3 #xa1 #xb1 #xc6 #xe6 ; #x100-#x107 + nil nil nil nil #xc8 #xe8 #xcf #xef ; #x108-#x10f + #xd0 #xf0 nil nil nil nil nil nil ; #x110-#x117 + #xca #xea #xcc #xec nil nil nil nil ; #x118-#x11f + nil nil nil nil nil nil nil nil ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + nil nil nil nil nil nil nil nil ; #x130-#x137 + nil #xc5 #xe5 nil nil #xa5 #xb5 nil ; #x138-#x13f + nil #xa3 #xb3 #xd1 #xf1 nil nil #xd2 ; #x140-#x147 + #xf2 nil nil nil nil nil nil nil ; #x148-#x14f + #xd5 #xf5 nil nil #xc0 #xe0 nil nil ; #x150-#x157 + #xd8 #xf8 #xa6 #xb6 nil nil #xaa #xba ; #x158-#x15f + #xa9 #xb9 #xde #xfe #xab #xbb nil nil ; #x160-#x167 + nil nil nil nil nil nil #xd9 #xf9 ; #x168-#x16f + #xdb #xfb nil nil nil nil nil nil ; #x170-#x177 + nil #xac #xbc #xaf #xbf #xae #xbe nil ; #x178-#x17f + )) + +(defstatic *unicode-00c0-00e0-to-iso-8859-2* + #( + nil nil nil nil nil nil nil #xb7 ; #xc0-#xc7 + nil nil nil nil nil nil nil nil ; #xc8-#xcf + nil nil nil nil nil nil nil nil ; #xd0-#xd7 + #xa2 #xff nil #xb2 nil #xbd nil nil ; #xd8-#xdf + )) + +(define-character-encoding :iso-8859-2 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in most +languages used in Central/Eastern Europe." + :aliases '(:iso_8859-2 :latin-2 :l2 :csISOLatin2) + :stream-encode-function + (nfunction + iso-8859-2-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-00a0-0180-to-iso-8859-2* + (the fixnum (- code #xa0)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-00c0-00e0-to-iso-8859-2* + (the fixnum (- code #x2c0))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-2-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-00a0-0180-to-iso-8859-2* + (the fixnum (- code #xa0)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-00c0-00e0-to-iso-8859-2* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-2-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-00a0-0180-to-iso-8859-2* + (the fixnum (- code #xa0)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-00c0-00e0-to-iso-8859-2* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (1+ idx))))) + :memory-decode-function + (nfunction + iso-8859-2-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-3-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0126 #\u+02d8 #\u+00a3 #\u+00a4 #\u+fffd #\u+0124 #\u+00a7 + #\u+00a8 #\u+0130 #\u+015e #\u+011e #\u+0134 #\u+00ad #\u+fffd #\u+017b + ;; #xb0 + #\u+00b0 #\u+0127 #\u+00b2 #\u+00b3 #\u+00b4 #\u+00b5 #\u+0125 #\u+00b7 + #\u+00b8 #\u+0131 #\u+015f #\u+011f #\u+0135 #\u+00bd #\u+fffd #\u+017c + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+fffd #\u+00c4 #\u+010a #\u+0108 #\u+00c7 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+fffd #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+0120 #\u+00d6 #\u+00d7 + #\u+011c #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+016c #\u+015c #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+fffd #\u+00e4 #\u+010b #\u+0109 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+fffd #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+0121 #\u+00f6 #\u+00f7 + #\u+011d #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+016d #\u+015d #\u+02d9 + )) + +(defstatic *unicode-a0-100-to-iso-8859-3* + #( + #xa0 nil nil #xa3 #xa4 nil nil #xa7 ; #xa0-#xa7 + #xa8 nil nil nil nil #xad nil nil ; #xa8-#xaf + #xb0 nil #xb2 #xb3 #xb4 #xb5 nil #xb7 ; #xb0-#xb7 + #xb8 nil nil nil nil #xbd nil nil ; #xb8-#xbf + #xc0 #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + nil #xd1 #xd2 #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7 + nil #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil #xf1 #xf2 #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7 + nil #xf9 #xfa #xfb #xfc nil nil nil ; #xf8-#xff + )) + +(defstatic *unicode-108-180-to-iso-8859-3* + #( + #xc6 #xe6 #xc5 #xe5 #x00 #x00 #x00 #x00 ; #x108-#x10f + nil nil nil nil nil nil nil nil ; #x110-#x117 + nil nil nil nil #xd8 #xf8 #xab #xbb ; #x118-#x11f + #xd5 #xf5 nil nil #xa6 #xb6 #xa1 #xb1 ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + #xa9 #xb9 nil nil #xac #xbc nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil nil nil nil nil nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + nil nil nil nil nil nil nil nil ; #x150-#x157 + nil nil nil nil #xde #xfe #xaa #xba ; #x158-#x15f + nil nil nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil #xdd #xfd nil nil ; #x168-#x16f + nil nil nil nil nil nil nil nil ; #x170-#x177 + nil nil nil #xaf #xbf nil nil nil ; #x178-#x17f + )) + +(defstatic *unicode-2d8-2e0-to-iso-8859-3* + #( + #xa2 #xff nil nil nil nil nil nil ; #x2d8-#x2df + )) + + + +(define-character-encoding :iso-8859-3 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in most +languages used in Southern Europe." + + :aliases '(:iso_8859-3 :latin3 :l3 :csisolatin3) + :stream-encode-function + (nfunction + iso-8859-3-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-3* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x180)) + (svref *unicode-108-180-to-iso-8859-3* + (the fixnum (- code #x108)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2d8-2e0-to-iso-8859-3* + (the fixnum (- code #x2d8))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-3-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-3-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-3* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x180)) + (svref *unicode-108-180-to-iso-8859-3* + (the fixnum (- code #x108)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2d8-2e0-to-iso-8859-3* + + (the fixnum (- code #x2d8))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-3-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-3-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-3* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x180)) + (svref *unicode-108-180-to-iso-8859-3* + (the fixnum (- code #x108)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2d8-2e0-to-iso-8859-3* + (the fixnum (- code #x2d8))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-3-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + + +(defstatic *iso-8859-4-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+0138 #\u+0156 #\u+00a4 #\u+0128 #\u+013b #\u+00a7 + #\u+00a8 #\u+0160 #\u+0112 #\u+0122 #\u+0166 #\u+00ad #\u+017d #\u+00af + ;; #xb0 + #\u+00b0 #\u+0105 #\u+02db #\u+0157 #\u+00b4 #\u+0129 #\u+013c #\u+02c7 + #\u+00b8 #\u+0161 #\u+0113 #\u+0123 #\u+0167 #\u+014a #\u+017e #\u+014b + ;; #xc0 + #\u+0100 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+012e + #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+0116 #\u+00cd #\u+00ce #\u+012a + ;; #xd0 + #\u+0110 #\u+0145 #\u+014c #\u+0136 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 + #\u+00d8 #\u+0172 #\u+00da #\u+00db #\u+00dc #\u+0168 #\u+016a #\u+00df + ;; #xe0 + #\u+0101 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+012f + #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+0117 #\u+00ed #\u+00ee #\u+012b + ;; #xf0 + #\u+0111 #\u+0146 #\u+014d #\u+0137 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 + #\u+00f8 #\u+0173 #\u+00fa #\u+00fb #\u+00fc #\u+0169 #\u+016b #\u+02d9 + )) + + +(defstatic *unicode-a0-180-to-iso-8859-4* + #( + #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 + #xa8 nil nil nil nil #xad nil #xaf ; #xa8-#xaf + #xb0 nil nil nil #xb4 nil nil nil ; #xb0-#xb7 + #xb8 nil nil nil nil nil nil nil ; #xb8-#xbf + nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 nil ; #xc0-#xc7 + nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf + nil nil nil nil #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xd8 nil #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + nil #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 nil ; #xe0-#xe7 + nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef + nil nil nil nil #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xf8 nil #xfa #xfb #xfc nil nil nil ; #xf8-#xff + #xc0 #xe0 nil nil #xa1 #xb1 nil nil ; #x100-#x107 + nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f + #xd0 #xf0 #xaa #xba nil nil #xcc #xec ; #x110-#x117 + #xca #xea nil nil nil nil nil nil ; #x118-#x11f + nil nil #xab #xbb nil nil nil nil ; #x120-#x127 + #xa5 #xb5 #xcf #xef nil nil #xc7 #xe7 ; #x128-#x12f + nil nil nil nil nil nil #xd3 #xf3 ; #x130-#x137 + #xa2 nil nil #xa6 #xb6 nil nil nil ; #x138-#x13f + nil nil nil nil nil #xd1 #xf1 nil ; #x140-#x147 + nil nil #xbd #xbf #xd2 #xf2 nil nil ; #x148-#x14f + nil nil nil nil nil nil #xa3 #xb3 ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + #xa9 #xb9 nil nil nil nil #xac #xbc ; #x160-#x167 + #xdd #xfd #xde #xfe nil nil nil nil ; #x168-#x16f + nil nil #xd9 #xf9 nil nil nil nil ; #x170-#x177 + nil nil nil nil nil #xae #xbe nil ; #x178-#x17f + )) + +(defstatic *unicode-2c0-2e0-to-iso-8859-4* + #( + nil nil nil nil nil nil nil #xb7 ; #x2c0-#x2c7 + nil nil nil nil nil nil nil nil ; #x2c8-#x2cf + nil nil nil nil nil nil nil nil ; #x2d0-#x2d7 + nil #xff nil #xb2 nil nil nil nil ; #x2d8-#x2df + )) + + + +(define-character-encoding :iso-8859-4 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in most +languages used in Northern Europe." + + :aliases '(:iso_8859-4 :latin4 :l4 :csisolatin4) + :stream-encode-function + (nfunction + iso-8859-4-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-4* + (the fixnum (- code #xa0)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-iso-8859-4* + (the fixnum (- code #x2c0))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-4-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-4-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-4* + (the fixnum (- code #xa0)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-iso-8859-4* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-4-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-4-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-4* + (the fixnum (- code #xa0)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-iso-8859-4* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-4-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-5-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0401 #\u+0402 #\u+0403 #\u+0404 #\u+0405 #\u+0406 #\u+0407 + #\u+0408 #\u+0409 #\u+040a #\u+040b #\u+040c #\u+00ad #\u+040e #\u+040f + ;; #xb0 + #\u+0410 #\u+0411 #\u+0412 #\u+0413 #\u+0414 #\u+0415 #\u+0416 #\u+0417 + #\u+0418 #\u+0419 #\u+041a #\u+041b #\u+041c #\u+041d #\u+041e #\u+041f + ;; #xc0 + #\u+0420 #\u+0421 #\u+0422 #\u+0423 #\u+0424 #\u+0425 #\u+0426 #\u+0427 + #\u+0428 #\u+0429 #\u+042a #\u+042b #\u+042c #\u+042d #\u+042e #\u+042f + ;; #xd0 + #\u+0430 #\u+0431 #\u+0432 #\u+0433 #\u+0434 #\u+0435 #\u+0436 #\u+0437 + #\u+0438 #\u+0439 #\u+043a #\u+043b #\u+043c #\u+043d #\u+043e #\u+043f + ;; #xe0 + #\u+0440 #\u+0441 #\u+0442 #\u+0443 #\u+0444 #\u+0445 #\u+0446 #\u+0447 + #\u+0448 #\u+0449 #\u+044a #\u+044b #\u+044c #\u+044d #\u+044e #\u+044f + ;; #xf0 + #\u+2116 #\u+0451 #\u+0452 #\u+0453 #\u+0454 #\u+0455 #\u+0456 #\u+0457 + #\u+0458 #\u+0459 #\u+045a #\u+045b #\u+045c #\u+00a7 #\u+045e #\u+045f + )) + + +(defstatic *unicode-a0-b0-to-iso-8859-5* + #( + #xa0 nil nil nil nil nil nil #xfd ; #xa0-#xa7 + nil nil nil nil nil #xad nil nil ; #xa8-#xaf + )) + +(defstatic *unicode-400-460-to-iso-8859-5* + #( + nil #xa1 #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #x400-#x407 + #xa8 #xa9 #xaa #xab #xac nil #xae #xaf ; #x408-#x40f + #xb0 #xb1 #xb2 #xb3 #xb4 #xb5 #xb6 #xb7 ; #x410-#x417 + #xb8 #xb9 #xba #xbb #xbc #xbd #xbe #xbf ; #x418-#x41f + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x420-#x427 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x428-#x42f + #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x430-#x437 + #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x438-#x43f + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x440-#x447 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x448-#x44f + nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x450-#x457 + #xf8 #xf9 #xfa #xfb #xfc nil #xfe #xff ; #x458-#x45f + )) + + +(define-character-encoding :iso-8859-5 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Cyrillic alphabet." + + :aliases '(:iso_8859-5 :cyrillic :csISOLatinCyrillic :iso-ir-144) + :stream-encode-function + (nfunction + iso-8859-5-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-5* + (the fixnum (- code #xa0)))) + ((and (>= code #x400) (< code #x460)) + (svref *unicode-400-460-to-iso-8859-5* + (the fixnum (- code #x400))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-5-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-5-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-5* + (the fixnum (- code #xa0)))) + ((and (>= code #x400) (< code #x460)) + (svref *unicode-400-460-to-iso-8859-5* + (the fixnum (- code #x400))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-5-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-5-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-5* + (the fixnum (- code #xa0)))) + ((and (>= code #x400) (< code #x460)) + (svref *unicode-400-460-to-iso-8859-5* + (the fixnum (- code #x400))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-5-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-6-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+fffd #\u+fffd #\u+fffd #\u+00a4 #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+060c #\u+00ad #\u+fffd #\u+fffd + ;; #xb0 + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+061b #\u+fffd #\u+fffd #\u+fffd #\u+061f + ;; #xc0 + #\u+fffd #\u+0621 #\u+0622 #\u+0623 #\u+0624 #\u+0625 #\u+0626 #\u+0627 + #\u+0628 #\u+0629 #\u+062a #\u+062b #\u+062c #\u+062d #\u+062e #\u+062f + ;; #xd0 + #\u+0630 #\u+0631 #\u+0632 #\u+0633 #\u+0634 #\u+0635 #\u+0636 #\u+0637 + #\u+0638 #\u+0639 #\u+063a #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + ;; #xe0 + #\u+0640 #\u+0641 #\u+0642 #\u+0643 #\u+0644 #\u+0645 #\u+0646 #\u+0647 + #\u+0648 #\u+0649 #\u+064a #\u+064b #\u+064c #\u+064d #\u+064e #\u+064f + ;; #xf0 + #\u+0650 #\u+0651 #\u+0652 #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + )) + +(defstatic *unicode-a0-b0-to-iso-8859-6* + #( + 0xa0 nil nil nil 0xa4 nil nil nil ; #xa0-#xa7 + nil nil nil nil nil #xad nil nil ; #xa8-#xaf + )) + + +(defstatic *unicode-608-658-to-iso-8859-6* + #( + nil nil nil nil #xac nil nil nil ; #x608-#x60f + nil nil nil nil nil nil nil nil ; #x610-#x617 + nil nil nil #xbb nil nil nil #xbf ; #x618-#x61f + nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x620-#x627 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x628-#x62f + #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x630-#x637 + #xd8 #xd9 #xda nil nil nil nil nil ; #x638-#x63f + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x640-#x647 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x648-#x64f + #xf0 #xf1 #xf2 nil nil nil nil nil ; #x650-#x657 + )) + +(define-character-encoding :iso-8859-6 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Arabic alphabet." + + :aliases '(:iso_8859-6 :arabic :csISOLatinArabic :iso-ir-127) + :stream-encode-function + (nfunction + iso-8859-6-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-6* + (the fixnum (- code #xa0)))) + ((and (>= code #x608) (< code #x658)) + (svref *unicode-608-658-to-iso-8859-6* + (the fixnum (- code #x608))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-6-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-6-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-6* + (the fixnum (- code #xa0)))) + ((and (>= code #x608) (< code #x658)) + (svref *unicode-608-658-to-iso-8859-6* + (the fixnum (- code #x608))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-6-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-6-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-6* + (the fixnum (- code #xa0)))) + ((and (>= code #x608) (< code #x658)) + (svref *unicode-608-658-to-iso-8859-6* + (the fixnum (- code #x608))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-6-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-7-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+2018 #\u+2019 #\u+00a3 #\u+20ac #\u+20af #\u+00a6 #\u+00a7 + #\u+00a8 #\u+00a9 #\u+037a #\u+00ab #\u+00ac #\u+00ad #\u+fffd #\u+2015 + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+0384 #\u+0385 #\u+0386 #\u+00b7 + #\u+0388 #\u+0389 #\u+038a #\u+00bb #\u+038c #\u+00bd #\u+038e #\u+038f + ;; #xc0 + #\u+0390 #\u+0391 #\u+0392 #\u+0393 #\u+0394 #\u+0395 #\u+0396 #\u+0397 + #\u+0398 #\u+0399 #\u+039a #\u+039b #\u+039c #\u+039d #\u+039e #\u+039f + ;; #xd0 + #\u+03a0 #\u+03a1 #\u+fffd #\u+03a3 #\u+03a4 #\u+03a5 #\u+03a6 #\u+03a7 + #\u+03a8 #\u+03a9 #\u+03aa #\u+03ab #\u+03ac #\u+03ad #\u+03ae #\u+03af + ;; #xe0 + #\u+03b0 #\u+03b1 #\u+03b2 #\u+03b3 #\u+03b4 #\u+03b5 #\u+03b6 #\u+03b7 + #\u+03b8 #\u+03b9 #\u+03ba #\u+03bb #\u+03bc #\u+03bd #\u+03be #\u+03bf + ;; #xf0 + #\u+03c0 #\u+03c1 #\u+03c2 #\u+03c3 #\u+03c4 #\u+03c5 #\u+03c6 #\u+03c7 + #\u+03c8 #\u+03c9 #\u+03ca #\u+03cb #\u+03cc #\u+03cd #\u+03ce #\u+fffd + )) + +(defstatic *unicode-a0-c0-to-iso-8859-7* + #( + #xa0 nil nil #xa3 nil nil #xa6 #xa7 ; #xa0-#xa7 + #xa8 #xa9 nil #xab #xac #xad nil nil ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 nil nil nil #xb7 ; #xb0-#xb7 + nil nil nil #xbb nil #xbd nil nil ; #xb8-#xbf + )) + +(defstatic *unicode-378-3d0-to-iso-8859-7* + #( + nil nil #xaa nil nil nil nil nil ; #x378-#x37f + nil nil nil nil #xb4 #xb5 #xb6 nil ; #x380-#x387 + #xb8 #xb9 #xba nil #xbc nil #xbe #xbf ; #x388-#x38f + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x390-#x397 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x398-#x39f + #xd0 #xd1 nil #xd3 #xd4 #xd5 #xd6 #xd7 ; #x3a0-#x3a7 + #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x3a8-#x3af + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x3b0-#x3b7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x3b8-#x3bf + #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x3c0-#x3c7 + #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe nil ; #x3c8-#x3cf + )) + +(defstatic *unicode-2010-2020-to-iso-8859-7* + #( + nil nil nil nil nil #xaf nil nil ; #x2010-#x2017 + #xa1 #xa2 nil nil nil nil nil nil ; #x2018-#x201f + )) + +(defstatic *unicode-20ac-20b0-to-iso-8859-7* + #( + #xa4 nil nil #xa5 + )) + +(define-character-encoding :iso-8859-7 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Greek alphabet." + + :aliases '(:iso_8859-7 :greek :greek8 :csISOLatinGreek :iso-ir-126 :ELOT_928 :ecma-118) + :stream-encode-function + (nfunction + iso-8859-7-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xc0) + (svref *unicode-a0-c0-to-iso-8859-7* + (the fixnum (- code #xa0)))) + ((and (>= code #x378) (< code #x3d0)) + (svref *unicode-378-3d0-to-iso-8859-7* + (the fixnum (- code #x378)))) + ((and (>= code #x2010) (< code #x2020)) + (svref *unicode-2010-2020-to-iso-8859-7* + (the fixnum (- code #x2010)))) + ((and (>= code #x20ac) (< code #x20b0)) + (svref *unicode-20ac-20b0-to-iso-8859-7* + (the fixnum (- code #x20ac))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-7-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-7-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xc0) + (svref *unicode-a0-c0-to-iso-8859-7* + (the fixnum (- code #xa0)))) + ((and (>= code #x378) (< code #x3d0)) + (svref *unicode-378-3d0-to-iso-8859-7* + (the fixnum (- code #x378)))) + ((and (>= code #x2010) (< code #x2020)) + (svref *unicode-2010-2020-to-iso-8859-7* + (the fixnum (- code #x2010)))) + ((and (>= code #x20ac) (< code #x20b0)) + (svref *unicode-20ac-20b0-to-iso-8859-7* + (the fixnum (- code #x20ac))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-7-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-7-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xc0) + (svref *unicode-a0-c0-to-iso-8859-7* + (the fixnum (- code #xa0)))) + ((and (>= code #x378) (< code #x3d0)) + (svref *unicode-378-3d0-to-iso-8859-7* + (the fixnum (- code #x378)))) + ((and (>= code #x2010) (< code #x2020)) + (svref *unicode-2010-2020-to-iso-8859-7* + (the fixnum (- code #x2010)))) + ((and (>= code #x20ac) (< code #x20b0)) + (svref *unicode-20ac-20b0-to-iso-8859-7* + (the fixnum (- code #x20ac))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-7-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-8-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+fffd #\u+00a2 #\u+00a3 #\u+00a4 #\u+00a5 #\u+00a6 #\u+00a7 + #\u+00a8 #\u+00a9 #\u+00d7 #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00af + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+00b4 #\u+00b5 #\u+00b6 #\u+00b7 + #\u+00b8 #\u+00b9 #\u+00f7 #\u+00bb #\u+00bc #\u+00bd #\u+00be #\u+fffd + ;; #xc0 + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + ;; #xd0 + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+2017 + ;; #xe0 + #\u+05d0 #\u+05d1 #\u+05d2 #\u+05d3 #\u+05d4 #\u+05d5 #\u+05d6 #\u+05d7 + #\u+05d8 #\u+05d9 #\u+05da #\u+05db #\u+05dc #\u+05dd #\u+05de #\u+05df + ;; #xf0 + #\u+05e0 #\u+05e1 #\u+05e2 #\u+05e3 #\u+05e4 #\u+05e5 #\u+05e6 #\u+05e7 + #\u+05e8 #\u+05e9 #\u+05ea #\u+fffd #\u+fffd #\u+200e #\u+200f #\u+fffd + )) + +(defstatic *unicode-a0-f8-to-iso-8859-8* + #( + #xa0 nil #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #xa0-#xa7 + #xa8 #xa9 nil #xab #xac #xad #xae #xaf ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 #xb4 #xb5 #xb6 #xb7 ; #xb0-#xb7 + #xb8 #xb9 nil #xbb #xbc #xbd #xbe nil ; #xb8-#xbf + nil nil nil nil nil nil nil nil ; #xc0-#xc7 + nil nil nil nil nil nil nil nil ; #xc8-#xcf + nil nil nil nil nil nil nil #xaa ; #xd0-#xd7 + nil nil nil nil nil nil nil nil ; #xd8-#xdf + nil nil nil nil nil nil nil nil ; #xe0-#xe7 + nil nil nil nil nil nil nil nil ; #xe8-#xef + nil nil nil nil nil nil nil #xba ; #xf0-#xf7 + )) + +(defstatic *unicode-5d0-5f0-to-iso-8859-8* + #( + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x5d0-#x5d7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x5d8-#x5df + #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x5e0-#x5e7 + #xf8 #xf9 #xfa nil nil nil nil nil ; #x5e8-#x5ef + )) + +(defstatic *unicode-2008-2018-to-iso-8859-8* + #( + nil nil nil nil nil nil #xfd #xfe ; #x2008-#x200f + nil nil nil nil nil nil nil #xdf ; #x2010-#x2017 + )) + +(define-character-encoding :iso-8859-8 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Hebrew alphabet." + + :aliases '(:iso_8859-8 :hebrew :csISOLatinHebrew :iso-ir-138) + :stream-encode-function + (nfunction + iso-8859-8-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xf8) + (svref *unicode-a0-f8-to-iso-8859-8* + (the fixnum (- code #xa0)))) + ((and (>= code #x5d0) (< code #x5f0)) + (svref *unicode-5d0-5f0-to-iso-8859-8* + (the fixnum (- code #x5d0)))) + ((and (>= code #x2008) (< code #x2018)) + (svref *unicode-2008-2018-to-iso-8859-8* + (the fixnum (- code #x2008))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-8-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-8-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xf8) + (svref *unicode-a0-f8-to-iso-8859-8* + (the fixnum (- code #xa0)))) + ((and (>= code #x5d0) (< code #x5f0)) + (svref *unicode-5d0-5f0-to-iso-8859-8* + (the fixnum (- code #x5d0)))) + ((and (>= code #x2008) (< code #x2018)) + (svref *unicode-2008-2018-to-iso-8859-8* + (the fixnum (- code #x2008))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-8-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-8-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xf8) + (svref *unicode-a0-f8-to-iso-8859-8* + (the fixnum (- code #xa0)))) + ((and (>= code #x5d0) (< code #x5f0)) + (svref *unicode-5d0-5f0-to-iso-8859-8* + (the fixnum (- code #x5d0)))) + ((and (>= code #x2008) (< code #x2018)) + (svref *unicode-2008-2018-to-iso-8859-8* + (the fixnum (- code #x2008))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-8-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-9-to-unicode* + #( + ;; #xd0 + #\u+011e #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 + #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+0130 #\u+015e #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+011f #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 + #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+0131 #\u+015f #\u+00ff + )) + +(defstatic *unicode-d0-100-to-iso-8859-9* + #( + nil #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xd8 #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xf8 #xf9 #xfa #xfb #xfc nil nil #xff ; #xf8-#xff + )) + +(defstatic *unicode-118-160-to-iso-8859-9* + #( + nil nil nil nil nil nil #xd0 #xf0 ; #x118-#x11f + nil nil nil nil nil nil nil nil ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + #xdd #xfd nil nil nil nil nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil nil nil nil nil nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + nil nil nil nil nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil #xde #xfe ; #x158-#x15f + )) + + +(define-character-encoding :iso-8859-9 + "An 8-bit, fixed-width character encoding in which codes #x00-#xcf +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Turkish alphabet." + + :aliases '(:iso_8859-9 :latin5 :csISOLatin5 :iso-ir-148) + :stream-encode-function + (nfunction + iso-8859-9-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xd0) code) + ((< code #x100) + (svref *unicode-d0-100-to-iso-8859-9* + (the fixnum (- code #xd0)))) + ((and (>= code #x118) (< code #x160)) + (svref *unicode-118-160-to-iso-8859-9* + (the fixnum (- code #x118))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-9-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-9-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xd0) code) + ((< code #x100) + (svref *unicode-d0-100-to-iso-8859-9* + (the fixnum (- code #xd0)))) + ((and (>= code #x118) (< code #x160)) + (svref *unicode-118-160-to-iso-8859-9* + (the fixnum (- code #x118))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-9-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-9-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xd0) code) + ((< code #x100) + (svref *unicode-d0-100-to-iso-8859-9* + (the fixnum (- code #xd0)))) + ((and (>= code #x118) (< code #x160)) + (svref *unicode-118-160-to-iso-8859-9* + (the fixnum (- code #x118))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-9-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xd0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-10-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+0112 #\u+0122 #\u+012a #\u+0128 #\u+0136 #\u+00a7 + #\u+013b #\u+0110 #\u+0160 #\u+0166 #\u+017d #\u+00ad #\u+016a #\u+014a + ;; #xb0 + #\u+00b0 #\u+0105 #\u+0113 #\u+0123 #\u+012b #\u+0129 #\u+0137 #\u+00b7 + #\u+013c #\u+0111 #\u+0161 #\u+0167 #\u+017e #\u+2015 #\u+016b #\u+014b + ;; #xc0 + #\u+0100 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+012e + #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+0116 #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+00d0 #\u+0145 #\u+014c #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+0168 + #\u+00d8 #\u+0172 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+00de #\u+00df + ;; #xe0 + #\u+0101 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+012f + #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+0117 #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+00f0 #\u+0146 #\u+014d #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+0169 + #\u+00f8 #\u+0173 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+00fe #\u+0138 + )) + +(defstatic *unicode-a0-180-to-iso-8859-10* + #( + #xa0 nil nil nil nil nil nil #xa7 ; #xa0-#xa7 + nil nil nil nil nil #xad nil nil ; #xa8-#xaf + #xb0 nil nil nil nil nil nil #xb7 ; #xb0-#xb7 + nil nil nil nil nil nil nil nil ; #xb8-#xbf + nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 nil ; #xc0-#xc7 + nil #xc9 nil #xcb nil #xcd #xce #xcf ; #xc8-#xcf + #xd0 nil nil #xd3 #xd4 #xd5 #xd6 nil ; #xd0-#xd7 + #xd8 nil #xda #xdb #xdc #xdd #xde #xdf ; #xd8-#xdf + nil #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 nil ; #xe0-#xe7 + nil #xe9 nil #xeb nil #xed #xee #xef ; #xe8-#xef + #xf0 nil nil #xf3 #xf4 #xf5 #xf6 nil ; #xf0-#xf7 + #xf8 nil #xfa #xfb #xfc #xfd #xfe nil ; #xf8-#xff + #xc0 #xe0 nil nil #xa1 #xb1 nil nil ; #x100-#x107 + nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f + #xa9 #xb9 #xa2 #xb2 nil nil #xcc #xec ; #x110-#x117 + #xca #xea nil nil nil nil nil nil ; #x118-#x11f + nil nil #xa3 #xb3 nil nil nil nil ; #x120-#x127 + #xa5 #xb5 #xa4 #xb4 nil nil #xc7 #xe7 ; #x128-#x12f + nil nil nil nil nil nil #xa6 #xb6 ; #x130-#x137 + #xff nil nil #xa8 #xb8 nil nil nil ; #x138-#x13f + nil nil nil nil nil #xd1 #xf1 nil ; #x140-#x147 + nil nil #xaf #xbf #xd2 #xf2 nil nil ; #x148-#x14f + nil nil nil nil nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + #xaa #xba nil nil nil nil #xab #xbb ; #x160-#x167 + #xd7 #xf7 #xae #xbe nil nil nil nil ; #x168-#x16f + nil nil #xd9 #xf9 nil nil nil nil ; #x170-#x177 + nil nil nil nil nil #xac #xbc nil ; #x178-#x17f + )) + +(define-character-encoding :iso-8859-10 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Nordic +alphabets." + + :aliases '(:iso_8859-10 :latin6 :csISOLatin6 :iso-ir-157) + :stream-encode-function + (nfunction + iso-8859-10-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-10* + (the fixnum (- code #xa0))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-10-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-10-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-10* + (the fixnum (- code #xa0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-10-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-10-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-10* + (the fixnum (- code #xa0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-10-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(define-character-encoding :iso-8859-11 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found the Thai +alphabet." + :aliases '() + :stream-encode-function + (nfunction + iso-8859-11-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa1) code) + ((and (<= code #xfb) + (not (and (>= code #xdb) (<= code #xde)))) + (+ code #x0d60))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-11-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa1) + (code-char 1st-unit) + (if (and (>= 1st-unit #xe01) + (<= 1st-unit #xe5b) + (not (and (>= 1st-unit #xe3b) + (<= 1st-unit #xe3e)))) + (code-char (- 1st-unit #xd60)) + #\Replacement_Character)))) + :vector-encode-function + (nfunction + iso-8859-11-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa1) code) + ((and (<= code #xfb) + (not (and (>= code #xdb) (<= code #xde)))) + (+ code #x0d60))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-11-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa1) + (code-char 1st-unit) + (if (and (>= 1st-unit #xe01) + (<= 1st-unit #xe5b) + (not (and (>= 1st-unit #xe3b) + (<= 1st-unit #xe3e)))) + (code-char (- 1st-unit #xd60)) + #\Replacement_Character))))))) + :memory-encode-function + (nfunction + iso-8859-11-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa1) code) + ((and (<= code #xfb) + (not (and (>= code #xdb) (<= code #xde)))) + (+ code #x0d60))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-11-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa1) + (code-char 1st-unit) + (if (and (>= 1st-unit #xe01) + (<= 1st-unit #xe5b) + (not (and (>= 1st-unit #xe3b) + (<= 1st-unit #xe3e)))) + (code-char (- 1st-unit #xd60)) + #\Replacement_Character))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +;;; There is no iso-8859-12 encoding. + +(defstatic *iso-8859-13-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+201d #\u+00a2 #\u+00a3 #\u+00a4 #\u+201e #\u+00a6 #\u+00a7 + #\u+00d8 #\u+00a9 #\u+0156 #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00c6 + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+201c #\u+00b5 #\u+00b6 #\u+00b7 + #\u+00f8 #\u+00b9 #\u+0157 #\u+00bb #\u+00bc #\u+00bd #\u+00be #\u+00e6 + ;; #xc0 + #\u+0104 #\u+012e #\u+0100 #\u+0106 #\u+00c4 #\u+00c5 #\u+0118 #\u+0112 + #\u+010c #\u+00c9 #\u+0179 #\u+0116 #\u+0122 #\u+0136 #\u+012a #\u+013b + ;; #xd0 + #\u+0160 #\u+0143 #\u+0145 #\u+00d3 #\u+014c #\u+00d5 #\u+00d6 #\u+00d7 + #\u+0172 #\u+0141 #\u+015a #\u+016a #\u+00dc #\u+017b #\u+017d #\u+00df + ;; #xe0 + #\u+0105 #\u+012f #\u+0101 #\u+0107 #\u+00e4 #\u+00e5 #\u+0119 #\u+0113 + #\u+010d #\u+00e9 #\u+017a #\u+0117 #\u+0123 #\u+0137 #\u+012b #\u+013c + ;; #xf0 + #\u+0161 #\u+0144 #\u+0146 #\u+00f3 #\u+014d #\u+00f5 #\u+00f6 #\u+00f7 + #\u+0173 #\u+0142 #\u+015b #\u+016b #\u+00fc #\u+017c #\u+017e #\u+2019 + )) + +(defstatic *unicode-a0-180-to-iso-8859-13* + #( + #xa0 nil #xa2 #xa3 #xa4 nil #xa6 #xa7 ; #xa0-#xa7 + nil #xa9 nil #xab #xac #xad #xae nil ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 nil #xb5 #xb6 #xb7 ; #xb0-#xb7 + nil #xb9 nil #xbb #xbc #xbd #xbe nil ; #xb8-#xbf + nil nil nil nil #xc4 #xc5 #xaf nil ; #xc0-#xc7 + nil #xc9 nil nil nil nil nil nil ; #xc8-#xcf + nil nil nil #xd3 nil #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xa8 nil nil nil #xdc nil nil #xdf ; #xd8-#xdf + nil nil nil nil #xe4 #xe5 #xbf nil ; #xe0-#xe7 + nil #xe9 nil nil nil nil nil nil ; #xe8-#xef + nil nil nil #xf3 nil #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xb8 nil nil nil #xfc nil nil nil ; #xf8-#xff + #xc2 #xe2 nil nil #xc0 #xe0 #xc3 #xe3 ; #x100-#x107 + nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f + nil nil #xc7 #xe7 nil nil #xcb #xeb ; #x110-#x117 + #xc6 #xe6 nil nil nil nil nil nil ; #x118-#x11f + nil nil #xcc #xec nil nil nil nil ; #x120-#x127 + nil nil #xce #xee nil nil #xc1 #xe1 ; #x128-#x12f + nil nil nil nil nil nil #xcd #xed ; #x130-#x137 + nil nil nil #xcf #xef nil nil nil ; #x138-#x13f + nil #xd9 #xf9 #xd1 #xf1 #xd2 #xf2 nil ; #x140-#x147 + nil nil nil nil #xd4 #xf4 nil nil ; #x148-#x14f + nil nil nil nil nil nil #xaa #xba ; #x150-#x157 + nil nil #xda #xfa nil nil nil nil ; #x158-#x15f + #xd0 #xf0 nil nil nil nil nil nil ; #x160-#x167 + nil nil #xdb #xfb nil nil nil nil ; #x168-#x16f + nil nil #xd8 #xf8 nil nil nil nil ; #x170-#x177 + nil #xca #xea #xdd #xfd #xde #xfe nil ; #x178-#x17f + )) + +(defstatic *unicode-2018-2020-to-iso-8859-13* + #( + nil #xff nil nil #xb4 #xa1 #xa5 nil ; #x2018-#x201f */ + )) + + +(define-character-encoding :iso-8859-13 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Baltic +alphabets." + + :aliases '() + :stream-encode-function + (nfunction + iso-8859-13-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-13* + (the fixnum (- code #xa0)))) + ((and (>= code #x2018) + (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-13* + (the fixnum (- code #x2018))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-13-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-13-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-13* + (the fixnum (- code #xa0)))) + ((and (>= code #x2018) + (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-13* + (the fixnum (- code #x2018))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-13-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-13-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-13* + (the fixnum (- code #xa0)))) + ((and (>= code #x2018) + (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-13* + (the fixnum (- code #x2018))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-13-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-14-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+1e02 #\u+1e03 #\u+00a3 #\u+010a #\u+010b #\u+1e0a #\u+00a7 + #\u+1e80 #\u+00a9 #\u+1e82 #\u+1e0b #\u+1ef2 #\u+00ad #\u+00ae #\u+0178 + ;; #xb0 + #\u+1e1e #\u+1e1f #\u+0120 #\u+0121 #\u+1e40 #\u+1e41 #\u+00b6 #\u+1e56 + #\u+1e81 #\u+1e57 #\u+1e83 #\u+1e60 #\u+1ef3 #\u+1e84 #\u+1e85 #\u+1e61 + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+00c7 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+0174 #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+1e6a + #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+0176 #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+0175 #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+1e6b + #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+0177 #\u+00ff + )) + +(defstatic *unicode-a0-100-to-iso-8859-14* + #( + #xa0 nil nil #xa3 nil nil nil #xa7 ; #xa0-#xa7 + nil #xa9 nil nil nil #xad #xae nil ; #xa8-#xaf + nil nil nil nil nil nil #xb6 nil ; #xb0-#xb7 + nil nil nil nil nil nil nil nil ; #xb8-#xbf + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + nil #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 nil ; #xd0-#xd7 + #xd8 #xd9 #xda #xdb #xdc #xdd nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 nil ; #xf0-#xf7 + #xf8 #xf9 #xfa #xfb #xfc #xfd nil #xff ; #xf8-#xff + )) + +(defstatic *unicode-108-128-to-iso-8859-14* + #( + nil nil #xa4 #xa5 nil nil nil nil ; #x108-#x10f + nil nil nil nil nil nil nil nil ; #x110-#x117 + nil nil nil nil nil nil nil nil ; #x118-#x11f + #xb2 #xb3 nil nil nil nil nil nil ; #x120-#x127 + )) + +(defstatic *unicode-170-180-to-iso-8859-14* + #( + nil nil nil nil #xd0 #xf0 #xde #xfe ; #x170-#x177 + #xaf nil nil nil nil nil nil nil ; #x178-#x17f + )) + +(defstatic *unicode-1e00-1e88-to-iso-8859-14* + #( + nil nil #xa1 #xa2 nil nil nil nil ; #x1e00-#x1e07 + nil nil #xa6 #xab nil nil nil nil ; #x1e08-#x1e0f + nil nil nil nil nil nil nil nil ; #x1e10-#x1e17 + nil nil nil nil nil nil #xb0 #xb1 ; #x1e18-#x1e1f + nil nil nil nil nil nil nil nil ; #x1e20-#x1e27 + nil nil nil nil nil nil nil nil ; #x1e28-#x1e2f + nil nil nil nil nil nil nil nil ; #x1e30-#x1e37 + nil nil nil nil nil nil nil nil ; #x1e38-#x1e3f + #xb4 #xb5 nil nil nil nil nil nil ; #x1e40-#x1e47 + nil nil nil nil nil nil nil nil ; #x1e48-#x1e4f + nil nil nil nil nil nil #xb7 #xb9 ; #x1e50-#x1e57 + nil nil nil nil nil nil nil nil ; #x1e58-#x1e5f + #xbb #xbf nil nil nil nil nil nil ; #x1e60-#x1e67 + nil nil #xd7 #xf7 nil nil nil nil ; #x1e68-#x1e6f + nil nil nil nil nil nil nil nil ; #x1e70-#x1e77 + nil nil nil nil nil nil nil nil ; #x1e78-#x1e7f + #xa8 #xb8 #xaa #xba #xbd #xbe nil nil ; #x1e80-#x1e87 + )) + +(defstatic *unicode-1ef0-1ef8-to-iso-8859-14* + #( + nil nil #xac #xbc nil nil nil nil ; #x1ef0-#x1ef7 + )) + +(define-character-encoding :iso-8859-14 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Celtic +languages." + :aliases '(:iso_8859-14 :iso-ir-199 :latin8 :l8 :iso-celtic) + :stream-encode-function + (nfunction + iso-8859-14-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-14* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x128)) + (svref *unicode-108-128-to-iso-8859-14* + (the fixnum (- code #x108)))) + ((and (>= code #x170) (< code #x180)) + (svref *unicode-170-180-to-iso-8859-14* + (the fixnum (- code #x170)))) + ((and (>= code #x1e00) (< code #x1e88)) + (svref *unicode-1e00-1e88-to-iso-8859-14* + (the fixnum (- code #x1e00)))) + ((and (>= code #x1ef0) (< code #x1ef8)) + (svref *unicode-1ef0-1ef8-to-iso-8859-14* + (the fixnum (- code #x1ef0))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-14-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-14-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-14* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x128)) + (svref *unicode-108-128-to-iso-8859-14* + (the fixnum (- code #x108)))) + ((and (>= code #x170) (< code #x180)) + (svref *unicode-170-180-to-iso-8859-14* + (the fixnum (- code #x170)))) + ((and (>= code #x1e00) (< code #x1e88)) + (svref *unicode-1e00-1e88-to-iso-8859-14* + (the fixnum (- code #x1e00)))) + ((and (>= code #x1ef0) (< code #x1ef8)) + (svref *unicode-1ef0-1ef8-to-iso-8859-14* + (the fixnum (- code #x1ef0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-14-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-14-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-14* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x128)) + (svref *unicode-108-128-to-iso-8859-14* + (the fixnum (- code #x108)))) + ((and (>= code #x170) (< code #x180)) + (svref *unicode-170-180-to-iso-8859-14* + (the fixnum (- code #x170)))) + ((and (>= code #x1e00) (< code #x1e88)) + (svref *unicode-1e00-1e88-to-iso-8859-14* + (the fixnum (- code #x1e00)))) + ((and (>= code #x1ef0) (< code #x1ef8)) + (svref *unicode-1ef0-1ef8-to-iso-8859-14* + (the fixnum (- code #x1ef0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-14-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-15-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+00a1 #\u+00a2 #\u+00a3 #\u+20ac #\u+00a5 #\u+0160 #\u+00a7 + #\u+0161 #\u+00a9 #\u+00aa #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00af + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+017d #\u+00b5 #\u+00b6 #\u+00b7 + #\u+017e #\u+00b9 #\u+00ba #\u+00bb #\u+0152 #\u+0153 #\u+0178 #\u+00bf + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+00c7 + ;; #xc8 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+00d0 #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 + ;; #xd8 + #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+00de #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7 + ;; #xe8 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+00f0 #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 + ;; #xf8 + #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+00fe #\u+00ff + )) + +(defstatic *unicode-a0-100-to-iso-8859-15* + #( + #xa0 #xa1 #xa2 #xa3 nil #xa5 nil #xa7 ; #xa0-#xa7 + nil #xa9 #xaa #xab #xac #xad #xae #xaf ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 nil #xb5 #xb6 #xb7 ; #xb0-#xb7 + nil #xb9 #xba #xbb nil nil nil #xbf ; #xb8-0xbf + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff ; #xf8-#xff + )) + +(defstatic *unicode-150-180-to-iso-8859-15* + #( + nil nil #xbc #xbd nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + #xa6 #xa8 nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil nil nil nil nil ; #x168-#x16f + nil nil nil nil nil nil nil nil ; #x170-#x177 + #xbe nil nil nil nil #xb4 #xb8 nil ; #x178-#x17f + )) + +(define-character-encoding :iso-8859-15 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Western +European languages (including the Euro sign and some other characters +missing from ISO-8859-1." + :aliases '(:iso_8859-15 :latin9) + :stream-encode-function + (nfunction + iso-8859-15-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-15* + (the fixnum (- code #xa0)))) + ((and (>= code #x150) (< code #x180)) + (svref *unicode-150-180-to-iso-8859-15* + (the fixnum (- code #x150)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-15-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-15-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-15* + (the fixnum (- code #xa0)))) + ((and (>= code #x150) (< code #x180)) + (svref *unicode-150-180-to-iso-8859-15* + (the fixnum (- code #x150)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-15-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-15-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-15* + (the fixnum (- code #xa0)))) + ((and (>= code #x150) (< code #x180)) + (svref *unicode-150-180-to-iso-8859-15* + (the fixnum (- code #x150)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-15-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-16-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+0105 #\u+0141 #\u+20ac #\u+201e #\u+0160 #\u+00a7 + #\u+0161 #\u+00a9 #\u+0218 #\u+00ab #\u+0179 #\u+00ad #\u+017a #\u+017b + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+010c #\u+0142 #\u+017d #\u+201d #\u+00b6 #\u+00b7 + #\u+017e #\u+010d #\u+0219 #\u+00bb #\u+0152 #\u+0153 #\u+0178 #\u+017c + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+0102 #\u+00c4 #\u+0106 #\u+00c6 #\u+00c7 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+0110 #\u+0143 #\u+00d2 #\u+00d3 #\u+00d4 #\u+0150 #\u+00d6 #\u+015a + #\u+0170 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+0118 #\u+021a #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+0103 #\u+00e4 #\u+0107 #\u+00e6 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+0111 #\u+0144 #\u+00f2 #\u+00f3 #\u+00f4 #\u+0151 #\u+00f6 #\u+015b + #\u+0171 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+0119 #\u+021b #\u+00ff + )) + +(defstatic *unicode-a0-180-to-iso-8859-16* + #( + #xa0 nil nil nil nil nil nil #xa7 ; #xa0-#xa7 + nil #xa9 nil #xab nil #xad nil nil ; #xa8-#xaf + #xb0 #xb1 nil nil nil nil #xb6 #xb7 ; #xb0-#xb7 + nil nil nil #xbb nil nil nil nil ; #xb8-#xbf + #xc0 #xc1 #xc2 nil #xc4 nil #xc6 #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + nil nil #xd2 #xd3 #xd4 nil #xd6 nil ; #xd0-#xd7 + nil #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 nil #xe4 nil #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil nil #xf2 #xf3 #xf4 nil #xf6 nil ; #xf0-#xf7 + nil #xf9 #xfa #xfb #xfc nil nil #xff ; #xf8-#xff + nil nil #xc3 #xe3 #xa1 #xa2 #xc5 #xe5 ; #x100-#x107 + nil nil nil nil #xb2 #xb9 nil nil ; #x108-#x10f + #xd0 #xf0 nil nil nil nil nil nil ; #x110-#x117 + #xdd #xfd nil nil nil nil nil nil ; #x118-#x11f + nil nil nil nil nil nil nil nil ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + nil nil nil nil nil nil nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil #xa3 #xb3 #xd1 #xf1 nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + #xd5 #xf5 #xbc #xbd nil nil nil nil ; #x150-#x157 + nil nil #xd7 #xf7 nil nil nil nil ; #x158-#x15f + #xa6 #xa8 nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil nil nil nil nil ; #x168-#x16f + #xd8 #xf8 nil nil nil nil nil nil ; #x170-#x177 + #xbe #xac #xae #xaf #xbf #xb4 #xb8 nil ; #x178-#x17f + )) + +(defstatic *unicode-218-220-to-iso-8859-16* + #( + #xaa #xba #xde #xfe nil nil nil nil ; #x218-#x21f + )) + +(defstatic *unicode-2018-2020-to-iso-8859-16* + #( + nil nil nil nil nil #xb5 #xa5 nil ; #x2018-#x201f + )) + + +(define-character-encoding :iso-8859-16 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Southeast +European languages." + :aliases '(:iso_8859-16 :latin10 :l1 :iso-ir-226) + :stream-encode-function + (nfunction + iso-8859-16-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-16* + (the fixnum (- code #xa0)))) + ((and (>= code #x218) (< code #x220)) + (svref *unicode-218-220-to-iso-8859-16* + (the fixnum (- code #x218)))) + ((and (>= code #x2018) (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-16* + (the fixnum (- code #x2018)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-16-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-16* + (the fixnum (- code #xa0)))) + ((and (>= code #x218) (< code #x220)) + (svref *unicode-218-220-to-iso-8859-16* + (the fixnum (- code #x218)))) + ((and (>= code #x2018) (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-16* + (the fixnum (- code #x2018)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-16-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-16* + (the fixnum (- code #xa0)))) + ((and (>= code #x218) (< code #x220)) + (svref *unicode-218-220-to-iso-8859-16* + (the fixnum (- code #x218)))) + ((and (>= code #x2018) (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-16* + (the fixnum (- code #x2018)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-16-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *macintosh-to-unicode* + #( + ;; #x80 + #\u+00c4 #\u+00c5 #\u+00c7 #\u+00c9 #\u+00d1 #\u+00d6 #\u+00dc #\u+00e1 + #\u+00e0 #\u+00e2 #\u+00e4 #\u+00e3 #\u+00e5 #\u+00e7 #\u+00e9 #\u+00e8 + ;; #x90 + #\u+00ea #\u+00eb #\u+00ed #\u+00ec #\u+00ee #\u+00ef #\u+00f1 #\u+00f3 + #\u+00f2 #\u+00f4 #\u+00f6 #\u+00f5 #\u+00fa #\u+00f9 #\u+00fb #\u+00fc + ;; #xa0 + #\u+2020 #\u+00b0 #\u+00a2 #\u+00a3 #\u+00a7 #\u+2022 #\u+00b6 #\u+00df + #\u+00ae #\u+00a9 #\u+2122 #\u+00b4 #\u+00a8 #\u+2260 #\u+00c6 #\u+00d8 + ;; #xb0 + #\u+221e #\u+00b1 #\u+2264 #\u+2265 #\u+00a5 #\u+00b5 #\u+2202 #\u+2211 + #\u+220f #\u+03c0 #\u+222b #\u+00aa #\u+00ba #\u+2126 #\u+00e6 #\u+00f8 + ;; #xc0 + #\u+00bf #\u+00a1 #\u+00ac #\u+221a #\u+0192 #\u+2248 #\u+2206 #\u+00ab + #\u+00bb #\u+2026 #\u+00a0 #\u+00c0 #\u+00c3 #\u+00d5 #\u+0152 #\u+0153 + ;; #xd0 + #\u+2013 #\u+2014 #\u+201c #\u+201d #\u+2018 #\u+2019 #\u+00f7 #\u+25ca + #\u+00ff #\u+0178 #\u+2044 #\u+00a4 #\u+2039 #\u+203a #\u+fb01 #\u+fb02 + ;; #xe0 + #\u+2021 #\u+00b7 #\u+201a #\u+201e #\u+2030 #\u+00c2 #\u+00ca #\u+00c1 + #\u+00cb #\u+00c8 #\u+00cd #\u+00ce #\u+00cf #\u+00cc #\u+00d3 #\u+00d4 + ;; #xf0 + #\u+f8ff #\u+00d2 #\u+00da #\u+00db #\u+00d9 #\u+0131 #\u+02c6 #\u+02dc + #\u+00af #\u+02d8 #\u+02d9 #\u+02da #\u+00b8 #\u+02dd #\u+02db #\u+02c7 + )) + + +(defstatic *unicode-a0-100-to-macintosh* + #( + #xca #xc1 #xa2 #xa3 #xdb #xb4 nil #xa4 ; #xa0-#xa7 + #xac #xa9 #xbb #xc7 #xc2 nil #xa8 #xf8 ; #xa8-#xaf + #xa1 #xb1 nil nil #xab #xb5 #xa6 #xe1 ; #xb0-#xb7 + #xfc nil #xbc #xc8 nil nil nil #xc0 ; #xb8-#xbf + #xcb #xe7 #xe5 #xcc #x80 #x81 #xae #x82 ; #xc0-#xc7 + #xe9 #x83 #xe6 #xe8 #xed #xea #xeb #xec ; #xc8-#xcf + nil #x84 #xf1 #xee #xef #xcd #x85 nil ; #xd0-#xd7 + #xaf #xf4 #xf2 #xf3 #x86 nil nil #xa7 ; #xd8-#xdf + #x88 #x87 #x89 #x8b #x8a #x8c #xbe #x8d ; #xe0-#xe7 + #x8f #x8e #x90 #x91 #x93 #x92 #x94 #x95 ; #xe8-#xef + nil #x96 #x98 #x97 #x99 #x9b #x9a #xd6 ; #xf0-#xf7 + #xbf #x9d #x9c #x9e #x9f nil nil #xd8 ; #xf8-#xff + )) + +(defstatic *unicode-130-198-to-macintosh* + #( + nil #xf5 nil nil nil nil nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil nil nil nil nil nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + nil nil #xce #xcf nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + nil nil nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil nil nil nil nil ; #x168-#x16f + nil nil nil nil nil nil nil nil ; #x170-#x177 + #xd9 nil nil nil nil nil nil nil ; #x178-#x17f + nil nil nil nil nil nil nil nil ; #x180-#x187 + nil nil nil nil nil nil nil nil ; #x188-#x18f + nil nil #xc4 nil nil nil nil nil ; #x190-#x197 + )) + +(defstatic *unicode-2c0-2e0-to-macintosh* + #( + nil nil nil nil nil nil #xf6 #xff ; #x2c0-#x2c7 + nil nil nil nil nil nil nil nil ; #x2c8-#x2cf + nil nil nil nil nil nil nil nil ; #x2d0-#x2d7 + #xf9 #xfa #xfb #xfe #xf7 #xfd nil nil ; #x2d8-#x2df + )) + +(defstatic *unicode-2010-2048-to-macintosh* + #( + nil nil nil #xd0 #xd1 nil nil nil ; #x2010-#x2017 + #xd4 #xd5 #xe2 nil #xd2 #xd3 #xe3 nil ; #x2018-#x201f + #xa0 #xe0 #xa5 nil nil nil #xc9 nil ; #x2020-#x2027 + nil nil nil nil nil nil nil nil ; #x2028-#x202f + #xe4 nil nil nil nil nil nil nil ; #x2030-#x2037 + nil #xdc #xdd nil nil nil nil nil ; #x2038-#x203f + nil nil nil nil #xda nil nil nil ; #x2040-#x2047 + )) + +(defstatic *unicode-2120-2128-to-macintosh* + #( + nil nil #xaa nil nil nil #xbd nil ; #x2120-#x2127 + )) + +(defstatic *unicode-2200-2268-to-macintosh* + #( + nil nil #xb6 nil nil nil #xc6 nil ; #x2200-#x2207 + nil nil nil nil nil nil nil #xb8 ; #x2208-#x220f + nil #xb7 nil nil nil nil nil nil ; #x2210-#x2217 + nil nil #xc3 nil nil nil #xb0 nil ; #x2218-#x221f + nil nil nil nil nil nil nil nil ; #x2220-#x2227 + nil nil nil #xba nil nil nil nil ; #x2228-#x222f + nil nil nil nil nil nil nil nil ; #x2230-#x2237 + nil nil nil nil nil nil nil nil ; #x2238-#x223f + nil nil nil nil nil nil nil nil ; #x2240-#x2247 + #xc5 nil nil nil nil nil nil nil ; #x2248-#x224f + nil nil nil nil nil nil nil nil ; #x2250-#x2257 + nil nil nil nil nil nil nil nil ; #x2258-#x225f + #xad nil nil nil #xb2 #xb3 nil nil ; #x2260-#x2267 + )) + +(defstatic *unicode-fb00-fb08-to-macintosh* + #( + nil #xde #xdf nil nil nil nil nil ; #xfb00-#xfb07 + )) + +(define-character-encoding :macintosh + "An 8-bit, fixed-width character encoding in which codes #x00-#x7f +map to their Unicode equivalents and other codes map to other Unicode +character values. Traditionally used on Classic MacOS to encode characters +used in western languages." + :aliases '(:macos-roman :macosroman :mac-roman :macroman) + + :stream-encode-function + (nfunction + macintosh-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + macintosh-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80)))))) + :vector-encode-function + (nfunction + macintosh-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + macintosh-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80))))))))) + :memory-encode-function + (nfunction + macintosh-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + macintosh-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #x80 + :encode-literal-char-code-limit #x80 + ) + + +;;; UTF-8. Decoding checks for malformed sequences; it might be faster (and +;;; would certainly be simpler) if it didn't. +(define-character-encoding :utf-8 + "An 8-bit, variable-length character encoding in which characters +with CHAR-CODEs in the range #x00-#x7f can be encoded in a single +octet; characters with larger code values can be encoded in 2 to 4 +bytes." + :max-units-per-char 4 + :stream-encode-function + (nfunction + utf-8-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (cond ((< code #x80) + (funcall write-function stream code) + 1) + ((< code #x800) + (let* ((y (ldb (byte 5 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum y z)) + (funcall write-function stream (logior #xc0 y)) + (funcall write-function stream (logior #x80 z)) + 2)) + ((< code #x10000) + (let* ((x (ldb (byte 4 12) code)) + (y (ldb (byte 6 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum x y z)) + (funcall write-function stream (logior #xe0 x)) + (funcall write-function stream (logior #x80 y)) + (funcall write-function stream (logior #x80 z)) + 3)) + (t + (let* ((w (ldb (byte 3 18) code)) + (x (ldb (byte 6 12) code)) + (y (ldb (byte 6 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum w x y z)) + (funcall write-function stream (logior #xf0 w)) + (funcall write-function stream (logior #x80 x)) + (funcall write-function stream (logior #x80 y)) + (funcall write-function stream (logior #x80 z)) + 4)))))) + :stream-decode-function + (nfunction + utf-8-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (if (>= 1st-unit #xc2) + (let* ((s1 (funcall next-unit-function stream))) + (if (eq s1 :eof) + s1 + (locally + (declare (type (unsigned-byte 8) s1)) + (if (< 1st-unit #xe0) + (if (< (the fixnum (logxor s1 #x80)) #x40) + (code-char + (logior + (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) + (the fixnum (logxor s1 #x80)))) + #\Replacement_Character) + (let* ((s2 (funcall next-unit-function stream))) + (if (eq s2 :eof) + s2 + (locally + (declare (type (unsigned-byte 8) s2)) + (if (< 1st-unit #xf0) + (if (and (< (the fixnum (logxor s1 #x80)) #x40) + (< (the fixnum (logxor s2 #x80)) #x40) + (or (>= 1st-unit #xe1) + (>= s1 #xa0))) + (or (code-char (the fixnum + (logior (the fixnum + (ash (the fixnum (logand 1st-unit #xf)) + 12)) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand s1 #x3f)) + 6)) + (the fixnum (logand s2 #x3f))))))) + #\Replacement_Character) + #\Replacement_Character) + (if (< 1st-unit #xf8) + (let* ((s3 (funcall next-unit-function stream))) + (if (eq s3 :eof) + s3 + (locally + (declare (type (unsigned-byte 8) s3)) + (if (and (< (the fixnum (logxor s1 #x80)) #x40) + (< (the fixnum (logxor s2 #x80)) #x40) + (< (the fixnum (logxor s3 #x80)) #x40) + (or (>= 1st-unit #xf1) + (>= s1 #x90))) + (code-char + (logior + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 1st-unit 7)) 18)) + (the fixnum + (ash (the fixnum (logxor s1 #x80)) 12)))) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logxor s2 #x80)) 6)) + (the fixnum (logxor s3 #x80)))))) + #\Replacement_Character)))) + #\Replacement_Character))))))))) + #\Replacement_Character)))) + :vector-encode-function + (nfunction + utf-8-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (cond ((< code #x80) + (setf (aref vector idx) code) + (incf idx)) + ((< code #x800) + (setf (aref vector idx) + (logior #xc0 (the fixnum (ash code -6)))) + (setf (aref vector (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 2)) + ((< code #x10000) + (setf (aref vector idx) + (logior #xe0 (the fixnum (ash code -12)))) + (setf (aref vector (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (aref vector (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 3)) + (t + (setf (aref vector idx) + (logior #xf0 + (the fixnum (logand #x7 (the fixnum (ash code -18)))))) + (setf (aref vector (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) + (setf (aref vector (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (aref vector (the fixnum (+ idx 3))) + (logior #x80 (logand #x3f code))) + (incf idx 4))))))) + :vector-decode-function + (nfunction + utf-8-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((= index end) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((char + (if (< 1st-unit #x80) + (code-char 1st-unit) + (if (>= 1st-unit #xc2) + (let* ((2nd-unit (aref vector (incf index)))) + (declare (type (unsigned-byte 8) 2nd-unit)) + (if (< 1st-unit #xe0) + (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (code-char + (logior + (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) + (the fixnum (logxor 2nd-unit #x80))))) + (let* ((3rd-unit (aref vector (incf index)))) + (declare (type (unsigned-byte 8) 3rd-unit)) + (if (< 1st-unit #xf0) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (or (>= 1st-unit #xe1) + (>= 2nd-unit #xa0))) + (code-char (the fixnum + (logior (the fixnum + (ash (the fixnum (logand 1st-unit #xf)) + 12)) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 2nd-unit #x3f)) + 6)) + (the fixnum (logand 3rd-unit #x3f)))))))) + (let* ((4th-unit (aref vector (incf index)))) + (declare (type (unsigned-byte 8) 4th-unit)) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (< (the fixnum (logxor 4th-unit #x80)) #x40) + (or (>= 1st-unit #xf1) + (>= 2nd-unit #x90))) + (code-char + (logior + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 1st-unit 7)) 18)) + (the fixnum + (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logxor 3rd-unit #x80)) 6)) + (the fixnum (logxor 4th-unit #x80)))))))))))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :memory-encode-function + #'utf-8-memory-encode + :memory-decode-function + #'utf-8-memory-decode + :octets-in-string-function + #'utf-8-octets-in-string + :length-of-vector-encoding-function + (nfunction + utf-8-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i start) + (nchars 0)) + ((>= i end) + (values nchars i)) + (declare (fixnum i)) + (let* ((code (aref vector i)) + (nexti (+ i (cond ((< code #xc2) 1) + ((< code #xe0) 2) + ((< code #xf0) 3) + ((< code #xf8) 4) + (t 1))))) + (declare (type (unsigned-byte 8) code)) + (if (> nexti end) + (return (values nchars i)) + (setq nchars (1+ nchars) i nexti)))))) + :length-of-memory-encoding-function + #'utf-8-length-of-memory-encoding + :decode-literal-code-unit-limit #x80 + :encode-literal-char-code-limit #x80 + :bom-encoding #(#xef #xbb #xbf) + :character-size-in-octets-function (lambda (c) + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (if (< code #x80) + 1 + (if (< code #x800) + 2 + (if (< code #x10000) + 3 + 4))))) + + ) + + +;;; For a code-unit-size greater than 8: the stream-encode function's write-function +;;; accepts a code-unit in native byte order and swaps it if necessary and the +;;; stream-decode function receives a first-unit in native byte order and its +;;; next-unit-function returns a unit in native byte order. The memory/vector +;;; functions have to do their own byte swapping. + + +(defmacro utf-16-combine-surrogate-pairs (a b) + `(code-char + (the (unsigned-byte 21) + (+ #x10000 + (the (unsigned-byte 20) + (logior + (the (unsigned-byte 20) (ash (the (unsigned-byte 10) + (- ,a #xd800)) + 10)) + (the (unsigned-byte 10) (- ,b #xdc00)))))))) + +(defun utf-16-stream-encode (char write-function stream) + (let* ((code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (if (< highbits 0) + (progn + (funcall write-function stream code) + 1) + (progn + (funcall write-function stream (logior #xd800 (the fixnum (ash highbits -10)))) + (funcall write-function stream (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + 2)))) + +(defun utf-16-stream-decode (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 16) 1st-unit)) + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (funcall next-unit-function stream))) + (if (eq 2nd-unit :eof) + 2nd-unit + (locally (declare (type (unsigned-byte 16) 2nd-unit)) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit) + #\Replacement_Character)))) + #\Replacement_Character))) + + + +(declaim (inline %big-endian-u8-ref-u16 %little-endian-u8-ref-u16)) +(defun %big-endian-u8-ref-u16 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8) (aref u8-vector idx)) 8)) + (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))))) + +(defun %little-endian-u8-ref-u16 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8) + (aref u8-vector (the fixnum (1+ idx)))) 8)) + (the (unsigned-byte 8) (aref u8-vector idx)))) + +#+big-endian-target +(progn +(defmacro %native-u8-ref-u16 (vector idx) + `(%big-endian-u8-ref-u16 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u16 (vector idx) + `(%little-endian-u8-ref-u16 ,vector ,idx)) +) + +#+little-endian-target +(progn +(defmacro %native-u8-ref-u16 (vector idx) + `(%little-endian-u8-ref-u16 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u16 (vector idx) + `(%big-endian-u8-ref-u16 ,vector ,idx)) +) + + +(declaim (inline (setf %big-endian-u8-ref-u16) (setf %little-endian-u8-ref-u16))) +(defun (setf %big-endian-u8-ref-u16) (val u8-vector idx) + (declare (type (unsigned-byte 16) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 8) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 0) val)) + val) + +(defun (setf %little-endian-u8-ref-u16) (val u8-vector idx) + (declare (type (unsigned-byte 16) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 0) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 8) val)) + val) + +(defun utf-16-character-size-in-octets (c) + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (if (< code #x10000) + 2 + 4))) + +;;; utf-16, native byte order. +(define-character-encoding #+big-endian-target :utf-16be #-big-endian-target :utf-16le + #+big-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word and characters with larger codes can be encoded in a +pair of 16-bit big-endian words. The endianness of the encoded data +is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + #+little-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +little-endian word and characters with larger codes can be encoded in +a pair of 16-bit little-endian words. The endianness of the encoded +data is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + :max-units-per-char 2 + :code-unit-size 16 + :native-endianness t + :stream-encode-function + #'utf-16-stream-encode + :stream-decode-function + #'utf-16-stream-decode + :vector-encode-function + (nfunction + native-utf-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx start end)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (declare (fixnum i)) + (let* ((char (schar string i)) + (code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2)) + (t + (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10)))) + (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (declare (type (unsigned-byte 16) firstword secondword)) + (setf (%native-u8-ref-u16 vector idx) firstword + (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword) + (incf idx 4)))))))) + :vector-decode-function + (nfunction + native-utf-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (%native-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%native-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :memory-encode-function + (nfunction + native-utf-16-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) code) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10)))) + (incf idx 2) + (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + (incf idx 2))))))) + :memory-decode-function + (nfunction + native-utf-16-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((>= index end) index) + (declare (fixnum i index end)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :octets-in-string-function + #'utf-16-octets-in-string + :length-of-vector-encoding-function + (nfunction + native-utf-16-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (declare (fixnum start end)) + (do* ((i start) + (j (+ 2 i) (+ 2 i)) + (nchars 0)) + ((> j end) (values nchars i)) + (declare (fixnum i j nchars)) + (let* ((code (%native-u8-ref-u16 vector i)) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :length-of-memory-encoding-function + (nfunction + native-utf-16-length-of-memory-encoding + (lambda (pointer noctets start) + (do* ((i start) + (j (+ i 2) (+ i 2)) + (end (+ start noctets)) + (nchars 0)) + ((> j end) (values nchars i)) + (let* ((code (%get-unsigned-word pointer i)) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :decode-literal-code-unit-limit #xd800 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'utf-16-character-size-in-octets + ) + +;;; utf-16, reversed byte order +(define-character-encoding #+big-endian-target :utf-16le #-big-endian-target :utf-16be + #+little-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word and characters with larger codes can be encoded in a +pair of 16-bit big-endian words. The endianness of the encoded data +is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + #+big-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +little-endian word and characters with larger codes can be encoded in +a pair of 16-bit little-endian words. The endianness of the encoded +data is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + :max-units-per-char 2 + :code-unit-size 16 + :native-endianness nil + :stream-encode-function + #'utf-16-stream-encode + :stream-decode-function + #'utf-16-stream-decode + :vector-encode-function + (nfunction + reversed-utf-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx start end)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (declare (fixnum i)) + (let* ((char (schar string i)) + (code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%reversed-u8-ref-u16 vector idx) code) + (incf idx 2)) + (t + (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10)))) + (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (declare (type (unsigned-byte 16) firstword secondword)) + (setf (%reversed-u8-ref-u16 vector idx) firstword + (%reversed-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword) + (incf idx 4)))))))) + :vector-decode-function + (nfunction + reversed-utf-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (%reversed-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%reversed-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :memory-encode-function + (nfunction + reversed-utf-16-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) (%swap-u16 code)) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xd800 (the fixnum (ash highbits -10))))) + (incf idx 2) + (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (incf idx 2))))))) + :memory-decode-function + (nfunction + reversed-utf-16-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((>= index end) index) + (declare (fixnum i index end)) + (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%swap-u16 (%get-unsigned-word pointer index)))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :octets-in-string-function + #'utf-16-octets-in-string + :length-of-vector-encoding-function + (nfunction + reversed-utf-16-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (declare (fixnum start end)) + (do* ((i start) + (j (+ 2 i) (+ 2 i)) + (nchars 0)) + ((> j end) (values nchars i)) + (declare (fixnum i j nchars)) + (let* ((code (%reversed-u8-ref-u16 vector i)) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :length-of-memory-encoding-function + (nfunction + reversed-utf-16-length-of-memory-encoding + (lambda (pointer noctets start) + (do* ((i start) + (j (+ i 2) (+ i 2)) + (end (+ start noctets)) + (nchars 0)) + ((> j end) (values nchars i)) + (let* ((code (%swap-u16 (%get-unsigned-word pointer i))) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :decode-literal-code-unit-limit #xd800 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'utf-16-character-size-in-octets + ) + +;;; UTF-16. Memory and vector functions determine endianness of +;;; input by the presence of a byte-order mark (or swapped BOM) +;;; at the beginning of input, and assume big-endian order +;;; if this mark is missing; on output, a BOM is prepended and +;;; things are written in native byte order. +;;; The endianness of stream-io operations is determined by +;;; stream content; new output streams are written in native +;;; endianness with a BOM character prepended. Input streams +;;; are read in native byte order if the initial character is +;;; a BOM, in reversed byte order if the initial character is +;;; a swapped BOM, and in big-endian order (per RFC 2781) if +;;; there is no BOM. + +(define-character-encoding :utf-16 + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +word and characters with larger codes can be encoded in a +pair of 16-bit words. The endianness of the encoded data is +indicated by the endianness of a byte-order-mark character (#\u+feff) +prepended to the data; in the absence of such a character on input, +the data is assumed to be in big-endian order. Output is written +in native byte-order with a leading byte-order mark." + :max-units-per-char 2 + :code-unit-size 16 + :native-endianness t ;not necessarily true. + :stream-encode-function + #'utf-16-stream-encode + :stream-decode-function + #'utf-16-stream-decode + :vector-encode-function + (nfunction + utf-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (declare (fixnum i)) + (let* ((char (schar string i)) + (code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2)) + (t + (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10)))) + (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (declare (type (unsigned-byte 16) firstword secondword)) + (setf (%native-u8-ref-u16 vector idx) firstword + (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword) + (incf idx 4)))))))) + :vector-decode-function + (nfunction + utf-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 16) (*)) vector) + (type index idx)) + (let* ((origin idx) + (swap (if (>= noctets 2) + (case (%native-u8-ref-u16 vector idx) + (#.byte-order-mark-char-code + (incf idx 2) nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (end (+ origin noctets)) + (index idx)) + ((= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (if swap + (%reversed-u8-ref-u16 vector index) + (%native-u8-ref-u16 vector index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (if swap + (%reversed-u8-ref-u16 vector index) + (%native-u8-ref-u16 vector index)))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character)))))))) + :memory-encode-function + (nfunction + utf-16-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + ;; Output a BOM. + (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) code) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10)))) + (setf (%get-unsigned-word pointer (the fixnum (+ idx 2))) + (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + (incf idx 4))))))) + :memory-decode-function + (nfunction + utf-16-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (let* ((swap (when (> noctets 1) + (case (%get-unsigned-word pointer idx) + (#.byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx )) + ((>= index end) index) + (declare (fixnum i index end)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (if swap (setq 1st-unit (%swap-u16 1st-unit))) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (if swap (setq 2nd-unit (%swap-u16 2nd-unit))) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character)))))))) + :octets-in-string-function + (nfunction + utf-16-bom-octets-in-string + (lambda (string start end) + (+ 2 (utf-16-octets-in-string string start end)))) + :length-of-vector-encoding-function + (nfunction + utf-16-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 16) (*)) vector)) + (let* ((swap (when (>= end (+ start 2)) + (case (%native-u8-ref-u16 vector start) + (#.byte-order-mark-char-code + (incf start 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf start 2) + t) + (t #+little-endian-target t))))) + (do* ((i start) + (j (+ 2 i) (+ 2 j)) + (nchars 0)) + ((> j end) + (values nchars i)) + (let* ((code (if swap + (%reversed-u8-ref-u16 vector i) + (%native-u8-ref-u16 vector i))) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars)))))))) + :length-of-memory-encoding-function + (nfunction + utf-16-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (fixnum noctets start)) + (when (oddp noctets) + (setq noctets (1- noctets))) + (let* ((origin start) + (swap (when (>= noctets 2) + (case (%get-unsigned-word pointer (+ start start)) + (#.byte-order-mark-char-code + (incf start 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf start 2) + t) + (t #+little-endian-target t))))) + (declare (fixnum origin)) + (do* ((i start) + (j (+ i 2) (+ i 2)) + (end (+ origin noctets)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars (- i origin))) + (declare (fixnum i j end nchars)) + (let* ((code (%get-unsigned-word pointer i))) + (declare (type (unsigned-byte 16) code)) + (if swap (setq code (%swap-u16 code))) + (let* ((nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (fixnum nexti)) + (if (> nexti end) + (return (values nchars (- i origin))) + (setq i nexti)))))))) + :decode-literal-code-unit-limit #xd800 + :encode-literal-char-code-limit #x10000 + :use-byte-order-mark + #+big-endian-target :utf-16le + #+little-endian-target :utf-16be + :bom-encoding #+big-endian-target #(#xfe #xff) #+little-endian-target #(#xff #xfe) + :nul-encoding #(0 0) + :character-size-in-octets-function 'utf-16-character-size-in-octets + ) + + +(defun two-octets-per-character (c) + (declare (ignore c)) + 2) + +(defun ucs-2-stream-encode (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (funcall write-function stream code) + 1)) + +(defun ucs-2-stream-decode (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 16) 1st-unit) + (ignore next-unit-function stream)) + ;; CODE-CHAR returns NIL on either half of a surrogate pair. + (or (code-char 1st-unit) + #\Replacement_Character)) + + +(defun ucs-2-octets-in-string (string start end) + (declare (ignore string)) + (if (>= end start) + (* 2 (- end start)) + 0)) + +(defun ucs-2-length-of-vector-encoding (vector start end) + (declare (ignore vector)) + (let* ((noctets (max (- end start) 0))) + (values (ash noctets -1) (+ start (logandc2 noctets 1))))) + +(defun ucs-2-length-of-memory-encoding (pointer noctets start) + (declare (ignore pointer start)) + (values (ash noctets -1) (logandc2 noctets 1))) + + + +;;; UCS-2, native byte order +(define-character-encoding #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le + #+big-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+little-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +little-endian word. The encoded data is implicitly little-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + :max-units-per-char 1 + :code-unit-size 16 + :native-endianness t + :stream-encode-function + #'ucs-2-stream-encode + :stream-decode-function + #'ucs-2-stream-decode + :vector-encode-function + (nfunction + native-ucs-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2))))) + :vector-decode-function + (nfunction + native-ucs-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 2 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (setf (schar string i) + (or (code-char (%native-u8-ref-u16 vector index)) + #\Replacement_Character))))) + :memory-encode-function + (nfunction + native-ucs-2-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-word pointer idx) + (if (>= code #x10000) + (char-code #\Replacement_Character) + code)) + (incf idx 2))))) + :memory-decode-function + (nfunction + native-ucs-2-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (setf (schar string i) (or (char-code 1st-unit) #\Replacement_Character)))))) + :octets-in-string-function + #'ucs-2-octets-in-string + :length-of-vector-encoding-function + #'ucs-2-length-of-vector-encoding + :length-of-memory-encoding-function + #'ucs-2-length-of-memory-encoding + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'two-octets-per-character + ) + +;;; UCS-2, reversed byte order +(define-character-encoding #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be + #+little-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+big-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit + +little-endian word. The encoded data is implicitly little-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + :max-units-per-char 1 + :code-unit-size 16 + :native-endianness nil + :stream-encode-function + #'ucs-2-stream-encode + :stream-decode-function + #'ucs-2-stream-decode + :vector-encode-function + (nfunction + reversed-ucs-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (setf (%reversed-u8-ref-u16 vector idx) code) + (incf idx 2))))) + :vector-decode-function + (nfunction + reversed-ucs-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 2 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (setf (schar string i) + (or (code-char (%reversed-u8-ref-u16 vector index)) + #\Replacement_Character))))) + :memory-encode-function + (nfunction + reversed-ucs-2-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-word pointer idx) + (if (>= code #x10000) + (%swap-u16 (char-code #\Replacement_Character)) + (%swap-u16 code))) + (incf idx 2))))) + :memory-decode-function + (nfunction + reversed-ucs-2-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character)))))) + :octets-in-string-function + #'ucs-2-octets-in-string + :length-of-vector-encoding-function + #'ucs-2-length-of-vector-encoding + :length-of-memory-encoding-function + #'ucs-2-length-of-memory-encoding + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'two-octets-per-character + ) + +(define-character-encoding :ucs-2 + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit word. +The endianness of the encoded data is indicated by the endianness of a +byte-order-mark character (#\u+feff) prepended to the data; in the +absence of such a character on input, the data is assumed to be in +big-endian order." + :max-units-per-char 1 + :code-unit-size 16 + :native-endianness t ;not necessarily true. + :stream-encode-function + #'ucs-2-stream-encode + :stream-decode-function + #'ucs-2-stream-decode + :vector-encode-function + (nfunction + ucs-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2))))) + :vector-decode-function + (nfunction + ucs-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx) + (fixnum noctets)) + (let* ((swap (if (> noctets 1) + (case (%native-u8-ref-u16 vector idx) + (#.byte-order-mark-char-code + (incf idx 2) (decf noctets 2) nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) (decf noctets 2) t) + (t #+little-endian-target t))))) + + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (if swap + (%reversed-u8-ref-u16 vector index) + (%native-u8-ref-u16 vector index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character))))))) + :memory-encode-function + (nfunction + ucs-2-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-word pointer idx) + (if (>= code #x10000) + (char-code #\Replacement_Character) + code)) + (incf idx 2))))) + :memory-decode-function + (nfunction + ucs-2-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (let* ((swap (when (> noctets 1) + (case (%get-unsigned-word pointer idx) + (#.byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (if swap (setq 1st-unit (%swap-u16 1st-unit))) + (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character))))))) + :octets-in-string-function + (nfunction + ucs-2-bom-octets-in-string + (lambda (string start end) + (+ 2 (ucs-2-octets-in-string string start end)))) + :length-of-vector-encoding-function + (nfunction + ucs-2-length-of-vector-encoding + (lambda (vector start end) + (declare (fixnum start end)) + (when (>= end (+ start 2)) + (let* ((maybe-bom (%native-u8-ref-u16 vector start))) + (declare (type (unsigned-byte 16) maybe-bom)) + (when (or (= maybe-bom byte-order-mark-char-code) + (= maybe-bom swapped-byte-order-mark-char-code)) + (incf start 2)))) + (do* ((i start j) + (j (+ i 2) (+ j 2)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + ucs-2-length-of-memory-encoding + (lambda (pointer noctets start) + (let* ((skip + (when (> noctets 1) + (case (%get-unsigned-word pointer start) + (#.byte-order-mark-char-code + 2) + (#.swapped-byte-order-mark-char-code + 2))))) + (values (ash (- noctets skip) -1) (logandc2 noctets 1))))) + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :use-byte-order-mark + #+big-endian-target :ucs-2le + #+little-endian-target :ucs-2be + :nul-encoding #(0 0) + :character-size-in-octets-function 'two-octets-per-character + ) + + +(defun four-octets-per-character (c) + (declare (ignore c)) + 4) + +(defun ucs-4-stream-encode (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (funcall write-function stream code) + 1)) + +(defun ucs-4-stream-decode (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 16) 1st-unit) + (ignore next-unit-function stream)) + (code-char 1st-unit)) + + +(defun ucs-4-octets-in-string (string start end) + (declare (ignore string)) + (if (>= end start) + (* 4 (- end start)) + 0)) + + +(declaim (inline %big-endian-u8-ref-u32 %little-endian-u8-ref-u32)) +(defun %big-endian-u8-ref-u32 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 32) (ash (the (unsigned-byte 8) (aref u8-vector idx)) 24)) + (the (unsigned-byte 24) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))) 16) + (the (unsigned-byte 16) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 2)))) 8) + (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 3)))))))))) + +(defun %little-endian-u8-ref-u32 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 32) (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 3)))) 24)) + (the (unsigned-byte 24) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 2)))) 16) + (the (unsigned-byte 16) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))) 8) + (the (unsigned-byte 8) (aref u8-vector (the fixnum idx))))))))) + +#+big-endian-target +(progn +(defmacro %native-u8-ref-u32 (vector idx) + `(%big-endian-u8-ref-u32 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u32 (vector idx) + `(%little-endian-u8-ref-u32 ,vector ,idx)) +) + +#+little-endian-target +(progn +(defmacro %native-u8-ref-u32 (vector idx) + `(%little-endian-u8-ref-u32 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u32 (vector idx) + `(%big-endian-u8-ref-u32 ,vector ,idx)) +) + + +(declaim (inline (setf %big-endian-u8-ref-32) (setf %little-endian-u8-ref-u32))) +(defun (setf %big-endian-u8-ref-u32) (val u8-vector idx) + (declare (type (unsigned-byte 32) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 24) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 16) val) + (aref u8-vector (the fixnum (+ idx 2))) (ldb (byte 8 8) val) + (aref u8-vector (the fixnum (+ idx 3))) (ldb (byte 8 0) val)) + val) + +(defun (setf %little-endian-u8-ref-u32) (val u8-vector idx) + (declare (type (unsigned-byte 32) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 0) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 8) val) + (aref u8-vector (the fixnum (+ idx 2))) (ldb (byte 8 16) val) + (aref u8-vector (the fixnum (+ idx 3))) (ldb (byte 8 24) val)) + val) + + +;;; UTF-32/UCS-4, native byte order +(define-character-encoding #+big-endian-target :utf-32be #-big-endian-target :utf-32le + #+big-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters +encoded in a single 32-bit word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+little-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters can +encoded in a single 32-bit word. The encoded data is implicitly +little-endian; byte-order-mark characters are not interpreted on input +or prepended to output." + :aliases #+big-endian-target '(:ucs-4be) #+little-endian-target '(:ucs-4le) + :max-units-per-char 1 + :code-unit-size 32 + :native-endianness t + :stream-encode-function + #'ucs-4-stream-encode + :Stream-decode-function + #'ucs-4-stream-decode + :vector-encode-function + (nfunction + native-ucs-4-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (setf (%native-u8-ref-u32 vector idx) code) + (incf idx 4))))) + :vector-decode-function + (nfunction + native-ucs-4-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 4 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((code (%native-u8-ref-u32 vector index))) + (declare (type (unsigned-byte 32) code)) + (setf (schar string i) + (or (if (< code char-code-limit) + (code-char code)) + #\Replacement_Character)))))) + :memory-encode-function + (nfunction + native-ucs-4-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-long pointer idx) code) + (incf idx 4))))) + :memory-decode-function + (nfunction + native-ucs-4-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 4))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-long pointer index))) + (declare (type (unsigned-byte 32) 1st-unit)) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character)))))) + :octets-in-string-function + #'ucs-4-octets-in-string + :length-of-vector-encoding-function + (nfunction + native-ucs-4-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start j) + (j (+ i 4) (+ j 4)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + native-ucs-4-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (ignore pointer)) + (values (ash noctets -2) (+ start (logandc2 noctets 3))))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :nul-encoding #(0 0 0 0) + :character-size-in-octets-function 'four-octets-per-character + ) + +;;; UTF-32/UCS-4, reversed byte order +(define-character-encoding #+big-endian-target :utf-32le #-big-endian-target :utf-32be + #+little-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters +encoded in a single 32-bit word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+big-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters can +encoded in a single 32-bit word. The encoded data is implicitly +little-endian; byte-order-mark characters are not interpreted on input +or prepended to output." + :aliases #+big-endian-target '(:ucs-4le) #+little-endian-target '(:ucs-4be) + :max-units-per-char 1 + :code-unit-size 32 + :native-endianness nil + :stream-encode-function + #'ucs-4-stream-encode + :Stream-decode-function + #'ucs-4-stream-decode + :vector-encode-function + (nfunction + native-ucs-4-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (setf (%reversed-u8-ref-u32 vector idx) code) + (incf idx 4))))) + :vector-decode-function + (nfunction + native-ucs-4-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 4 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((code (%reversed-u8-ref-u32 vector index))) + (declare (type (unsigned-byte 32) code)) + (setf (schar string i) + (or (if (< code char-code-limit) + (code-char code)) + #\Replacement_Character)))))) + :memory-encode-function + (nfunction + native-ucs-4-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-long pointer idx) (%swap-u32 code)) + (incf idx 4))))) + :memory-decode-function + (nfunction + reversed-ucs-4-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 4))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%swap-u32 (%get-unsigned-long pointer index)))) + (declare (type (unsigned-byte 32) 1st-unit)) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character)))))) + + :octets-in-string-function + #'ucs-4-octets-in-string + :length-of-vector-encoding-function + (nfunction + reversed-ucs-4-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start j) + (j (+ i 4) (+ j 4)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + reversed-ucs-4-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (ignore pointer)) + (values (ash noctets -2) (+ start (logandc2 noctets 3))))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :nul-encoding #(0 0 0 0) + :character-size-in-octets-function 'four-octets-per-character + ) + +(define-character-encoding :utf-32 + "A 32-bit, fixed-length encoding in which all Unicode characters +can be encoded in a single 32-bit word. The endianness of the encoded +data is indicated by the endianness of a byte-order-mark +character (#\u+feff) prepended to the data; in the absence of such a +character on input, input data is assumed to be in big-endian order. +Output is written in native byte order with a leading byte-order +mark." + + :aliases '(:ucs-4) + :max-units-per-char 1 + :code-unit-size 32 + :native-endianness t ;not necessarily true. + :stream-encode-function + #+ucs-4-stream-encode + :stream-decode-function + #'ucs-4-stream-decode + :vector-encode-function + (nfunction + utf-32-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (setf (%native-u8-ref-u32 vector idx) byte-order-mark-char-code) + (incf idx 4) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (setf (%native-u8-ref-u32 vector idx) code) + (incf idx 4))))) + :vector-decode-function + (nfunction + utf-32-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx) + (fixnum noctets)) + (let* ((swap (if (> noctets 3) + (case (%native-u8-ref-u32 vector idx) + (#.byte-order-mark-char-code + (incf idx 4) (decf noctets 4) nil) + (#.swapped-byte-order-mark-char-code + (incf idx 4) (decf noctets 4) t) + (t #+little-endian-target t))))) + + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (if swap + (%reversed-u8-ref-u32 vector index) + (%native-u8-ref-u32 vector index)))) + (declare (type (unsigned-byte 32) 1st-unit)) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character))))))) + :memory-encode-function + (nfunction + utf-32-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (setf (%get-unsigned-long pointer idx) byte-order-mark-char-code) + (incf idx 4) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-long pointer idx) code) + (incf idx 4))))) + :memory-decode-function + (nfunction + utf-32-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (let* ((swap (when (> noctets 3) + (case (%get-unsigned-long pointer idx) + (#.byte-order-mark-char-code + (incf idx 4) + (decf noctets 4) + nil) + (#.swapped-byte-order-mark-char-code + (incf idx 4) + (decf noctets 4) + t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-long pointer index))) + (declare (type (unsigned-byte 32) 1st-unit)) + (if swap (setq 1st-unit (%swap-u32 1st-unit))) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character))))))) + :octets-in-string-function + (nfunction + utf-32-bom-octets-in-string + (lambda (string start end) + (+ 4 (ucs-4-octets-in-string string start end)))) + :length-of-vector-encoding-function + (nfunction + utf-32-length-of-vector-encoding + (lambda (vector start end) + (when (>= end (+ start 4)) + (let* ((maybe-bom (%native-u8-ref-u32 vector start))) + (declare (type (unsigned-byte 32) maybe-bom)) + (when (or (= maybe-bom byte-order-mark-char-code) + (= maybe-bom swapped-byte-order-mark-char-code)) + (incf start 4)))) + (do* ((i start j) + (j (+ i 4) (+ J 4)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + utf-32-length-of-memory-encoding + (lambda (pointer noctets start) + (when (> noctets 3) + (case (%get-unsigned-long pointer ) + (#.byte-order-mark-char-code + (incf start 4) + (decf noctets 4)) + (#.swapped-byte-order-mark-char-code + (incf start 4) + (decf noctets 4)))) + (values (ash noctets -2) (+ start (logandc2 noctets 3))))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :use-byte-order-mark + #+big-endian-target :utf-32le + #+little-endian-target :utf-32be + :bom-encoding #+big-endian-target #(#x00 #x00 #xfe #xff) #+little-endian-target #(#xff #xfe #x00 #x00) + :nul-encoding #(0 0 0 0) + :character-size-in-octets-function 'four-octets-per-character + ) + +(defun describe-character-encoding (name) + (let* ((enc (lookup-character-encoding name))) + (when enc + (let* ((name (character-encoding-name enc)) + (doc (character-encoding-documentation enc)) + (aliases (character-encoding-aliases enc))) + (format t "~&~s" name) + (when (null (car aliases)) + (pop aliases)) + (when aliases + (format t " [Aliases:~{ ~s~}]" aliases)) + (format t "~&~a~%~%" doc) + (values))))) + +(defun describe-character-encodings () + (let* ((names nil)) + (maphash #'(lambda (name enc) + (when (eq name (character-encoding-name enc)) + (push name names))) + *character-encodings*) + (dolist (name (sort names #'string<) (values)) + (describe-character-encoding name)))) + +(defmethod make-load-form ((c character-encoding) &optional environment) + (declare (ignore environment)) + `(get-character-encoding ,(character-encoding-name c))) + +(defvar *native-newline-string* (make-string 1 :initial-element #\Newline)) +(defvar *unicode-newline-string* (make-string 1 :initial-element #\Line_Separator)) +(defvar *cr-newline-string* (make-string 1 :initial-element #\Return)) +(defvar *crlf-newline-string* (make-array 2 :element-type 'character :initial-contents '(#\Return #\Linefeed))) +(defvar *nul-string* (make-string 1 :initial-element #\Nul)) + +(defun string-size-in-octets (string &key + (start 0) + end + external-format + use-byte-order-mark) + (setq end (check-sequence-bounds string start end)) + (let* ((ef (normalize-external-format t external-format))) + (%string-size-in-octets string + start + end + (get-character-encoding + (external-format-character-encoding ef)) + (cdr (assoc (external-format-line-termination ef) + *canonical-line-termination-conventions*)) + use-byte-order-mark))) + + +(defun %string-size-in-octets (string start end encoding line-termination use-byte-order-mark) + (declare (fixnum start end)) + (multiple-value-bind (simple-string offset) + (array-data-and-offset string) + (declare (fixnum offset) (simple-string simple-string)) + (incf start offset) + (incf end offset) + (let* ((n (if use-byte-order-mark + (length (character-encoding-bom-encoding encoding)) + 0)) + (f (character-encoding-octets-in-string-function encoding)) + (nlpos (if line-termination + (position #\Newline simple-string :start start :end end)))) + (if (not nlpos) + (+ n (funcall f simple-string start end)) + (let* ((nlstring (case line-termination + (:cr *cr-newline-string*) + (:crlf *crlf-newline-string*) + (:unicode *unicode-newline-string*))) + (nlstring-length (if (eq line-termination :crlf) 2 1))) + (do* () + ((null nlpos) (+ n (funcall f simple-string start end))) + (unless (eql nlpos start) + (incf n (funcall f simple-string start nlpos))) + (incf n (funcall f nlstring 0 nlstring-length)) + (setq start (1+ nlpos) + nlpos (position #\Newline simple-string :start start :end end)))))))) + +(defun encode-string-to-octets (string &key + (start 0) + end + external-format + use-byte-order-mark + (vector nil vector-p) + (vector-offset 0)) + (setq end (check-sequence-bounds string start end)) + (let* ((ef (normalize-external-format t external-format)) + (encoding (get-character-encoding + (external-format-character-encoding ef))) + (line-termination (cdr (assoc (external-format-line-termination ef) + *canonical-line-termination-conventions*))) + (n (%string-size-in-octets string start end encoding line-termination use-byte-order-mark))) + (declare (fixnum start end n)) + (unless (and (typep vector-offset 'fixnum) + (or (not vector-p) + (< vector-offset (length vector)))) + (error "Invalid vector offset ~s" vector-offset)) + (if (not vector-p) + (setq vector (make-array (+ n vector-offset) + :element-type '(unsigned-byte 8))) + (progn + (unless (= (typecode vector) target::subtag-u8-vector) + (report-bad-arg vector '(simple-array (unsigned-byte 8) (*)))) + (unless (>= (length vector) (+ vector-offset n)) + (error "Can't encode ~s into supplied vector ~s; ~&~d octets are needed, but only ~d are available" string vector n (- (length vector) vector-offset))))) + (when use-byte-order-mark + (let* ((bom (character-encoding-bom-encoding encoding))) + (dotimes (i (length bom)) + (setf (aref vector vector-offset) + (aref bom i)) + (incf vector-offset)))) + (multiple-value-bind (simple-string offset) (array-data-and-offset string) + (incf start offset) + (incf end offset) + (let* ((f (character-encoding-vector-encode-function encoding)) + (nlpos (if line-termination + (position #\Newline simple-string :start start :end end)))) + (if (null nlpos) + (setq vector-offset + (funcall f simple-string vector vector-offset start end)) + (let* ((nlstring (case line-termination + (:cr *cr-newline-string*) + (:crlf *crlf-newline-string*) + (:unicode *unicode-newline-string*))) + (nlstring-length (if (eq line-termination :crlf) 2 1))) + (do* () + ((null nlpos) + (setq vector-offset + (funcall f simple-string vector vector-offset start end))) + (unless (eql nlpos start) + (setq vector-offset (funcall f simple-string vector vector-offset start nlpos))) + (setq vector-offset (funcall f nlstring vector vector-offset 0 nlstring-length)) + (setq start (1+ nlpos) + nlpos (position #\Newline simple-string :start start :end end))))) + (values vector vector-offset))))) + + + +(defun count-characters-in-octet-vector (vector &key + (start 0) + end + external-format) + (setq end (check-sequence-bounds vector start end)) + (%count-characters-in-octet-vector + vector + start + end + (get-character-encoding (external-format-character-encoding (normalize-external-format t external-format))))) + +(defun %count-characters-in-octet-vector (vector start end encoding) + (unless (= (typecode vector) target::subtag-u8-vector) + (report-bad-arg vector '(simple-array (unsigned-byte 8) (*)))) + (funcall (character-encoding-length-of-vector-encoding-function encoding) + vector + start + end)) + + +(defun decode-string-from-octets (vector &key + (start 0) + end + external-format + (string nil string-p)) + (setq end (check-sequence-bounds vector start end)) + (unless (= (typecode vector) target::subtag-u8-vector) + (multiple-value-bind (array offset) + (array-data-and-offset vector) + (unless (= (typecode array) target::subtag-u8-vector) + (report-bad-arg vector '(array (unsgigned-byte 8) (*)))) + (setq vector array + start (+ start offset) + end (+ end offset)))) + (let* ((encoding (get-character-encoding + (external-format-character-encoding + (normalize-external-format t external-format))))) + (multiple-value-bind (nchars last-octet) + (%count-characters-in-octet-vector vector start end encoding) + (if (not string-p) + (setq string (make-string nchars)) + (progn + (unless (= (typecode string) target::subtag-simple-base-string) + (report-bad-arg string 'simple-string)) + (unless (>= (length string) nchars) + (error "String ~s is too small; ~d characters are needed." + string nchars)))) + (funcall (character-encoding-vector-decode-function encoding) + vector + start + (- last-octet start) + string) + (values string last-octet)))) + + +(defun string-encoded-length-in-bytes (encoding string start end) + (if (typep string 'simple-base-string) + (funcall (character-encoding-octets-in-string-function encoding) + string + (or start 0) + (or end (length string))) + (let* ((s (string string))) + (multiple-value-bind (data offset) (array-data-and-offset s) + (funcall (character-encoding-octets-in-string-function encoding) + data + (+ offset (or start 0)) + (+ offset (or end (length s)))))))) + +;;; Same as above, but add the length of a trailing 0 code-unit. +(defun cstring-encoded-length-in-bytes (encoding string start end) + (+ (ash (character-encoding-code-unit-size encoding) -3) ; NUL terminator + (string-encoded-length-in-bytes encoding string start end))) + + + +(defun encode-string-to-memory (encoding pointer offset string start end) + (if (typep string 'simple-base-string) + (funcall (character-encoding-memory-encode-function encoding) + string pointer offset (or start 0) (or end (length string))) + (let* ((s (string string))) + (multiple-value-bind (data data-offset) + (array-data-and-offset s) + (funcall (character-encoding-memory-encode-function encoding) + data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s)))))))) + +(defun get-encoded-string (encoding-name pointer noctets) + (let* ((encoding (ensure-character-encoding encoding-name))) + (multiple-value-bind (nchars nused) + (funcall (character-encoding-length-of-memory-encoding-function encoding) + pointer + noctets + 0) + (let* ((string (make-string nchars))) + (funcall (character-encoding-memory-decode-function encoding) + pointer + nused + 0 + string) + string)))) + + +(defun get-encoded-cstring (encoding-name pointer) + (let* ((encoding (ensure-character-encoding encoding-name))) + (get-encoded-string + encoding + pointer + (ecase (character-encoding-code-unit-size encoding) + (8 (%cstrlen pointer)) + (16 (do* ((i 0 (+ i 2))) + ((= 0 (%get-unsigned-word pointer i)) + (return i)) + (declare (fixnum i)))) + (32 (do* ((i 0 (+ i 4))) + ((= 0 (%get-unsigned-long pointer i)) + (return i)) + (declare (fixnum i)))))))) + + + + + + + +;;; This is an array of 256 integers, that (sparsely) encodes 64K bits. +;;; (There might be as many as 256 significant bits in some of entries +;;; in this table.) +(defstatic *bmp-combining-bitmap* + #( + #x00 + #x00 + #x00 + #xFFFF0000FFFFFFFFFFFFFFFFFFFF + #x37800000000000000000000000000000000 + #x16BBFFFFFBFFFE000000000000000000000000000000000000 + #x3D9FFFC00000000000000000000000010000003FF8000000000000000000 + #x1FFC00000000000000000000007FFFFFF000000020000 + + #x00 + #xC0080399FD00000000000000E0000000C001E3FFFD00000000000000E + #x3BBFD00000000000000E0003000000003987D000000000000004 + #x803DC7C0000000000000040000000000C0398FD00000000000000E + #x603DDFC00000000000000C0000000000603DDFC00000000000000E + #xC0000FF5F8400000000000000000C0000000000803DCFC00000000000000C + #x3F001BF20000000000000000000000007F8007F2000000000000 + #x401FFFFFFFFEFF00DFFFFE000000000000C2A0000003000000 + + #x3C0000003C7F00000000000 + #x7FFFFFF0000000000003FFFFE000000000000000000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #xFFFFFFFF0000000000000000C0000000C0000001C0000001C0000 + + #x2000000000000000000000000000000000000003800 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x7FFFFFF0000000000000000000000000000000000000000000000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x600000000000000000000000000FC0000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x40000000 + #x00 + #x00 + #xF0000FFFF + #x00)) + +(defun is-combinable (char) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (when (< code #x1000) + (logbitp (ldb (byte 8 0) code) + (svref *bmp-combining-bitmap* (ldb (byte 8 8) code)))))) + +(defstatic *bmp-combining-chars* + #(#\Combining_Grave_Accent + #\Combining_Acute_Accent + #\Combining_Circumflex_Accent + #\Combining_Tilde + #\Combining_Macron + #\Combining_Breve + #\Combining_Dot_Above + #\Combining_Diaeresis + #\Combining_Hook_Above + #\Combining_Ring_Above + #\Combining_Double_Acute_Accent + #\Combining_Caron + #\Combining_Double_Grave_Accent + #\Combining_Inverted_Breve + #\Combining_Comma_Above + #\Combining_Reversed_Comma_Above + #\Combining_Horn + #\Combining_Dot_Below + #\Combining_Diaeresis_Below + #\Combining_Ring_Below + #\Combining_Comma_Below + #\Combining_Cedilla + #\Combining_Ogonek + #\Combining_Circumflex_Accent_Below + #\Combining_Breve_Below + #\Combining_Tilde_Below + #\Combining_Macron_Below + #\Combining_Long_Solidus_Overlay + #\Combining_Greek_Perispomeni + #\Combining_Greek_Ypogegrammeni + #\Arabic_Maddah_Above + #\Arabic_Hamza_Above + #\Arabic_Hamza_Below + #\U+093C + #\U+09BE + #\U+09D7 + #\U+0B3E + #\U+0B56 + #\U+0B57 + #\U+0BBE + #\U+0BD7 + #\U+0C56 + #\U+0CC2 + #\U+0CD5 + #\U+0CD6 + #\U+0D3E + #\U+0D57 + #\U+0DCA + #\U+0DCF + #\U+0DDF + #\U+102E + #\U+3099 + #\U+309A)) + +(defstatic *bmp-combining-base-chars* + #( + ;; #\Combining_Grave_Accent + + #(#\A #\E #\I #\N #\O #\U #\W #\Y #\a #\e #\i #\n #\o #\u #\w #\y + #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Macron + #\Latin_Small_Letter_E_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_I + #\Cyrillic_Small_Letter_Ie #\Cyrillic_Small_Letter_I #\U+1F00 #\U+1F01 + #\U+1F08 #\U+1F09 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 + #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 + #\U+1F40 #\U+1F41 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 + #\U+1F60 #\U+1F61 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Acute_Accent + + #(#\A #\C #\E #\G #\I #\K #\L #\M #\N #\O #\P #\R #\S #\U #\W #\Y #\Z + #\a #\c #\e #\g #\i #\k #\l #\m #\n #\o #\p #\r #\s #\u #\w #\y #\z + #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_A_With_Ring_Above #\Latin_Capital_Letter_Ae + #\Latin_Capital_Letter_C_With_Cedilla + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_I_With_Diaeresis + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_O_With_Stroke + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_A_With_Ring_Above #\Latin_Small_Letter_Ae + #\Latin_Small_Letter_C_With_Cedilla + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_I_With_Diaeresis + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_O_With_Stroke + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Macron + #\Latin_Small_Letter_E_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_U_With_Tilde + #\Latin_Small_Letter_U_With_Tilde #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Greek_Upsilon_With_Hook_Symbol #\Cyrillic_Capital_Letter_Ghe + #\Cyrillic_Capital_Letter_Ka #\Cyrillic_Small_Letter_Ghe + #\Cyrillic_Small_Letter_Ka #\U+1F00 #\U+1F01 #\U+1F08 #\U+1F09 + #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 #\U+1F21 #\U+1F28 + #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 #\U+1F40 #\U+1F41 + #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 + #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Circumflex_Accent + + #(#\A #\C #\E #\G #\H #\I #\J #\O #\S #\U #\W #\Y #\Z #\a #\c #\e #\g + #\h #\i #\j #\o #\s #\u #\w #\y #\z #\U+1EA0 #\U+1EA1 #\U+1EB8 + #\U+1EB9 #\U+1ECC #\U+1ECD) + + + ;; #\Combining_Tilde + + #(#\A #\E #\I #\N #\O #\U #\V #\Y #\a #\e #\i #\n #\o #\u #\v #\y + #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Macron + + #(#\A #\E #\G #\I #\O #\U #\Y #\a #\e #\g #\i #\o #\u #\y + #\Latin_Capital_Letter_A_With_Diaeresis #\Latin_Capital_Letter_Ae + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_O_With_Diaeresis + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Diaeresis #\Latin_Small_Letter_Ae + #\Latin_Small_Letter_O_With_Tilde + #\Latin_Small_Letter_O_With_Diaeresis + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_O_With_Ogonek + #\Latin_Small_Letter_O_With_Ogonek + #\Latin_Capital_Letter_A_With_Dot_Above + #\Latin_Small_Letter_A_With_Dot_Above + #\Latin_Capital_Letter_O_With_Dot_Above + #\Latin_Small_Letter_O_With_Dot_Above #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_I + #\Cyrillic_Capital_Letter_U #\Cyrillic_Small_Letter_I + #\Cyrillic_Small_Letter_U #\U+1E36 #\U+1E37 #\U+1E5A #\U+1E5B) + + + ;; #\Combining_Breve + + #(#\A #\E #\G #\I #\O #\U #\a #\e #\g #\i #\o #\u + #\Latin_Capital_Letter_E_With_Cedilla + #\Latin_Small_Letter_E_With_Cedilla #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_A + #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_Zhe + #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_U + #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie + #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_I + #\Cyrillic_Small_Letter_U #\U+1EA0 #\U+1EA1) + + + ;; #\Combining_Dot_Above + + #(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\M #\N #\O #\P #\R #\S #\T #\W + #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\m #\n #\o #\p #\r #\s + #\t #\w #\x #\y #\z #\Latin_Capital_Letter_S_With_Acute + #\Latin_Small_Letter_S_With_Acute #\Latin_Capital_Letter_S_With_Caron + #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_Long_S #\U+1E62 + #\U+1E63) + + + ;; #\Combining_Diaeresis + + #(#\A #\E #\H #\I #\O #\U #\W #\X #\Y #\a #\e #\h #\i #\o #\t #\u #\w + #\x #\y #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Small_Letter_O_With_Tilde #\Latin_Capital_Letter_U_With_Macron + #\Latin_Small_Letter_U_With_Macron #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Upsilon #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Greek_Upsilon_With_Hook_Symbol + #\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I + #\Cyrillic_Capital_Letter_A #\Cyrillic_Capital_Letter_Ie + #\Cyrillic_Capital_Letter_Zhe #\Cyrillic_Capital_Letter_Ze + #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_O + #\Cyrillic_Capital_Letter_U #\Cyrillic_Capital_Letter_Che + #\Cyrillic_Capital_Letter_Yeru #\Cyrillic_Capital_Letter_E + #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie + #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_Ze + #\Cyrillic_Small_Letter_I #\Cyrillic_Small_Letter_O + #\Cyrillic_Small_Letter_U #\Cyrillic_Small_Letter_Che + #\Cyrillic_Small_Letter_Yeru #\Cyrillic_Small_Letter_E + #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I + #\Cyrillic_Capital_Letter_Schwa #\Cyrillic_Small_Letter_Schwa + #\Cyrillic_Capital_Letter_Barred_O #\Cyrillic_Small_Letter_Barred_O) + + + ;; #\Combining_Hook_Above + + #(#\A #\E #\I #\O #\U #\Y #\a #\e #\i #\o #\u #\y + #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Ring_Above + + #(#\A #\U #\a #\u #\w #\y) + + + ;; #\Combining_Double_Acute_Accent + + #(#\O #\U #\o #\u #\Cyrillic_Capital_Letter_U + #\Cyrillic_Small_Letter_U) + + + ;; #\Combining_Caron + + #(#\A #\C #\D #\E #\G #\H #\I #\K #\L #\N #\O #\R #\S #\T #\U #\Z #\a + #\c #\d #\e #\g #\h #\i #\j #\k #\l #\n #\o #\r #\s #\t #\u #\z + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_U_With_Diaeresis #\Latin_Capital_Letter_Ezh + #\Latin_Small_Letter_Ezh) + + + ;; #\Combining_Double_Grave_Accent + + #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u + #\Cyrillic_Capital_Letter_Izhitsa #\Cyrillic_Small_Letter_Izhitsa) + + + ;; #\Combining_Inverted_Breve + + #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u) + + + ;; #\Combining_Comma_Above + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon + #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho + #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) + + + ;; #\Combining_Reversed_Comma_Above + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon + #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Rho + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho + #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) + + + ;; #\Combining_Horn + + #(#\O #\U #\o #\u) + + + ;; #\Combining_Dot_Below + + #(#\A #\B #\D #\E #\H #\I #\K #\L #\M #\N #\O #\R #\S #\T #\U #\V #\W + #\Y #\Z #\a #\b #\d #\e #\h #\i #\k #\l #\m #\n #\o #\r #\s #\t #\u + #\v #\w #\y #\z #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Diaeresis_Below + + #(#\U #\u) + + + ;; #\Combining_Ring_Below + + #(#\A #\a) + + + ;; #\Combining_Comma_Below + + #(#\S #\T #\s #\t) + + + ;; #\Combining_Cedilla + + #(#\C #\D #\E #\G #\H #\K #\L #\N #\R #\S #\T #\c #\d #\e #\g #\h #\k + #\l #\n #\r #\s #\t) + + + ;; #\Combining_Ogonek + + #(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u) + + + ;; #\Combining_Circumflex_Accent_Below + + #(#\D #\E #\L #\N #\T #\U #\d #\e #\l #\n #\t #\u) + + + ;; #\Combining_Breve_Below + + #(#\H #\h) + + + ;; #\Combining_Tilde_Below + + #(#\E #\I #\U #\e #\i #\u) + + + ;; #\Combining_Macron_Below + + #(#\B #\D #\K #\L #\N #\R #\T #\Z #\b #\d #\h #\k #\l #\n #\r #\t #\z) + + + ;; #\Combining_Long_Solidus_Overlay + + #(#\< #\= #\> #\U+2190 #\U+2192 #\U+2194 #\U+21D0 #\U+21D2 #\U+21D4 + #\U+2203 #\U+2208 #\U+220B #\U+2223 #\U+2225 #\U+223C #\U+2243 + #\U+2245 #\U+2248 #\U+224D #\U+2261 #\U+2264 #\U+2265 #\U+2272 + #\U+2273 #\U+2276 #\U+2277 #\U+227A #\U+227B #\U+227C #\U+227D + #\U+2282 #\U+2283 #\U+2286 #\U+2287 #\U+2291 #\U+2292 #\U+22A2 + #\U+22A8 #\U+22A9 #\U+22AB #\U+22B2 #\U+22B3 #\U+22B4 #\U+22B5) + + + ;; #\Combining_Greek_Perispomeni + + #(#\Diaeresis #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Eta + #\Greek_Small_Letter_Iota #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika #\U+1F00 #\U+1F01 #\U+1F08 + #\U+1F09 #\U+1F20 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 + #\U+1F38 #\U+1F39 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 + #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Greek_Ypogegrammeni + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Omega #\Greek_Small_Letter_Alpha_With_Tonos + #\Greek_Small_Letter_Eta_With_Tonos #\Greek_Small_Letter_Alpha + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Omega + #\Greek_Small_Letter_Omega_With_Tonos #\U+1F00 #\U+1F01 #\U+1F02 + #\U+1F03 #\U+1F04 #\U+1F05 #\U+1F06 #\U+1F07 #\U+1F08 #\U+1F09 + #\U+1F0A #\U+1F0B #\U+1F0C #\U+1F0D #\U+1F0E #\U+1F0F #\U+1F20 + #\U+1F21 #\U+1F22 #\U+1F23 #\U+1F24 #\U+1F25 #\U+1F26 #\U+1F27 + #\U+1F28 #\U+1F29 #\U+1F2A #\U+1F2B #\U+1F2C #\U+1F2D #\U+1F2E + #\U+1F2F #\U+1F60 #\U+1F61 #\U+1F62 #\U+1F63 #\U+1F64 #\U+1F65 + #\U+1F66 #\U+1F67 #\U+1F68 #\U+1F69 #\U+1F6A #\U+1F6B #\U+1F6C + #\U+1F6D #\U+1F6E #\U+1F6F #\U+1F70 #\U+1F74 #\U+1F7C #\U+1FB6 + #\U+1FC6 #\U+1FF6) + + + ;; #\Arabic_Maddah_Above + + #(#\Arabic_Letter_Alef) + + + ;; #\Arabic_Hamza_Above + + #(#\Arabic_Letter_Alef #\Arabic_Letter_Waw #\Arabic_Letter_Yeh + #\Arabic_Letter_Heh_Goal #\Arabic_Letter_Yeh_Barree + #\Arabic_Letter_Ae) + + + ;; #\Arabic_Hamza_Below + + #(#\Arabic_Letter_Alef) + + + ;; #\U+093C + + #(#\U+0928 #\U+0930 #\U+0933) + + + ;; #\U+09BE + + #(#\U+09C7) + + + ;; #\U+09D7 + + #(#\U+09C7) + + + ;; #\U+0B3E + + #(#\U+0B47) + + + ;; #\U+0B56 + + #(#\U+0B47) + + + ;; #\U+0B57 + + #(#\U+0B47) + + + ;; #\U+0BBE + + #(#\U+0BC6 #\U+0BC7) + + + ;; #\U+0BD7 + + #(#\U+0B92 #\U+0BC6) + + + ;; #\U+0C56 + + #(#\U+0C46) + + + ;; #\U+0CC2 + + #(#\U+0CC6) + + + ;; #\U+0CD5 + + #(#\U+0CBF #\U+0CC6 #\U+0CCA) + + + ;; #\U+0CD6 + + #(#\U+0CC6) + + + ;; #\U+0D3E + + #(#\U+0D46 #\U+0D47) + + + ;; #\U+0D57 + + #(#\U+0D46) + + + ;; #\U+0DCA + + #(#\U+0DD9 #\U+0DDC) + + + ;; #\U+0DCF + + #(#\U+0DD9) + + + ;; #\U+0DDF + + #(#\U+0DD9) + + + ;; #\U+102E + + #(#\U+1025) + + + ;; #\U+3099 + + #(#\U+3046 #\U+304B #\U+304D #\U+304F #\U+3051 #\U+3053 #\U+3055 + #\U+3057 #\U+3059 #\U+305B #\U+305D #\U+305F #\U+3061 #\U+3064 + #\U+3066 #\U+3068 #\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B + #\U+309D #\U+30A6 #\U+30AB #\U+30AD #\U+30AF #\U+30B1 #\U+30B3 + #\U+30B5 #\U+30B7 #\U+30B9 #\U+30BB #\U+30BD #\U+30BF #\U+30C1 + #\U+30C4 #\U+30C6 #\U+30C8 #\U+30CF #\U+30D2 #\U+30D5 #\U+30D8 + #\U+30DB #\U+30EF #\U+30F0 #\U+30F1 #\U+30F2 #\U+30FD) + + + ;; #\U+309A + + #(#\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B #\U+30CF #\U+30D2 + #\U+30D5 #\U+30D8 #\U+30DB) + )) + +(defstatic *bmp-precombined-chars* + #( + + ;; #\Combining_Grave_Accent + + #(#\Latin_Capital_Letter_A_With_Grave + #\Latin_Capital_Letter_E_With_Grave + #\Latin_Capital_Letter_I_With_Grave + #\Latin_Capital_Letter_N_With_Grave + #\Latin_Capital_Letter_O_With_Grave + #\Latin_Capital_Letter_U_With_Grave #\U+1E80 #\U+1EF2 + #\Latin_Small_Letter_A_With_Grave #\Latin_Small_Letter_E_With_Grave + #\Latin_Small_Letter_I_With_Grave #\Latin_Small_Letter_N_With_Grave + #\Latin_Small_Letter_O_With_Grave #\Latin_Small_Letter_U_With_Grave + #\U+1E81 #\U+1EF3 #\U+1FED #\U+1EA6 #\U+1EC0 #\U+1ED2 + #\Latin_Capital_Letter_U_With_Diaeresis_And_Grave #\U+1EA7 #\U+1EC1 + #\U+1ED3 #\Latin_Small_Letter_U_With_Diaeresis_And_Grave #\U+1EB0 + #\U+1EB1 #\U+1E14 #\U+1E15 #\U+1E50 #\U+1E51 #\U+1EDC #\U+1EDD + #\U+1EEA #\U+1EEB #\U+1FBA #\U+1FC8 #\U+1FCA #\U+1FDA #\U+1FF8 + #\U+1FEA #\U+1FFA #\U+1F70 #\U+1F72 #\U+1F74 #\U+1F76 #\U+1F78 + #\U+1F7A #\U+1F7C #\U+1FD2 #\U+1FE2 + #\Cyrillic_Capital_Letter_Ie_With_Grave + #\Cyrillic_Capital_Letter_I_With_Grave + #\Cyrillic_Small_Letter_Ie_With_Grave + #\Cyrillic_Small_Letter_I_With_Grave #\U+1F02 #\U+1F03 #\U+1F0A + #\U+1F0B #\U+1F12 #\U+1F13 #\U+1F1A #\U+1F1B #\U+1F22 #\U+1F23 + #\U+1F2A #\U+1F2B #\U+1F32 #\U+1F33 #\U+1F3A #\U+1F3B #\U+1F42 + #\U+1F43 #\U+1F4A #\U+1F4B #\U+1F52 #\U+1F53 #\U+1F5B #\U+1F62 + #\U+1F63 #\U+1F6A #\U+1F6B #\U+1FCD #\U+1FDD) + + + ;; #\Combining_Acute_Accent + + #(#\Latin_Capital_Letter_A_With_Acute + #\Latin_Capital_Letter_C_With_Acute + #\Latin_Capital_Letter_E_With_Acute + #\Latin_Capital_Letter_G_With_Acute + #\Latin_Capital_Letter_I_With_Acute #\U+1E30 + #\Latin_Capital_Letter_L_With_Acute #\U+1E3E + #\Latin_Capital_Letter_N_With_Acute + #\Latin_Capital_Letter_O_With_Acute #\U+1E54 + #\Latin_Capital_Letter_R_With_Acute + #\Latin_Capital_Letter_S_With_Acute + #\Latin_Capital_Letter_U_With_Acute #\U+1E82 + #\Latin_Capital_Letter_Y_With_Acute + #\Latin_Capital_Letter_Z_With_Acute #\Latin_Small_Letter_A_With_Acute + #\Latin_Small_Letter_C_With_Acute #\Latin_Small_Letter_E_With_Acute + #\Latin_Small_Letter_G_With_Acute #\Latin_Small_Letter_I_With_Acute + #\U+1E31 #\Latin_Small_Letter_L_With_Acute #\U+1E3F + #\Latin_Small_Letter_N_With_Acute #\Latin_Small_Letter_O_With_Acute + #\U+1E55 #\Latin_Small_Letter_R_With_Acute + #\Latin_Small_Letter_S_With_Acute #\Latin_Small_Letter_U_With_Acute + #\U+1E83 #\Latin_Small_Letter_Y_With_Acute + #\Latin_Small_Letter_Z_With_Acute #\Greek_Dialytika_Tonos #\U+1EA4 + #\Latin_Capital_Letter_A_With_Ring_Above_And_Acute + #\Latin_Capital_Letter_Ae_With_Acute #\U+1E08 #\U+1EBE #\U+1E2E + #\U+1ED0 #\U+1E4C #\Latin_Capital_Letter_O_With_Stroke_And_Acute + #\Latin_Capital_Letter_U_With_Diaeresis_And_Acute #\U+1EA5 + #\Latin_Small_Letter_A_With_Ring_Above_And_Acute + #\Latin_Small_Letter_Ae_With_Acute #\U+1E09 #\U+1EBF #\U+1E2F #\U+1ED1 + #\U+1E4D #\Latin_Small_Letter_O_With_Stroke_And_Acute + #\Latin_Small_Letter_U_With_Diaeresis_And_Acute #\U+1EAE #\U+1EAF + #\U+1E16 #\U+1E17 #\U+1E52 #\U+1E53 #\U+1E78 #\U+1E79 #\U+1EDA + #\U+1EDB #\U+1EE8 #\U+1EE9 #\Greek_Capital_Letter_Alpha_With_Tonos + #\Greek_Capital_Letter_Epsilon_With_Tonos + #\Greek_Capital_Letter_Eta_With_Tonos + #\Greek_Capital_Letter_Iota_With_Tonos + #\Greek_Capital_Letter_Omicron_With_Tonos + #\Greek_Capital_Letter_Upsilon_With_Tonos + #\Greek_Capital_Letter_Omega_With_Tonos + #\Greek_Small_Letter_Alpha_With_Tonos + #\Greek_Small_Letter_Epsilon_With_Tonos + #\Greek_Small_Letter_Eta_With_Tonos + #\Greek_Small_Letter_Iota_With_Tonos + #\Greek_Small_Letter_Omicron_With_Tonos + #\Greek_Small_Letter_Upsilon_With_Tonos + #\Greek_Small_Letter_Omega_With_Tonos + #\Greek_Small_Letter_Iota_With_Dialytika_And_Tonos + #\Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos + #\Greek_Upsilon_With_Acute_And_Hook_Symbol + #\Cyrillic_Capital_Letter_Gje #\Cyrillic_Capital_Letter_Kje + #\Cyrillic_Small_Letter_Gje #\Cyrillic_Small_Letter_Kje #\U+1F04 + #\U+1F05 #\U+1F0C #\U+1F0D #\U+1F14 #\U+1F15 #\U+1F1C #\U+1F1D + #\U+1F24 #\U+1F25 #\U+1F2C #\U+1F2D #\U+1F34 #\U+1F35 #\U+1F3C + #\U+1F3D #\U+1F44 #\U+1F45 #\U+1F4C #\U+1F4D #\U+1F54 #\U+1F55 + #\U+1F5D #\U+1F64 #\U+1F65 #\U+1F6C #\U+1F6D #\U+1FCE #\U+1FDE) + + + ;; #\Combining_Circumflex_Accent + + #(#\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_C_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_G_With_Circumflex + #\Latin_Capital_Letter_H_With_Circumflex + #\Latin_Capital_Letter_I_With_Circumflex + #\Latin_Capital_Letter_J_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_S_With_Circumflex + #\Latin_Capital_Letter_U_With_Circumflex + #\Latin_Capital_Letter_W_With_Circumflex + #\Latin_Capital_Letter_Y_With_Circumflex #\U+1E90 + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_C_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_G_With_Circumflex + #\Latin_Small_Letter_H_With_Circumflex + #\Latin_Small_Letter_I_With_Circumflex + #\Latin_Small_Letter_J_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_S_With_Circumflex + #\Latin_Small_Letter_U_With_Circumflex + #\Latin_Small_Letter_W_With_Circumflex + #\Latin_Small_Letter_Y_With_Circumflex #\U+1E91 #\U+1EAC #\U+1EAD + #\U+1EC6 #\U+1EC7 #\U+1ED8 #\U+1ED9) + + + ;; #\Combining_Tilde + + #(#\Latin_Capital_Letter_A_With_Tilde #\U+1EBC + #\Latin_Capital_Letter_I_With_Tilde + #\Latin_Capital_Letter_N_With_Tilde + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_U_With_Tilde #\U+1E7C #\U+1EF8 + #\Latin_Small_Letter_A_With_Tilde #\U+1EBD + #\Latin_Small_Letter_I_With_Tilde #\Latin_Small_Letter_N_With_Tilde + #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_U_With_Tilde + #\U+1E7D #\U+1EF9 #\U+1EAA #\U+1EC4 #\U+1ED6 #\U+1EAB #\U+1EC5 + #\U+1ED7 #\U+1EB4 #\U+1EB5 #\U+1EE0 #\U+1EE1 #\U+1EEE #\U+1EEF) + + + ;; #\Combining_Macron + + #(#\Latin_Capital_Letter_A_With_Macron + #\Latin_Capital_Letter_E_With_Macron #\U+1E20 + #\Latin_Capital_Letter_I_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Capital_Letter_U_With_Macron + #\Latin_Capital_Letter_Y_With_Macron + #\Latin_Small_Letter_A_With_Macron #\Latin_Small_Letter_E_With_Macron + #\U+1E21 #\Latin_Small_Letter_I_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Small_Letter_U_With_Macron + #\Latin_Small_Letter_Y_With_Macron + #\Latin_Capital_Letter_A_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_Ae_With_Macron + #\Latin_Capital_Letter_O_With_Tilde_And_Macron + #\Latin_Capital_Letter_O_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_U_With_Diaeresis_And_Macron + #\Latin_Small_Letter_A_With_Diaeresis_And_Macron + #\Latin_Small_Letter_Ae_With_Macron + #\Latin_Small_Letter_O_With_Tilde_And_Macron + #\Latin_Small_Letter_O_With_Diaeresis_And_Macron + #\Latin_Small_Letter_U_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_O_With_Ogonek_And_Macron + #\Latin_Small_Letter_O_With_Ogonek_And_Macron + #\Latin_Capital_Letter_A_With_Dot_Above_And_Macron + #\Latin_Small_Letter_A_With_Dot_Above_And_Macron + #\Latin_Capital_Letter_O_With_Dot_Above_And_Macron + #\Latin_Small_Letter_O_With_Dot_Above_And_Macron #\U+1FB9 #\U+1FD9 + #\U+1FE9 #\U+1FB1 #\U+1FD1 #\U+1FE1 + #\Cyrillic_Capital_Letter_I_With_Macron + #\Cyrillic_Capital_Letter_U_With_Macron + #\Cyrillic_Small_Letter_I_With_Macron + #\Cyrillic_Small_Letter_U_With_Macron #\U+1E38 #\U+1E39 #\U+1E5C + #\U+1E5D) + + + ;; #\Combining_Breve + + #(#\Latin_Capital_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Breve + #\Latin_Capital_Letter_G_With_Breve + #\Latin_Capital_Letter_I_With_Breve + #\Latin_Capital_Letter_O_With_Breve + #\Latin_Capital_Letter_U_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Small_Letter_E_With_Breve #\Latin_Small_Letter_G_With_Breve + #\Latin_Small_Letter_I_With_Breve #\Latin_Small_Letter_O_With_Breve + #\Latin_Small_Letter_U_With_Breve #\U+1E1C #\U+1E1D #\U+1FB8 #\U+1FD8 + #\U+1FE8 #\U+1FB0 #\U+1FD0 #\U+1FE0 + #\Cyrillic_Capital_Letter_A_With_Breve + #\Cyrillic_Capital_Letter_Ie_With_Breve + #\Cyrillic_Capital_Letter_Zhe_With_Breve + #\Cyrillic_Capital_Letter_Short_I #\Cyrillic_Capital_Letter_Short_U + #\Cyrillic_Small_Letter_A_With_Breve + #\Cyrillic_Small_Letter_Ie_With_Breve + #\Cyrillic_Small_Letter_Zhe_With_Breve #\Cyrillic_Small_Letter_Short_I + #\Cyrillic_Small_Letter_Short_U #\U+1EB6 #\U+1EB7) + + + ;; #\Combining_Dot_Above + + #(#\Latin_Capital_Letter_A_With_Dot_Above #\U+1E02 + #\Latin_Capital_Letter_C_With_Dot_Above #\U+1E0A + #\Latin_Capital_Letter_E_With_Dot_Above #\U+1E1E + #\Latin_Capital_Letter_G_With_Dot_Above #\U+1E22 + #\Latin_Capital_Letter_I_With_Dot_Above #\U+1E40 #\U+1E44 + #\Latin_Capital_Letter_O_With_Dot_Above #\U+1E56 #\U+1E58 #\U+1E60 + #\U+1E6A #\U+1E86 #\U+1E8A #\U+1E8E + #\Latin_Capital_Letter_Z_With_Dot_Above + #\Latin_Small_Letter_A_With_Dot_Above #\U+1E03 + #\Latin_Small_Letter_C_With_Dot_Above #\U+1E0B + #\Latin_Small_Letter_E_With_Dot_Above #\U+1E1F + #\Latin_Small_Letter_G_With_Dot_Above #\U+1E23 #\U+1E41 #\U+1E45 + #\Latin_Small_Letter_O_With_Dot_Above #\U+1E57 #\U+1E59 #\U+1E61 + #\U+1E6B #\U+1E87 #\U+1E8B #\U+1E8F + #\Latin_Small_Letter_Z_With_Dot_Above #\U+1E64 #\U+1E65 #\U+1E66 + #\U+1E67 #\U+1E9B #\U+1E68 #\U+1E69) + + + ;; #\Combining_Diaeresis + + #(#\Latin_Capital_Letter_A_With_Diaeresis + #\Latin_Capital_Letter_E_With_Diaeresis #\U+1E26 + #\Latin_Capital_Letter_I_With_Diaeresis + #\Latin_Capital_Letter_O_With_Diaeresis + #\Latin_Capital_Letter_U_With_Diaeresis #\U+1E84 #\U+1E8C + #\Latin_Capital_Letter_Y_With_Diaeresis + #\Latin_Small_Letter_A_With_Diaeresis + #\Latin_Small_Letter_E_With_Diaeresis #\U+1E27 + #\Latin_Small_Letter_I_With_Diaeresis + #\Latin_Small_Letter_O_With_Diaeresis #\U+1E97 + #\Latin_Small_Letter_U_With_Diaeresis #\U+1E85 #\U+1E8D + #\Latin_Small_Letter_Y_With_Diaeresis #\U+1E4E #\U+1E4F #\U+1E7A + #\U+1E7B #\Greek_Capital_Letter_Iota_With_Dialytika + #\Greek_Capital_Letter_Upsilon_With_Dialytika + #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Greek_Upsilon_With_Diaeresis_And_Hook_Symbol + #\Cyrillic_Capital_Letter_Yi + #\Cyrillic_Capital_Letter_A_With_Diaeresis + #\Cyrillic_Capital_Letter_Io + #\Cyrillic_Capital_Letter_Zhe_With_Diaeresis + #\Cyrillic_Capital_Letter_Ze_With_Diaeresis + #\Cyrillic_Capital_Letter_I_With_Diaeresis + #\Cyrillic_Capital_Letter_O_With_Diaeresis + #\Cyrillic_Capital_Letter_U_With_Diaeresis + #\Cyrillic_Capital_Letter_Che_With_Diaeresis + #\Cyrillic_Capital_Letter_Yeru_With_Diaeresis + #\Cyrillic_Capital_Letter_E_With_Diaeresis + #\Cyrillic_Small_Letter_A_With_Diaeresis #\Cyrillic_Small_Letter_Io + #\Cyrillic_Small_Letter_Zhe_With_Diaeresis + #\Cyrillic_Small_Letter_Ze_With_Diaeresis + #\Cyrillic_Small_Letter_I_With_Diaeresis + #\Cyrillic_Small_Letter_O_With_Diaeresis + #\Cyrillic_Small_Letter_U_With_Diaeresis + #\Cyrillic_Small_Letter_Che_With_Diaeresis + #\Cyrillic_Small_Letter_Yeru_With_Diaeresis + #\Cyrillic_Small_Letter_E_With_Diaeresis #\Cyrillic_Small_Letter_Yi + #\Cyrillic_Capital_Letter_Schwa_With_Diaeresis + #\Cyrillic_Small_Letter_Schwa_With_Diaeresis + #\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis + #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis) + + + ;; #\Combining_Hook_Above + + #(#\U+1EA2 #\U+1EBA #\U+1EC8 #\U+1ECE #\U+1EE6 #\U+1EF6 #\U+1EA3 + #\U+1EBB #\U+1EC9 #\U+1ECF #\U+1EE7 #\U+1EF7 #\U+1EA8 #\U+1EC2 + #\U+1ED4 #\U+1EA9 #\U+1EC3 #\U+1ED5 #\U+1EB2 #\U+1EB3 #\U+1EDE + #\U+1EDF #\U+1EEC #\U+1EED) + + + ;; #\Combining_Ring_Above + + #(#\Latin_Capital_Letter_A_With_Ring_Above + #\Latin_Capital_Letter_U_With_Ring_Above + #\Latin_Small_Letter_A_With_Ring_Above + #\Latin_Small_Letter_U_With_Ring_Above #\U+1E98 #\U+1E99) + + + ;; #\Combining_Double_Acute_Accent + + #(#\Latin_Capital_Letter_O_With_Double_Acute + #\Latin_Capital_Letter_U_With_Double_Acute + #\Latin_Small_Letter_O_With_Double_Acute + #\Latin_Small_Letter_U_With_Double_Acute + #\Cyrillic_Capital_Letter_U_With_Double_Acute + #\Cyrillic_Small_Letter_U_With_Double_Acute) + + + ;; #\Combining_Caron + + #(#\Latin_Capital_Letter_A_With_Caron + #\Latin_Capital_Letter_C_With_Caron + #\Latin_Capital_Letter_D_With_Caron + #\Latin_Capital_Letter_E_With_Caron + #\Latin_Capital_Letter_G_With_Caron + #\Latin_Capital_Letter_H_With_Caron + #\Latin_Capital_Letter_I_With_Caron + #\Latin_Capital_Letter_K_With_Caron + #\Latin_Capital_Letter_L_With_Caron + #\Latin_Capital_Letter_N_With_Caron + #\Latin_Capital_Letter_O_With_Caron + #\Latin_Capital_Letter_R_With_Caron + #\Latin_Capital_Letter_S_With_Caron + #\Latin_Capital_Letter_T_With_Caron + #\Latin_Capital_Letter_U_With_Caron + #\Latin_Capital_Letter_Z_With_Caron #\Latin_Small_Letter_A_With_Caron + #\Latin_Small_Letter_C_With_Caron #\Latin_Small_Letter_D_With_Caron + #\Latin_Small_Letter_E_With_Caron #\Latin_Small_Letter_G_With_Caron + #\Latin_Small_Letter_H_With_Caron #\Latin_Small_Letter_I_With_Caron + #\Latin_Small_Letter_J_With_Caron #\Latin_Small_Letter_K_With_Caron + #\Latin_Small_Letter_L_With_Caron #\Latin_Small_Letter_N_With_Caron + #\Latin_Small_Letter_O_With_Caron #\Latin_Small_Letter_R_With_Caron + #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_T_With_Caron + #\Latin_Small_Letter_U_With_Caron #\Latin_Small_Letter_Z_With_Caron + #\Latin_Capital_Letter_U_With_Diaeresis_And_Caron + #\Latin_Small_Letter_U_With_Diaeresis_And_Caron + #\Latin_Capital_Letter_Ezh_With_Caron + #\Latin_Small_Letter_Ezh_With_Caron) + + + ;; #\Combining_Double_Grave_Accent + + #(#\Latin_Capital_Letter_A_With_Double_Grave + #\Latin_Capital_Letter_E_With_Double_Grave + #\Latin_Capital_Letter_I_With_Double_Grave + #\Latin_Capital_Letter_O_With_Double_Grave + #\Latin_Capital_Letter_R_With_Double_Grave + #\Latin_Capital_Letter_U_With_Double_Grave + #\Latin_Small_Letter_A_With_Double_Grave + #\Latin_Small_Letter_E_With_Double_Grave + #\Latin_Small_Letter_I_With_Double_Grave + #\Latin_Small_Letter_O_With_Double_Grave + #\Latin_Small_Letter_R_With_Double_Grave + #\Latin_Small_Letter_U_With_Double_Grave + #\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent + #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent) + + + ;; #\Combining_Inverted_Breve + + #(#\Latin_Capital_Letter_A_With_Inverted_Breve + #\Latin_Capital_Letter_E_With_Inverted_Breve + #\Latin_Capital_Letter_I_With_Inverted_Breve + #\Latin_Capital_Letter_O_With_Inverted_Breve + #\Latin_Capital_Letter_R_With_Inverted_Breve + #\Latin_Capital_Letter_U_With_Inverted_Breve + #\Latin_Small_Letter_A_With_Inverted_Breve + #\Latin_Small_Letter_E_With_Inverted_Breve + #\Latin_Small_Letter_I_With_Inverted_Breve + #\Latin_Small_Letter_O_With_Inverted_Breve + #\Latin_Small_Letter_R_With_Inverted_Breve + #\Latin_Small_Letter_U_With_Inverted_Breve) + + + ;; #\Combining_Comma_Above + + #(#\U+1F08 #\U+1F18 #\U+1F28 #\U+1F38 #\U+1F48 #\U+1F68 #\U+1F00 + #\U+1F10 #\U+1F20 #\U+1F30 #\U+1F40 #\U+1FE4 #\U+1F50 #\U+1F60) + + + ;; #\Combining_Reversed_Comma_Above + + #(#\U+1F09 #\U+1F19 #\U+1F29 #\U+1F39 #\U+1F49 #\U+1FEC #\U+1F59 + #\U+1F69 #\U+1F01 #\U+1F11 #\U+1F21 #\U+1F31 #\U+1F41 #\U+1FE5 + #\U+1F51 #\U+1F61) + + + ;; #\Combining_Horn + + #(#\Latin_Capital_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Dot_Below + + #(#\U+1EA0 #\U+1E04 #\U+1E0C #\U+1EB8 #\U+1E24 #\U+1ECA #\U+1E32 + #\U+1E36 #\U+1E42 #\U+1E46 #\U+1ECC #\U+1E5A #\U+1E62 #\U+1E6C + #\U+1EE4 #\U+1E7E #\U+1E88 #\U+1EF4 #\U+1E92 #\U+1EA1 #\U+1E05 + #\U+1E0D #\U+1EB9 #\U+1E25 #\U+1ECB #\U+1E33 #\U+1E37 #\U+1E43 + #\U+1E47 #\U+1ECD #\U+1E5B #\U+1E63 #\U+1E6D #\U+1EE5 #\U+1E7F + #\U+1E89 #\U+1EF5 #\U+1E93 #\U+1EE2 #\U+1EE3 #\U+1EF0 #\U+1EF1) + + + ;; #\Combining_Diaeresis_Below + + #(#\U+1E72 #\U+1E73) + + + ;; #\Combining_Ring_Below + + #(#\U+1E00 #\U+1E01) + + + ;; #\Combining_Comma_Below + + #(#\Latin_Capital_Letter_S_With_Comma_Below + #\Latin_Capital_Letter_T_With_Comma_Below + #\Latin_Small_Letter_S_With_Comma_Below + #\Latin_Small_Letter_T_With_Comma_Below) + + + ;; #\Combining_Cedilla + + #(#\Latin_Capital_Letter_C_With_Cedilla #\U+1E10 + #\Latin_Capital_Letter_E_With_Cedilla + #\Latin_Capital_Letter_G_With_Cedilla #\U+1E28 + #\Latin_Capital_Letter_K_With_Cedilla + #\Latin_Capital_Letter_L_With_Cedilla + #\Latin_Capital_Letter_N_With_Cedilla + #\Latin_Capital_Letter_R_With_Cedilla + #\Latin_Capital_Letter_S_With_Cedilla + #\Latin_Capital_Letter_T_With_Cedilla + #\Latin_Small_Letter_C_With_Cedilla #\U+1E11 + #\Latin_Small_Letter_E_With_Cedilla + #\Latin_Small_Letter_G_With_Cedilla #\U+1E29 + #\Latin_Small_Letter_K_With_Cedilla + #\Latin_Small_Letter_L_With_Cedilla + #\Latin_Small_Letter_N_With_Cedilla + #\Latin_Small_Letter_R_With_Cedilla + #\Latin_Small_Letter_S_With_Cedilla + #\Latin_Small_Letter_T_With_Cedilla) + + + ;; #\Combining_Ogonek + + #(#\Latin_Capital_Letter_A_With_Ogonek + #\Latin_Capital_Letter_E_With_Ogonek + #\Latin_Capital_Letter_I_With_Ogonek + #\Latin_Capital_Letter_O_With_Ogonek + #\Latin_Capital_Letter_U_With_Ogonek + #\Latin_Small_Letter_A_With_Ogonek #\Latin_Small_Letter_E_With_Ogonek + #\Latin_Small_Letter_I_With_Ogonek #\Latin_Small_Letter_O_With_Ogonek + #\Latin_Small_Letter_U_With_Ogonek) + + + ;; #\Combining_Circumflex_Accent_Below + + #(#\U+1E12 #\U+1E18 #\U+1E3C #\U+1E4A #\U+1E70 #\U+1E76 #\U+1E13 + #\U+1E19 #\U+1E3D #\U+1E4B #\U+1E71 #\U+1E77) + + + ;; #\Combining_Breve_Below + + #(#\U+1E2A #\U+1E2B) + + + ;; #\Combining_Tilde_Below + + #(#\U+1E1A #\U+1E2C #\U+1E74 #\U+1E1B #\U+1E2D #\U+1E75) + + + ;; #\Combining_Macron_Below + + #(#\U+1E06 #\U+1E0E #\U+1E34 #\U+1E3A #\U+1E48 #\U+1E5E #\U+1E6E + #\U+1E94 #\U+1E07 #\U+1E0F #\U+1E96 #\U+1E35 #\U+1E3B #\U+1E49 + #\U+1E5F #\U+1E6F #\U+1E95) + + + ;; #\Combining_Long_Solidus_Overlay + + #(#\U+226E #\U+2260 #\U+226F #\U+219A #\U+219B #\U+21AE #\U+21CD + #\U+21CF #\U+21CE #\U+2204 #\U+2209 #\U+220C #\U+2224 #\U+2226 + #\U+2241 #\U+2244 #\U+2247 #\U+2249 #\U+226D #\U+2262 #\U+2270 + #\U+2271 #\U+2274 #\U+2275 #\U+2278 #\U+2279 #\U+2280 #\U+2281 + #\U+22E0 #\U+22E1 #\U+2284 #\U+2285 #\U+2288 #\U+2289 #\U+22E2 + #\U+22E3 #\U+22AC #\U+22AD #\U+22AE #\U+22AF #\U+22EA #\U+22EB + #\U+22EC #\U+22ED) + + + ;; #\Combining_Greek_Perispomeni + + #(#\U+1FC1 #\U+1FB6 #\U+1FC6 #\U+1FD6 #\U+1FE6 #\U+1FF6 #\U+1FD7 + #\U+1FE7 #\U+1F06 #\U+1F07 #\U+1F0E #\U+1F0F #\U+1F26 #\U+1F27 + #\U+1F2E #\U+1F2F #\U+1F36 #\U+1F37 #\U+1F3E #\U+1F3F #\U+1F56 + #\U+1F57 #\U+1F5F #\U+1F66 #\U+1F67 #\U+1F6E #\U+1F6F #\U+1FCF + #\U+1FDF) + + + ;; #\Combining_Greek_Ypogegrammeni + + #(#\U+1FBC #\U+1FCC #\U+1FFC #\U+1FB4 #\U+1FC4 #\U+1FB3 #\U+1FC3 + #\U+1FF3 #\U+1FF4 #\U+1F80 #\U+1F81 #\U+1F82 #\U+1F83 #\U+1F84 + #\U+1F85 #\U+1F86 #\U+1F87 #\U+1F88 #\U+1F89 #\U+1F8A #\U+1F8B + #\U+1F8C #\U+1F8D #\U+1F8E #\U+1F8F #\U+1F90 #\U+1F91 #\U+1F92 + #\U+1F93 #\U+1F94 #\U+1F95 #\U+1F96 #\U+1F97 #\U+1F98 #\U+1F99 + #\U+1F9A #\U+1F9B #\U+1F9C #\U+1F9D #\U+1F9E #\U+1F9F #\U+1FA0 + #\U+1FA1 #\U+1FA2 #\U+1FA3 #\U+1FA4 #\U+1FA5 #\U+1FA6 #\U+1FA7 + #\U+1FA8 #\U+1FA9 #\U+1FAA #\U+1FAB #\U+1FAC #\U+1FAD #\U+1FAE + #\U+1FAF #\U+1FB2 #\U+1FC2 #\U+1FF2 #\U+1FB7 #\U+1FC7 #\U+1FF7) + + + ;; #\Arabic_Maddah_Above + + #(#\Arabic_Letter_Alef_With_Madda_Above) + + + ;; #\Arabic_Hamza_Above + + #(#\Arabic_Letter_Alef_With_Hamza_Above + #\Arabic_Letter_Waw_With_Hamza_Above + #\Arabic_Letter_Yeh_With_Hamza_Above + #\Arabic_Letter_Heh_Goal_With_Hamza_Above + #\Arabic_Letter_Yeh_Barree_With_Hamza_Above + #\Arabic_Letter_Heh_With_Yeh_Above) + + + ;; #\Arabic_Hamza_Below + + #(#\Arabic_Letter_Alef_With_Hamza_Below) + + + ;; #\U+093C + + #(#\U+0929 #\U+0931 #\U+0934) + + + ;; #\U+09BE + + #(#\U+09CB) + + + ;; #\U+09D7 + + #(#\U+09CC) + + + ;; #\U+0B3E + + #(#\U+0B4B) + + + ;; #\U+0B56 + + #(#\U+0B48) + + + ;; #\U+0B57 + + #(#\U+0B4C) + + + ;; #\U+0BBE + + #(#\U+0BCA #\U+0BCB) + + + ;; #\U+0BD7 + + #(#\U+0B94 #\U+0BCC) + + + ;; #\U+0C56 + + #(#\U+0C48) + + + ;; #\U+0CC2 + + #(#\U+0CCA) + + + ;; #\U+0CD5 + + #(#\U+0CC0 #\U+0CC7 #\U+0CCB) + + + ;; #\U+0CD6 + + #(#\U+0CC8) + + + ;; #\U+0D3E + + #(#\U+0D4A #\U+0D4B) + + + ;; #\U+0D57 + + #(#\U+0D4C) + + + ;; #\U+0DCA + + #(#\U+0DDA #\U+0DDD) + + + ;; #\U+0DCF + + #(#\U+0DDC) + + + ;; #\U+0DDF + + #(#\U+0DDE) + + + ;; #\U+102E + + #(#\U+1026) + + + ;; #\U+3099 + + #(#\U+3094 #\U+304C #\U+304E #\U+3050 #\U+3052 #\U+3054 #\U+3056 + #\U+3058 #\U+305A #\U+305C #\U+305E #\U+3060 #\U+3062 #\U+3065 + #\U+3067 #\U+3069 #\U+3070 #\U+3073 #\U+3076 #\U+3079 #\U+307C + #\U+309E #\U+30F4 #\U+30AC #\U+30AE #\U+30B0 #\U+30B2 #\U+30B4 + #\U+30B6 #\U+30B8 #\U+30BA #\U+30BC #\U+30BE #\U+30C0 #\U+30C2 + #\U+30C5 #\U+30C7 #\U+30C9 #\U+30D0 #\U+30D3 #\U+30D6 #\U+30D9 + #\U+30DC #\U+30F7 #\U+30F8 #\U+30F9 #\U+30FA #\U+30FE) + + + ;; #\U+309A + + #(#\U+3071 #\U+3074 #\U+3077 #\U+307A #\U+307D #\U+30D1 #\U+30D4 + #\U+30D7 #\U+30DA #\U+30DD) + )) + +(defun search-char-vector (vector char) + ;; vector is a SIMPLE-VECTOR of chars sorted by char-code. + ;; return the index of char in vector or NIL if not found + (let* ((left 0) + (right (1- (length vector)))) + (declare (fixnum left right)) + (if (and (char>= char (svref vector left)) + (char<= char (svref vector right))) + (do* () + ((> left right)) + (let* ((mid (ash (the fixnum (+ left right)) -1)) + (midch (svref vector mid))) + (declare (fixnum mid)) + (if (eql char midch) + (return mid) + (if (char< char midch) + (setq right (1- mid)) + (setq left (1+ mid))))))))) + + +(defconstant HANGUL-SBASE #xAC00) +(defconstant HANGUL-LBASE #x1100) +(defconstant HANGUL-VBASE #x1161) +(defconstant HANGUL-TBASE #x11A7) + +(defconstant HANGUL-SCOUNT 11172) +(defconstant HANGUL-LCOUNT 19) +(defconstant HANGUL-VCOUNT 21) +(defconstant HANGUL-TCOUNT 28) +(defconstant HANGUL-NCOUNT (* HANGUL-VCOUNT HANGUL-TCOUNT)) + +(defun combine-bmp-chars (base combiner) + (if (and (char>= combiner (code-char hangul-vbase)) + (char< combiner (code-char (+ hangul-tbase hangul-tcount)))) + (if (and (char< combiner (code-char (+ hangul-vbase hangul-vcount))) + (char>= base (code-char hangul-lbase)) + (char< base (code-char (+ hangul-lbase hangul-lcount)))) + (return-from combine-bmp-chars + (code-char (+ hangul-lbase + (* hangul-ncount (- (char-code base) hangul-lbase)) + (* hangul-tcount (- (char-code combiner) hangul-vbase)))))) + (if (and (char> combiner (code-char hangul-tbase)) + (char>= base (code-char hangul-sbase)) + (char< base (code-char (+ hangul-sbase hangul-scount)))) + (if (not (zerop (the fixnum (mod (- (char-code base) hangul-sbase) hangul-tcount)))) + (return-from combine-bmp-chars nil) + (return-from combine-bmp-chars + (code-char (+ (char-code base) (- (char-code combiner) hangul-tbase))))))) + + (let* ((idx (search-char-vector *bmp-combining-chars* combiner)) + (base-table (if idx (svref *bmp-combining-base-chars* idx)))) + (if base-table + (let* ((combined-idx (search-char-vector base-table base))) + (if combined-idx + (svref (svref *bmp-precombined-chars* idx) combined-idx)))))) + +(defun precompose-simple-string (s) + (let* ((n (length s))) + (or (dotimes (i n s) + (when (is-combinable (schar s i)) + (return nil))) + (let* ((new (make-string n))) + (declare (dynamic-extent new)) + (do* ((i 0 (1+ i)) + (nout -1) + (lastch nil)) + ((= i n) (subseq new 0 (1+ nout))) + (declare (fixnum nout i)) + (let* ((ch (schar s i))) + (if (or (not lastch) + (not (is-combinable ch))) + (setf lastch ch + (schar new (incf nout)) ch) + (let* ((combined (combine-bmp-chars lastch ch))) + (if combined + (setf (schar new nout) (setq lastch combined)) + (setf lastch ch + (schar new (incf nout)) ch)))))))))) Index: /branches/qres/ccl/level-1/l1-utils.lisp =================================================================== --- /branches/qres/ccl/level-1/l1-utils.lisp (revision 13564) +++ /branches/qres/ccl/level-1/l1-utils.lisp (revision 13564) @@ -0,0 +1,1182 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; L1-utils.lisp + +(in-package "CCL") + +;The following forms (up thru defn of %DEFUN) must come before any DEFUN's. +;Any (non-kernel) functions must be defined before they're used! +;In fact, ALL functions must be defined before they're used! How about that ? + + + +(setq %lisp-system-fixups% nil) + + +;;; Kludge for record-source-file bootstrapping + +(%fhave 'full-pathname (qlfun bootstrapping-full-pathname (name) name)) + + +; real one is in setf.lisp +(%fhave '%setf-method (qlfun bootstripping-setf-fsname (spec) + spec nil)) + +(fset 'physical-pathname-p (lambda (file)(declare (ignore file)) nil)) ; redefined later + +(setq *record-source-file* t) + +(fset 'level-1-record-source-file + (qlfun level-1-record-source-file (name def-type &optional (source (or *loading-toplevel-location* + *loading-file-source-file*))) + ;; Level-0 puts stuff on plist of name. Once we're in level-1, names can + ;; be more complicated than just a symbol, so just collect all calls until + ;; the real record-source-file is loaded. + (when *record-source-file* + (unless (listp *record-source-file*) + (setq *record-source-file* nil)) + (push (list name def-type source) *record-source-file*)))) + +(fset 'record-source-file #'level-1-record-source-file) + +(defun inherit-from-p (ob parent) + (memq (if (symbolp parent) (find-class parent nil) parent) + (%inited-class-cpl (class-of ob)))) + +;;; returns new plist with value spliced in or key, value consed on. +(defun setprop (plist key value &aux loc) + (if (setq loc (pl-search plist key)) + (progn (%rplaca (%cdr loc) value) plist) + (cons key (cons value plist)))) + +(defun getf-test (place indicator test &optional default) + (loop + (when (null place) + (return default)) + (when (funcall test indicator (car place)) + (return (cadr place))) + (setq place (cddr place)))) + +(defun setprop-test (plist indicator test value) + (let ((tail plist)) + (loop + (when (null tail) + (return (cons indicator (cons value plist)))) + (when (funcall test indicator (car tail)) + (setf (cadr tail) value) + (return plist)) + (setq tail (cddr tail))))) + +(defun plistp (p &aux len) + (and (listp p) + (setq len (list-length p)) + (not (%ilogbitp 0 len)))) ; (evenp p) + +(defun %imax (i1 i2) + (if (%i> i1 i2) i1 i2)) + +(defun %imin (i1 i2) + (if (%i< i1 i2) i1 i2)) + + + + +;|# + + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS")) + + + + +(defun loading-file-source-file () + *loading-file-source-file*) + +(setq *save-local-symbols* t) + +(%fhave 'require-type (nfunction bootstrapping-require-type + (lambda (thing type) + (declare (ignore type)) + thing))) +(%fhave '%require-type + (nfunction bootstrapping-%require-type + (lambda (thing predicate) + (declare (ignore predicate)) + thing))) + +(setf (type-predicate 'macptr) 'macptrp) + + + + + + +(defun %pop-required-arg-ptr (ptr) + (if (atom (destructure-state.current ptr)) + (signal-program-error "Required arguments in ~s don't match lambda list ~s." + (destructure-state.whole ptr) (destructure-state.lambda ptr)) + (pop (destructure-state.current ptr)))) + +(defun %default-optional-value (ptr &optional default) + (let* ((tail (destructure-state.current ptr))) + (if tail + (if (atom tail) + (signal-program-error "Optional arguments in ~s don't match lambda list ~s." + (destructure-state.whole ptr) (destructure-state.lambda ptr)) + (pop (destructure-state.current ptr))) + default))) + +(defun %check-extra-arguments (ptr) + (when (destructure-state.current ptr) + (signal-program-error "Extra arguments in ~s don't match lambda list ~s." + (destructure-state.whole ptr) (destructure-state.lambda ptr)))) + +(defun %keyword-present-p (keys keyword) + (let* ((not-there (cons nil nil))) + (declare (dynamic-extent not-there)) + (not (eq (getf keys keyword not-there) not-there)))) + +(defun check-keywords (keys actual allow-others) + (let* ((len (ignore-errors (list-length actual)))) + (if (null len) + (signal-simple-program-error "Circular or dotted keyword list: ~s" actual) + (if (oddp len) + (signal-simple-program-error "Odd length keyword list: ~s" actual)))) + (setq allow-others (or allow-others (getf actual :allow-other-keys))) + (do* ((a actual (cddr a)) + (k (car a) (car a))) + ((null a)) + (unless (typep k 'symbol) + (signal-simple-program-error + "Invalid keyword argument ~s in ~s. ~&Valid keyword arguments are ~s." k actual keys)) + (unless (or allow-others + (eq k :allow-other-keys) + (member k keys)) + (signal-simple-program-error "Unknown keyword argument ~s in ~s. ~&Valid keyword arguments are ~s." k actual keys)))) + +(%fhave 'set-macro-function #'%macro-have) ; redefined in sysutils. + +;;; Define special forms. +(dolist (sym '(block catch compiler-let eval-when + flet function go if labels let let* macrolet + multiple-value-call multiple-value-prog1 + progn progv quote return-from setq tagbody + the throw unwind-protect locally load-time-value + symbol-macrolet + ;; These are implementation-specific special forms : + nfunction + ppc-lap-function fbind + with-c-frame with-variable-c-frame)) + (%macro-have sym sym)) + + +(defun %macro (named-fn &optional doc &aux arglist) + ;; "doc" is either a string or a list of the form : + ;; (doc-string-or-nil . (body-pos-or-nil . arglist-or-nil)) + (if (listp doc) + (setq arglist (cddr doc) + doc (car doc))) + (let* ((name (function-name named-fn))) + (record-source-file name 'function) + (set-macro-function name named-fn) + (when (and doc *save-doc-strings*) + (set-documentation name 'function doc)) + (when arglist + (record-arglist name arglist)) + (when *fasload-print* (format t "~&~S~%" name)) + name)) + + +(defun %defvar (var &optional doc) + "Returns boundp" + (%proclaim-special var) + (record-source-file var 'variable) + (when (and doc *save-doc-strings*) + (set-documentation var 'variable doc)) + (cond ((not (boundp var)) + (when *fasload-print* (format t "~&~S~%" var)) + nil) + (t t))) + +(defun %defparameter (var value &optional doc) + (%proclaim-special var) + (record-source-file var 'variable) + (when (and doc *save-doc-strings*) + (set-documentation var 'variable doc)) + (when *fasload-print* (format t "~&~S~%" var)) + (set var value) + var) + + +(defun %defglobal (var value &optional doc) + (%symbol-bits var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits var)))) + (%defparameter var value doc)) + +;Needed early for member etc. +(defun identity (x) + "This function simply returns what was passed to it." + x) + +(defun coerce-to-function (arg) + (if (functionp arg) + arg + (if (symbolp arg) + (%function arg) + (report-bad-arg arg 'function)))) + +;;; takes arguments in arg_x, arg_y, arg_z, returns "multiple values" +;;; Test(-not) arguments are NOT validated beyond what is done +;;; here. +;;; if both :test and :test-not supplied, signal error. +;;; if test provided as #'eq or 'eq, return first value 'eq. +;;; if test defaulted, provided as 'eql, or provided as #'eql, return +;;; first value 'eql. +;;; if test-not provided as 'eql or provided as #'eql, return second +;;; value 'eql. +;;; if key provided as either 'identity or #'identity, return third value nil. +(defun %key-conflict (test-fn test-not-fn key) + (let* ((eqfn #'eq) + (eqlfn #'eql) + (idfn #'identity)) + (if (or (eq key 'identity) (eq key idfn)) + (setq key nil)) + (if test-fn + (if test-not-fn + (%err-disp $xkeyconflict ':test test-fn ':test-not test-not-fn) + (if (eq test-fn eqfn) + (values 'eq nil key) + (if (eq test-fn eqlfn) + (values 'eql nil key) + (values test-fn nil key)))) + (if test-not-fn + (if (eq test-not-fn eqfn) + (values nil 'eq key) + (if (eq test-not-fn eqlfn) + (values nil 'eql key) + (values nil test-not-fn key))) + (values 'eql nil key))))) + + + + + +;;; Assoc. + +;;; (asseql item list) <=> (assoc item list :test #'eql :key #'identity) + + + +;;; (assoc-test item list test-fn) +;;; <=> +;;; (assoc item list :test test-fn :key #'identity) +;;; test-fn may not be FUNCTIONP, so we coerce it here. +(defun assoc-test (item list test-fn) + (dolist (pair list) + (if pair + (if (funcall test-fn item (car pair)) + (return pair))))) + + + +; (assoc-test-not item list test-not-fn) +; <=> +; (assoc item list :test-not test-not-fn :key #'identity) +; test-not-fn may not be FUNCTIONP, so we coerce it here. +(defun assoc-test-not (item list test-not-fn) + (dolist (pair list) + (if pair + (if (not (funcall test-not-fn item (car pair))) + (return pair))))) + +(defun assoc (item list &key test test-not key) + "Return the cons in ALIST whose car is equal (by a given test or EQL) to + the ITEM." + (multiple-value-bind (test test-not key) (%key-conflict test test-not key) + (if (null key) + (if (eq test 'eq) + (assq item list) + (if (eq test 'eql) + (asseql item list) + (if test + (assoc-test item list test) + (assoc-test-not item list test-not)))) + (if test + (dolist (pair list) + (if pair + (if (funcall test item (funcall key (car pair))) + (return pair)))) + (dolist (pair list) + (if pair + (unless (funcall test-not item (funcall key (car pair))) + (return pair)))))))) + + + +;;;; Member. + +;;; (member-test-not item list test-not-fn) +;;; <=> +;;; (member item list :test-not test-not-fn :key #'identity) +(defun member-test-not (item list test-not-fn) + (do* ((l list (cdr l))) + ((endp l)) + (unless (funcall test-not-fn item (%car l)) (return l)))) + +(defun member (item list &key test test-not key) + "Return the tail of LIST beginning with first element satisfying EQLity, + :TEST, or :TEST-NOT with the given ITEM." + (multiple-value-bind (test test-not key) (%key-conflict test test-not key) + (if (null key) + (if (eq test 'eq) + (memq item list) + (if (eq test 'eql) + (memeql item list) + (if test + (member-test item list test) + (member-test-not item list test-not)))) + (if test + (do* ((l list (cdr l))) + ((endp l)) + (if (funcall test item (funcall key (car l))) + (return l))) + (do* ((l list (cdr l))) + ((null l)) + (unless (funcall test-not item (funcall key (car l))) + (return l))))))) + + +(defun adjoin (item list &key test test-not key) + "Add ITEM to LIST unless it is already a member" + (if (and (not test)(not test-not)(not key)) + (if (not (memeql item list))(cons item list) list) + (multiple-value-bind (test test-not key) (%key-conflict test test-not key) + (if + (if (null key) + (if (eq test 'eq) + (memq item list) + (if (eq test 'eql) + (memeql item list) + (if test + (member-test item list test) + (member-test-not item list test-not)))) + (if test + (member (funcall key item) list :test test :key key) + (member (funcall key item) list :test-not test-not :key key))) + list + (cons item list))))) + +(defun adjoin-eq (elt list) + (if (memq elt list) + list + (cons elt list))) + +(defun adjoin-eql (elt list) + (if (memeql elt list) + list + (cons elt list))) + +(defun union-eq (list1 list2) + (let ((res list2)) + (dolist (elt list1) + (unless (memq elt res) + (push elt res))) + res)) + +(defun union-eql (list1 list2) + (let ((res list2)) + (dolist (elt list1) + (unless (memeql elt res) + (push elt res))) + res)) + +;;; Fix this someday. Fix EQUALP, while you're at it ... +(defun similar-as-constants-p (x y) + (or (eq x y) ; Redefinition of constants to themselves. + (if (and (stringp x) (stringp y)) ;The most obvious case where equalp & s-a-c-p need to differ... + (string= x y) + (equalp x y)))) + +(defun undefine-constant (var) + (%set-sym-global-value var (%unbound-marker-8))) + +(defparameter *cerror-on-constant-redefinition* t) + +(defun define-constant (var value) + (block nil + (if (constant-symbol-p var) + (let* ((old-value (%sym-global-value var))) + (unless (eq old-value (%unbound-marker-8)) + (if (or (eql old-value value) + (and (not *strict-checking*) (similar-as-constants-p old-value value))) + (return) + ;; This should really be a cell error, allow options other than + ;; redefining (such as don't redefine and continue)... + (when *cerror-on-constant-redefinition* + (cerror "Redefine ~S to have new value ~*~s" + "Constant ~S is already defined with a different value (~s)" + var old-value value)))))) + (%symbol-bits var + (%ilogior (%ilsl $sym_bit_special 1) (%ilsl $sym_bit_const 1) + (%symbol-bits var))) + (%set-sym-global-value var value)) + var) + +(defun %defconstant (var value &optional doc) + (%proclaim-special var) + (record-source-file var 'constant) + (define-constant var value) + (when (and doc *save-doc-strings*) + (set-documentation var 'variable doc)) + (when *fasload-print* (format t "~&~S~%" var)) + var) + +(defparameter *nx1-compiler-special-forms* ()) +(defparameter *nx-proclaimed-types* ()) +(defparameter *nx-proclaimed-ftypes* nil) + +(defun compiler-special-form-p (sym) + (or (eq sym 'quote) + (if (memq sym *nx1-compiler-special-forms*) t))) + + + +(defparameter *nx-known-declarations* ()) +(defparameter *nx-proclaimed-inline* ()) +(defparameter *nx-proclaimed-ignore* ()) +(defparameter *nx-globally-inline* ()) + + + +(defconstant *cl-types* '( +array +atom +base-char +bignum +bit +bit-vector +character +#| +lisp:common +|# +compiled-function +complex +cons +double-float +extended-char +fixnum +float +function +hash-table +integer +keyword +list +long-float +nil +null +number +package +pathname +random-state +ratio +rational +readtable +real +sequence +short-float +signed-byte +simple-array +simple-bit-vector +simple-string +simple-base-string +simple-vector +single-float +standard-char +stream +string +#| +lisp:string-char +|# +symbol +t +unsigned-byte +vector +)) + +;; Redefined in sysutils. +(%fhave 'specifier-type-if-known + (qlfun bootstrapping-type-specifier-p (name &optional env &key &allow-other-keys) + (declare (ignore env)) + (memq name *cl-types*))) + + + +(defun proclaim (spec) + (case (car spec) + (special (apply #'proclaim-special (%cdr spec))) + (notspecial (apply #'proclaim-notspecial (%cdr spec))) + (optimize (%proclaim-optimize (%cdr spec))) + (inline (apply #'proclaim-inline t (%cdr spec))) + (notinline (apply #'proclaim-inline nil (%cdr spec))) + (declaration (apply #'proclaim-declaration (%cdr spec))) + (ignore (apply #'proclaim-ignore t (%cdr spec))) + (unignore (apply #'proclaim-ignore nil (%cdr spec))) + (type (apply #'proclaim-type (%cdr spec))) + (ftype (apply #'proclaim-ftype (%cdr spec))) + (function (apply #'proclaim-type spec)) + (t (unless (memq (%car spec) *nx-known-declarations*) + ;; Any type name is now (ANSI CL) a valid declaration. + (if (specifier-type-if-known (%car spec)) + (apply #'proclaim-type spec) + (signal-program-error "Unknown declaration specifier ~s in ~S" (%car spec) spec)))))) + +(defun bad-proclaim-spec (spec) + (signal-program-error "Invalid declaration specifier ~s" spec)) + +(defun proclaim-type (type &rest vars) + (declare (dynamic-extent vars)) + ;; Called too early to use (every #'symbolp vars) + (unless (loop for v in vars always (symbolp v)) (bad-proclaim-spec `(,type ,@vars))) + (when *type-system-initialized* + ;; Check the type. This will signal program-error's in case of invalid types, let it. + ;; Do not signal anything about unknown types though -- it should be ok to have forward + ;; references here, before anybody needs the info. + (specifier-type type)) + (dolist (var vars) + (let ((spec (assq var *nx-proclaimed-types*))) + (if spec + (rplacd spec type) + (push (cons var type) *nx-proclaimed-types*))))) + +(defun proclaim-ftype (ftype &rest names) + (declare (dynamic-extent names)) + (unless (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) names) + (bad-proclaim-spec `(ftype ,ftype ,@names))) + (unless *nx-proclaimed-ftypes* + (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq))) + ;; Check the type. This will signal program-error's in case of invalid types, let it. + ;; Do not signal anything about unknown types though -- it should be ok to have forward + ;; references here, before anybody needs the info. + (let* ((ctype (specifier-type ftype))) + ;; If know enough to complain now, do so. + (when (types-disjoint-p ctype (specifier-type 'function)) + (bad-proclaim-spec `(ftype ,ftype ,@names)))) + (dolist (name names) + (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype))) + + + +(defun proclaimed-ftype (name) + (when *nx-proclaimed-ftypes* + (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*))) + + +(defun proclaim-special (&rest vars) + (declare (dynamic-extent vars)) + (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars))) + (dolist (sym vars) (%proclaim-special sym))) + + +(defun proclaim-notspecial (&rest vars) + (declare (dynamic-extent vars)) + (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars))) + (dolist (sym vars) (%proclaim-notspecial sym))) + +(defun proclaim-inline (t-or-nil &rest names) + (declare (dynamic-extent names)) + ;;This is just to make it more likely to detect forgetting about the + ;;first arg... + (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil))) + (unless (loop for v in names always (or (symbolp v) (setf-function-name-p v))) + (bad-proclaim-spec `(,(if t-or-nil 'inline 'notinline) ,@names))) + (dolist (name names) + (setq name (maybe-setf-function-name name)) + (if (listp *nx-proclaimed-inline*) + (setq *nx-proclaimed-inline* + (alist-adjoin name + (or t-or-nil (if (compiler-special-form-p name) t)) + *nx-proclaimed-inline*)) + (setf (gethash name *nx-proclaimed-inline*) + (or t-or-nil (if (compiler-special-form-p name) t)))))) + +(defun proclaim-declaration (&rest syms) + (declare (dynamic-extent syms)) + (unless (every #'symbolp syms) (bad-proclaim-spec `(declaration ,@syms))) + (dolist (sym syms) + (when (type-specifier-p sym) + (error "Cannot define declaration ~s because it is the name of a type" sym)) + (setq *nx-known-declarations* + (adjoin sym *nx-known-declarations* :test 'eq)))) + +(defun check-declaration-redefinition (name why) + (when (memq name *nx-known-declarations*) + (cerror "Undeclare the declaration ~*~s" + "Cannot ~a ~s because ~:*~s has been declared as a declaration name" why name) + (setq *nx-known-declarations* (remove name *nx-known-declarations*)))) + +(defun proclaim-ignore (t-or-nil &rest syms) + (declare (dynamic-extent syms)) + ;;This is just to make it more likely to detect forgetting about the + ;;first arg... + (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil))) + (unless (every #'symbolp syms) (bad-proclaim-spec `(,(if t-or-nil 'ignore 'unignore) ,@syms))) + (dolist (sym syms) + (setq *nx-proclaimed-ignore* + (alist-adjoin sym t-or-nil *nx-proclaimed-ignore*)))) + + +(queue-fixup + (when (listp *nx-proclaimed-inline*) + (let ((table (make-hash-table :size 100 :test #'eq))) + (dolist (x *nx-proclaimed-inline*) + (let ((name (car x)) (value (cdr x))) + (when (symbolp name) + (setf (gethash name table) value)))) + (setq *nx-proclaimed-inline* table)))) + +(defun proclaimed-special-p (sym) + (%ilogbitp $sym_vbit_special (%symbol-bits sym))) + +(defun proclaimed-inline-p (sym) + (if (listp *nx-proclaimed-inline*) + (%cdr (assq sym *nx-proclaimed-inline*)) + (gethash sym *nx-proclaimed-inline*))) + +(defun proclaimed-notinline-p (sym) + (if (listp *nx-proclaimed-inline*) + (and (setq sym (assq sym *nx-proclaimed-inline*)) + (null (%cdr sym))) + (null (gethash sym *nx-proclaimed-inline* t)))) + + +(defun self-evaluating-p (form) + (and (atom form) + (or (not (non-nil-symbol-p form)) + (eq form t) + (keywordp form)))) + +(defun constantp (form &optional env) + "True of any Lisp object that has a constant value: types that eval to + themselves, keywords, constants, and list whose car is QUOTE." + (or (self-evaluating-p form) + (quoted-form-p form) + (constant-symbol-p form) + (and env + (symbolp form) + (eq :constant (variable-information form env))))) + + +(defun eval-constant (form) + (if (quoted-form-p form) (%cadr form) + (if (constant-symbol-p form) (symbol-value form) + (if (self-evaluating-p form) form + (report-bad-arg form '(satisfies constantp)))))) + +(defvar *lfun-names*) + + +(defvar %lambda-lists% (make-hash-table :test #'eq :weak t)) +(defparameter *save-arglist-info* t) + + +(defun record-arglist (name args) + "Used by defmacro & defgeneric" + (when (or *save-arglist-info* *save-local-symbols*) + (setf (gethash name %lambda-lists%) args))) + + +;;;Support the simple case of defsetf. +(%fhave 'store-setf-method + (qlfun bootstrapping-store-setf-method (name fn &optional doc) + (declare (ignore doc)) + (put name 'bootstrapping-setf-method (require-type fn 'symbol)))) +(%fhave '%setf-method + (qlfun bootstrapping-%setf-method (name) + (get name 'bootstrapping-setf-method))) + + +;;; defmacro uses (setf (assq ...) ...) for &body forms. +(defun adjoin-assq (indicator alist value) + (let ((cell (assq indicator alist))) + (if cell + (setf (cdr cell) value) + (push (cons indicator value) alist))) + alist) + +(defmacro setf-assq (indicator place value) + (let ((res (gensym))) + `(let (,res) + (setf ,place (adjoin-assq ,indicator ,place (setq ,res ,value))) + ,res))) + +(defsetf assq setf-assq) +(defsetf %typed-miscref %typed-miscset) + +(defun quoted-form-p (form) + (and (consp form) + (eq (%car form) 'quote) + (consp (%cdr form)) + (null (%cdr (%cdr form))))) + +(defun lambda-expression-p (form) + (and (consp form) + (eq (%car form) 'lambda) + (consp (%cdr form)) + (listp (%cadr form)))) + +;;;;;FUNCTION BINDING Functions + +;;; A symbol's entrypoint contains: +;;; 1) something tagged as $t_lfun if the symbol is +;;; not fbound as a macro or special form; +;;; 2) a cons, otherwise, where the cdr is a fixnum +;;; whose value happens to be the same bit-pattern +;;; as a "jsr_subprim $sp-apply-macro" instruction. +;;; The car of this cons is either: +;;; a) a function -> macro-function; +;;; b) a symbol: special form not redefined as a macro. +;;; c) a cons whose car is a function -> macro function defined +;;; on a special form. + + + + +(defun symbol-function (name) + "Return the definition of NAME, even if it is a macro or a special form. + Error if NAME doesn't have a definition." + (or (fboundp name) ;Our fboundp returns the binding + (prog1 (%err-disp $xfunbnd name)))) + +(%fhave 'fdefinition #'symbol-function) + + +(defun kernel-function-p (f) + (declare (ignore f)) + nil) + +(defun %make-function (name fn env) + (compile-user-function fn name env)) + +;;;;;;;;; VALUE BINDING Functions + +(defun gensym (&optional (string-or-integer nil string-or-integer-p)) + "Creates a new uninterned symbol whose name is a prefix string (defaults + to \"G\"), followed by a decimal number. Thing, when supplied, will + alter the prefix if it is a string, or be used for the decimal number + if it is a number, of this symbol. The default value of the number is + the current value of *gensym-counter* which is incremented each time + it is used." + (let ((prefix "G") + (counter nil)) + (when string-or-integer-p + (etypecase string-or-integer + (integer (setq counter string-or-integer)) ; & emit-style-warning + (string (setq prefix (ensure-simple-string string-or-integer))))) + (unless counter + (setq *gensym-counter* (1+ (setq counter *gensym-counter*)))) + (make-symbol (%str-cat prefix (%integer-to-string counter))))) + +(defun make-keyword (name) + (if (and (symbolp name) (eq (symbol-package name) *keyword-package*)) + name + (values (intern (string name) *keyword-package*)))) + + + + +; destructive, removes first match only +(defun remove-from-alist (thing alist) + (let ((start alist)) + (if (eq thing (%caar alist)) + (%cdr alist) + (let* ((prev start) + (this (%cdr prev)) + (next (%cdr this))) + (while this + (if (eq thing (%caar this)) + (progn + (%rplacd prev next) + (return-from remove-from-alist start)) + (setq prev this + this next + next (%cdr next)))) + start)))) + +;destructive +(defun add-to-alist (thing val alist &aux (pair (assq thing alist))) + (if pair + (progn (%rplacd pair thing) alist) + (cons (cons thing val) alist))) + +;non-destructive... +(defun alist-adjoin (thing val alist &aux (pair (assq thing alist))) + (if (and pair (eq (%cdr pair) val)) + alist + (cons (cons thing val) alist))) + +(defun %str-assoc (str alist) + (assoc str alist :test #'string-equal)) + +(defstatic *pathname-escape-character* + #+windows-target #\' + #-windows-target #\\ + "Not CL. A Coral addition for compatibility between CL spec and the shell.") + + +(defun caar (x) + "Return the car of the 1st sublist." + (car (car x))) + +(defun cadr (x) + "Return the 2nd object in a list." + (car (cdr x))) + +(defun cdar (x) + "Return the cdr of the 1st sublist." + (cdr (car x))) + +(defun cddr (x) + "Return all but the 1st two objects of a list." + + (cdr (cdr x))) + +(defun caaar (x) + "Return the 1st object in the caar of a list." + (car (car (car x)))) + +(defun caadr (x) + "Return the 1st object in the cadr of a list." + (car (car (cdr x)))) + +(defun cadar (x) + "Return the car of the cdar of a list." + (car (cdr (car x)))) + +(defun caddr (x) + "Return the 1st object in the cddr of a list." + (car (cdr (cdr x)))) + +(defun cdaar (x) + "Return the cdr of the caar of a list." + (cdr (car (car x)))) + +(defun cdadr (x) + "Return the cdr of the cadr of a list." + (cdr (car (cdr x)))) + +(defun cddar (x) + "Return the cdr of the cdar of a list." + (cdr (cdr (car x)))) + +(defun cdddr (x) + "Return the cdr of the cddr of a list." + (cdr (cdr (cdr x)))) + +(defun cadddr (x) + "Return the car of the cdddr of a list." + (car (cdr (cdr (cdr x))))) + +(%fhave 'type-of #'%type-of) + + + +(defun pointerp (thing &optional errorp) + (if (macptrp thing) + t + (if errorp (error "~S is not a pointer" thing) nil))) + + +;Add an item to a dialog items list handle. HUH ? +(defun %rsc-string (n) + (or (cdr (assq n *error-format-strings*)) + (%str-cat "Error #" (%integer-to-string n)))) + +(defun string-arg (arg) + (or (string-argp arg) (error "~S is not a string" arg))) + +(defun string-argp (arg) + (cond ((symbolp arg) (symbol-name arg)) + ((typep arg 'character) (string arg)) + ((stringp arg) (ensure-simple-string arg)) + (t nil))) + +(defun symbol-arg (arg) + (unless (symbolp arg) + (report-bad-arg arg 'symbol)) + arg) + +(defun %cstrlen (ptr) + ;;(#_strlen ptr) + (do* ((i 0 (1+ i))) + ((zerop (the fixnum (%get-byte ptr i))) i) + (declare (fixnum i)))) + + +(defun %set-cstring (ptr string) + (%cstr-pointer string ptr) + string) + +(defsetf %get-cstring %set-cstring) + +;;; Deprecated, but used by UFFI. +(defun %put-cstring (ptr str &optional (offset 0)) + (setf (%get-cstring (%inc-ptr ptr offset)) str) + ;; 0 is the traditional, not-very-useful return value ... + 0) + + + + + + +;;; Returns a simple string and adjusted start and end, such that +;;; 0<= start <= end <= (length simple-string). +(defun get-sstring (str &optional (start 0) (end (length (require-type str 'string)))) + (multiple-value-bind (sstr offset) (array-data-and-offset (string str)) + (setq start (+ start offset) end (+ end offset)) + (when (< (length sstr) end)(setq end (length sstr))) + (when (< end start) (setq start end)) + (values sstr start end))) + +;e.g. (bad-named-arg :key key 'function) +(defun bad-named-arg (name arg &optional (type nil type-p)) + (if type-p + (%err-disp $err-bad-named-arg-2 name arg type) + (%err-disp $err-bad-named-arg name arg))) + +(defun verify-arg-count (call min &optional max) + "If call contains less than MIN number of args, or more than MAX + number of args, error. Otherwise, return call. + If Max is NIL, the maximum args for the fn are infinity." + (or (verify-call-count (car call) (%cdr call) min max) call)) + +(defun verify-call-count (sym args min &optional max &aux argcount) + (if (%i< (setq argcount (list-length args)) min) + (%err-disp $xtoofew (cons sym args)) + (if (if max (%i> argcount max)) + (%err-disp $xtoomany (cons sym args))))) + +(defun getf (place key &optional (default ())) + "Search the property list stored in Place for an indicator EQ to INDICATOR. + If one is found, return the corresponding value, else return DEFAULT." + (let ((p (pl-search place key))) (if p (%cadr p) default))) + +(defun remprop (symbol key) + "Look on property list of SYMBOL for property with specified + INDICATOR. If found, splice this indicator and its value out of + the plist, and return the tail of the original list starting with + INDICATOR. If not found, return () with no side effects. + + NOTE: The ANSI specification requires REMPROP to return true (not false) + or false (the symbol NIL). Portable code should not rely on any other value." + (do* ((prev nil plist) + (plist (symbol-plist symbol) tail) + (tail (cddr plist) (cddr tail))) + ((null plist)) + (when (eq (car plist) key) + (if prev + (rplacd (cdr prev) tail) + (setf (symbol-plist symbol) tail)) + (return t)))) + + + +;;; If this returns non-nil, safe to do %rplaca of %cdr to update. +(defun pl-search (plist key) + (unless (plistp plist) + (report-bad-arg plist '(satisfies plistp))) + (%pl-search plist key)) + + +(defun rassoc (item alist &key (test #'eql test-p) test-not (key #'identity)) + (declare (list alist)) + "Return the cons in ALIST whose CDR is equal (by a given test or EQL) to + the ITEM." + (if (or test-p (not test-not)) + (progn + (if test-not (error "Cannot specify both :TEST and :TEST-NOT.")) + (dolist (pair alist) + (if (atom pair) + (if pair (error "Invalid alist containing ~S: ~S" pair alist)) + (when (funcall test item (funcall key (cdr pair))) (return pair))))) + (progn + (unless test-not (error "Must specify at least one of :TEST or :TEST-NOT")) + (dolist (pair alist) + (if (atom pair) + (if pair (error "Invalid alist containing ~S: ~S" pair alist)) + (unless (funcall test-not item (funcall key (cdr pair))) (return pair))))))) + +(defun *%saved-method-var%* () + (declare (special %saved-method-var%)) + %saved-method-var%) + +(defun set-*%saved-method-var%* (new-value) + (declare (special %saved-method-var%)) + (setq %saved-method-var% new-value)) + +(defsetf *%saved-method-var%* set-*%saved-method-var%*) + + + + + + +(setf (symbol-function 'clear-type-cache) #'false) ; bootstrapping + +(defun make-array-1 (dims element-type element-type-p + displaced-to + displaced-index-offset + adjustable + fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + size) + (let ((subtype (element-type-subtype element-type))) + (when (and element-type (null subtype)) + (error "Unknown element-type ~S" element-type)) + (when (null size) + (cond ((listp dims) + (setq size 1) + (dolist (dim dims) + (when (< dim 0) + (report-bad-arg dim '(integer 0 *))) + (setq size (* size dim)))) + (t (setq size dims)))) ; no need to check vs. array-dimension-limit + (cond + (displaced-to + (when (or initial-element-p initial-contents-p) + (error "Cannot specify initial values for displaced arrays")) + (when (and element-type-p + (neq (array-element-subtype displaced-to) subtype)) + (error "The ~S array ~S is not of ~S ~S" + :displaced-to displaced-to :element-type element-type)) + (%make-displaced-array dims displaced-to + fill-pointer adjustable displaced-index-offset t)) + (t + (when displaced-index-offset + (error "Cannot specify ~S for non-displaced-array" :displaced-index-offset)) + (when (null subtype) + (error "Cannot make an array of empty type ~S" element-type)) + (make-uarray-1 subtype dims adjustable fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + nil size))))) + +(defun %make-simple-array (subtype dims) + (let* ((size (if (listp dims) (apply #'* dims) dims)) + (vector (%alloc-misc size subtype))) + (if (and (listp dims) + (not (eql (length dims) 1))) + (let* ((array (%make-displaced-array dims vector))) + (%set-simple-array-p array) + array) + vector))) + +(defun make-uarray-1 (subtype dims adjustable fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + temporary + size) + (declare (ignore temporary)) + (when (null size)(setq size (if (listp dims)(apply #'* dims) dims))) + (let ((vector (%alloc-misc size subtype))) ; may not get here in that case + (if initial-element-p + (cond ((and (eql subtype target::subtag-simple-base-string) + (eql initial-element #\Null))) + ((and (eql subtype target::subtag-double-float-vector) + (eql initial-element 0.0d0))) + ((and (eql subtype target::subtag-single-float-vector) + (eql initial-element 0.0s0))) + (t (or (eql initial-element 0) + (%init-misc initial-element vector)))) + (if initial-contents-p + (if (null dims) (uvset vector 0 initial-contents) + (init-uvector-contents vector 0 dims initial-contents)))) + (if (and (null fill-pointer) + (not adjustable) + dims + (or (atom dims) (null (%cdr dims)))) + vector + (let ((array (%make-displaced-array dims vector + fill-pointer adjustable nil))) + (when (and (null fill-pointer) (not adjustable)) + (%set-simple-array-p array)) + array)))) + +(defun init-uvector-contents (vect offset dims contents + &aux (len (length contents))) + "Returns final offset. Assumes dims not ()." + (unless (eq len (if (atom dims) dims (%car dims))) + (error "~S doesn't match array dimensions of ~S ." contents vect)) + (cond ((or (atom dims) (null (%cdr dims))) + (if (listp contents) + (let ((contents-tail contents)) + (dotimes (i len) + (declare (fixnum i)) + (uvset vect offset (pop contents-tail)) + (setq offset (%i+ offset 1)))) + (dotimes (i len) + (declare (fixnum i)) + (uvset vect offset (elt contents i)) + (setq offset (%i+ offset 1))))) + (t (setq dims (%cdr dims)) + (if (listp contents) + (let ((contents-tail contents)) + (dotimes (i len) + (declare (fixnum i)) + (setq offset + (init-uvector-contents vect offset dims (pop contents-tail))))) + (dotimes (i len) + (declare (fixnum i)) + (setq offset + (init-uvector-contents vect offset dims (elt contents i))))))) + offset) + +(defun %get-signed-long-long (ptr &optional (offset 0)) + (%%get-signed-longlong ptr offset)) + +(defun %set-signed-long-long (ptr arg1 + &optional + (arg2 (prog1 arg1 (setq arg1 0)))) + (%%set-signed-longlong ptr arg1 arg2)) + +(defun %get-unsigned-long-long (ptr &optional (offset 0)) + (%%get-unsigned-longlong ptr offset)) + +(defun %set-unsigned-long-long (ptr arg1 + &optional + (arg2 (prog1 arg1 (setq arg1 0)))) + (%%set-unsigned-longlong ptr arg1 arg2)) + +(defun %composite-pointer-ref (size pointer offset) + (declare (ignorable size)) + (%inc-ptr pointer offset)) + +(defun %set-composite-pointer-ref (size pointer offset new) + (#_memmove (%inc-ptr pointer offset) + new + size)) + + +(defsetf %composite-pointer-ref %set-composite-pointer-ref) + + +(defsetf pathname-encoding-name set-pathname-encoding-name) + +;end of L1-utils.lisp + Index: /branches/qres/ccl/level-1/level-1.lisp =================================================================== --- /branches/qres/ccl/level-1/level-1.lisp (revision 13564) +++ /branches/qres/ccl/level-1/level-1.lisp (revision 13564) @@ -0,0 +1,107 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; Level-1.lisp + +(in-package "CCL") + +(macrolet ((l1-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./l1-fasls/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(%fasload ,namestring))) + (bin-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./bin/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(%fasload ,namestring)))) + + (l1-load "l1-cl-package") + (l1-load "l1-utils") + (l1-load "l1-init") + (l1-load "l1-symhash") + (l1-load "l1-numbers") + (l1-load "l1-aprims") + #+ppc-target + (l1-load "ppc-callback-support") + #+x86-target + (l1-load "x86-callback-support") + (l1-load "l1-callbacks") + (l1-load "l1-sort") + (bin-load "lists") + (bin-load "sequences") + (l1-load "l1-dcode") + (l1-load "l1-clos-boot") + (bin-load "hash") + (l1-load "l1-clos") + (bin-load "defstruct") + (bin-load "dll-node") + (l1-load "l1-unicode") + (l1-load "l1-streams") + (l1-load "linux-files") + (bin-load "chars") + (l1-load "l1-files") + (provide "SEQUENCES") + (provide "DEFSTRUCT") + (provide "CHARS") + (provide "LISTS") + (provide "DLL-NODE") + (l1-load "l1-typesys") + (l1-load "sysutils") + #+ppc-target + (l1-load "ppc-threads-utils") + #+x86-target + (l1-load "x86-threads-utils") + (l1-load "l1-lisp-threads") + (l1-load "l1-application") + (l1-load "l1-processes") + (l1-load "l1-io") + (l1-load "l1-reader") + (l1-load "l1-readloop") + (l1-load "l1-readloop-lds") + (l1-load "l1-error-system") + + (l1-load "l1-events") + #+ppc-target + (l1-load "ppc-trap-support") + #+x86-target + (l1-load "x86-trap-support") + (l1-load "l1-format") + (l1-load "l1-sysio") + (l1-load "l1-pathnames") + (l1-load "l1-boot-lds") + + (l1-load "l1-boot-1") + (l1-load "l1-boot-2") + (l1-load "l1-boot-3") + + ) + +(require "PREPARE-MCL-ENVIRONMENT") +(progn + (%set-toplevel #'(lambda () + (setq *loading-file-source-file* nil + *loading-toplevel-location* nil) + (toplevel-loop))) + (set-user-environment t) + (toplevel)) Index: /branches/qres/ccl/level-1/linux-files.lisp =================================================================== --- /branches/qres/ccl/level-1/linux-files.lisp (revision 13564) +++ /branches/qres/ccl/level-1/linux-files.lisp (revision 13564) @@ -0,0 +1,2386 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant unix-to-universal-time 2208988800) + +#+windows-target +(progn + + + + +(defun nbackslash-to-forward-slash (namestring) + (dotimes (i (length namestring) namestring) + (when (eql (schar namestring i) #\\) + (setf (schar namestring i) #\/)))) + +(defconstant univeral-time-start-in-windows-seconds 9435484800) + +(defun windows-filetime-to-universal-time (ft) + (let* ((100-ns (dpb (pref ft #>FILETIME.dwHighDateTime) (byte 32 32) + (pref ft #>FILETIME.dwLowDateTime))) + (seconds-since-windows-epoch (floor 100-ns 10000000))) + (- seconds-since-windows-epoch univeral-time-start-in-windows-seconds))) +) + +(defun get-foreign-namestring (pointer) + ;; On Darwin, foreign namestrings are encoded in UTF-8 and + ;; are canonically decomposed (NFD). Use PRECOMPOSE-SIMPLE-STRING + ;; to ensure that the string is "precomposed" (NFC), like the + ;; rest of the world and most sane people would expect. + #+darwin-target + (precompose-simple-string (%get-utf-8-cstring pointer)) + #+windows-target (nbackslash-to-forward-slash + (%get-native-utf-16-cstring pointer)) + ;; On some other platforms, the namestring is assumed to + ;; be encoded according to the current locale's character + ;; encoding (though FreeBSD seems to be moving towards + ;; precomposed UTF-8.). + #-(or darwin-target windows-target) + (let* ((encoding-name (pathname-encoding-name))) + (if encoding-name + (get-encoded-cstring encoding-name pointer) + (%get-cstring pointer)))) + +(defun nanoseconds (seconds) + (when (and (typep seconds 'fixnum) + (>= (the fixnum seconds) 0)) + (return-from nanoseconds (values seconds 0))) + (check-type seconds (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))) + (multiple-value-bind (q r) + (floor seconds) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000000000)))) + (values q r))) + +(defun milliseconds (seconds) + (when (and (typep seconds 'fixnum) + (>= (the fixnum seconds) 0)) + (return-from milliseconds (values seconds 0))) + (check-type seconds (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))) + (multiple-value-bind (q r) + (floor seconds) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000)))) + (values q r))) + +(defun microseconds (seconds) + (when (and (typep seconds 'fixnum) + (>= (the fixnum seconds) 0)) + (return-from microseconds (values seconds 0))) + (check-type seconds (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))) + (multiple-value-bind (q r) + (floor seconds) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000000)))) + (values q r))) + +(defun semaphore-value (s) + (if (istruct-typep s 'semaphore) + (semaphore.value s) + (semaphore-value (require-type s 'semaphore)))) + +(defun %wait-on-semaphore-ptr (s seconds milliseconds &optional flag) + (if flag + (if (istruct-typep flag 'semaphore-notification) + (setf (semaphore-notification.status flag) nil) + (report-bad-arg flag 'semaphore-notification))) + (without-interrupts + (let* ((status (ff-call + (%kernel-import target::kernel-import-wait-on-semaphore) + :address s + :unsigned seconds + :unsigned milliseconds + :signed)) + (result (zerop status))) + (declare (fixnum status)) + (when flag (setf (semaphore-notification.status flag) result)) + (values result status)))) + +(defun %process-wait-on-semaphore-ptr (s seconds milliseconds &optional + (whostate "semaphore wait") flag) + (or (%wait-on-semaphore-ptr s 0 0 flag) + (with-process-whostate (whostate) + (loop + (when (%wait-on-semaphore-ptr s seconds milliseconds flag) + (return)))))) + + +(defun wait-on-semaphore (s &optional flag (whostate "semaphore wait")) + "Wait until the given semaphore has a positive count which can be +atomically decremented." + (%process-wait-on-semaphore-ptr (semaphore-value s) #xffffff 0 whostate flag) + t) + + +(defun %timed-wait-on-semaphore-ptr (semptr duration notification) + (or (%wait-on-semaphore-ptr semptr 0 0 notification) + (with-process-whostate ("Semaphore timed wait") + (let* ((now (get-internal-real-time)) + (stop (+ now (floor (* duration internal-time-units-per-second))))) + (multiple-value-bind (secs millis) (milliseconds duration) + (loop + (multiple-value-bind (success err) + (progn + (%wait-on-semaphore-ptr semptr secs millis notification)) + (when success + (return t)) + (when (or (not (eql err #$EINTR)) + (>= (setq now (get-internal-real-time)) stop)) + (return nil)) + (unless (zerop duration) + (let* ((diff (- stop now))) + (multiple-value-bind (remaining-seconds remaining-itus) + (floor diff internal-time-units-per-second) + (setq secs remaining-seconds + millis (floor remaining-itus (/ internal-time-units-per-second 1000))))))))))))) + +(defun timed-wait-on-semaphore (s duration &optional notification) + "Wait until the given semaphore has a postive count which can be +atomically decremented, or until a timeout expires." + (%timed-wait-on-semaphore-ptr (semaphore-value s) duration notification)) + + +(defun %signal-semaphore-ptr (p) + (ff-call + (%kernel-import target::kernel-import-signal-semaphore) + :address p + :signed-fullword)) + +(defun signal-semaphore (s) + "Atomically increment the count of a given semaphore." + (%signal-semaphore-ptr (semaphore-value s))) + +(defun %os-getcwd (buf noctets) + ;; Return N < 0, if error + ;; N < noctets: success, string is of length N (octets). + ;; N >= noctets: buffer needs to be larger. + (let* ((p #+windows-target + (#__wgetcwd buf (ash noctets -1)) + #-windows-target + (#_getcwd buf noctets))) + (declare (dynamic-extent p)) + (if (%null-ptr-p p) + (let* ((err (%get-errno))) + (if (eql err (- #$ERANGE)) + (+ noctets noctets) + err)) + #+windows-target + (do* ((i 0 (+ i 2))) + ((= i noctets) (+ noctets noctets)) + (when (eql (%get-unsigned-word buf i) 0) + (return i))) + #-windows-target + (dotimes (i noctets (+ noctets noctets)) + (when (eql 0 (%get-byte buf i)) + (return i)))))) + +(defun temp-pathname () + "Return a suitable pathname for a temporary file. A different name is returned +each time this is called in a session. No file by that name existed when last +checked, though no guarantee is given that one hasn't been created since." + (native-to-pathname + #-windows-target (get-foreign-namestring (#_tmpnam (%null-ptr))) + #+windows-target (rlet ((buffer (:array :wchar_t #.#$MAX_PATH))) + (#_GetTempPathW #$MAX_PATH buffer) + (with-filename-cstrs ((c-prefix "ccl")) + (#_GetTempFileNameW buffer c-prefix 0 buffer) + (#_DeleteFileW buffer) + (%get-native-utf-16-cstring buffer))))) + +(defun current-directory-name () + "Look up the current working directory of the Clozure CL process; unless +it has been changed, this is the directory Clozure CL was started in." + (flet ((try-getting-dirname (bufsize) + (%stack-block ((buf bufsize)) + (let* ((len (%os-getcwd buf bufsize))) + (cond ((< len 0) (%errno-disp len)) + ((< len bufsize) + (setf (%get-unsigned-byte buf len) 0) + (values (get-foreign-namestring buf) len)) + (t (values nil len))))))) + (do* ((string nil) + (len #+windows-target 128 #-windows-target 64) + (bufsize len len)) + ((multiple-value-setq (string len) (try-getting-dirname bufsize)) + string)))) + + +(defun current-directory () + (mac-default-directory)) + +(defun (setf current-directory) (path) + (cwd path) + path) + +(defun cd (path) + (cwd path)) + + + + +(defun %chdir (dirname) + (with-filename-cstrs ((dirname dirname)) + (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname)))) + +(defun %mkdir (name mode) + #+windows-target (declare (ignore mode)) + (let* ((name name) + (len (length name))) + (when (and (> len 0) (eql (char name (1- len)) #\/)) + (setq name (subseq name 0 (1- len)))) + (with-filename-cstrs ((name name)) + (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir name #-windows-target mode))))) + +(defun %rmdir (name) + (let* ((last (1- (length name)))) + (with-filename-cstrs ((name name)) + (when (and (>= last 0) + (eql (%get-byte name last) (char-code #\/))) + (setf (%get-byte name last) 0)) + (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir name))))) + + +(defun getenv (key) + "Look up the value of the environment variable named by name, in the +OS environment." + (with-cstrs ((key (string key))) + (let* ((env-ptr (%null-ptr))) + (declare (dynamic-extent env-ptr)) + (%setf-macptr env-ptr (#_getenv key)) + (unless (%null-ptr-p env-ptr) + (%get-cstring env-ptr)))) + ) + +(defun setenv (key value &optional (overwrite t)) + "Set the value of the environment variable named by name, in the OS +environment. If there is no such environment variable, create it." + #+windows-target (declare (ignore overwrite)) + #-windows-target + (with-cstrs ((ckey key) + (cvalue value)) + (#_setenv ckey cvalue (if overwrite 1 0))) + #+windows-target + (with-cstrs ((pair (format nil "~a=~a" key value))) + (#__putenv pair)) + ) + +#-windows-target ; Windows "impersonation" crap ? +(defun setuid (uid) + "Attempt to change the current user ID (both real and effective); +fails unless the Clozure CL process has super-user privileges or the ID +given is that of the current user." + (int-errno-call (#_setuid uid))) + +#-windows-target +(defun setgid (uid) + "Attempt to change the current group ID (both real and effective); +fails unless the Clozure CL process has super-user privileges or the ID +given is that of a group to which the current user belongs." + (int-errno-call (#_setgid uid))) + + +;;; On Linux, "stat" & friends are implemented in terms of deeper, +;;; darker things that need to know what version of the stat buffer +;;; they're talking about. + +#-windows-target +(defun %stat-values (result stat) + (if (eql 0 (the fixnum result)) + (values + t + (pref stat :stat.st_mode) + (pref stat :stat.st_size) + #+(or linux-target solaris-target) + (pref stat :stat.st_mtim.tv_sec) + #-(or linux-target solaris-target) + (pref stat :stat.st_mtimespec.tv_sec) + (pref stat :stat.st_ino) + (pref stat :stat.st_uid) + (pref stat :stat.st_blksize) + #+(or linux-target solaris-target) + (round (pref stat :stat.st_mtim.tv_nsec) 1000) + #-(or linux-target solaris-target) + (round (pref stat :stat.st_mtimespec.tv_nsec) 1000) + (pref stat :stat.st_gid)) + (values nil nil nil nil nil nil nil))) + +#+win64-target +(defun %stat-values (result stat) + (if (eql 0 (the fixnum result)) + (values + t + (pref stat :_stat64.st_mode) + (pref stat :_stat64.st_size) + (pref stat :_stat64.st_mtime) + (pref stat :_stat64.st_ino) + (pref stat :_stat64.st_uid) + #$BUFSIZ + (pref stat :_stat64.st_mtime) ; ??? + (pref stat :_stat64.st_gid)) + (values nil nil nil nil nil nil nil nil nil))) + +#+win32-target +(defun %stat-values (result stat) + (if (eql 0 (the fixnum result)) + (values + t + (pref stat :__stat64.st_mode) + (pref stat :__stat64.st_size) + (pref stat :__stat64.st_mtime) + (pref stat :__stat64.st_ino) + (pref stat :__stat64.st_uid) + #$BUFSIZ + (pref stat :__stat64.st_mtime) ; ??? + (pref stat :__stat64.st_gid)) + (values nil nil nil nil nil nil nil nil nil))) + +#+windows-target +(defun windows-strip-trailing-slash (namestring) + (do* ((len (length namestring) (length namestring))) + ((<= len 3) namestring) + (let* ((p (1- len)) + (ch (char namestring p))) + (unless (or (eql ch #\\) + (eql ch #\/)) + (return namestring)) + (setq namestring (subseq namestring 0 p))))) + + +(defun %%stat (name stat) + (with-filename-cstrs ((cname #+windows-target (windows-strip-trailing-slash name) #-windows-target name)) + (%stat-values + #+linux-target + (#_ __xstat #$_STAT_VER_LINUX cname stat) + #-linux-target + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-stat) + :address cname + :address stat + :int) + stat))) + +(defun %%fstat (fd stat) + (%stat-values + #+linux-target + (#_ __fxstat #$_STAT_VER_LINUX fd stat) + #-linux-target + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fstat) + :int fd + :address stat + :int) + stat)) + +#-windows-target +(defun %%lstat (name stat) + (with-filename-cstrs ((cname name)) + (%stat-values + #+linux-target + (#_ __lxstat #$_STAT_VER_LINUX cname stat) + #-linux-target + (#_lstat cname stat) + stat))) + + +;;; Returns: (values t mode size mtime inode uid blksize) on success, +;;; (values nil nil nil nil nil nil nil) otherwise +;;; NAME should be a "native namestring", e.g,, have all lisp pathname +;;; escaping removed. +#-windows-target +(defun %stat (name &optional link-p) + (rlet ((stat :stat)) + (if link-p + (%%lstat name stat) + (%%stat name stat)))) + +#+windows-target +(defun %stat (name &optional link-p) + (declare (ignore link-p)) + (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64)) + (%%stat name stat))) + +(defun %fstat (fd) + (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat)) + (%%fstat fd stat))) + + +(defun %file-kind (mode &optional fd) + (declare (ignorable fd)) + (when mode + (let* ((kind (logand mode #$S_IFMT))) + (cond ((eql kind #$S_IFDIR) :directory) + ((eql kind #$S_IFREG) :file) + #-windows-target + ((eql kind #$S_IFLNK) :link) + ((eql kind #$S_IFIFO) + #-windows-target :pipe + ;; Windows doesn't seem to be able to distinguish between + ;; sockets and pipes. Since this function is currently + ;; (mostly) used for printing streams and since we've + ;; already done something fairly expensive (stat, fstat) + ;; to get here. try to distinguish between pipes and + ;; sockets by calling #_getsockopt. If that succeeds, + ;; we've got a socket; otherwise, we're probably got a pipe. + #+windows-target (rlet ((ptype :int) + (plen :int 4)) + (if (and fd (eql 0 (#_getsockopt fd #$SOL_SOCKET #$SO_TYPE ptype plen))) + :socket + :pipe))) + #-windows-target + ((eql kind #$S_IFSOCK) :socket) + ((eql kind #$S_IFCHR) :character-special) + (t :special))))) + +(defun %unix-file-kind (native-namestring &optional check-for-link) + (%file-kind (nth-value 1 (%stat native-namestring check-for-link)))) + +(defun %unix-fd-kind (fd) + (if (isatty fd) + :tty + (%file-kind (nth-value 1 (%fstat fd)) fd))) + +#-windows-target +(defun %uts-string (result idx buf) + (if (>= result 0) + (%get-cstring (%inc-ptr buf (* #+linux-target #$_UTSNAME_LENGTH + #+darwin-target #$_SYS_NAMELEN + #+(or freebsd-target solaris-target) #$SYS_NMLN + idx))) + "unknown")) + +#-windows-target +(defun copy-file-attributes (source-path dest-path) + "Copy the mode, owner, group and modification time of source-path to dest-path. + Returns T if succeeded, NIL if some of the attributes couldn't be copied due to + permission problems. Any other failures cause an error to be signalled" + (multiple-value-bind (win mode ignore mtime-sec ignore uid ignore mtime-usec gid) + (%stat (native-translated-namestring source-path) t) + (declare (ignore ignore)) + (unless win + (error "Cannot get attributes of ~s" source-path)) + (with-filename-cstrs ((cnamestr (native-translated-namestring dest-path))) + (macrolet ((errchk (form) + `(let ((err ,form)) + (unless (eql err 0) + (setq win nil) + (when (eql err -1) + (setq err (- (%get-errno)))) + (unless (eql err #$EPERM) (%errno-disp err dest-path)))))) + (errchk (#_chmod cnamestr mode)) + (errchk (%stack-block ((times (record-length (:array (:struct :timeval) 2)))) + (setf (pref times :timeval.tv_sec) mtime-sec) + (setf (pref times :timeval.tv_usec) mtime-usec) + (%incf-ptr times (record-length :timeval)) + (setf (pref times :timeval.tv_sec) mtime-sec) + (setf (pref times :timeval.tv_usec) mtime-usec) + (%incf-ptr times (- (record-length :timeval))) + (#_utimes cnamestr times))) + (errchk (#_chown cnamestr uid gid)))) + win)) + +#+windows-target +(defun copy-file-attributes (source-path dest-path) + "could at least copy the file times" + (declare (ignore source-path dest-path))) + + +#+linux-target +(defun %uname (idx) + (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) + (%uts-string (#_uname buf) idx buf))) + +#+darwin-target +(defun %uname (idx) + (%stack-block ((buf (* #$_SYS_NAMELEN 5))) + (%uts-string (#_uname buf) idx buf))) + +#+freebsd-target +(defun %uname (idx) + (%stack-block ((buf (* #$SYS_NMLN 5))) + (%uts-string (#___xuname #$SYS_NMLN buf) idx buf))) + +#+solaris-target +(defun %uname (idx) + (%stack-block ((buf (* #$SYS_NMLN 5))) + (%uts-string (#_uname buf) idx buf))) + +#-windows-target +(defun fd-dup (fd) + (int-errno-call (#_dup fd))) + +#+windows-target +(defun fd-dup (fd &key direction inheritable) + (declare (ignore direction)) + (rlet ((handle #>HANDLE)) + (if (eql 0 (#_DuplicateHandle (#_GetCurrentProcess) + (%int-to-ptr fd) + (#_GetCurrentProcess) + handle + 0 + (if inheritable #$TRUE #$FALSE) + #$DUPLICATE_SAME_ACCESS)) + (%windows-error-disp (#_GetLastError)) + (pref handle #>DWORD)))) + + +(defun fd-fsync (fd) + #+windows-target (#_FlushFileBuffers (%int-to-ptr fd)) + #-windows-target + (int-errno-call (#_fsync fd))) + +#-windows-target +(progn +(defun fd-get-flags (fd) + (int-errno-call (#_fcntl fd #$F_GETFL))) + +(defun fd-set-flags (fd new) + (int-errno-call (#_fcntl fd #$F_SETFL :int new))) + +(defun fd-set-flag (fd mask) + (let* ((old (fd-get-flags fd))) + (if (< old 0) + old + (fd-set-flags fd (logior old mask))))) + +(defun fd-clear-flag (fd mask) + (let* ((old (fd-get-flags fd))) + (if (< old 0) + old + (fd-set-flags fd (logandc2 old mask))))) +) + +;;; Assume that any quoting's been removed already. +(defun tilde-expand (namestring) + (let* ((len (length namestring))) + (if (or (zerop len) + (not (eql (schar namestring 0) #\~))) + namestring + (if (or (= len 1) + (eql (schar namestring 1) #\/)) + (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1))) + #+windows-target namestring + #-windows-target + (let* ((slash-pos (position #\/ namestring)) + (user-name (subseq namestring 1 slash-pos)) + (uid (or (get-uid-from-name user-name) + (error "Unknown user ~s in namestring ~s" user-name namestring)))) + (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/"))))))) + + +#+windows-target +(defun %windows-realpath (namestring) + (with-filename-cstrs ((path namestring)) + (do* ((bufsize 256)) + () + (%stack-block ((buf bufsize)) + (let* ((nchars (#_GetFullPathNameW path (ash bufsize -1) buf (%null-ptr)))) + (if (eql 0 nchars) + (return nil) + (let* ((max (+ nchars nchars 2))) + (if (> max bufsize) + (setq bufsize max) + (let* ((real (get-foreign-namestring buf))) + (return (and (%stat real) real))))))))))) + + +;;; This doesn't seem to exist on VxWorks. It's a POSIX +;;; function AFAIK, so the source should be somewhere ... + +(defun %realpath (namestring) + ;; It's not at all right to just return the namestring here. + (when (zerop (length namestring)) + (setq namestring (current-directory-name))) + #+windows-target (%windows-realpath namestring) + #-windows-target + (%stack-block ((resultbuf #$PATH_MAX)) + (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#)) + (let* ((result (#_realpath name resultbuf))) + (declare (dynamic-extent result)) + (unless (%null-ptr-p result) + (get-foreign-namestring result)))))) + +;;; Return fully resolved pathname & file kind, or (values nil nil) + +(defun %probe-file-x (namestring) + (let* ((realpath (%realpath namestring)) + (kind (if realpath (%unix-file-kind realpath)))) + (if kind + (values realpath kind) + (values nil nil)))) + +;;; The mingw headers define timeval.tv_sec and timeval.tv_usec to be +;;; signed 32-bit quantities. +(macrolet ((timeval-ref (ptr accessor) + #+windows-target `(logand #xfffffffff (pref ,ptr ,accessor)) + #-windows-target `(pref ,ptr ,accessor)) + (set-timeval-ref (ptr accessor new) + `(setf (pref ,ptr ,accessor) + #+windows-target (u32->s32 ,new) + #-windows-target ,new))) + +(defun timeval->milliseconds (tv) + (+ (* 1000 (timeval-ref tv :timeval.tv_sec)) (round (timeval-ref tv :timeval.tv_usec) 1000))) + +(defun timeval->microseconds (tv) + (+ (* 1000000 (timeval-ref tv :timeval.tv_sec)) (timeval-ref tv :timeval.tv_usec))) + +(defun %add-timevals (result a b) + (let* ((seconds (+ (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec))) + (micros (+ (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec)))) + (if (>= micros 1000000) + (setq seconds (1+ seconds) micros (- micros 1000000))) + (set-timeval-ref result :timeval.tv_sec seconds) + (set-timeval-ref result :timeval.tv_usec micros) + result)) + +(defun %sub-timevals (result a b) + (let* ((seconds (- (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec))) + (micros (- (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec)))) + (if (< micros 0) + (setq seconds (1- seconds) micros (+ micros 1000000))) + (set-timeval-ref result :timeval.tv_sec seconds) + (set-timeval-ref result :timeval.tv_usec micros) + result)) + +;;; Return T iff the time denoted by the timeval a is not later than the +;;; time denoted by the timeval b. +(defun %timeval<= (a b) + (let* ((asec (timeval-ref a :timeval.tv_sec)) + (bsec (timeval-ref b :timeval.tv_sec))) + (or (< asec bsec) + (and (= asec bsec) + (< (timeval-ref a :timeval.tv_usec) + (timeval-ref b :timeval.tv_usec)))))) + +); windows signed nonsense. + +#-windows-target +(defun %%rusage (usage &optional (who #$RUSAGE_SELF)) + (int-errno-call (#_getrusage who usage))) + + + + +(defun %file-write-date (namestring) + (let* ((date (nth-value 3 (%stat namestring)))) + (if date + (+ date unix-to-universal-time)))) + +#-windows-target +(defun %file-author (namestring) + (let* ((uid (nth-value 5 (%stat namestring)))) + (if uid + (with-macptrs ((pw (#_getpwuid uid))) + (unless (%null-ptr-p pw) + (without-interrupts + (%get-cstring (pref pw :passwd.pw_name)))))))) + +#+windows-target +(defun %file-author (namestring) + (declare (ignore namestring)) + nil) + +#-windows-target +(defun %utimes (namestring) + (with-filename-cstrs ((cnamestring namestring)) + (let* ((err (#_utimes cnamestring (%null-ptr)))) + (declare (fixnum err)) + (or (eql err 0) + (%errno-disp err namestring))))) + +#+windows-target +(defun %utimes (namestring) + (with-filename-cstrs ((cnamestring namestring)) + (let* ((handle (#_CreateFileW + cnamestring + #$FILE_WRITE_ATTRIBUTES + (logior #$FILE_SHARE_READ #$FILE_SHARE_WRITE) + (%null-ptr) + #$OPEN_EXISTING + #$FILE_FLAG_BACKUP_SEMANTICS + (%null-ptr)))) + (if (eql handle *windows-invalid-handle*) + (%windows-error-disp (#_GetLastError)) + (rlet ((st #>SYSTEMTIME) + (ft #>FILETIME)) + (#_GetSystemTime st) + (#_SystemTimeToFileTime st ft) + (let* ((result (#_SetFileTime handle (%null-ptr) (%null-ptr) ft)) + (err (when (eql 0 result) (#_GetLastError)))) + (#_CloseHandle handle) + (if err + (%windows-error-disp err) + t))))))) + + + + +#-windows-target +(defun get-uid-from-name (name) + (with-cstrs ((name name)) + (let* ((pwent (#_getpwnam name))) + (unless (%null-ptr-p pwent) + (pref pwent :passwd.pw_uid))))) + + +(defun isatty (fd) + #+windows-target (declare (ignore fd)) + #+windows-target nil + #-windows-target + (= 1 (#_isatty fd))) + +(defun %open-dir (namestring) + (with-filename-cstrs ((name namestring)) + (let* ((DIR (ff-call (%kernel-import target::kernel-import-lisp-opendir) + :address name + :address))) + (unless (%null-ptr-p DIR) + DIR)))) + +(defun close-dir (dir) + (ff-call (%kernel-import target::kernel-import-lisp-closedir) + :address dir + :int)) + +(defun %read-dir (dir) + (let* ((res (ff-call (%kernel-import target::kernel-import-lisp-readdir) + :address dir + :address))) + (unless (%null-ptr-p res) + (get-foreign-namestring (pref res + #+windows-target :_wdirent.d_name + #-windows-target :dirent.d_name))))) + + +#-windows-target +(defun tcgetpgrp (fd) + (#_tcgetpgrp fd)) + +(defun getpid () + "Return the ID of the Clozure CL OS process." + #-windows-target + (int-errno-call (#_getpid)) + #+windows-target (#_GetCurrentProcessId)) + + +(defun getuid () + "Return the (real) user ID of the current user." + #+windows-target 0 + #-windows-target (int-errno-call (#_getuid))) + +(defun get-user-home-dir (userid) + "Look up and return the defined home directory of the user identified +by uid. This value comes from the OS user database, not from the $HOME +environment variable. Returns NIL if there is no user with the ID uid." + #+windows-target + (declare (ignore userid)) + #+windows-target + (dolist (k '(#||"HOME"||# "USERPROFILE")) + (with-native-utf-16-cstrs ((key k)) + (let* ((p (#__wgetenv key))) + (unless (%null-ptr-p p) + (return (get-foreign-namestring p)))))) + #-windows-target + (rlet ((pwd :passwd) + (result :address pwd)) + (do* ((buflen 512 (* 2 buflen))) + () + (%stack-block ((buf buflen)) + (let* ((err + #-solaris-target + (#_getpwuid_r userid pwd buf buflen result) + #+solaris-target + (external-call "__posix_getpwuid_r" + :uid_t userid + :address pwd + :address buf + :int buflen + :address result + :int))) + (if (eql 0 err) + (let* ((rp (%get-ptr result)) + (dir (and (not (%null-ptr-p rp)) + (get-foreign-namestring (pref rp :passwd.pw_dir))))) + (return (if (and dir (eq (%unix-file-kind dir) :directory)) + dir))) + (unless (eql err #$ERANGE) + (return nil)))))))) + +(defun %delete-file (name) + (with-cstrs ((n name)) + (int-errno-call (#+windows-target #__unlink #-windows-target #_unlink n)))) + +(defun os-command (string) + "Invoke the Posix function system(), which invokes the user's default +system shell (such as sh or tcsh) as a new process, and has that shell +execute command-line. + +If the shell was able to find the command specified in command-line, then +exit-code is the exit code of that command. If not, it is the exit code +of the shell itself." + (with-cstrs ((s string)) + (#_system s))) + +(defun %strerror (errno) + (declare (fixnum errno)) + (if (< errno 0) + (setq errno (- errno))) + (with-macptrs (p) + (%setf-macptr p (#_strerror errno)) + (if (%null-ptr-p p) + (format nil "OS Error ~d" errno) + (%get-cstring p)))) + +#+windows-target +(defun %windows-error-string (error-number) + (rlet ((pbuffer :address (%null-ptr))) + (if (eql 0 + (#_FormatMessageW (logior #$FORMAT_MESSAGE_ALLOCATE_BUFFER + #$FORMAT_MESSAGE_FROM_SYSTEM + #$FORMAT_MESSAGE_IGNORE_INSERTS + #$FORMAT_MESSAGE_MAX_WIDTH_MASK) + (%null-ptr) + (abs error-number) + 0 ; default langid, more-or-less + pbuffer + 0 + (%null-ptr))) + (format nil "Windows error ~d" (abs error-number)) + (let* ((p (%get-ptr pbuffer)) + (q (%get-native-utf-16-cstring p))) + (#_LocalFree p) + q)))) + + + +;;; Kind of has something to do with files, and doesn't work in level-0. +#+(or linux-target freebsd-target solaris-target) +(defun close-shared-library (lib &key (completely t)) + "If completely is T, set the reference count of library to 0. Otherwise, +decrements it by 1. In either case, if the reference count becomes 0, +close-shared-library frees all memory resources consumed library and causes +any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved." + (let* ((lib (if (typep lib 'string) + (or (shared-library-with-name lib) + (error "Shared library ~s not found." lib)) + (require-type lib 'shlib))) + (handle (shlib.handle lib))) + (when handle + (let* ((found nil) + (base (shlib.base lib))) + (do* () + ((progn + (#_dlclose handle) + (or (not (setq found (shlib-containing-address base))) + (not completely))))) + (when (not found) + (setf (shlib.pathname lib) nil + (shlib.base lib) nil + (shlib.handle lib) nil + (shlib.map lib) nil) + (unload-foreign-variables lib) + (unload-library-entrypoints lib)))))) + +#+darwin-target +;; completely specifies whether to remove it totally from our list +(defun close-shared-library (lib &key (completely nil)) + "If completely is T, set the reference count of library to 0. Otherwise, +decrements it by 1. In either case, if the reference count becomes 0, +close-shared-library frees all memory resources consumed library and causes +any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved." + (let* ((lib (if (typep lib 'string) + (or (shared-library-with-name lib) + (error "Shared library ~s not found." lib)) + (require-type lib 'shlib)))) + ;; no possible danger closing libsystem since dylibs can't be closed + (cond + ((or (not (shlib.map lib)) (not (shlib.base lib))) + (error "Shared library ~s uninitialized." (shlib.soname lib))) + ((and (not (%null-ptr-p (shlib.map lib))) + (%null-ptr-p (shlib.base lib))) + (warn "Dynamic libraries cannot be closed on Darwin.")) + ((and (%null-ptr-p (shlib.map lib)) + (not (%null-ptr-p (shlib.base lib)))) + ;; we have a bundle type library not sure what to do with the + ;; completely flag when we open the same bundle more than once, + ;; Darwin gives back a new module address, so we have multiple + ;; entries on *shared-libraries* the best we can do is unlink + ;; the module asked for (or our best guess based on name) and + ;; invalidate any entries which refer to this container + (if (= 0 (#_NSUnLinkModule (shlib.base lib) #$NSUNLINKMODULE_OPTION_NONE)) + (error "Unable to close shared library, NSUnlinkModule failed.") + (progn + (setf (shlib.map lib) nil + (shlib.base lib) nil) + (unload-library-entrypoints lib) + (when completely + (setq *shared-libraries* (delete lib *shared-libraries*))))))))) + + + + +;;; Foreign (unix) processes. + +(defun call-with-string-vector (function strings) + (let ((bufsize (reduce #'+ strings + :key #'(lambda (s) (1+ (length (string s)))))) + (argvsize (ash (1+ (length strings)) target::word-shift)) + (bufpos 0) + (argvpos 0)) + (%stack-block ((buf bufsize) (argv argvsize)) + (flet ((init (s) + (multiple-value-bind (sstr start end) (get-sstring s) + (declare (fixnum start end)) + (let ((len (- end start))) + (declare (fixnum len)) + (do* ((i 0 (1+ i)) + (start start (1+ start)) + (bufpos bufpos (1+ bufpos))) + ((= i len)) + (setf (%get-unsigned-byte buf bufpos) + (logand #xff (%scharcode sstr start)))) + (setf (%get-byte buf (%i+ bufpos len)) 0) + (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos)) + (setq bufpos (%i+ bufpos len 1)) + (setq argvpos (%i+ argvpos target::node-size)))))) + (declare (dynamic-extent #'init)) + (map nil #'init strings)) + (setf (%get-ptr argv argvpos) (%null-ptr)) + (funcall function argv)))) + +(defmacro with-string-vector ((var strings) &body body) + `(call-with-string-vector #'(lambda (,var) ,@body) ,strings)) + +(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32) + +(defun pipe () + ;; (rlet ((filedes (:array :int 2))) + (%stack-block ((filedes 8)) + (let* ((status (ff-call (%kernel-import target::kernel-import-lisp-pipe) + :address filedes :int)) + (errno (if (eql status 0) 0 (%get-errno)))) + (unless (zerop status) + (when (or (eql errno (- #$EMFILE)) + (eql errno (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq status (ff-call (%kernel-import target::kernel-import-lisp-pipe) + :address filedes :int) + errno (if (zerop status) 0 (%get-errno))))) + (if (zerop status) + (values (paref filedes (:array :int) 0) (paref filedes (:array :int) 1)) + (%errno-disp errno))))) + +#-windows-target +(progn + (defun %execvp (argv) + (#_execvp (%get-ptr argv) argv) + (#_exit #$EX_OSERR)) + + (defun exec-with-io-redirection (new-in new-out new-err argv) + (#_setpgid 0 0) + (if new-in (#_dup2 new-in 0)) + (if new-out (#_dup2 new-out 1)) + (if new-err (#_dup2 new-err 2)) + (do* ((fd 3 (1+ fd))) + ((= fd *max-os-open-files*) (%execvp argv)) + (declare (fixnum fd)) + (#_close fd))) + + + + + + (defstruct external-process + pid + %status + %exit-code + pty + input + output + error + status-hook + plist + token + core + args + (signal (make-semaphore)) + (completed (make-semaphore)) + watched-fds + watched-streams + external-format + ) + + (defmethod print-object ((p external-process) stream) + (print-unreadable-object (p stream :type t :identity t) + (let* ((status (external-process-%status p))) + (let* ((*print-length* 3)) + (format stream "~a" (external-process-args p))) + (format stream "[~d] (~a" (external-process-pid p) status) + (unless (eq status :running) + (format stream " : ~d" (external-process-%exit-code p))) + (format stream ")")))) + + (defun get-descriptor-for (object proc close-in-parent close-on-error + &rest keys + &key direction (element-type 'character) + (sharing :private) + external-format + &allow-other-keys) + (etypecase object + ((eql t) + (values nil nil close-in-parent close-on-error)) + (null + (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null") + (fd (fd-open null-device (case direction + (:input #$O_RDONLY) + (:output #$O_WRONLY) + (t #$O_RDWR))))) + (if (< fd 0) + (signal-file-error fd null-device)) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) + ((eql :stream) + (multiple-value-bind (read-pipe write-pipe) (pipe) + (case direction + (:input + (values read-pipe + (make-fd-stream write-pipe + :direction :output + :element-type element-type + :interactive nil + :sharing sharing + :basic t + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons read-pipe close-in-parent) + (cons write-pipe close-on-error))) + (:output + (values write-pipe + (make-fd-stream read-pipe + :direction :input + :element-type element-type + :interactive nil + :basic t + :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error))) + (t + (fd-close read-pipe) + (fd-close write-pipe) + (report-bad-arg direction '(member :input :output)))))) + ((or pathname string) + (with-open-stream (file (apply #'open object keys)) + (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t))))) + (values fd + nil + (cons fd close-in-parent) + (cons fd close-on-error))))) + #|| + ;; What's an FD-STREAM ? + (fd-stream + (let ((fd (fd-dup (ioblock-device (stream-ioblock object t))))) + (values fd + nil + (cons fd close-in-parent) + (cons fd close-on-error)))) + ||# + (stream + (ecase direction + (:input + (with-cstrs ((template "/tmp/lisp-tempXXXXXX")) + (let* ((fd (#_mkstemp template))) + (if (< fd 0) + (%errno-disp fd)) + (#_unlink template) + (let* ((out (make-fd-stream (fd-dup fd) + :direction :output + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format)))) + (loop + (multiple-value-bind (line no-newline) + (read-line object nil nil) + (unless line + (return)) + (if no-newline + (write-string line out) + (write-line line out)))) + (close out)) + (fd-lseek fd 0 #$SEEK_SET) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))) + (:output + (multiple-value-bind (read-pipe write-pipe) (pipe) + (push read-pipe (external-process-watched-fds proc)) + (push object (external-process-watched-streams proc)) + (incf (car (external-process-token proc))) + (values write-pipe + nil + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error)))))))) + + (let* ((external-processes ()) + (external-processes-lock (make-lock))) + (defun add-external-process (p) + (with-lock-grabbed (external-processes-lock) + (push p external-processes))) + (defun remove-external-process (p) + (with-lock-grabbed (external-processes-lock) + (setq external-processes (delete p external-processes)))) + ;; Likewise + (defun external-processes () + (with-lock-grabbed (external-processes-lock) + (copy-list external-processes))) + ) + + + (defmacro wtermsig (status) + `(ldb (byte 7 0) ,status)) + + (defmacro wexitstatus (status) + `(ldb (byte 8 8) (the fixnum ,status))) + + (defmacro wstopsig (status) + `(wexitstatus ,status)) + + (defmacro wifexited (status) + `(eql (wtermsig ,status) 0)) + + (defmacro wifstopped (status) + `(eql #x7f (ldb (byte 7 0) (the fixnum ,status)))) + + (defun monitor-external-process (p) + (let* ((in-fds (external-process-watched-fds p)) + (out-streams (external-process-watched-streams p)) + (token (external-process-token p)) + (terminated) + (changed) + (maxfd 0) + (external-format (external-process-external-format p)) + (encoding (external-format-character-encoding external-format)) + (line-termination (external-format-line-termination external-format)) + (pairs (pairlis + (mapcar (lambda (fd) + (cons fd + (make-fd-stream fd + :direction :input + :sharing :private + :encoding encoding + :line-termination line-termination))) + in-fds) out-streams))) + (%stack-block ((in-fd-set *fd-set-size*)) + (rlet ((tv #>timeval)) + (loop + (when changed + (setq pairs (delete nil pairs :key #'car) + changed nil)) + (when (and terminated (null pairs)) + (signal-semaphore (external-process-completed p)) + (return)) + (when pairs + (fd-zero in-fd-set) + (setq maxfd 0) + (dolist (p pairs) + (let* ((fd (caar p))) + (when (> fd maxfd) + (setq maxfd fd)) + (fd-set fd in-fd-set))) + (setf (pref tv #>timeval.tv_sec) 1 + (pref tv #>timeval.tv_usec) 0) + (when (> (#_select (1+ maxfd) in-fd-set (%null-ptr) (%null-ptr) tv) + 0) + (dolist (p pairs) + (let* ((in-fd (caar p)) + (in-stream (cdar p)) + (out-stream (cdr p))) + (when (fd-is-set in-fd in-fd-set) + (let* ((buf (make-string 1024)) + (n (ignore-errors (read-sequence buf in-stream)))) + (declare (dynamic-extent buf)) + (if (or (null n) (eql n 0)) + (without-interrupts + (decf (car token)) + (close in-stream) + (setf (car p) nil changed t)) + (write-sequence buf out-stream :end n)))))))) + (let* ((statusflags (check-pid (external-process-pid p) + (logior + (if in-fds #$WNOHANG 0) + #$WUNTRACED))) + (oldstatus (external-process-%status p))) + (cond ((null statusflags) + (remove-external-process p) + (setq terminated t)) + ((eq statusflags t)) ; Running. + (t + (multiple-value-bind (status code core) + (cond ((wifstopped statusflags) + (values :stopped (wstopsig statusflags))) + ((wifexited statusflags) + (values :exited (wexitstatus statusflags))) + (t + (let* ((signal (wtermsig statusflags))) + (declare (fixnum signal)) + (values + (if (or (= signal #$SIGSTOP) + (= signal #$SIGTSTP) + (= signal #$SIGTTIN) + (= signal #$SIGTTOU)) + :stopped + :signaled) + signal + (logtest #-solaris-target #$WCOREFLAG + #+solaris-target #$WCOREFLG + statusflags))))) + (setf (external-process-%status p) status + (external-process-%exit-code p) code + (external-process-core p) core) + (let* ((status-hook (external-process-status-hook p))) + (when (and status-hook (not (eq oldstatus status))) + (funcall status-hook p))) + (when (or (eq status :exited) + (eq status :signaled)) + (remove-external-process p) + (setq terminated t))))))))))) + + (defun run-external-process (proc in-fd out-fd error-fd argv &optional env) + (let* ((signaled nil)) + (unwind-protect + (let* ((child-pid (#-solaris-target #_fork #+solaris-target #_forkall))) + (declare (fixnum child-pid)) + (cond ((zerop child-pid) + ;; Running in the child; do an exec + (setq signaled t) + (dolist (pair env) + (setenv (string (car pair)) (cdr pair))) + (without-interrupts + (exec-with-io-redirection + in-fd out-fd error-fd argv))) + ((> child-pid 0) + ;; Running in the parent: success + (setf (external-process-pid proc) child-pid) + (add-external-process proc) + (signal-semaphore (external-process-signal proc)) + (setq signaled t) + (monitor-external-process proc)) + (t + ;; Fork failed + (setf (external-process-%status proc) :error + (external-process-%exit-code proc) (%get-errno)) + (signal-semaphore (external-process-signal proc)) + (setq signaled t)))) + (unless signaled + (setf (external-process-%status proc) :error + (external-process-%exit-code proc) -1) + (signal-semaphore (external-process-signal proc)))))) + + (defparameter *silently-ignore-catastrophic-failure-in-run-program* + #+ccl-0711 t #-ccl-0711 nil + "If NIL, signal an error if run-program is unable to start the program. +If non-NIL, treat failure to start the same as failure from the program +itself, by setting the status and exit-code fields.") + + (defun run-program (program args &key + (wait t) pty + input if-input-does-not-exist + output (if-output-exists :error) + (error :output) (if-error-exists :error) + status-hook (element-type 'character) + env + (sharing :private) + (external-format `(:character-encoding ,*terminal-character-encoding-name*)) + (silently-ignore-catastrophic-failures + *silently-ignore-catastrophic-failure-in-run-program*)) + "Invoke an external program as an OS subprocess of lisp." + (declare (ignore pty)) + (unless (every #'(lambda (a) (typep a 'simple-string)) args) + (error "Program args must all be simple strings : ~s" args)) + (dolist (pair env) + (destructuring-bind (var . val) pair + (check-type var (or string symbol character)) + (check-type val string))) + (push (native-untranslated-namestring program) args) + (let* ((token (list 0)) + (in-fd nil) + (in-stream nil) + (out-fd nil) + (out-stream nil) + (error-fd nil) + (error-stream nil) + (close-in-parent nil) + (close-on-error nil) + (proc + (make-external-process + :pid nil + :args args + :%status :running + :input nil + :output nil + :error nil + :token token + :status-hook status-hook + :external-format (setq external-format (normalize-external-format t external-format))))) + (unwind-protect + (progn + (multiple-value-setq (in-fd in-stream close-in-parent close-on-error) + (get-descriptor-for input proc nil nil :direction :input + :if-does-not-exist if-input-does-not-exist + :element-type element-type + :sharing sharing + :external-format external-format)) + (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for output proc close-in-parent close-on-error + :direction :output + :if-exists if-output-exists + :element-type element-type + :sharing sharing + :external-format external-format)) + (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) + (if (eq error :output) + (values out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for error proc close-in-parent close-on-error + :direction :output + :if-exists if-error-exists + :sharing sharing + :element-type element-type + :external-format external-format))) + (setf (external-process-input proc) in-stream + (external-process-output proc) out-stream + (external-process-error proc) error-stream) + (call-with-string-vector + #'(lambda (argv) + (process-run-function + (list :name + (format nil "Monitor thread for external process ~a" args) + :stack-size (ash 128 10) + :vstack-size (ash 128 10) + :tstack-size (ash 128 10)) + #'run-external-process proc in-fd out-fd error-fd argv env) + (wait-on-semaphore (external-process-signal proc))) + args)) + (dolist (fd close-in-parent) (fd-close fd)) + (unless (external-process-pid proc) + (dolist (fd close-on-error) (fd-close fd))) + (when (and wait (external-process-pid proc)) + (with-interrupts-enabled + (wait-on-semaphore (external-process-completed proc))))) + (unless (external-process-pid proc) + ;; something is wrong + (if (eq (external-process-%status proc) :error) + ;; Fork failed + (unless silently-ignore-catastrophic-failures + (cerror "Pretend the program ran and failed" 'external-process-creation-failure :proc proc)) + ;; Currently can't happen. + (error "Bug: fork failed but status field not set?"))) + proc)) + + + + (defmacro wifsignaled (status) + (let* ((statname (gensym))) + `(let* ((,statname ,status)) + (and (not (wifstopped ,statname)) (not (wifexited ,statname)))))) + + + (defun check-pid (pid &optional (flags (logior #$WNOHANG #$WUNTRACED))) + (declare (fixnum pid)) + (rlet ((status :signed)) + (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags)))) + (declare (fixnum retval)) + (if (= retval pid) + (pref status :signed) + (zerop retval))))) + + + + + + (defun external-process-wait (proc &optional check-stopped) + (process-wait "external-process-wait" + #'(lambda () + (case (external-process-%status proc) + (:running) + (:stopped + (when check-stopped + t)) + (t + (when (zerop (car (external-process-token proc))) + t)))))) + + + + + + (defun external-process-error-stream (proc) + "Return the stream which is used to read error output from a given OS +subprocess, if it has one." + (require-type proc 'external-process) + (external-process-error proc)) + + + + (defun signal-external-process (proc signal) + "Send the specified signal to the specified external process. (Typically, +it would only be useful to call this function if the EXTERNAL-PROCESS was +created with :WAIT NIL.) Return T if successful; NIL if the process wasn't +created successfully, and signal an error otherwise." + (require-type proc 'external-process) + (let* ((pid (external-process-pid proc))) + (when pid + (let ((error (int-errno-call (#_kill pid signal)))) + (or (eql error 0) + (%errno-disp error)))))) + + ) ; #-windows-target (progn + +#+windows-target +(progn + (defun temp-file-name (prefix) + "Returns a unique name for a temporary file, residing in system temp +space, and prefixed with PREFIX." + (rlet ((buffer (:array :wchar_t #.#$MAX_PATH))) + (#_GetTempPathW #$MAX_PATH buffer) + (with-filename-cstrs ((c-prefix prefix)) + (#_GetTempFileNameW buffer c-prefix 0 buffer) + (%get-native-utf-16-cstring buffer)))) + + (defun get-descriptor-for (object proc close-in-parent close-on-error + &rest keys + &key + direction (element-type 'character) + (sharing :private) + external-format + &allow-other-keys) + (etypecase object + ((eql t) + (values nil nil close-in-parent close-on-error)) + (null + (let* ((null-device "nul") + (fd (fd-open null-device (case direction + (:input #$O_RDONLY) + (:output #$O_WRONLY) + (t #$O_RDWR))))) + (if (< fd 0) + (signal-file-error fd null-device)) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) + ((eql :stream) + (multiple-value-bind (read-pipe write-pipe) (pipe) + (case direction + (:input + (values read-pipe + (make-fd-stream (fd-uninheritable write-pipe :direction :output) + :direction :output + :element-type element-type + :interactive nil + :basic t + :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons read-pipe close-in-parent) + (cons write-pipe close-on-error))) + (:output + (values write-pipe + (make-fd-stream (fd-uninheritable read-pipe :direction :input) + :direction :input + :element-type element-type + :interactive nil + :basic t + :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error))) + (t + (fd-close read-pipe) + (fd-close write-pipe) + (report-bad-arg direction '(member :input :output)))))) + ((or pathname string) + (with-open-stream (file (apply #'open object keys)) + (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t))) + (values fd + nil + (cons fd close-in-parent) + (cons fd close-on-error))))) + (stream + (ecase direction + (:input + (let* ((tempname (temp-file-name "lisp-temp")) + (fd (fd-open tempname #$O_RDWR))) + (if (< fd 0) + (%errno-disp fd)) + (let* ((out (make-fd-stream (fd-dup fd) + :direction :output + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format)))) + (loop + (multiple-value-bind (line no-newline) + (read-line object nil nil) + (unless line + (return)) + (if no-newline + (write-string line out) + (write-line line out)) + )) + (close out)) + (fd-lseek fd 0 #$SEEK_SET) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) + (:output + (multiple-value-bind (read-pipe write-pipe) (pipe) + (push read-pipe (external-process-watched-fds proc)) + (push object (external-process-watched-streams proc)) + (incf (car (external-process-token proc))) + (values write-pipe + nil + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error)))))))) + + (defstruct external-process + pid + %status + %exit-code + pty + input + output + error + status-hook + plist + token + core + args + (signal (make-semaphore)) + (completed (make-semaphore)) + watched-fds + watched-streams + external-format + ) + + + + (defmethod print-object ((p external-process) stream) + (print-unreadable-object (p stream :type t :identity t) + (let* ((status (external-process-%status p))) + (let* ((*print-length* 3)) + (format stream "~a" (external-process-args p))) + (format stream "[~d] (~a" (external-process-pid p) status) + (unless (eq status :running) + (format stream " : ~d" (external-process-%exit-code p))) + (format stream ")")))) + + (defun run-program (program args &key + (wait t) pty + input if-input-does-not-exist + output (if-output-exists :error) + (error :output) (if-error-exists :error) + status-hook (element-type 'character) + (sharing :private) + (external-format `(:character-encoding ,*terminal-character-encoding-name* :line-termination :crlf)) + env) + "Invoke an external program as an OS subprocess of lisp." + (declare (ignore pty)) + (unless (every #'(lambda (a) (typep a 'simple-string)) args) + (error "Program args must all be simple strings : ~s" args)) + (push program args) + (let* ((token (list 0)) + (in-fd nil) + (in-stream nil) + (out-fd nil) + (out-stream nil) + (error-fd nil) + (error-stream nil) + (close-in-parent nil) + (close-on-error nil) + (proc + (make-external-process + :pid nil + :args args + :%status :running + :input nil + :output nil + :error nil + :token token + :external-format (setq external-format (normalize-external-format t external-format)) + :status-hook status-hook))) + (unwind-protect + (progn + (multiple-value-setq (in-fd in-stream close-in-parent close-on-error) + (get-descriptor-for input proc nil nil :direction :input + :if-does-not-exist if-input-does-not-exist + :sharing sharing + :element-type element-type + :external-format external-format)) + (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for output proc close-in-parent close-on-error + :direction :output + :if-exists if-output-exists + :sharing sharing + :element-type element-type + :external-format external-format)) + (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) + (if (eq error :output) + (values out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for error proc close-in-parent close-on-error + :direction :output + :if-exists if-error-exists + :sharing sharing + :element-type element-type + :external-format external-format))) + (setf (external-process-input proc) in-stream + (external-process-output proc) out-stream + (external-process-error proc) error-stream) + (process-run-function + (format nil "Monitor thread for external process ~a" args) + + #'run-external-process proc in-fd out-fd error-fd env) + (wait-on-semaphore (external-process-signal proc)) + ) + (dolist (fd close-in-parent) (fd-close fd)) + (if (external-process-pid proc) + (when (and wait (external-process-pid proc)) + (with-interrupts-enabled + (wait-on-semaphore (external-process-completed proc)))) + (progn + (dolist (fd close-on-error) (fd-close fd))))) + proc)) + + (let* ((external-processes ()) + (external-processes-lock (make-lock))) + (defun add-external-process (p) + (with-lock-grabbed (external-processes-lock) + (push p external-processes))) + (defun remove-external-process (p) + (with-lock-grabbed (external-processes-lock) + (setq external-processes (delete p external-processes)))) + ;; Likewise + (defun external-processes () + (with-lock-grabbed (external-processes-lock) + (copy-list external-processes))) + ) + + + + + (defun run-external-process (proc in-fd out-fd error-fd &optional env) + (let* ((args (external-process-args proc)) + (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env))) + (when child-pid + (setf (external-process-pid proc) child-pid) + (add-external-process proc) + (signal-semaphore (external-process-signal proc)) + (monitor-external-process proc)))) + + (defun join-strings (strings) + (reduce (lambda (left right) (concatenate 'string left " " right)) strings)) + + (defun create-windows-process (new-in new-out new-err cmdstring env) + (declare (ignore env)) ; until we can do better. + (with-filename-cstrs ((command cmdstring)) + (rletz ((proc-info #>PROCESS_INFORMATION) + (si #>STARTUPINFO)) + (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO)) + (setf (pref si #>STARTUPINFO.dwFlags) + (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW)) + (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE) + (setf (pref si #>STARTUPINFO.hStdInput) + (if new-in + (%int-to-ptr new-in) + (#_GetStdHandle #$STD_INPUT_HANDLE))) + (setf (pref si #>STARTUPINFO.hStdOutput) + (if new-out + (%int-to-ptr new-out) + (#_GetStdHandle #$STD_OUTPUT_HANDLE))) + (setf (pref si #>STARTUPINFO.hStdError) + (if new-err + (%int-to-ptr new-err) + (#_GetStdHandle #$STD_ERROR_HANDLE))) + (if (zerop (#_CreateProcessW (%null-ptr) + command + (%null-ptr) + (%null-ptr) + 1 + #$CREATE_NEW_CONSOLE + (%null-ptr) + (%null-ptr) + si + proc-info)) + (values nil (#_GetLastError)) + (progn + (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)) + (values t (pref proc-info #>PROCESS_INFORMATION.hProcess))))))) + + (defun exec-with-io-redirection (new-in new-out new-err args proc &optional env) + (multiple-value-bind (win handle-to-process-or-error) + (create-windows-process new-in new-out new-err (join-strings args) env) + (if win + handle-to-process-or-error + (progn + (setf (external-process-%status proc) :error + (external-process-%exit-code proc) handle-to-process-or-error) + (signal-semaphore (external-process-signal proc)) + (signal-semaphore (external-process-completed proc)) + nil)))) + + (defun fd-uninheritable (fd &key direction) + (let ((new-fd (fd-dup fd :direction direction))) + (fd-close fd) + new-fd)) + + + (defun data-available-on-pipe-p (hpipe) + (rlet ((navail #>DWORD 0)) + (unless (eql 0 (#_PeekNamedPipe (if (typep hpipe 'macptr) + hpipe + (%int-to-ptr hpipe)) + (%null-ptr) + 0 + (%null-ptr) + navail + (%null-ptr))) + (not (eql 0 (pref navail #>DWORD)))))) + + + ;;; There doesn't seem to be any way to wait on input from an + ;;; anonymous pipe in Windows (that would, after all, make too + ;;; much sense.) We -can- check for pending unread data on + ;;; pipes, and can expect to eventually get EOF on a pipe. + ;;; So, this tries to loop until the process handle is signaled and + ;;; all data has been read. + (defun monitor-external-process (p) + (let* ((in-fds (external-process-watched-fds p)) + (out-streams (external-process-watched-streams p)) + (token (external-process-token p)) + (terminated) + (changed) + (external-format (external-process-external-format p)) + (encoding (external-format-character-encoding external-format)) + (line-termination (external-format-line-termination external-format)) + (pairs (pairlis (mapcar (lambda (fd) + (cons fd + (make-fd-stream fd + :direction :input + :sharing :private + :encoding encoding + :line-termination line-termination))) + in-fds) + out-streams)) + ) + (loop + (when changed + (setq pairs (delete nil pairs :key #'car) + changed nil)) + (when (and terminated (null pairs)) + (without-interrupts + (rlet ((code #>DWORD)) + (loop + (#_GetExitCodeProcess (external-process-pid p) code) + (unless (eql (pref code #>DWORD) #$STILL_ACTIVE) + (return)) + (#_SleepEx 10 #$TRUE)) + (setf (external-process-%exit-code p) (pref code #>DWORD))) + (#_CloseHandle (external-process-pid p)) + (setf (external-process-pid p) nil) + (setf (external-process-%status p) :exited) + (let ((status-hook (external-process-status-hook p))) + (when status-hook + (funcall status-hook p))) + (remove-external-process p) + (signal-semaphore (external-process-completed p)) + (return))) + (dolist (p pairs) + (let* ((in-fd (caar p)) + (in-stream (cdar p)) + (out-stream (cdr p))) + (when (or terminated (data-available-on-pipe-p in-fd)) + (let* ((buf (make-string 1024))) + (declare (dynamic-extent buf)) + (let* ((n (ignore-errors (read-sequence buf in-stream)))) + (if (or (null n) (eql n 0)) + (progn + (without-interrupts + (decf (car token)) + (fd-close in-fd) + (setf (car p) nil changed t))) + (progn + (write-sequence buf out-stream :end n) + (force-output out-stream)))))))) + (unless terminated + (setq terminated (eql (#_WaitForSingleObjectEx + (external-process-pid p) + 1000 + #$true) + #$WAIT_OBJECT_0)))))) + + + (defun signal-external-process (proc signal) + "Does nothing on Windows" + (declare (ignore signal)) + (require-type proc 'external-process) + nil) + + + ) + ;#+windows-target (progn + + +(defun external-process-input-stream (proc) + "Return the lisp stream which is used to write input to a given OS +subprocess, if it has one." + (require-type proc 'external-process) + (external-process-input proc)) + +(defun external-process-output-stream (proc) + "Return the lisp stream which is used to read output from a given OS +subprocess, if there is one." + (require-type proc 'external-process) + (external-process-output proc)) + + +(defun external-process-id (proc) + "Return the process id of an OS subprocess, a positive integer which +identifies it." + (require-type proc 'external-process) + (external-process-pid proc)) + +(defun external-process-status (proc) + "Return information about whether an OS subprocess is running; or, if +not, why not; and what its result code was if it completed." + (require-type proc 'external-process) + (values (external-process-%status proc) + (external-process-%exit-code proc))) + +;;; EOF on a TTY is transient, but I'm less sure of other cases. +(defun eof-transient-p (fd) + (case (%unix-fd-kind fd) + (:tty t) + #+windows-target (:character-special t) + (t nil))) + + +(defstruct (shared-resource (:constructor make-shared-resource (name))) + (name) + (lock (make-lock)) + (primary-owner *current-process*) + (primary-owner-notify (make-semaphore)) + (current-owner nil) + (requestors (make-dll-header))) + +(defstruct (shared-resource-request + (:constructor make-shared-resource-request (process)) + (:include dll-node)) + process + (signal (make-semaphore))) + + +;; Returns NIL if already owned by calling thread, T otherwise +(defun %acquire-shared-resource (resource &optional verbose) + (let* ((current *current-process*)) + (with-lock-grabbed ((shared-resource-lock resource)) + (let* ((secondary (shared-resource-current-owner resource))) + (if (or (eq current secondary) + (and (null secondary) + (eq current (shared-resource-primary-owner resource)))) + (return-from %acquire-shared-resource nil)))) + (let* ((request (make-shared-resource-request *current-process*))) + (when verbose + (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;; Type (:y ~D) to yield control to this thread.~%;;;~%" + *current-process* (shared-resource-name resource) + (process-serial-number *current-process*))) + (with-lock-grabbed ((shared-resource-lock resource)) + (append-dll-node request (shared-resource-requestors resource))) + (wait-on-semaphore (shared-resource-request-signal request)) + (assert (eq current (shared-resource-current-owner resource))) + (when verbose + (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%" + (shared-resource-name resource) current)) + t))) + +;;; If we're the primary owner and there is no secondary owner, do nothing. +;;; If we're the secondary owner, cease being the secondary owner. +(defun %release-shared-resource (r) + (let* ((not-any-owner ())) + (with-lock-grabbed ((shared-resource-lock r)) + (let* ((current *current-process*) + (primary (shared-resource-primary-owner r)) + (secondary (shared-resource-current-owner r))) + (unless (setq not-any-owner + (not (or (eq current secondary) + (and (null secondary) + (eq current primary))))) + (when (eq current secondary) + (setf (shared-resource-current-owner r) nil) + (signal-semaphore (shared-resource-primary-owner-notify r)))))) + (when not-any-owner + (signal-program-error "Process ~a does not own ~a" *current-process* + (shared-resource-name r))))) + +;;; The current thread should be the primary owner; there should be +;;; no secondary owner. Wakeup the specified (or first) requesting +;;; process, then block on our semaphore +(defun %yield-shared-resource (r &optional to) + (let* ((request nil)) + (with-lock-grabbed ((shared-resource-lock r)) + (let* ((current *current-process*) + (primary (shared-resource-primary-owner r))) + (when (and (eq current primary) + (null (shared-resource-current-owner r))) + (setq request + (let* ((header (shared-resource-requestors r))) + (if to + (do-dll-nodes (node header) + (when (eq to (shared-resource-request-process node)) + (return node))) + (let* ((first (dll-header-first header))) + (unless (eq first header) + first))))) + (when request + (remove-dll-node request) + (setf (shared-resource-current-owner r) + (shared-resource-request-process request)) + (signal-semaphore (shared-resource-request-signal request)))))) + (when request + (wait-on-semaphore (shared-resource-primary-owner-notify r)) + (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&" + (shared-resource-name r) + *current-process*)))) + + + + +(defun %shared-resource-requestor-p (r proc) + (with-lock-grabbed ((shared-resource-lock r)) + (do-dll-nodes (node (shared-resource-requestors r)) + (when (eq proc (shared-resource-request-process node)) + (return t))))) + +(defparameter *resident-editor-hook* nil + "If non-NIL, should be a function that takes an optional argument + (like ED) and invokes a \"resident\" editor.") + +(defun ed (&optional arg) + (if *resident-editor-hook* + (funcall *resident-editor-hook* arg) + (error "This implementation doesn't provide a resident editor."))) + +(defun running-under-emacs-p () + (not (null (getenv "EMACS")))) + +(defloadvar *cpu-count* nil) + +(defun cpu-count () + (or *cpu-count* + (setq *cpu-count* + #+darwin-target + (rlet ((info :host_basic_info) + (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT)) + (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self) + #$HOST_BASIC_INFO + info + count)) + (pref info :host_basic_info.max_cpus) + 1)) + #+(or linux-target solaris-target) + (or + (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN))) + (declare (fixnum n)) + (if (> n 0) n)) + #+linux-target + (ignore-errors + (with-open-file (p "/proc/cpuinfo") + (let* ((ncpu 0) + (match "processor") + (matchlen (length match))) + (do* ((line (read-line p nil nil) (read-line p nil nil))) + ((null line) ncpu) + (let* ((line-length (length line))) + (when (and + (> line-length matchlen) + (string= match line + :end2 matchlen) + (whitespacep (schar line matchlen))) + (incf ncpu))))))) + 1) + #+freebsd-target + (rlet ((ret :uint)) + (%stack-block ((mib (* (record-length :uint) 2))) + (setf (paref mib (:array :uint) 0) + #$CTL_HW + (paref mib (:array :uint) 1) + #$HW_NCPU) + (rlet ((oldsize :uint (record-length :uint))) + (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0)) + (pref ret :uint) + 1)))) + #+windows-target + (rlet ((procmask #>DWORD_PTR) + (sysmask #>DWORD_PTR)) + (if (eql 0 (#_GetProcessAffinityMask (#_GetCurrentProcess) procmask sysmask)) + 1 + (logcount (pref sysmask #>DWORD_PTR))))))) + +(def-load-pointers spin-count () + (if (eql 1 (cpu-count)) + (%defglobal '*spin-lock-tries* 1) + (%defglobal '*spin-lock-tries* 1024)) + (%defglobal '*spin-lock-timeouts* 0)) + +(defun yield () + (process-allow-schedule)) + +(defloadvar *host-page-size* + #-windows-target (#_getpagesize) + #+windows-target + (rlet ((info #>SYSTEM_INFO)) + (#_GetSystemInfo info) + (pref info #>SYSTEM_INFO.dwPageSize)) + ) + +;;(assert (= (logcount *host-page-size*) 1)) + +(defun get-universal-time () + "Return a single integer for the current time of + day in universal time format." + (rlet ((tv :timeval)) + (gettimeofday tv) + (+ (pref tv :timeval.tv_sec) unix-to-universal-time))) + +#+windows-target +(defloadvar *windows-allocation-granularity* + (rlet ((info #>SYSTEM_INFO)) + (#_GetSystemInfo info) + (pref info #>SYSTEM_INFO.dwAllocationGranularity))) + +#-windows-target +(defun %memory-map-fd (fd len bits-per-element) + (let* ((nbytes (+ *host-page-size* + (logandc2 (+ len + (1- *host-page-size*)) + (1- *host-page-size*)))) + (ndata-elements + (ash len + (ecase bits-per-element + (1 3) + (8 0) + (16 -1) + (32 -2) + (64 -3)))) + (nalignment-elements + (ash target::nbits-in-word + (ecase bits-per-element + (1 0) + (8 -3) + (16 -4) + (32 -5) + (64 -6))))) + (if (>= (+ ndata-elements nalignment-elements) + array-total-size-limit) + (progn + (fd-close fd) + (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements))) + (let* ((addr (#_mmap (%null-ptr) + nbytes + #$PROT_NONE + (logior #$MAP_ANON #$MAP_PRIVATE) + -1 + 0))) + (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED + (let* ((errno (%get-errno))) + (fd-close fd) + (error "Can't map ~d bytes: ~a" nbytes (%strerror errno))) + ;;; Remap the first page so that we can put a vector header + ;;; there; use the first word on the first page to remember + ;;; the file descriptor. + (progn + (#_mmap addr + *host-page-size* + (logior #$PROT_READ #$PROT_WRITE) + (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED) + -1 + 0) + (setf (pref addr :int) fd) + (let* ((header-addr (%inc-ptr addr (- *host-page-size* + (* 2 target::node-size))))) + + (when (> len 0) + (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size)))) + (unless (eql target-addr + (#_mmap target-addr + len + #$PROT_READ + (logior #$MAP_PRIVATE #$MAP_FIXED) + fd + 0)) + (let* ((errno (%get-errno))) + (fd-close fd) + (#_munmap addr nbytes) + (error "Mapping failed: ~a" (%strerror errno)))))) + (values header-addr ndata-elements nalignment-elements)))))))) + +#+windows-target +(defun %memory-map-fd (fd len bits-per-element) + (let* ((nbytes (+ *windows-allocation-granularity* + (logandc2 (+ len + (1- *windows-allocation-granularity*)) + (1- *windows-allocation-granularity*)))) + (ndata-elements + (ash len + (ecase bits-per-element + (1 3) + (8 0) + (16 -1) + (32 -2) + (64 -3)))) + (nalignment-elements + (ash target::nbits-in-word + (ecase bits-per-element + (1 0) + (8 -3) + (16 -4) + (32 -5) + (64 -6))))) + (if (>= (+ ndata-elements nalignment-elements) + array-total-size-limit) + (progn + (fd-close fd) + (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements))) + (let* ((mapping (#_CreateFileMappingA (%int-to-ptr fd) (%null-ptr) #$PAGE_READONLY 0 0 (%null-ptr)))) + (if (%null-ptr-p mapping) + (let* ((err (#_GetLastError))) + (fd-close fd) + (error "Couldn't create a file mapping - ~a." (%windows-error-string err))) + (loop + (let* ((base (#_VirtualAlloc (%null-ptr) nbytes #$MEM_RESERVE #$PAGE_NOACCESS))) + (if (%null-ptr-p base) + (let* ((err (#_GetLastError))) + (#_CloseHandle mapping) + (fd-close fd) + (error "Couldn't reserve ~d bytes of address space for mapped file - ~a" + nbytes (%windows-error-string err))) + ;; Now we have to free the memory and hope that we can reallocate it ... + (progn + (#_VirtualFree base 0 #$MEM_RELEASE) + (unless (%null-ptr-p (#_VirtualAlloc base *windows-allocation-granularity* #$MEM_RESERVE #$PAGE_NOACCESS)) + (let* ((fptr (%inc-ptr base *windows-allocation-granularity*))) + (if (%null-ptr-p (#_MapViewOfFileEx mapping #$FILE_MAP_READ 0 0 0 fptr)) + (#_VirtualFree base 0 #$MEM_RELEASE) + (let* ((prefix-page (%inc-ptr base (- *windows-allocation-granularity* + *host-page-size*)))) + (#_VirtualAlloc prefix-page *host-page-size* #$MEM_COMMIT #$PAGE_READWRITE) + (setf (paref prefix-page (:* :address) 0) mapping + (paref prefix-page (:* :address) 1) (%int-to-ptr fd)) + (return (values + (%inc-ptr prefix-page (- *host-page-size* + (* 2 target::node-size))) + ndata-elements + nalignment-elements))))))))))))))) + + + +(defun map-file-to-ivector (pathname element-type) + (let* ((upgraded-type (upgraded-array-element-type element-type)) + (upgraded-ctype (specifier-type upgraded-type))) + (unless (and (typep upgraded-ctype 'numeric-ctype) + (eq 'integer (numeric-ctype-class upgraded-ctype))) + (error "Invalid element-type: ~s" element-type)) + (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype) + (numeric-ctype-low upgraded-ctype)))) + (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY))) + (if (< fd 0) + (signal-file-error fd pathname) + (let* ((len (fd-size fd))) + (if (< len 0) + (signal-file-error fd pathname) + (multiple-value-bind (header-address ndata-elements nalignment-elements) + (%memory-map-fd fd len bits-per-element) + (setf (%get-natural header-address 0) + (logior (element-type-subtype upgraded-type) + (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits))) + (with-macptrs ((v (%inc-ptr header-address target::fulltag-misc))) + (let* ((vector (rlet ((p :address v)) (%get-object p 0)))) + ;; Tell some parts of Clozure CL - notably the + ;; printer - that this thing off in foreign + ;; memory is a real lisp object and not + ;; "bogus". + (with-lock-grabbed (*heap-ivector-lock*) + (push vector *heap-ivectors*)) + (make-array ndata-elements + :element-type upgraded-type + :displaced-to vector + :adjustable t + :displaced-index-offset nalignment-elements)))))))))) + +(defun map-file-to-octet-vector (pathname) + (map-file-to-ivector pathname '(unsigned-byte 8))) + +(defun mapped-vector-data-address-and-size (displaced-vector) + (let* ((v (array-displacement displaced-vector)) + (element-type (array-element-type displaced-vector))) + (if (or (eq v displaced-vector) + (not (with-lock-grabbed (*heap-ivector-lock*) + (member v *heap-ivectors*)))) + (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector)) + (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address))) + (ctype (specifier-type element-type)) + (arch (backend-target-arch *target-backend*))) + (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc)) + (- (funcall (arch::target-array-data-size-function arch) + (ctype-subtype ctype) + (length v)) + target::node-size))))) + + +#-windows-target +(defun %unmap-file (data-address size-in-octets) + (let* ((base-address (%inc-ptr data-address (- *host-page-size*))) + (fd (pref base-address :int))) + (#_munmap base-address (+ *host-page-size* size-in-octets)) + (fd-close fd))) + +#+windows-target +(defun %unmap-file (data-address size-in-octets) + (declare (ignore size-in-octets)) + (let* ((prefix-page (%inc-ptr data-address (- *host-page-size*))) + (prefix-allocation (%inc-ptr data-address (- *windows-allocation-granularity*))) + (mapping (paref prefix-page (:* :address) 0)) + (fd (%ptr-to-int (paref prefix-page (:* :address) 1)))) + (#_UnmapViewOfFile data-address) + (#_CloseHandle mapping) + (#_VirtualFree prefix-allocation 0 #$MEM_RELEASE) + (fd-close fd))) + + + +;;; Argument should be something returned by MAP-FILE-TO-IVECTOR; +;;; this should be called at most once for any such object. +(defun unmap-ivector (displaced-vector) + (multiple-value-bind (data-address size-in-octets) + (mapped-vector-data-address-and-size displaced-vector) + (let* ((v (array-displacement displaced-vector))) + (let* ((element-type (array-element-type displaced-vector))) + (adjust-array displaced-vector 0 + :element-type element-type + :displaced-to (make-array 0 :element-type element-type) + :displaced-index-offset 0)) + (with-lock-grabbed (*heap-ivector-lock*) + (setq *heap-ivectors* (delete v *heap-ivectors*))) + (%unmap-file data-address size-in-octets) + t))) + +(defun unmap-octet-vector (v) + (unmap-ivector v)) + +#-windows-target +(progn +(defun lock-mapped-vector (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (eql 0 (#_mlock address nbytes)))) + +(defun unlock-mapped-vector (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (eql 0 (#_munlock address nbytes)))) + +(defun bitmap-for-mapped-range (address nbytes) + (let* ((npages (ceiling nbytes *host-page-size*))) + (%stack-block ((vec npages)) + (when (eql 0 (#_mincore address nbytes vec)) + (let* ((bits (make-array npages :element-type 'bit))) + (dotimes (i npages bits) + (setf (sbit bits i) + (logand 1 (%get-unsigned-byte vec i))))))))) + +(defun percentage-of-resident-pages (address nbytes) + (let* ((npages (ceiling nbytes *host-page-size*))) + (%stack-block ((vec npages)) + (when (eql 0 (#_mincore address nbytes vec)) + (let* ((nresident 0)) + (dotimes (i npages (* 100.0 (/ nresident npages))) + (when (logbitp 0 (%get-unsigned-byte vec i)) + (incf nresident)))))))) + +(defun mapped-vector-resident-pages (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (bitmap-for-mapped-range address nbytes))) + +(defun mapped-vector-resident-pages-percentage (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (percentage-of-resident-pages address nbytes))) +) + + +#+windows-target +(defun cygpath (winpath) + "Try to use the Cygwin \"cygpath\" program to map a Windows-style + pathname to a POSIX-stype Cygwin pathname." + (let* ((posix-path winpath)) + (with-output-to-string (s) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "cygpath" (list "-u" winpath) :output s)) + (when (and (eq status :exited) + (eql exit-code 0)) + (with-input-from-string (output (get-output-stream-string s)) + (setq posix-path (read-line output nil nil)))))) + posix-path)) + +#-windows-target (defun cygpath (path) path) + + + + +#+x86-target +(progn +(defloadvar *last-rdtsc-time* 0) + +(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...") + +(defun rdtsc-monotonic () + "Return monotonically increasing values, partly compensating for + OSes that don't keep the TSCs of all processorsin synch." + (loop + (let* ((old *last-rdtsc-time*) + (new (rdtsc))) + (when (< new old) + ;; We're running on a CPU whose TSC is behind the one + ;; on the last CPU we were scheduled on. + (setq new (+ old *rdtsc-estimated-increment*))) + (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new) + (return new))))) + +(defun estimate-rdtsc-skew (&optional (niter 1000000)) + (do* ((i 0 (1+ i)) + (last (rdtsc) next) + (next (rdtsc) (rdtsc)) + (skew 1)) + ((>= i niter) (setq *rdtsc-estimated-increment* skew)) + (declare (fixnum last next skew)) + (when (> last next) + (let* ((s (- last next))) + (declare (fixnum s)) + (when (> s skew) (setq skew s)))))) +) + + Index: /branches/qres/ccl/level-1/ppc-callback-support.lisp =================================================================== --- /branches/qres/ccl/level-1/ppc-callback-support.lisp (revision 13564) +++ /branches/qres/ccl/level-1/ppc-callback-support.lisp (revision 13564) @@ -0,0 +1,64 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; ppc-callback-support.lisp +;;; +;;; Support for PPC callbacks + +(in-package "CCL") + + + +;;; This is machine-dependent (it conses up a piece of "trampoline" code +;;; which calls a subprim in the lisp kernel.) +#-(and linuxppc-target poweropen-target) +(defun make-callback-trampoline (index &optional info) + (declare (ignorable info)) + (macrolet ((ppc-lap-word (instruction-form) + (uvref (uvref (compile nil `(lambda (&lap 0) (ppc-lap-function () ((?? 0)) ,instruction-form))) 0) #+ppc32-host 0 #+ppc64-host 1))) + (let* ((subprim + #+eabi-target + #.(subprim-name->offset '.SPeabi-callback) + #-eabi-target + #.(subprim-name->offset '.SPpoweropen-callback)) + (p (%allocate-callback-pointer 12))) + (setf (%get-long p 0) (logior (ldb (byte 8 16) index) + (ppc-lap-word (lis 11 ??))) ; unboxed index + (%get-long p 4) (logior (ldb (byte 16 0) index) + (ppc-lap-word (ori 11 11 ??))) + + (%get-long p 8) (logior subprim + (ppc-lap-word (ba ??)))) + (ff-call (%kernel-import #.target::kernel-import-makedataexecutable) + :address p + :unsigned-fullword 12 + :void) + p))) + +;;; In the 64-bit LinuxPPC ABI, functions are "transfer vectors": +;;; two-word vectors that contain the entry point in the first word +;;; and a pointer to the global variables ("table of contents", or +;;; TOC) the function references in the second word. We can use the +;;; TOC word in the transfer vector to store the callback index. +#+(and linuxppc-target poweropen-target) +(defun make-callback-trampoline (index &optional info) + (declare (ignorable info)) + (let* ((p (%allocate-callback-pointer 16))) + (setf (%%get-unsigned-longlong p 0) #.(subprim-name->offset '.SPpoweropen-callback) + (%%get-unsigned-longlong p 8) index) + p)) + Index: /branches/qres/ccl/level-1/ppc-error-signal.lisp =================================================================== --- /branches/qres/ccl/level-1/ppc-error-signal.lisp (revision 13564) +++ /branches/qres/ccl/level-1/ppc-error-signal.lisp (revision 13564) @@ -0,0 +1,157 @@ +;;; PPC-specific code to handle trap and uuo callbacks. +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + +;;; callback here from C exception handler + +(defcallback + %xerr-disp + (:address xp :unsigned-fullword fn-reg :unsigned-fullword pc-or-index :signed-fullword errnum :unsigned-fullword rb :signed-fullword continuable) + (block %err-disp + (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg))) + (err-fn (if (eql continuable 0) '%err-disp-internal '%kernel-restart-internal))) + (if (eql errnum arch::error-stack-overflow) + (handle-stack-overflow xp fn rb) + (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s) + (with-error-reentry-detection + (let* ((rb-value (xp-gpr-lisp xp rb)) + (res + (cond ((< errnum 0) + (%err-disp-internal errnum nil frame-ptr)) + ((logtest errnum arch::error-type-error) + (funcall err-fn + #.(car (rassoc 'type-error *kernel-simple-error-classes*)) + (list rb-value (logandc2 errnum arch::error-type-error)) + frame-ptr)) + ((eql errnum arch::error-udf) + (funcall err-fn $xfunbnd (list rb-value) frame-ptr)) + ((eql errnum arch::error-throw-tag-missing) + (%error (make-condition 'cant-throw-error + :tag rb-value) + nil frame-ptr)) + ((eql errnum arch::error-cant-call) + (%error (make-condition 'type-error + :datum rb-value + :expected-type '(or symbol function) + :format-control + "~S is not of type ~S, and can't be FUNCALLed or APPLYed") + nil frame-ptr)) + ((eql errnum arch::error-udf-call) + (return-from %err-disp + (handle-udf-call xp frame-ptr))) + ((eql errnum arch::error-alloc-failed) + (%error (make-condition + 'simple-storage-condition + :format-control (%rsc-string $xmemfull)) + nil frame-ptr)) + ((eql errnum arch::error-memory-full) + (%error (make-condition + 'simple-storage-condition + :format-control (%rsc-string $xnomem)) + nil frame-ptr)) + ((or (eql errnum arch::error-fpu-exception-double) + (eql errnum arch::error-fpu-exception-single)) + (let* ((code-vector (and fn (uvref fn 0))) + (instr (if code-vector + (uvref code-vector pc-or-index) + (%get-long (%int-to-ptr pc-or-index))))) + (let* ((minor (ldb (byte 5 1) instr)) + (fra (ldb (byte 5 16) instr)) + (frb (ldb (byte 5 11) instr)) + (frc (ldb (byte 5 6) instr))) + (declare (fixnum minor fra frb frc)) + (if (= minor 12) ; FRSP + (%err-disp-internal $xcoerce (list (xp-double-float xp frc) 'short-float) frame-ptr) + (flet ((coerce-to-op-type (double-arg) + (if (eql errnum arch::error-fpu-exception-double) + double-arg + (handler-case (coerce double-arg 'short-float) + (error (c) (declare (ignore c)) double-arg))))) + (multiple-value-bind (status control) (xp-fpscr-info xp) + (%error (make-condition (fp-condition-from-fpscr status control) + :operation (fp-minor-opcode-operation minor) + :operands + (if (= minor 22) + (list (coerce-to-op-type (xp-double-float xp frb))) + (list (coerce-to-op-type + (xp-double-float xp fra)) + (if (= minor 25) + (coerce-to-op-type + (xp-double-float xp frc)) + (coerce-to-op-type + (xp-double-float xp frb)))))) + nil + frame-ptr))))))) + ((eql errnum arch::error-excised-function-call) + (%error "~s: code has been excised." (list (xp-gpr-lisp xp ppc::nfn)) frame-ptr)) + ((eql errnum arch::error-too-many-values) + (%err-disp-internal $xtoomanyvalues (list rb-value) frame-ptr)) + (t (%error "Unknown error #~d with arg: ~d" (list errnum rb-value) frame-ptr))))) + (setf (xp-gpr-lisp xp rb) res) ; munge register for continuation + ))))))) + + + +(defun handle-udf-call (xp frame-ptr) + (let* ((args (xp-argument-list xp)) + (values (multiple-value-list + (%kernel-restart-internal + $xudfcall + (list (maybe-setf-name (xp-gpr-lisp xp ppc::fname)) args) + frame-ptr))) + (stack-argcnt (max 0 (- (length args) 3))) + (vsp (%i+ (xp-gpr-lisp xp ppc::vsp) stack-argcnt)) + (f #'(lambda (values) (apply #'values values)))) + (setf (xp-gpr-lisp xp ppc::vsp) vsp + (xp-gpr-lisp xp ppc::nargs) 1 + (xp-gpr-lisp xp ppc::arg_z) values + (xp-gpr-lisp xp ppc::nfn) f) + ;; handle_uuo() (in the lisp kernel) will not bump the PC here. + (setf (xp-gpr-lisp xp #+linuxppc-target #$PT_NIP #+darwinppc-target -2) + (uvref f 0)))) + + + + + + +;;; rb is the register number of the stack that overflowed. +;;; xp & fn are passed so that we can establish error context. +(defun handle-stack-overflow (xp fn rb) + (unwind-protect + (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s) + (%error + (make-condition + 'stack-overflow-condition + :format-control "Stack overflow on ~a stack." + :format-arguments (list + (if (eql rb ppc::sp) + "control" + (if (eql rb ppc::vsp) + "value" + (if (eql rb ppc::tsp) + "temp" + "unknown"))))) + nil frame-ptr)) + (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit) + :unsigned-fullword rb + :void))) + + Index: /branches/qres/ccl/level-1/ppc-threads-utils.lisp =================================================================== --- /branches/qres/ccl/level-1/ppc-threads-utils.lisp (revision 13564) +++ /branches/qres/ccl/level-1/ppc-threads-utils.lisp (revision 13564) @@ -0,0 +1,210 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; low-level support for PPC threads and stack-backtrace printing + +(in-package "CCL") + + +;;; Sure would be nice to have &optional in defppclapfunction arglists +;;; Sure would be nice not to do this at runtime. + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref))))) + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref-natural))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set-natural))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + + + + + +(defun %frame-backlink (p &optional context) + (cond ((fake-stack-frame-p p) + (%fake-stack-frame.next-sp p)) + ((fixnump p) + (let ((backlink (%%frame-backlink p)) + (fake-frame + (if context (bt.fake-frames context) *fake-stack-frames*))) + (loop + (when (null fake-frame) (return backlink)) + (when (eq backlink (%fake-stack-frame.sp fake-frame)) + (return fake-frame)) + (setq fake-frame (%fake-stack-frame.link fake-frame))))) + (t (error "~s is not a valid stack frame" p)))) + + + + +(defun catch-frame-sp (catch) + (uvref catch target::catch-frame.csp-cell)) + +(defun bottom-of-stack-p (p context) + (and (fixnump p) + (locally (declare (fixnum p)) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (cs-area (%fixnum-ref tcr target::tcr.cs-area))) + (not (%ptr-in-area-p p cs-area)))))) + +(defun lisp-frame-p (p context) + (or (fake-stack-frame-p p) + (locally (declare (fixnum p)) + (let ((next-frame (%frame-backlink p context))) + (when (fake-stack-frame-p next-frame) + (setq next-frame (%fake-stack-frame.sp next-frame))) + (locally (declare (fixnum next-frame)) + (if (bottom-of-stack-p next-frame context) + (values nil t) + (and + (eql (ash target::lisp-frame.size (- target::fixnum-shift)) + (the fixnum (- next-frame p))) + ;; EABI C functions keep their saved LRs where we save FN or 0 + ;; The saved LR of such a function would be fixnum-tagged and never 0. + (let* ((fn (%fixnum-ref p target::lisp-frame.savefn))) + (or (eql fn 0) (typep fn 'function)))))))))) + + + + + +#+ppc32-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) subtag))) + (declare (fixnum tagval)) + (case (logand subtag ppc32::fulltagmask) + (#. ppc32::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus))) + (#. ppc32::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus))) + (t nil)))) + +#+ppc64-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (ash subtag (- ppc64::nlowtagbits)))) + (declare (fixnum tagval)) + (case (logand subtag ppc64::lowtagmask) + (#. ppc64::lowtag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus))) + (#. ppc64::lowtag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus))) + (t nil)))) + +#+ppc32-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + (#.ppc32::fulltag-misc (valid-subtag-p (typecode thing))) + ((#.ppc32::fulltag-immheader #.ppc32::fulltag-nodeheader) nil) + (t t)))) + + + +#+ppc64-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + (#.ppc64::fulltag-misc (valid-subtag-p (typecode thing))) + ((#.ppc64::fulltag-immheader-0 + #.ppc64::fulltag-immheader-1 + #.ppc64::fulltag-immheader-2 + #.ppc64::fulltag-immheader-3 + #.ppc64::fulltag-nodeheader-0 + #.ppc64::fulltag-nodeheader-1 + #.ppc64::fulltag-nodeheader-2 + #.ppc64::fulltag-nodeheader-3) nil) + (t t)))) + + + + +#+ppc32-target +(defun bogus-thing-p (x) + (when x + #+cross-compiling (return-from bogus-thing-p nil) + (or (not (valid-header-p x)) + (let ((tag (lisptag x))) + (unless (or (eql tag ppc32::tag-fixnum) + (eql tag ppc32::tag-imm) + (in-any-consing-area-p x)) + ;; This is terribly complicated, should probably write some LAP + (let ((typecode (typecode x))) + (not (or (case typecode + (#.ppc32::tag-list + (temporary-cons-p x)) + ((#.ppc32::subtag-symbol #.ppc32::subtag-code-vector) + t) ; no stack-consed symbols or code vectors + (#.ppc32::subtag-value-cell + (on-any-vstack x)) + (t + (on-any-tsp-stack x))) + (%heap-ivector-p x))))))))) + + + +#+ppc64-target +(defun bogus-thing-p (x) + (when x + (or (not (valid-header-p x)) + (let ((tag (lisptag x))) + (unless (or (eql tag ppc64::tag-fixnum) + (eql tag ppc64::tag-imm-0) + (eql tag ppc64::tag-imm-2) + (in-any-consing-area-p x)) + ;; This is terribly complicated, should probably write some LAP + (let ((typecode (typecode x))) + (not (or (case typecode + (#.ppc64::fulltag-cons + (temporary-cons-p x)) + ((#.ppc64::subtag-symbol #.ppc64::subtag-code-vector) + t) ; no stack-consed symbols or code vectors + (#.ppc64::subtag-value-cell + (on-any-vstack x)) + (t + (on-any-tsp-stack x))) + (%heap-ivector-p x))))))))) Index: /branches/qres/ccl/level-1/ppc-trap-support.lisp =================================================================== --- /branches/qres/ccl/level-1/ppc-trap-support.lisp (revision 13564) +++ /branches/qres/ccl/level-1/ppc-trap-support.lisp (revision 13564) @@ -0,0 +1,1004 @@ +;;; ppc-trap-support +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Support for PPC traps, this includes the event-poll trap +;;; and all the trxxx traps for type checks & arg count checks. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + + + (defparameter *ppc-instruction-fields* + `((:opcode . ,(byte 6 26)) + (:rt . ,(byte 5 21)) + (:to . ,(byte 5 21)) + (:ra . ,(byte 5 16)) + (:rb . ,(byte 5 11)) + (:d . ,(byte 16 0)) + (:ds . ,(byte 14 2)) + (:ds-xo . ,(byte 2 0)) + (:sh . ,(byte 5 11)) + (:mb . ,(byte 5 6)) + (:me . ,(byte 5 1)) + (:mb6 . ,(byte 6 5)) + (:me6 . ,(byte 6 5)) + (:sh6 . ,(byte 1 1)) + (:x-minor . ,(byte 10 1)) + (:fulltag32 . ,(byte ppc32::ntagbits 0)) + (:lisptag32 . ,(byte ppc32::nlisptagbits 0)) + (:fulltag64 . ,(byte ppc64::ntagbits 0)) + (:lisptag64 . ,(byte ppc64::nlisptagbits 0)) + (:lowtag64 . ,(byte ppc64::nlowtagbits 0)))) + + (defun ppc-instruction-field (field-name) + (or (cdr (assoc field-name *ppc-instruction-fields*)) + (error "Unknown PPC instruction field: ~s" field-name))) + + (defun ppc-instruction-field-mask (field-spec) + (let* ((name (if (atom field-spec) field-spec (car field-spec))) + (value (if (atom field-spec) -1 (cadr field-spec)))) + (dpb value (ppc-instruction-field name) 0))) + + #+darwinppc-target + (progn + (def-foreign-type nil + (:struct :darwin-ppc-float-state + (:fpregs (:array :double 32)) + (:fpscr-pad (:unsigned 32)) + (:fpscr (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-ppc-vector-state + (:save-vr (:array (:array (:unsigned 32) 4) 32)) + (:save-vscr (:array (:unsigned 32) 4)) + (:save-pad5 (:array (:unsigned 32) 4)) + (:save-vrvalid (:unsigned 32)) + (:save-pad6 (:array (:unsigned 32) 7)))) + #+ppc64-target + (progn + (def-foreign-type nil + (:struct :darwin-ppc-exception-state64 + (:dar (:unsigned 64)) + (:dsisr (:unsigned 32)) + (:exception (:unsigned 32)) + (:pad1 (:array (:unsigned 32) 4)))) + (def-foreign-type nil + ;; The real record type is defined with + ;; #pragma pack(4) in effect. + ;; The :struct parser should really accept + ;; some option to deal with that, but Apple + ;; should also stop mis-aligning things. + (:struct :darwin-ppc-thread-state64 + (:srr0 (:unsigned 64)) + (:srr1 (:unsigned 64)) + (:r0 (:unsigned 64)) + (:r1 (:unsigned 64)) + (:r2 (:unsigned 64)) + (:r3 (:unsigned 64)) + (:r4 (:unsigned 64)) + (:r5 (:unsigned 64)) + (:r6 (:unsigned 64)) + (:r7 (:unsigned 64)) + (:r8 (:unsigned 64)) + (:r9 (:unsigned 64)) + (:r10 (:unsigned 64)) + (:r11 (:unsigned 64)) + (:r12 (:unsigned 64)) + (:r13 (:unsigned 64)) + (:r14 (:unsigned 64)) + (:r15 (:unsigned 64)) + (:r16 (:unsigned 64)) + (:r17 (:unsigned 64)) + (:r18 (:unsigned 64)) + (:r19 (:unsigned 64)) + (:r20 (:unsigned 64)) + (:r21 (:unsigned 64)) + (:r22 (:unsigned 64)) + (:r23 (:unsigned 64)) + (:r24 (:unsigned 64)) + (:r25 (:unsigned 64)) + (:r26 (:unsigned 64)) + (:r27 (:unsigned 64)) + (:r28 (:unsigned 64)) + (:r29 (:unsigned 64)) + (:r30 (:unsigned 64)) + (:r31 (:unsigned 64)) + (:cr (:unsigned 32)) + (:xer (:unsigned 32)) + (:xer-low (:unsigned 32)) + (:lr (:unsigned 32)) + (:lr-low (:unsigned 32)) + (:ctr (:unsigned 32)) + (:ctr-low (:unsigned 32)) + (:vrsave (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-sigaltstack64 + (:ss-sp (:* :void)) + (:ss-size (:unsigned 64)) + (:ss-flags (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-mcontext64 + (:es (:struct :darwin-ppc-exception-state64)) + (:ss (:struct :darwin-ppc-thread-state64)) + (:fs (:struct :darwin-ppc-float-state)) + (:vs (:struct :darwin-ppc-vector-state)))) + (def-foreign-type nil + (:struct :darwin-ucontext64 + (:uc-onstack (:signed 32)) + (:uc-sigmask (:signed 32)) + (:uc-stack (:struct :darwin-sigaltstack64)) + (:uc-link (:* (:struct :darwin-ucontext64))) + (:uc-mcsize (:signed 64)) + (:uc-mcontext64 (:* (:struct :darwin-mcontext64))))) + ) + #+ppc32-target + (progn + (def-foreign-type nil + (:struct :darwin-ppc-exception-state32 + (:dar (:unsigned 32)) + (:dsisr (:unsigned 32)) + (:exception (:unsigned 32)) + (:pad0 (:unsigned 32)) + (:pad1 (:array (:unsigned 32) 4)))) + (def-foreign-type nil + (:struct :darwin-ppc-thread-state32 + (:srr0 (:unsigned 32)) + (:srr1 (:unsigned 32)) + (:r0 (:unsigned 32)) + (:r1 (:unsigned 32)) + (:r2 (:unsigned 32)) + (:r3 (:unsigned 32)) + (:r4 (:unsigned 32)) + (:r5 (:unsigned 32)) + (:r6 (:unsigned 32)) + (:r7 (:unsigned 32)) + (:r8 (:unsigned 32)) + (:r9 (:unsigned 32)) + (:r10 (:unsigned 32)) + (:r11 (:unsigned 32)) + (:r12 (:unsigned 32)) + (:r13 (:unsigned 32)) + (:r14 (:unsigned 32)) + (:r15 (:unsigned 32)) + (:r16 (:unsigned 32)) + (:r17 (:unsigned 32)) + (:r18 (:unsigned 32)) + (:r19 (:unsigned 32)) + (:r20 (:unsigned 32)) + (:r21 (:unsigned 32)) + (:r22 (:unsigned 32)) + (:r23 (:unsigned 32)) + (:r24 (:unsigned 32)) + (:r25 (:unsigned 32)) + (:r26 (:unsigned 32)) + (:r27 (:unsigned 32)) + (:r28 (:unsigned 32)) + (:r29 (:unsigned 32)) + (:r30 (:unsigned 32)) + (:r31 (:unsigned 32)) + (:cr (:unsigned 32)) + (:xer (:unsigned 32)) + (:lr (:unsigned 32)) + (:ctr (:unsigned 32)) + (:mq (:unsigned 32)) ; ppc 601! + (:vrsave (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-sigaltstack32 + (:ss-sp (:* :void)) + (:ss-size (:unsigned 32)) + (:ss-flags (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-mcontext32 + (:es (:struct :darwin-ppc-exception-state32)) + (:ss (:struct :darwin-ppc-thread-state32)) + (:fs (:struct :darwin-ppc-float-state)) + (:vs (:struct :darwin-ppc-vector-state)))) + (def-foreign-type nil + (:struct :darwin-ucontext32 + (:uc-onstack (:signed 32)) + (:uc-sigmask (:signed 32)) + (:uc-stack (:struct :darwin-sigaltstack32)) + (:uc-link (:* (:struct :darwin-ucontext32))) + (:uc-mcsize (:signed 32)) + (:uc-mcontext32 (:* (:struct :darwin-mcontext32))))) + ) + ) + + + + + (defmacro with-xp-registers-and-gpr-offset ((xp register-number) (registers offset) &body body) + (let* ((regform #+linuxppc-target + `(pref ,xp :ucontext.uc_mcontext.regs) + #+darwinppc-target + (target-arch-case + ;; Gak. Apple gratuitously renamed things + ;; for Leopard. Hey, it's not as if anyone + ;; has better things to do than to deal with + ;; this crap ... + (:ppc32 `(pref ,xp :darwin-ucontext32.uc-mcontext32.ss)) + (:ppc64 `(pref ,xp :darwin-ucontext64.uc-mcontext64.ss))))) + `(with-macptrs ((,registers ,regform)) + (let ((,offset (xp-gpr-offset ,register-number))) + ,@body)))) + + (defmacro RA-field (instr) + `(ldb (byte 5 16) ,instr)) + + (defmacro RB-field (instr) + `(ldb (byte 5 11) ,instr)) + + (defmacro D-field (instr) + `(ldb (byte 16 0) ,instr)) + + (defmacro RS-field (instr) + `(ldb (byte 5 21) ,instr)) + + (defmacro lisp-reg-p (reg) + `(>= ,reg ppc::fn)) + + (defmacro ppc-lap-word (instruction-form) + (uvref (uvref (compile nil + `(lambda (&lap 0) + (ppc-lap-function () ((?? 0)) + ,instruction-form))) + + 0) #+ppc32-host 0 #+ppc64-host 1)) + + (defmacro ppc-instruction-mask (&rest fields) + `(logior ,@(mapcar #'ppc-instruction-field-mask (cons :opcode fields)))) + + ) + + + +(defun xp-gpr-offset (register-number) + (unless (and (fixnump register-number) + (<= -2 (the fixnum register-number)) + (< (the fixnum register-number) 48)) + (setq register-number (require-type register-number '(integer -2 48)))) + (the fixnum + (* (the fixnum #+linuxppc-target register-number + #+darwinppc-target (+ register-number 2)) + target::node-size))) + + + +(defun xp-gpr-lisp (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%get-object registers offset)))) + +(defun (setf xp-gpr-lisp) (value xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (%set-object registers offset value))) + +(defun xp-gpr-signed-long (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%get-signed-long registers offset)))) + +(defun xp-gpr-signed-doubleword (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%%get-signed-longlong registers offset)))) + + +(defun xp-gpr-macptr (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%get-ptr registers offset)))) + +(defun xp-argument-list (xp) + (let ((nargs (xp-gpr-lisp xp ppc::nargs)) ; tagged as a fixnum (how convenient) + (arg-x (xp-gpr-lisp xp ppc::arg_x)) + (arg-y (xp-gpr-lisp xp ppc::arg_y)) + (arg-z (xp-gpr-lisp xp ppc::arg_z))) + (cond ((eql nargs 0) nil) + ((eql nargs 1) (list arg-z)) + ((eql nargs 2) (list arg-y arg-z)) + (t (let ((args (list arg-x arg-y arg-z))) + (if (eql nargs 3) + args + (let ((vsp (xp-gpr-macptr xp ppc::vsp))) + (dotimes (i (- nargs 3)) + (push (%get-object vsp (* i target::node-size)) args)) + args))))))) + +(defun xp-fpscr-info (xp) + (let* ((fpscr #+(and linuxppc-target 32-bit-target) (%get-unsigned-long (pref xp :ucontext.uc_mcontext.regs) (ash #$PT_FPSCR 2)) + #+(and linuxppc-target 64-bit-target) + (%get-unsigned-long (pref xp :ucontext.uc_mcontext.fp_regs) (ash 65 2)) + #+(and darwinppc-target ppc32-target) + (pref xp :darwin-ucontext32.uc-mcontext32.fs.fpscr) + #+(and darwinppc-target ppc64-target) + (pref xp :darwin-ucontext64.uc-mcontext64.fs.fpscr))) + (values (ldb (byte 24 8) fpscr) (ldb (byte 8 0) fpscr)))) + +#+linuxppc-target +(defun xp-double-float (xp fpr) + #+32-bit-target + (%get-double-float (pref xp :ucontext.uc_mcontext.regs) (+ (ash #$PT_FPR0 2) (ash fpr 3))) + #+64-bit-target + (%get-double-float (pref xp :ucontext.uc_mcontext.fp_regs) (ash fpr 3)) + ) + +#+darwinppc-target +(defun xp-double-float (xp fpr) + (%get-double-float + #+ppc32-target (pref xp :darwin-ucontext32.uc-mcontext32.fs) + #+ppc64-target (pref xp :darwin-ucontext64.uc-mcontext64.fs) + (ash fpr 3))) + + +(defparameter *trap-lookup-tries* 5) + + + +(defun %scan-for-instr (mask opcode fn pc-index tries) + (let ((code-vector (and fn (uvref fn 0))) + (offset 0)) + (declare (fixnum offset)) + (flet ((get-instr () + (if code-vector + (let ((index (+ pc-index offset))) + (when (< index 0) (return-from %scan-for-instr nil)) + (uvref code-vector index)) + (%get-long pc-index (the fixnum (* 4 offset)))))) + (declare (dynamic-extent #'get-instr)) + (dotimes (i tries) + (decf offset) + (let ((instr (get-instr))) + (when (match-instr instr mask opcode) + (return instr)) + (when (codevec-header-p instr) + (return nil))))))) + + + + + + +(defun return-address-offset (xp fn machine-state-offset) + (with-macptrs ((regs (pref xp #+linuxppc-target :ucontext.uc_mcontext.regs + #+(and darwinppc-target ppc32-target) + :darwin-ucontext32.uc-mcontext32 + #+(and darwinppc-target ppc64-target) + :darwin-ucontext64.uc-mcontext64))) + (if (functionp fn) + (or (%code-vector-pc (uvref fn 0) (%inc-ptr regs machine-state-offset)) + (%get-ptr regs machine-state-offset)) + (%get-ptr regs machine-state-offset)))) + +(defconstant lr-offset-in-register-context + #+linuxppc-target (ash #$PT_LNK target::word-shift) + #+(and darwinppc-target ppc32-target) + (+ (get-field-offset :darwin-mcontext32.ss) + (get-field-offset :darwin-ppc-thread-state32.lr)) + #+(and darwinppc-target ppc64-target) + (+ (get-field-offset :darwin-mcontext64.ss) + (get-field-offset :darwin-ppc-thread-state64.lr))) + +(defconstant pc-offset-in-register-context + #+linuxppc-target (ash #$PT_NIP target::word-shift) + #+(and darwinppc-target ppc32-target) + (+ (get-field-offset :darwin-mcontext32.ss) + (get-field-offset :darwin-ppc-thread-state32.srr0)) + #+(and darwinppc-target ppc64-target) + (+ (get-field-offset :darwin-mcontext64.ss) + (get-field-offset :darwin-ppc-thread-state64.srr0))) + +;;; When a trap happens, we may have not yet created control +;;; stack frames for the functions containing PC & LR. +;;; If that is the case, we add fake-stack-frame's to *fake-stack-frames* +;;; There are 4 cases: +;;; +;;; PC in FN +;;; Push 1 stack frame: PC/FN +;;; This might miss one recursive call, but it won't miss any variables +;;; PC in NFN +;;; Push 2 stack frames: +;;; 1) PC/NFN/VSP +;;; 2) LR/FN/VSP +;;; This might think some of NFN's variables are part of FN's stack frame, +;;; but that's the best we can do. +;;; LR in FN +;;; Push 1 stack frame: LR/FN +;;; None of the above +;;; Push no new stack frames +;;; +;;; The backtrace support functions in "ccl:l1;l1-lisp-threads.lisp" know how +;;; to find the fake stack frames and handle them as arguments. +(defun funcall-with-xp-stack-frames (xp trap-function thunk) + (cond ((null trap-function) + ; Maybe inside a subprim from a lisp function + (let* ((fn (xp-gpr-lisp xp ppc::fn)) + (lr (return-address-offset + xp fn lr-offset-in-register-context))) + (if (fixnump lr) + (let* ((sp (xp-gpr-lisp xp ppc::sp)) + (vsp (xp-gpr-lisp xp ppc::vsp)) + (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) + (*fake-stack-frames* frame)) + (declare (dynamic-extent frame)) + (funcall thunk frame)) + (funcall thunk (xp-gpr-lisp xp ppc::sp))))) + ((eq trap-function (xp-gpr-lisp xp ppc::fn)) + (let* ((sp (xp-gpr-lisp xp ppc::sp)) + (fn trap-function) + (lr (return-address-offset + xp fn pc-offset-in-register-context)) + (vsp (xp-gpr-lisp xp ppc::vsp)) + (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) + (*fake-stack-frames* frame)) + (declare (dynamic-extent frame)) + (funcall thunk frame))) + ((eq trap-function (xp-gpr-lisp xp ppc::nfn)) + (let* ((sp (xp-gpr-lisp xp ppc::sp)) + (fn (xp-gpr-lisp xp ppc::fn)) + (lr (return-address-offset + xp fn lr-offset-in-register-context)) + (vsp (xp-gpr-lisp xp ppc::vsp)) + (lr-frame (%cons-fake-stack-frame sp sp fn lr vsp xp)) + (pc-fn trap-function) + (pc-lr (return-address-offset + xp pc-fn pc-offset-in-register-context)) + (pc-frame (%cons-fake-stack-frame sp lr-frame pc-fn pc-lr vsp xp *fake-stack-frames*)) + (*fake-stack-frames* pc-frame)) + (declare (dynamic-extent lr-frame pc-frame)) + (funcall thunk pc-frame))) + (t (funcall thunk (xp-gpr-lisp xp ppc::sp))))) + + + +;;; Enter here from handle-trap in "lisp-exceptions.c". +;;; xp is a pointer to an ExceptionInformationPowerPC record. +;;; the-trap is the trap instruction that got us here. +;;; fn-reg is either fn, nfn or 0. If it is fn or nfn, then +;;; the trap occcurred in that register's code vector. +;;; If it is 0, then the trap occurred somewhere else. +;;; pc-index is either the index in fn-reg's code vector +;;; or, if fn-reg is 0, the address of the PC at the trap instruction. +;;; This code parallels the trap decoding code in +;;; "lisp-exceptions.c" that runs if (symbol-value 'cmain) +;;; is not a macptr. +;;; Some of these could probably call %err-disp instead of error, +;;; but I was too lazy to look them up. + +#+ppc32-target +(defcallback xcmain (:without-interrupts t + :address xp + :unsigned-fullword fn-reg + :address pc-or-index + :unsigned-fullword the-trap + :signed-fullword arg-0 + :signed-fullword arg-1) + ;; twgti nargs,0 + ;; time for event polling. + ;; This used to happen a lot so we test for it first. + (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) + (with-xp-stack-frames (xp fn frame-ptr) + (if (eql the-trap (ppc-lap-word (twgti nargs 0))) + (cmain) + (with-error-reentry-detection + (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) + instr ra temp rs condition) + (cond + ((= the-trap #$SIGBUS) + (%error (make-condition 'invalid-memory-access + :address arg-0 + :write-p (not (zerop arg-1))) + () + frame-ptr)) + ;; tweqi RA nil-value - resolve-eep, or resolve-foreign-variable + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tweqi ?? (target-nil-value)))) + (setq instr (scan-for-instr + (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? + (+ 4 ppc32::misc-data-offset) + ??)) + fn pc-index))) + (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (fv.addr eep-or-fv)))))) + ;; twnei RA,N; RA = nargs + ;; nargs check, no optional or rest involved + ((match-instr the-trap + (ppc-instruction-mask :opcode :to :ra) + (ppc-lap-word (twnei nargs ??))) + (%error (if (< (xp-GPR-signed-long xp ppc::nargs) (D-field the-trap)) + 'too-few-arguments + 'too-many-arguments ) + (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) + (- ppc32::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; twnei RA,N; RA != nargs, N = fulltag_node/immheader + ;; type check; look for "lbz rt-imm,-3(ra-node)" + ((and (or (match-instr the-trap + (ppc-instruction-mask :opcode :to :fulltag32) + (ppc-lap-word (twnei ?? ppc32::fulltag-nodeheader))) + (match-instr the-trap + (ppc-instruction-mask :opcode :to :fulltag32) + (ppc-lap-word (twnei ?? ppc32::fulltag-immheader)))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lbz ?? ppc32::misc-subtag-offset ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (let* ((typecode (D-field the-trap)) + (type-tag (logand typecode ppc32::fulltagmask)) + (type-name (svref (if (eql type-tag ppc32::fulltag-nodeheader) + *nodeheader-types* + *immheader-types*) + (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) typecode)))) + (%error (make-condition 'type-error + :format-control (%rsc-string $XWRONGTYPE) + :datum (xp-GPR-lisp xp ra) + :expected-type type-name) + nil + frame-ptr))) + + ;; twnei RA,N; RA != nargs, N = subtag_character + ;; type check; look for "clrlwi rs-node,ra-imm,24" = "rlwinm rs,ra,0,24,31" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (twnei ?? ppc32::subtag-character))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb :mb :me) + (ppc-lap-word (rlwinm ?? ?? 0 24 31)) + fn pc-index)) + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'character) + nil + frame-ptr)) + + ;; twnei RA,N; RA != nargs, N != fulltag_node/immheader + ;; (since that case was handled above.) + ;; type check; look for "clrlwi rs-node,ra-imm,29/30" = "rlwinm rs,ra,0,29/30,31" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to) + (ppc-lap-word (twnei ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb (:mb 28) :me) + (ppc-lap-word (rlwinm ?? ?? 0 28 31)) + fn pc-index)) + (or (eql (- 32 ppc32::ntagbits) (setq temp (ldb #.(ppc-instruction-field :mb) instr))) + (eql (- 32 ppc32::nlisptagbits) temp)) + (lisp-reg-p (setq rs (RS-field instr)))) + (let* ((tag (logand the-trap ppc32::tagmask)) + (type-name + (case tag + (#.ppc32::tag-fixnum 'fixnum) + (#.ppc32::tag-list (if (eql temp (- 32 ppc32::ntagbits)) 'cons 'list)) + (#.ppc32::tag-misc 'uvector) + (#.ppc32::tag-imm 'immediate)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type type-name) + nil + frame-ptr))) + + ;; twlgti RA,N; RA = nargs (xy = 01) + ;; twllti RA,N; RA = nargs (xy = 10) + ;; nargs check, optional or rest involved + ((and (match-instr the-trap + (ppc-instruction-mask :opcode (:to #x1c) :ra) + (ppc-lap-word (twi ?? ppc::nargs ??))) + (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) + (eql #b10 temp))) + (%error (if (eql temp #b10) + 'too-few-arguments + 'too-many-arguments) + (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) + (- ppc32::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; tweqi RA,N; N = unbound + ;; symeval boundp check; look for "lwz RA,symbol.vcell(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tweqi ?? ppc32::unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? ppc32::symbol.vcell ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (setf (xp-GPR-lisp xp (RA-field the-trap)) + (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) + ;; tweqi RA,N: n = (%slot-unbound-marker) + ;; slot-unbound trap. Look for preceding "lwzx RA,rx,ry". + ;; rx = slots-vector, ry = scaled index in slots vector. + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tweqi ?? ppc32::slot-unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask + :opcode :rt :x-minor) + (dpb + (RA-field the-trap) + (byte 5 21) + (ppc-lap-word + (lwzx ?? ?? ??))) + fn pc-index))) + (setq *error-reentry-count* 0) ; succesfully reported error + + ;; %SLOT-UNBOUND-TRAP will decode the arguments further, + ;; then call the generic function SLOT-UNBOUND. That + ;; might return a value; if so, set the value of the + ;; register that caused the trap to that value. + (setf (xp-gpr-lisp xp (ra-field the-trap)) + (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) + (ash (- (xp-gpr-signed-long xp (RB-field instr)) + ppc32::misc-data-offset) + (- ppc32::word-shift)) + frame-ptr))) + ;; twlge RA,RB + ;; vector bounds check; look for "lwz immreg, misc_header_offset(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (twlge 0 0))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|#) + (ppc-lap-word (lwz ?? ?? #|ppc32::misc-header-offset|# ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xarroob) + (list (xp-GPR-lisp xp (RA-field the-trap)) + (xp-GPR-lisp xp ra)) + frame-ptr)) + ;; twi 27 ra d - array header rank check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to) + (ppc-lap-word (twi 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? ppc32::arrayH.rank ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xndims) + (list (xp-gpr-lisp xp ra) + (ash (ldb (byte 16 0) the-trap) (- ppc32::fixnumshift))) + frame-ptr)) + ;; tw 27 ra rb - array flags check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (tw 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? ppc32::arrayH.flags ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr))) + (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) + (expected-subtype (ldb + ppc32::arrayH.flags-cell-subtag-byte + expected)) + (expect-simple (= + (ldb ppc32::arrayH.flags-cell-bits-byte + expected) + (ash 1 $arh_simple_bit))) + (type-name + (case expected-subtype + (#.ppc32::subtag-double-float-vector 'double-float)))) + + (and type-name expect-simple + (setq condition + (make-condition 'type-error + :datum (xp-gpr-lisp xp ra) + :expected-type + `(simple-array ,type-name)))))) + (%error condition nil frame-ptr)) + + ;; Unknown trap + (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" + (list the-trap xp fn (ash pc-index ppc32::fixnumshift)) + frame-ptr))))))))) + +#+ppc64-target +(defcallback xcmain (:without-interrupts t + :address xp + :unsigned-fullword fn-reg + :address pc-or-index + :unsigned-fullword the-trap + :signed-doubleword arg0 + :signed-doubleword arg1) + ;; tdgti nargs,0 + ;; time for event polling. + ;; This used to happen a lot so we test for it first. + (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) + (with-xp-stack-frames (xp fn frame-ptr) + (if (eql the-trap (ppc-lap-word (tdgti nargs 0))) + (cmain) + (with-error-reentry-detection + (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) + instr ra temp rs condition) + (cond + ;; tdeqi RA nil-value - resolve-eep, or resolve-foreign-variable + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdeqi ?? (target-nil-value)))) + (setq instr (scan-for-instr + (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? + (+ 8 ppc64::misc-data-offset) + ??)) + fn pc-index))) + (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (fv.addr eep-or-fv)))))) + ((= the-trap #$SIGBUS) + (%error (make-condition 'invalid-memory-access + :address arg0 + :write-p (not (zerop arg1))) + () + frame-ptr)) + ;; tdnei RA,N; RA = nargs + ;; nargs check, no optional or rest involved + ((match-instr the-trap + (ppc-instruction-mask :opcode :to :ra) + (ppc-lap-word (tdnei nargs ??))) + (%error (if (< (xp-GPR-signed-doubleword xp ppc::nargs) (D-field the-trap)) + 'too-few-arguments + 'too-many-arguments ) + (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) + (- ppc64::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; tdnei RA,N; RA != nargs, N = lowtag_node/immheader + ;; type check; look for "lbz rt-imm,-5(ra-node)" + ((and (or (match-instr the-trap + (ppc-instruction-mask :opcode :to :lowtag64) + (ppc-lap-word (tdnei ?? ppc64::lowtag-nodeheader))) + (match-instr the-trap + (ppc-instruction-mask :opcode :rt :lowtag64) + (ppc-lap-word (tdnei ?? ppc64::lowtag-immheader)))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lbz ?? ppc64::misc-subtag-offset ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (let* ((typecode (D-field the-trap)) + (type-tag (logand typecode ppc64::lowtagmask)) + (type-name (svref (if (eql type-tag ppc64::lowtag-nodeheader) + *nodeheader-types* + *immheader-types*) + (ash typecode (- ppc64::nlowtagbits))))) + (%error (make-condition 'type-error + :format-control (%rsc-string $XWRONGTYPE) + :datum (xp-GPR-lisp xp ra) + :expected-type type-name) + nil + frame-ptr))) + ;; tdnei RA,N; RA != nargs, N = subtag_character type + ;; check; look for "clrldi rs-node,ra-imm,56" = "rldicl + ;; rs,ra,0,55" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :rt :d) + (ppc-lap-word (tdnei ?? ppc64::subtag-character))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 56)) + fn pc-index)) + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'character) + nil + frame-ptr)) + + ;; tdnei RA,N; RA != nargs, N = ppc64::tag-fixnum. type + ;; check; look for "clrldi rs-node,ra-imm,61" = "rldicl + ;; rs,ra,61" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :rt) + (ppc-lap-word (tdnei ?? ppc64::tag-fixnum))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 61)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'fixnum) + nil + frame-ptr)) + ;; tdi 3,RA,ppc64::fulltag-cons; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdi 3 ?? ppc64::fulltag-cons))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'list) + nil + frame-ptr)) + ;; tdnei RA,ppc64::fulltag-cons; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdnei ?? ppc64::fulltag-cons))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'cons) + nil + frame-ptr)) + ;; tdnei RA,ppc64::subtag-single-float; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdnei ?? ppc64::subtag-single-float))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'short-float) + nil + frame-ptr)) + ;; tdnei RA,ppc64::fulltag-misc; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdnei ?? ppc64::fulltag-misc))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'uvector) + nil + frame-ptr)) + ;; tdlgti RA,N; RA = nargs (xy = 01) + ;; tdllti RA,N; RA = nargs (xy = 10) + ;; nargs check, optional or rest involved + ((and (match-instr the-trap + (ppc-instruction-mask :opcode (:to #x1c) :ra) + (ppc-lap-word (tdi ?? ppc::nargs ??))) + (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) + (eql #b10 temp))) + (%error (if (eql temp #b10) + 'too-few-arguments + 'too-many-arguments) + (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) + (- ppc64::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; tdeqi RA,N; N = unbound + ;; symeval boundp check; look for "ld RA,symbol.vcell(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdeqi ?? ppc64::unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? ppc64::symbol.vcell ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (setf (xp-GPR-lisp xp (RA-field the-trap)) + (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) + ;; tdeqi RA,N: n = (%slot-unbound-marker) + ;; slot-unbound trap. Look for preceding "ldx RA,rx,ry". + ;; rx = slots-vector, ry = scaled index in slots vector. + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdeqi ?? ppc64::slot-unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask + :opcode :rt :x-minor) + (dpb + (RA-field the-trap) + (byte 5 21) + (ppc-lap-word + (ldx ?? ?? ??))) + fn pc-index))) + (setq *error-reentry-count* 0) ; succesfully reported error + ;; %SLOT-UNBOUND-TRAP will decode the arguments further, + ;; then call the generic function SLOT-UNBOUND. That + ;; might return a value; if so, set the value of the + ;; register that caused the trap to that value. + (setf (xp-gpr-lisp xp (ra-field the-trap)) + (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) + (ash (- (xp-gpr-signed-doubleword xp (RB-field instr)) + ppc64::misc-data-offset) + (- ppc64::word-shift)) + frame-ptr))) + ;; tdlge RA,RB + ;; vector bounds check; look for "ld immreg, misc_header_offset(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (tdlge ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|# :ds-xo) + (ppc-lap-word (ld ?? ?? #|ppc32::misc-header-offset|# ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xarroob) + (list (xp-GPR-lisp xp (RA-field the-trap)) + (xp-GPR-lisp xp ra)) + frame-ptr)) + ;; tdi 27 ra d - array header rank check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to) + (ppc-lap-word (tdi 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? ppc64::arrayH.rank ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xndims) + (list (xp-gpr-lisp xp ra) + (ash (ldb (byte 16 0) the-trap) (- ppc64::fixnumshift))) + frame-ptr)) + ;; td 27 ra rb - array flags check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (td 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? ppc64::arrayH.flags ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr))) + (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) + (expected-subtype (ldb + ppc64::arrayH.flags-cell-subtag-byte + expected)) + (expect-simple (= + (ldb ppc64::arrayH.flags-cell-bits-byte + expected) + (ash 1 $arh_simple_bit))) + (type-name + (case expected-subtype + (#.ppc64::subtag-double-float-vector 'double-float)))) + + (and type-name expect-simple + (setq condition + (make-condition 'type-error + :datum (xp-gpr-lisp xp ra) + :expected-type + `(simple-array ,type-name)))))) + (%error condition nil frame-ptr)) + + ;; Unknown trap + (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" + (list the-trap xp fn (ash pc-index ppc64::fixnumshift)) + frame-ptr))))))))) + + + + + Index: /branches/qres/ccl/level-1/runtime.lisp =================================================================== --- /branches/qres/ccl/level-1/runtime.lisp (revision 13564) +++ /branches/qres/ccl/level-1/runtime.lisp (revision 13564) @@ -0,0 +1,159 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Load .pfsl files, create a "runtime" (compiler- & development-tools-less) +;;; image. + +(in-package "CCL") + +(%fasload "./l1-pfsls/l1-cl-package.pfsl") +(%fasload "./l1-pfsls/l1-utils.pfsl") +(%fasload "./l1-pfsls/l1-init.pfsl") +(%fasload "./l1-pfsls/l1-symhash.pfsl") +(%fasload "./l1-pfsls/l1-numbers.pfsl") +(%fasload "./l1-pfsls/l1-aprims.pfsl") +(%fasload "./l1-pfsls/ppc-callback-support.pfsl") +(%fasload "./l1-pfsls/l1-sort.pfsl") +(%fasload "./l1-pfsls/l1-dcode.pfsl") +(%fasload "./l1-pfsls/l1-clos.pfsl") +(%fasload "./binppc/defstruct.pfsl") +(%fasload "./l1-pfsls/l1-streams.pfsl") +(%fasload "./l1-pfsls/linux-files.pfsl") +(%fasload "./binppc/lists.pfsl") +(%fasload "./binppc/sequences.pfsl") +(%fasload "./binppc/chars.pfsl") +(%fasload "./l1-pfsls/l1-files.pfsl") +(provide "SEQUENCES") +(provide "DEFSTRUCT") +(provide "CHARS") +(provide "LISTS") +(%fasload "./l1-pfsls/ppc-stack-groups.pfsl") +(%fasload "./l1-pfsls/l1-stack-groups.pfsl") +(%fasload "./l1-pfsls/l1-processes.pfsl") +(%fasload "./l1-pfsls/l1-io.pfsl") +(%fasload "./l1-pfsls/l1-reader.pfsl") +(%fasload "./l1-pfsls/l1-readloop.pfsl") +(%fasload "./l1-pfsls/l1-readloop-lds.pfsl") +(%fasload "./l1-pfsls/l1-error-system.pfsl") + +(%fasload "./l1-pfsls/l1-events.pfsl") +(%fasload "./l1-pfsls/ppc-trap-support.pfsl") +(%fasload "./l1-pfsls/l1-format.pfsl") +(%fasload "./l1-pfsls/l1-sysio.pfsl") +(%fasload "./l1-pfsls/l1-pathnames.pfsl") +(%fasload "./l1-pfsls/version.pfsl") +(%fasload "./l1-pfsls/l1-boot-lds.pfsl") + +(%fasload "./l1-pfsls/l1-boot-1.pfsl") +(catch :toplevel + (%fasload "./l1-pfsls/l1-typesys.pfsl") + (%fasload "./l1-pfsls/sysutils.pfsl") + (%fasload "./l1-pfsls/l1-error-signal.pfsl") + (setq *LEVEL-1-LOADED* t)) + +(def-ccl-pointers fd-streams () + (let* ((in (make-fd-stream 0 :direction :input)) + (out (make-fd-stream 1 :direction :output)) + (error out)) + (setq *terminal-io* (make-echoing-two-way-stream in out)) + (setq *debug-io* (make-echoing-two-way-stream in error) + *query-io* *debug-io*) + (setq *standard-input* in + *standard-output* out + *error-output* error + *trace-output* error))) + +(catch :toplevel + (flet ((load-provide (module path) + (let* ((*package* *package*)) + (%fasload path) + (provide module)))) + (load-provide "SORT" "./binppc/sort.pfsl") + (load-provide "NUMBERS" "./binppc/numbers.pfsl") + (load-provide "HASH" "./binppc/hash.pfsl") +;;; (load-provide "DLL-NODE" "./binppc/dll-node.pfsl") +;;; (load-provide "PPC32-ARCH" "./binppc/ppc32-arch.pfsl") +;;; (load-provide "VREG" "./binppc/vreg.pfsl") +;;; (load-provide "PPC-ASM" "./binppc/ppc-asm.pfsl") +;;; (load-provide "VINSN" "./binppc/vinsn.pfsl") +;;; (load-provide "PPC-VINSNS" "./binppc/ppc-vinsns.pfsl") +;;; (load-provide "PPC-REG" "./binppc/ppc-reg.pfsl") +;;; (load-provide "SUBPRIMS" "./binppc/subprims.pfsl") +;;; (load-provide "PPC-LAP" "./binppc/ppc-lap.pfsl") +;;; (provide "PPC2") ; Lie, load the module manually +;;; (load-provide "NX" "./l1-pfsls/nx.pfsl") +;;; (%fasload "./binppc/ppc2.pfsl") + (load-provide "LEVEL-2" "./binppc/level-2.pfsl") +;;; (load-provide "SETF" "./binppc/setf.pfsl") + (load-provide "SETF-RUNTIME" "./binppc/setf-runtime.pfsl") + (load-provide "FORMAT" "./binppc/format.pfsl") + (load-provide "STREAMS" "./binppc/streams.pfsl") +;;; (load-provide "OPTIMIZERS" "./binppc/optimizers.pfsl") +;;; (load-provide "PPC-OPTIMIZERS" "./binppc/ppc-optimizers.pfsl") +;;; (load-provide "LISPEQU" "./library/lispequ.pfsl") ; Shouldn't need this at load time ... +;;; (load-provide "DEFSTRUCT-MACROS" "./binppc/defstruct-macros.pfsl") ; ... but this file thinks it does. +;;; (load-provide "DEFSTRUCT-LDS" "./binppc/defstruct-lds.pfsl") +;;; (load-provide "NFCOMP" "./binppc/nfcomp.pfsl") +;;; (load-provide "BACKQUOTE" "./binppc/backquote.pfsl") + (load-provide "BACKTRACE-LDS" "./binppc/backtrace-lds.pfsl") + (load-provide "BACKTRACE" "./binppc/backtrace.pfsl") + (load-provide "READ" "./binppc/read.pfsl") + (load-provide "ARRAYS-FRY" "./binppc/arrays-fry.pfsl") +;;; (load-provide "APROPOS" "./binppc/apropos.pfsl") +;;; (load-provide "PPC-DISASSEMBLE" "./binppc/ppc-disassemble.pfsl") +;;; (load-provide "PPC-LAPMACROS" "./binppc/ppc-lapmacros.pfsl") +;;; (load-provide "MACTYPES" "./binppc/mactypes.pfsl") +;;; (load-provide "DEFRECORD" "./binppc/defrecord.pfsl") +;;; (load-provide "LINUX-RECORDS" "./library/linux-records.pfsl") + (load-provide "CASE-ERROR" "./binppc/case-error.pfsl") +;;; (load-provide "ENCAPSULATE" "./binppc/encapsulate.pfsl") + (load-provide "METHOD-COMBINATION" "./binppc/method-combination.pfsl") + (load-provide "MISC" "./binppc/misc.pfsl") + (load-provide "PPRINT" "./binppc/pprint.pfsl") + (load-provide "DUMPLISP" "./binppc/dumplisp.pfsl") + (load-provide "PATHNAMES" "./binppc/pathnames.pfsl") + (load-provide "TIME" "./binppc/time.pfsl") +;;; (load-provide "COMPILE-CCL" "./binppc/compile-ccl.pfsl") +;;; (load-provide "SOURCE-FILES" "./binppc/source-files.pfsl") + (load-provide "CCL-EXPORT-SYMS" "./binppc/ccl-export-syms.pfsl") + ) + (setq *%fasload-verbose* nil) + ) +(catch :toplevel + (or (find-package "COMMON-LISP-USER") + (make-package "COMMON-LISP-USER" :use '("COMMON-LISP" "CCL") :NICKNAMES '("CL-USER"))) +) + +(defvar *LISTENER-PROCESS-STACKSEG-SIZE* (* 4 16384)) + +(setf (interrupt-level) 0) + +(setq *warn-if-redefine* t) + +(setq *level-1-loaded* t) + +(set-periodic-task-interval 1) + +(do-all-symbols (s) + (setf (symbol-plist s) nil)) + +(progn (%set-toplevel #'toplevel-loop) (save-application "RUNTIME")) + + + + + Index: /branches/qres/ccl/level-1/sysutils.lisp =================================================================== --- /branches/qres/ccl/level-1/sysutils.lisp (revision 13564) +++ /branches/qres/ccl/level-1/sysutils.lisp (revision 13564) @@ -0,0 +1,895 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;; sysutils.lisp - things which have outgrown l1-utils + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require 'level-2) + (require 'optimizers) + (require 'backquote) + (require 'defstruct-macros) + ) + +;;; things might be clearer if this stuff were in l1-typesys? +;;; Translation from type keywords to specific predicates. +(eval-when (:execute :compile-toplevel) + +(defconstant type-pred-pairs + '((array . arrayp) + (atom . atom) + (base-string . base-string-p) + (bignum . bignump) + (bit . bitp) + (bit-vector . bit-vector-p) + (character . characterp) + (compiled-function . compiled-function-p) + (complex . complexp) + (cons . consp) + (double-float . double-float-p) + (fixnum . fixnump) ;not cl + (float . floatp) + (function . functionp) + (hash-table . hash-table-p) + (integer . integerp) + (real . realp) + (keyword . keywordp) + (list . listp) + (long-float . double-float-p) + (nil . false) + (null . null) + (number . numberp) + (package . packagep) + (pathname . pathnamep) + (logical-pathname . logical-pathname-p) + (random-state . random-state-p) + (ratio . ratiop) + (rational . rationalp) + (readtable . readtablep) + (sequence . sequencep) + (short-float . short-float-p) + (signed-byte . integerp) + (simple-array . simple-array-p) + (simple-base-string . simple-base-string-p) + (simple-bit-vector . simple-bit-vector-p) + (simple-string . simple-string-p) + (simple-vector . simple-vector-p) + (single-float . short-float-p) + (stream . streamp) + (string . stringp) + (base-char . base-char-p) + (extended-char . extended-char-p) + (structure-object . structurep) + (symbol . symbolp) + (t . true) + (unsigned-byte . unsigned-byte-p) + (vector . vectorp) + )) + +(defmacro init-type-predicates () + `(dolist (pair ',type-pred-pairs) + (setf (type-predicate (car pair)) (cdr pair)) + (let ((ctype (info-type-builtin (car pair)))) + (if (typep ctype 'numeric-ctype) + (setf (numeric-ctype-predicate ctype) (cdr pair)))))) + +) + +(init-type-predicates) + +(defun unsigned-byte-8-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n 0) + (< n #x100))))) + +(defun signed-byte-8-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n -128) + (<= n 127))))) + +(defun unsigned-byte-16-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n 0) + (< n #x10000))))) + +(defun signed-byte-16-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n -32768) + (<= n 32767))))) + +(defun unsigned-byte-32-p (n) + (and (integerp n) + (>= n 0) + (<= n #xffffffff))) + +(defun signed-byte-32-p (n) + (and (integerp n) + (>= n -2147483648) + (<= n 2147483647))) + +(eval-when (:load-toplevel :execute) + (let ((more-pairs + '(((unsigned-byte 8) . unsigned-byte-8-p) + ((signed-byte 8) . signed-byte-8-p) + ((unsigned-byte 16) . unsigned-byte-16-p) + ((signed-byte 16) . signed-byte-16-p) + ((unsigned-byte 32) . unsigned-byte-32-p) + ((signed-byte 32) . signed-byte-32-p)))) + (dolist (pair more-pairs) + (let ((ctype (info-type-builtin (car pair)))) + (if (typep ctype 'numeric-ctype) (setf (numeric-ctype-predicate ctype) (cdr pair)))))) + ) + + +(defun specifier-type-known (type) + (let ((ctype (specifier-type type))) + (if (typep ctype 'unknown-ctype) + (error "Unknown type specifier ~s." type) + (if (and (typep ctype 'numeric-ctype) ; complexp?? + (eq 'integer (numeric-ctype-class ctype)) + (not (numeric-ctype-predicate ctype))) + (setf (numeric-ctype-predicate ctype)(make-numeric-ctype-predicate ctype)))) + ctype)) + + +(defun find-builtin-cell (type &optional (create t)) + (let ((cell (gethash type %builtin-type-cells%))) + (or cell + (when create + (setf (gethash type %builtin-type-cells%) + (cons type (or (info-type-builtin type)(specifier-type-known type)))))))) + + +; for now only called for builtin types or car = unsigned-byte, signed-byte, mod or integer + +(defun builtin-typep (form cell) + (unless (listp cell) + (setq cell (require-type cell 'list))) + (locally (declare (type list cell)) + (let ((ctype (cdr cell)) + (name (car cell))) + (when (not ctype) + (setq ctype (or (info-type-builtin name)(specifier-type-known name))) + (when ctype (setf (gethash (car cell) %builtin-type-cells%) cell)) + (rplacd cell ctype)) + (if ctype + (if (and (typep ctype 'numeric-ctype) + (numeric-ctype-predicate ctype)) + ; doing this inline is a winner - at least if true + (funcall (numeric-ctype-predicate ctype) form) + (%%typep form ctype)) + (typep form name))))) + +#| +(defvar %find-classes% (make-hash-table :test 'eq)) + +(defun find-class-cell (name create?) + (let ((cell (gethash name %find-classes%))) + (or cell + (and create? + (setf (gethash name %find-classes%) (cons name nil)))))) +|# + +;(setq *type-system-initialized* t) + + +;; Type-of, typep, and a bunch of other predicates. + +;;; Data type predicates. + +;;; things might be clearer if this stuff were in l1-typesys? +;;; Translation from type keywords to specific predicates. + + + + +;necessary since standard-char-p, by definition, errors if not passed a char. +(setf (type-predicate 'standard-char) + #'(lambda (form) (and (characterp form) (standard-char-p form)))) + +(defun type-of (form) + "Return the type of OBJECT." + (case form + ((t) 'boolean) + ((0 1) 'bit) + (t + (typecase form + (standard-char 'standard-char) + (keyword 'keyword) + ;; Partition integers so that the negative cases + ;; are SIGNED-BYTE and the positive are UNSIGNED-BYTE + (fixnum + (if (< (the fixnum form) 0) + 'fixnum + '(integer 0 #.target::target-most-positive-fixnum))) + (bignum + (if (< form 0) + 'bignum + '(integer #.(1+ target::target-most-positive-fixnum)))) + ((or array complex) (type-specifier (ctype-of form))) + (single-float 'single-float) + (double-float 'double-float) + (t + (if (eql (typecode form) target::subtag-istruct) + (istruct-type-name form) + (let* ((class (class-of form))) + (or (%class-proper-name class) + class)))))))) + +;;; Create the list-style description of an array. + +;made more specific by fry. slisp used (mod 2) , etc. +;Oh. +; As much fun as this has been, I think it'd be really neat if +; it returned a type specifier. + +(defun describe-array (array) + (if (arrayp array) + (type-specifier + (specifier-type + `(,(if (simple-array-p array) 'simple-array 'array) + ,(array-element-type array) + ,(array-dimensions array)))) + (report-bad-arg array 'array))) + + +;;;; TYPEP and auxiliary functions. + + + +(defun type-specifier-p (form &aux sym) + (cond ((symbolp form) + (or (type-predicate form) + (structure-class-p form) + (%deftype-expander form) + (find-class form nil) + )) + ((consp form) + (setq sym (%car form)) + (or (type-specifier-p sym) + (memq sym '(member satisfies mod)) + (and (memq sym '(and or not)) + (dolist (spec (%cdr form) t) + (unless (type-specifier-p spec) (return nil)))))) + (t (typep form 'class)))) + +(defun built-in-type-p (type) + (if (symbolp type) + (or (type-predicate type) + (let ((class (find-class type nil))) + (and class (typep class 'built-in-class)))) + (and (consp type) + (or (and (memq (%car type) '(and or not)) + (every #'built-in-type-p (%cdr type))) + (memq (%car type) '(array simple-array vector simple-vector + string simple-string bit-vector simple-bit-vector + complex integer mod signed-byte unsigned-byte + rational float short-float single-float + double-float long-float real member)))))) + +(defun typep (object type &optional env) + "Is OBJECT of type TYPE?" + (let* ((pred (if (symbolp type) (type-predicate type)))) + (if pred + (funcall pred object) + (values (%typep object (if env (specifier-type type env) type)))))) + + + +;;; This is like check-type, except it returns the value rather than setf'ing +;;; anything, and so can be done entirely out-of-line. +(defun require-type (arg type) + (multiple-value-bind (win sure) + (ctypep arg (specifier-type type)) + (if (or win (not sure)) + arg + (%kernel-restart $xwrongtype arg type)))) + +;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named) +(defun %require-type (arg predsym) + (if (funcall predsym arg) + arg + (%kernel-restart $xwrongtype arg (type-for-predicate predsym)))) + +(defun %require-type-builtin (arg type-cell) + (if (builtin-typep arg type-cell) + arg + (%kernel-restart $xwrongtype arg (car type-cell)))) + + + +;;; In lieu of an inverted mapping, at least try to find cases involving +;;; builtin numeric types and predicates associated with them. +(defun type-for-predicate (pred) + (or (block find + (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype) + (eq (numeric-ctype-predicate ctype) + pred)) + (return-from find type))) + *builtin-type-info*)) + `(satisfies ,pred))) + + + + +; Subtypep. + +(defun subtypep (type1 type2 &optional env) + "Return two values indicating the relationship between type1 and type2. + If values are T and T, type1 definitely is a subtype of type2. + If values are NIL and T, type1 definitely is not a subtype of type2. + If values are NIL and NIL, it couldn't be determined." + (csubtypep (specifier-type type1 env) (specifier-type type2 env))) + +(defun types-disjoint-p (type1 type2 &optional env) + ;; Return true if types are guaranteed to be disjoint, nil if not disjoint or unknown. + (let ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env))) + (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env)))) + (eq *empty-type* (type-intersection ctype1 ctype2)))) + + + +(defun preload-all-functions () + nil) + + + ; used by arglist +(defun temp-cons (a b) + (cons a b)) + + + + +(defun copy-into-float (src dest) + (%copy-double-float src dest)) + +(queue-fixup + (defun fmakunbound (name) + "Make NAME have no global function definition." + (let* ((fname (validate-function-name name))) + (remhash fname %structure-refs%) + (%unfhave fname)) + name)) + +(defun frozen-definition-p (name) + (if (symbolp name) + (%ilogbitp $sym_fbit_frozen (%symbol-bits name)))) + +(defun redefine-kernel-function (name) + (when (and *warn-if-redefine-kernel* + (frozen-definition-p name) + (or (lfunp (fboundp name)) + (and (not (consp name)) (macro-function name))) + (or (and (consp name) (neq (car name) 'setf)) + (let ((pkg (symbol-package (if (consp name) (cadr name) name)))) + (or (eq *common-lisp-package* pkg) (eq *ccl-package* pkg))))) + (cerror "Replace the definition of ~S." + "The function ~S is predefined in Clozure CL." name) + (unless (consp name) + (proclaim-inline nil name)))) + +(defun fset (name function) + (setq function (require-type function 'function)) + (when (symbolp name) + (when (special-operator-p name) + (error "Can not redefine a special-form: ~S ." name)) + (when (macro-function name) + (cerror "Redefine the macro ~S as a function" + "The macro ~S is being redefined as a function." name))) +; This lets us redefine %FHAVE. Big fun. + (let ((fhave #'%fhave)) + (redefine-kernel-function name) + (fmakunbound name) + (funcall fhave name function) + function)) + +(defsetf symbol-function fset) +(defsetf fdefinition fset) + +(defun (setf macro-function) (macro-fun name &optional env) + (declare (ignore env)) + (unless (typep macro-fun 'function) + (report-bad-arg macro-fun 'function)) + (if (special-operator-p name) + (error "Can not redefine a special-form: ~S ." name)) + (when (and (fboundp name) (not (macro-function name))) + (warn "The function ~S is being redefined as a macro." name)) + (redefine-kernel-function name) + (fmakunbound name) + (%macro-have name macro-fun) + macro-fun) + +(defun set-macro-function (name def) + (setf (macro-function name) def)) + + + + + +;;; Arrays and vectors, including make-array. + + + + + + + +(defun char (string index) + "Given a string and a non-negative integer index less than the length of + the string, returns the character object representing the character at + that position in the string." + (if (typep string 'simple-string) + (schar (the simple-string string) index) + (if (stringp string) + (multiple-value-bind (data offset) (array-data-and-offset string) + (schar (the simple-string data) (+ index offset))) + (report-bad-arg string 'string)))) + +(defun set-char (string index new-el) + (if (typep string 'simple-string) + (setf (schar string index) new-el) + (if (stringp string) + (multiple-value-bind (data offset) (array-data-and-offset string) + (setf (schar (the simple-string data) (+ index offset)) new-el)) + (report-bad-arg string 'string)))) + +(defun equalp (x y) + "Just like EQUAL, but more liberal in several respects. + Numbers may be of different types, as long as the values are identical + after coercion. Characters may differ in alphabetic case. Vectors and + arrays must have identical dimensions and EQUALP elements, but may differ + in their type restriction. + If one of x or y is a pathname and one is a string with the name of the + pathname then this will return T." + (cond ((eql x y) t) + ((characterp x) (and (characterp y) (eq (char-upcase x) (char-upcase y)))) + ((numberp x) (and (numberp y) (= x y))) + ((consp x) + (and (consp y) + (equalp (car x) (car y)) + (equalp (cdr x) (cdr y)))) + ((pathnamep x) (equal x y)) + ((vectorp x) + (and (vectorp y) + (let ((length (length x))) + (when (eq length (length y)) + (dotimes (i length t) + (declare (fixnum i)) + (let ((x-el (aref x i)) + (y-el (aref y i))) + (unless (or (eq x-el y-el) (equalp x-el y-el)) + (return nil)))))))) + ((arrayp x) + (and (arrayp y) + (let ((rank (array-rank x)) x-el y-el) + (and (eq (array-rank y) rank) + (if (%izerop rank) (equalp (aref x) (aref y)) + (and + (dotimes (i rank t) + (declare (fixnum i)) + (unless (eq (array-dimension x i) + (array-dimension y i)) + (return nil))) + (multiple-value-bind (x0 i) (array-data-and-offset x) + (multiple-value-bind (y0 j) (array-data-and-offset y) + (dotimes (count (array-total-size x) t) + (declare (fixnum count)) + (setq x-el (uvref x0 i) y-el (uvref y0 j)) + (unless (or (eq x-el y-el) (equalp x-el y-el)) + (return nil)) + (setq i (%i+ i 1) j (%i+ j 1))))))))))) + ((and (structurep x) (structurep y)) + (let ((size (uvsize x))) + (and (eq size (uvsize y)) + (dotimes (i size t) + (declare (fixnum i)) + (unless (equalp (uvref x i) (uvref y i)) + (return nil)))))) + ((and (hash-table-p x) (hash-table-p y)) + (%hash-table-equalp x y)) + ((and (random-state-p x) (random-state-p y)) + (%random-state-equalp x y)) + (t nil))) + + +; The compiler (or some transforms) might want to do something more interesting +; with these, but they have to exist as functions anyhow. + + + +(defun complement (function) + "Return a new function that returns T whenever FUNCTION returns NIL and + NIL whenever FUNCTION returns non-NIL." + (let ((f (coerce-to-function function))) ; keep poor compiler from consing value cell + #'(lambda (&rest args) + (declare (dynamic-extent args)) ; not tail-recursive anyway + (not (apply f args))))) + +; Special variables are evil, but I can't think of a better way to do this. + +(defparameter *outstanding-deferred-warnings* nil) + +(defun call-with-compilation-unit (thunk &key override) + (let* ((*outstanding-deferred-warnings* (%defer-warnings override))) + (multiple-value-prog1 (funcall thunk) + (report-deferred-warnings)))) + +(defun %defer-warnings (override &aux (parent *outstanding-deferred-warnings*)) + (when parent + (ensure-merged-deferred-warnings parent)) + (%istruct 'deferred-warnings + (unless override parent) + nil + (make-hash-table :test #'eq) + nil)) + +(defun ensure-merged-deferred-warnings (parent &aux (last (deferred-warnings.last-file parent))) + (when last + (setf (deferred-warnings.last-file parent) nil) + (let* ((child (car last)) ;; last = (deferred-warnings . file) + (warnings (deferred-warnings.warnings child)) + (defs (deferred-warnings.defs child)) + (parent-defs (deferred-warnings.defs parent)) + (parent-warnings (deferred-warnings.warnings parent))) + (maphash (lambda (key val) (setf (gethash key parent-defs) val)) defs) + (setf (deferred-warnings.warnings parent) (append warnings parent-warnings)))) + parent) + + +;; Should be a generic function but compiler-warning class not defined yet. +(defun verify-deferred-warning (w) + (etypecase w + (undefined-type-reference (verify-deferred-type-warning w)) + (undefined-function-reference (verify-deferred-function-warning w)) + (undefined-keyword-reference (verify-deferred-keyword-warning w)) + (compiler-warning nil))) + +(defun verify-deferred-type-warning (w) + (let* ((args (compiler-warning-args w)) + (typespec (car args)) + (defs (deferred-warnings.defs *outstanding-deferred-warnings*))) + (handler-bind ((parse-unknown-type + (lambda (c) + (let* ((type (parse-unknown-type-specifier c)) + (spec (if (consp type) (car type) type)) + (cell (and (symbolp spec) (gethash spec defs)))) + (unless (and cell (def-info.deftype (cdr cell))) + (when (and args (neq type typespec)) + (setf (car args) type)) + (return-from verify-deferred-type-warning w)) + ;; Else got defined. TODO: Should check syntax, but don't have enuff info. + ;; TODO: should note if got defined as a deftype (rather than class or struct) and + ;; warn about forward reference, akin to the macro warning? Might be missing out on + ;; some intended optimizations. + ))) + (program-error ;; got defined, but turns out it's being used wrong + (lambda (c) + (let ((w2 (make-condition 'invalid-type-warning + :function-name (compiler-warning-function-name w) + :source-note (compiler-warning-source-note w) + :warning-type :invalid-type + :args (list typespec c)))) + (return-from verify-deferred-type-warning w2))))) + (values-specifier-type typespec) + nil))) + + +(defun deferred-function-def (name) + (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*)) + (def (or (let ((cell (gethash name defs))) + (and cell (def-info.function-p (cdr cell)) cell)) + (let* ((global (fboundp name))) + (and (typep global 'function) global))))) + def)) + +(defun check-deferred-call-args (w def wargs) + (destructuring-bind (arglist spread-p) wargs + (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist spread-p) + (when (and (eq deftype :deferred-mismatch) + (eq (car reason) :unknown-gf-keywords) + (consp def) + (not (logbitp $lfbits-gfn-bit (def-info.lfbits (cdr def))))) + ;; If didn't have a defgeneric, check against global defn + (let* ((global-def (fboundp (car def))) + (bad-keys (cadr reason))) + (when (typep global-def 'generic-function) + (setq bad-keys + (multiple-value-bind (bits keyvect) (innermost-lfun-bits-keyvect global-def) + (when (and bits + (logbitp $lfbits-keys-bit bits) + (not (logbitp $lfbits-aok-bit bits))) + (loop for key in bad-keys + unless (or (find key keyvect) + (nx1-valid-gf-keyword-p global-def key)) + collect key))))) + (if bad-keys + (setq reason (list* :unknown-gf-keys bad-keys (cddr reason))) + (setq deftype nil)))) + (when deftype + (when (eq deftype :deferred-mismatch) + (setq deftype (if (consp def) :environment-mismatch :global-mismatch))) + (make-condition + 'invalid-arguments + :function-name (compiler-warning-function-name w) + :source-note (compiler-warning-source-note w) + :warning-type deftype + :args (list (car (compiler-warning-args w)) reason arglist spread-p)))))) + +(defun verify-deferred-function-warning (w) + (let* ((args (compiler-warning-args w)) + (wfname (car args)) + (def (deferred-function-def wfname))) + (cond ((null def) w) + ((or (typep def 'function) + (and (consp def) + (def-info.lfbits (cdr def)))) + ;; Check args in call to forward-referenced function. + (when (cdr args) + (check-deferred-call-args w def (cdr args)))) + ((def-info.macro-p (cdr def)) + (let* ((w2 (make-condition + 'macro-used-before-definition + :function-name (compiler-warning-function-name w) + :source-note (compiler-warning-source-note w) + :warning-type :macro-used-before-definition + :args (list (car args))))) + w2))))) + +(defun verify-deferred-keyword-warning (w) + (let* ((args (compiler-warning-args w)) + (wfname (car args)) + (def (deferred-function-def wfname))) + (when def + (check-deferred-call-args w def (cddr args))))) + + +(defun report-deferred-warnings (&optional (file nil)) + (let* ((current (ensure-merged-deferred-warnings *outstanding-deferred-warnings*)) + (parent (deferred-warnings.parent current)) + (warnings (deferred-warnings.warnings current)) + (any nil) + (harsh nil)) + (if parent + (progn + (setf (deferred-warnings.last-file parent) (cons current file)) + (unless file ;; don't defer merge for non-file units. + (ensure-merged-deferred-warnings parent)) + (setq parent t)) + (let* ((file nil) + (init t)) + (dolist (w warnings) + (when (setq w (verify-deferred-warning w)) + (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any)) + (setq init nil))))) + (values any harsh parent))) + +(defun print-nested-name (name-list stream) + (if (null name-list) + (princ "a toplevel form" stream) + (progn + (if (car name-list) + (prin1 (%car name-list) stream) + (princ "an anonymous lambda form" stream)) + (when (%cdr name-list) + (princ " inside " stream) + (print-nested-name (%cdr name-list) stream))))) + +(defparameter *suppress-compiler-warnings* nil) + +(defun signal-compiler-warning (w init-p last-w-file harsh-p any-p &optional eval-p) + (let ((muffled *suppress-compiler-warnings*) + (w-file (compiler-warning-file-name w)) + (s *error-output*)) + (unless muffled + (restart-case (signal w) + (muffle-warning () (setq muffled t)))) + (unless muffled + (setq any-p t) + (unless (typep w 'style-warning) + (unless (eq harsh-p :very) + (setq harsh-p t) + (when (and (typep w 'compiler-warning) + (eq (compiler-warning-warning-type w) :program-error) + (typep (car (compiler-warning-args w)) 'error)) + (setq harsh-p :very)))) + (when (or init-p (not (equalp w-file last-w-file))) + (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter")) + (if w-file (format s "for ~S :" w-file) (princ ":" s))) + (let* ((indenting-stream (make-indenting-string-output-stream #\; 4))) + (format indenting-stream "~%~a" w) + (format s "~a" (get-output-stream-string indenting-stream)))) + (values harsh-p any-p w-file))) + +;;;; Assorted mumble-P type predicates. +;;;; No functions have been in the kernel for the last year or so. +;;;; (Just thought you'd like to know.) + +(defun sequencep (form) + "Not CL. SLISP Returns T if form is a sequence, NIL otherwise." + (or (listp form) (vectorp form))) + +;;; The following are not defined at user level, but are necessary for +;;; internal use by TYPEP. + +(defun bitp (form) + "Not CL. SLISP" + (or (eq form 0) (eq form 1))) + +(defun unsigned-byte-p (form) + (and (integerp form) (not (< form 0)))) + +;This is false for internal structures. +;;; ---- look at defenv.structures, not defenv.structrefs + +(defun structure-class-p (form &optional env) + (and (symbolp form) + (let ((sd (or (and env + (let ((defenv (definition-environment env))) + (and defenv + (%cdr (assq form (defenv.structures defenv)))))) + (gethash form %defstructs%)))) + (and sd + (null (sd-type sd)) + sd)))) + + + + + +(defun type-keyword-code (type-keyword &optional target) + (let* ((backend (if target (find-backend target) *target-backend*)) + (alist (arch::target-uvector-subtags (backend-target-arch backend))) + (entry (assq type-keyword alist))) + (if entry + (let* ((code (cdr entry))) + (or code (error "Vector type ~s invalid," type-keyword))) + (error "Unknown type-keyword ~s. " type-keyword)))) + + +(defstruct id-map + (vector (make-array 1 :initial-element nil)) + (free 0) + (lock (make-lock))) + +;;; Caller owns the lock on the id-map. +(defun id-map-grow (id-map) + (without-interrupts + (let* ((old-vector (id-map-vector id-map)) + (old-size (length old-vector)) + (new-size (+ old-size old-size)) + (new-vector (make-array new-size))) + (declare (fixnum old-size new-size)) + (dotimes (i old-size) + (setf (svref new-vector i) (svref old-vector i))) + (let* ((limit (1- new-size))) + (declare (fixnum limit)) + (do* ((i old-size (1+ i))) + ((= i limit) (setf (svref new-vector i) nil)) + (declare (fixnum i)) + (setf (svref new-vector i) (the fixnum (1+ i))))) + (setf (id-map-vector id-map) new-vector + (id-map-free id-map) old-size)))) + +;;; Map an object to a small fixnum ID in id-map. +;;; Object can't be NIL or a fixnum itself. +(defun assign-id-map-id (id-map object) + (if (or (null object) (typep object 'fixnum)) + (setq object (require-type object '(not (or null fixnum))))) + (with-lock-grabbed ((id-map-lock id-map)) + (let* ((free (or (id-map-free id-map) (id-map-grow id-map))) + (vector (id-map-vector id-map)) + (newfree (svref vector free))) + (setf (id-map-free id-map) newfree + (svref vector free) object) + free))) + +;;; Referemce the object with id ID in ID-MAP. Leave the object in +;;; the map. +(defun id-map-object (id-map id) + (let* ((object (with-lock-grabbed ((id-map-lock id-map)) + (svref (id-map-vector id-map) id)))) + (if (or (null object) (typep object 'fixnum)) + (error "invalid index ~d for ~s" id id-map) + object))) + +;;; Referemce the object with id ID in ID-MAP. Remove the object from +;;; the map. +(defun id-map-free-object (id-map id) + (with-lock-grabbed ((id-map-lock id-map)) + (let* ((vector (id-map-vector id-map)) + (object (svref vector id))) + (if (or (null object) (typep object 'fixnum)) + (error "invalid index ~d for ~s" id id-map)) + (setf (svref vector id) (id-map-free id-map) + (id-map-free id-map) id) + object))) + +(defun id-map-modify-object (id-map id old-value new-value) + (with-lock-grabbed ((id-map-lock id-map)) + (let* ((vector (id-map-vector id-map)) + (object (svref vector id))) + (if (or (null object) (typep object 'fixnum)) + (error "invalid index ~d for ~s" id id-map)) + (if (eq object old-value) + (setf (svref vector id) new-value))))) + + + + +(setq *type-system-initialized* t) + +;;; Try to map from a CTYPE describing some array/stream +;;; element-type to a target-specific typecode, catching +;;; cases that CTYPE-SUBTYPE missed. + +(defun harder-ctype-subtype (ctype) + (cond ((csubtypep ctype (load-time-value (specifier-type 'bit))) + target::subtag-bit-vector) + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 8)))) + target::subtag-u8-vector) + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 16)))) + target::subtag-u16-vector) + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 32)))) + target::subtag-u32-vector) + #+64-bit-target + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 64)))) + target::subtag-u64-vector) + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 8)))) + target::subtag-s8-vector) + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 16)))) + target::subtag-s16-vector) + #+32-bit-target + ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum)))) + target::subtag-fixnum-vector) + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 32)))) + target::subtag-s32-vector) + #+64-bit-target + ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum)))) + target::subtag-fixnum-vector) + #+64-bit-target + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 64)))) + target::subtag-s64-vector) + (t target::subtag-simple-vector))) + + +#+count-gf-calls +(progn +;;; Call-counting for generic functions. We overload the +;;; (previously unused +(defmethod generic-function-call-count ((gf generic-function)) + (gf.hash gf)) + + +(defun (setf generic-function-call-count) (count gf) + (setf (gf.hash gf) (require-type count 'fixnum))) + +(defun clear-all-generic-function-call-counts () + (dolist (gf (population.data %all-gfs%)) + (setf (gf.hash gf) 0))) +);#+count-gf-calls + + Index: /branches/qres/ccl/level-1/version.lisp =================================================================== --- /branches/qres/ccl/level-1/version.lisp (revision 13564) +++ /branches/qres/ccl/level-1/version.lisp (revision 13564) @@ -0,0 +1,41 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defparameter *openmcl-major-version* 1) +(defparameter *openmcl-minor-version* 4) +(defparameter *openmcl-revision* "dev") +;;; May be set by xload-level-0 +(defvar *openmcl-svn-revision* nil) +(defparameter *openmcl-dev-level* nil) + +(defparameter *openmcl-version* (format nil "~d.~d~@[-~a~]~@[-r~a~] ~@[+~s~] (~@[~A: ~]~~A)" + *openmcl-major-version* + *openmcl-minor-version* + (unless (null *openmcl-revision*) + *openmcl-revision*) + (if (and (typep *openmcl-svn-revision* 'string) + (> (length *openmcl-svn-revision*) 0)) + *openmcl-svn-revision*) + *optional-features* + *openmcl-dev-level*)) + + + + +;;; end Index: /branches/qres/ccl/level-1/x86-callback-support.lisp =================================================================== --- /branches/qres/ccl/level-1/x86-callback-support.lisp (revision 13564) +++ /branches/qres/ccl/level-1/x86-callback-support.lisp (revision 13564) @@ -0,0 +1,76 @@ +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +#+x8664-target +(defun make-callback-trampoline (index &optional info) + (declare (ignore info)) + (let* ((p (%allocate-callback-pointer 16)) + (addr #.(subprim-name->offset '.SPcallback))) + (setf (%get-unsigned-byte p 0) #x41 ; movl $n,%r11d + (%get-unsigned-byte p 1) #xc7 + (%get-unsigned-byte p 2) #xc3 + (%get-unsigned-byte p 3) (ldb (byte 8 0) index) + (%get-unsigned-byte p 4) (ldb (byte 8 8) index) + (%get-unsigned-byte p 5) (ldb (byte 8 16) index) + (%get-unsigned-byte p 6) (ldb (byte 8 24) index) + (%get-unsigned-byte p 7) #xff ; jmp * + (%get-unsigned-byte p 8) #x24 + (%get-unsigned-byte p 9) #x25 + (%get-unsigned-byte p 10) (ldb (byte 8 0) addr) + (%get-unsigned-byte p 11) (ldb (byte 8 8) addr) + (%get-unsigned-byte p 12) (ldb (byte 8 16) addr) + (%get-unsigned-byte p 13) (ldb (byte 8 24) addr)) + p)) + +#+x8632-target +(defun make-callback-trampoline (index &optional info) + (let* ((p (%allocate-callback-pointer 12)) + (addr #.(subprim-name->offset '.SPcallback))) + ;; If the optional info parameter is supplied, it will contain + ;; some stuff in bits 23 through 31. + ;; + ;; If bit 23 is set, that indicates that the caller will pass a + ;; "hidden" argument which is a pointer to appropriate storage for + ;; holding a returned structure. .SPcallback will have to discard + ;; this extra argument upon return. + ;; + ;; The high 8 bits denote the number of words that .SPcallback + ;; will have to discard upon return (used for _stdcall on + ;; Windows). Bit 23 won't be set in this case: we will have + ;; already added in the extra word to discard if that's necessary. + ;; + ;; These bits are be packed into the value that .SPcallback + ;; receives in %eax. Bits 0 through 22 are the callback index. + (if info + (setf (ldb (byte 23 0) info) index) + (setq info index)) + (setf (%get-unsigned-byte p 0) #xb8 ; movl $n,%eax + (%get-unsigned-byte p 1) (ldb (byte 8 0) info) + (%get-unsigned-byte p 2) (ldb (byte 8 8) info) + (%get-unsigned-byte p 3) (ldb (byte 8 16) info) + (%get-unsigned-byte p 4) (ldb (byte 8 24) info) + (%get-unsigned-byte p 5) #xff ; jmp * + (%get-unsigned-byte p 6) #x24 + (%get-unsigned-byte p 7) #x25 + (%get-unsigned-byte p 8) (ldb (byte 8 0) addr) + (%get-unsigned-byte p 9) (ldb (byte 8 8) addr) + (%get-unsigned-byte p 10) (ldb (byte 8 16) addr) + (%get-unsigned-byte p 11) (ldb (byte 8 24) addr)) + p)) + Index: /branches/qres/ccl/level-1/x86-error-signal.lisp =================================================================== --- /branches/qres/ccl/level-1/x86-error-signal.lisp (revision 13564) +++ /branches/qres/ccl/level-1/x86-error-signal.lisp (revision 13564) @@ -0,0 +1,445 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +#+x8664-target +(defun xp-argument-count (xp) + (ldb (byte (- 16 x8664::fixnumshift) 0) + (encoded-gpr-lisp xp x8664::nargs.q))) + +#+x8632-target +(defun xp-argument-count (xp) + (encoded-gpr-lisp xp target::nargs)) + +#+x8664-target +(defun xp-argument-list (xp) + (let ((nargs (xp-argument-count xp)) + (arg-x (encoded-gpr-lisp xp x8664::arg_x)) + (arg-y (encoded-gpr-lisp xp x8664::arg_y)) + (arg-z (encoded-gpr-lisp xp x8664::arg_z))) + (cond ((eql nargs 0) nil) + ((eql nargs 1) (list arg-z)) + ((eql nargs 2) (list arg-y arg-z)) + (t + (let ((args (list arg-x arg-y arg-z))) + (if (eql nargs 3) + args + (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8664::rsp) + (+ x8664::node-size x8664::xcf.size)))) + (dotimes (i (- nargs 3)) + (push (%get-object sp (* i x8664::node-size)) args)) + args))))))) + +#+x8632-target +(defun xp-argument-list (xp) + (let ((nargs (xp-argument-count xp)) + (arg-y (encoded-gpr-lisp xp x8632::arg_y)) + (arg-z (encoded-gpr-lisp xp x8632::arg_z))) + (cond ((eql nargs 0) nil) + ((eql nargs 1) (list arg-z)) + (t + (let ((args (list arg-y arg-z))) + (if (eql nargs 2) + args + (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8632::ebp) + (+ x8632::node-size x8632::xcf.size)))) + (dotimes (i (- nargs 2)) + (push (%get-object sp (* i x8632::node-size)) args)) + args))))))) + +;;; Making this be continuable is hard, because of the xcf on the +;;; stack and the way that the kernel saves/restores rsp and rbp +;;; before calling out. If we get around those problems, then +;;; we have to also deal with the fact that the return address +;;; is on the stack. Easiest to make the kernel deal with that, +;;; and just set %fn to the function that returns the values +;;; returned by the (newly defined) function and %arg_z to +;;; that list of values. +(defun handle-udf-call (xp frame-ptr) + (let* ((args (xp-argument-list xp)) + (values (multiple-value-list + (%kernel-restart-internal + $xudfcall + (list (maybe-setf-name (encoded-gpr-lisp xp target::fname)) args) + frame-ptr))) + (f #'(lambda (values) (apply #'values values)))) + (setf (encoded-gpr-lisp xp target::arg_z) values + (encoded-gpr-lisp xp target::fn) f))) + +#+x8664-target +(defcallback %xerr-disp (:address xp :address xcf :int) + (with-error-reentry-detection + (let* ((frame-ptr (macptr->fixnum xcf)) + (fn (%get-object xcf x8664::xcf.nominal-function)) + (op0 (%get-xcf-byte xcf 0)) + (op1 (%get-xcf-byte xcf 1)) + (op2 (%get-xcf-byte xcf 2))) + (declare (type (unsigned-byte 8) op0 op1 op2)) + (let* ((skip 2)) + (if (and (= op0 #xcd) + (>= op1 #x70)) + (cond ((< op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setq *error-reentry-count* 0) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) + (%slot-unbound-trap + (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + frame-ptr))) + ((= op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setf (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (%kernel-restart-internal $xvunbnd + (list + (encoded-gpr-lisp + xp + (ldb (byte 4 0) op2))) + frame-ptr))) + ((< op1 #xa0) + (setq skip (%check-anchored-uuo xcf 2)) + ;; #x9x, x>0 - register X is a symbol. It's unbound, + ;; but we don't have enough info to offer USE-VALUE, + ;; STORE-VALUE, or CONTINUE restarts. + (%error (make-condition 'unbound-variable + :name + (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1))) + () + frame-ptr)) + ((< op1 #xb0) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xfunbnd + (list (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1))) + frame-ptr)) + ((< op1 #xc0) + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal + #.(car (rassoc 'type-error *kernel-simple-error-classes*)) + (list (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + (logandc2 op2 arch::error-type-error)) + frame-ptr)) + ((= op1 #xc0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-few-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc1) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-many-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc2) + (setq skip (%check-anchored-uuo xcf 2)) + (let* ((flags (xp-flags-register xp)) + (nargs (xp-argument-count xp)) + (carry-bit (logbitp x86::x86-carry-flag-bit flags))) + (if carry-bit + (%error 'too-few-arguments + (list :nargs nargs + :fn fn) + frame-ptr) + (%error 'too-many-arguments + (list :nargs nargs + :fn fn) + frame-ptr)))) + ((= op1 #xc3) ;array rank + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal $XNDIMS + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc6) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp xp x8664::temp0) + :expected-type '(or symbol function) + :format-control + "~S is not of type ~S, and can't be FUNCALLed or APPLYed") + nil frame-ptr)) + ((= op1 #xc7) + (handle-udf-call xp frame-ptr) + (setq skip 0)) + ((or (= op1 #xc8) (= op1 #xcb)) + (setq skip (%check-anchored-uuo xcf 3)) + (%error (%rsc-string $xarroob) + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc9) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xnotfun + (list (encoded-gpr-lisp xp x8664::temp0)) + frame-ptr)) + ;; #xca = uuo-error-debug-trap + ((= op1 #xcc) + ;; external entry point or foreign variable + (setq skip (%check-anchored-uuo xcf 3)) + (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (fv.addr eep-or-fv)))))) + ((< op1 #xe0) + (setq skip (%check-anchored-uuo xcf 3)) + (if (= op2 x8664::subtag-catch-frame) + (%error (make-condition 'cant-throw-error + :tag (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1))) + nil frame-ptr) + (let* ((typename + (cond ((= op2 x8664::tag-fixnum) 'fixnum) + ((= op2 x8664::tag-single-float) 'single-float) + ((= op2 x8664::subtag-character) 'character) + ((= op2 x8664::fulltag-cons) 'cons) + ((= op2 x8664::tag-misc) 'uvector) + ((= op2 x8664::fulltag-symbol) 'symbol) + ((= op2 x8664::fulltag-function) 'function) + (t (let* ((class (logand op2 x8664::fulltagmask)) + (high4 (ash op2 (- x8664::ntagbits)))) + (cond ((= class x8664::fulltag-nodeheader-0) + (svref *nodeheader-0-types* high4)) + ((= class x8664::fulltag-nodeheader-1) + (svref *nodeheader-1-types* high4)) + ((= class x8664::fulltag-immheader-0) + (svref *immheader-0-types* high4)) + ((= class x8664::fulltag-immheader-1) + (svref *immheader-1-types* high4)) + ((= class x8664::fulltag-immheader-2) + (svref *immheader-2-types* high4)) + (t (list 'bogus op2)))))))) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + :expected-type typename) + nil + frame-ptr)))) + ((< op1 #xf0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + :expected-type 'list) + nil + frame-ptr)) + (t + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + :expected-type 'fixnum) + nil + frame-ptr))) + (%error "Unknown trap: #x~x~%xp=~s" + (list (list op0 op1 op2) xp) + frame-ptr)) + skip)))) + +;;; lots of duplicated code here +#+x8632-target +(defcallback %xerr-disp (:address xp :address xcf :int) + (with-error-reentry-detection + (let* ((frame-ptr (macptr->fixnum xcf)) + (fn (%get-object xcf x8632::xcf.nominal-function)) + (op0 (%get-xcf-byte xcf 0)) + (op1 (%get-xcf-byte xcf 1)) + (op2 (%get-xcf-byte xcf 2))) + (declare (type (unsigned-byte 8) op0 op1 op2)) + (let* ((skip 2)) + (if (and (= op0 #xcd) + (>= op1 #x70)) + (cond ((< op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setq *error-reentry-count* 0) + (setf (encoded-gpr-lisp xp (ldb (byte 3 0) op1)) + (%slot-unbound-trap + (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + frame-ptr))) + ((= op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setf (encoded-gpr-lisp + xp + (ldb (byte 3 0) op2)) + (%kernel-restart-internal $xvunbnd + (list + (encoded-gpr-lisp + xp + (ldb (byte 3 0) op2))) + frame-ptr))) + ((< op1 #xa0) + (setq skip (%check-anchored-uuo xcf 2)) + ;; #x9x, x>- - register X is a symbol. It's unbound, + ;; but we don't have enough info to offer USE-VALUE, + ;; STORE-VALUE, or CONTINUE restart + (%error (make-condition 'unbound-variable + :name + (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1))) + () + frame-ptr)) + ((< op1 #xb0) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xfunbnd + (list (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1))) + frame-ptr)) + ((< op1 #xc0) + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal + #.(car (rassoc 'type-error *kernel-simple-error-classes*)) + (list (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + (logandc2 op2 arch::error-type-error)) + frame-ptr)) + ((= op1 #xc0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-few-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc1) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-many-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc2) + (setq skip (%check-anchored-uuo xcf 2)) + (let* ((flags (xp-flags-register xp)) + (nargs (xp-argument-count xp)) + (carry-bit (logbitp x86::x86-carry-flag-bit flags))) + (if carry-bit + (%error 'too-few-arguments + (list :nargs nargs + :fn fn) + frame-ptr) + (%error 'too-many-arguments + (list :nargs nargs + :fn fn) + frame-ptr)))) + ((= op1 #xc3) ;array rank + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal $XNDIMS + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc6) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp xp x8632::temp0) + :expected-type '(or symbol function) + :format-control + "~S is not of type ~S, and can't be FUNCALLed or APPLYed") + nil frame-ptr)) + ((= op1 #xc7) + (handle-udf-call xp frame-ptr) + (setq skip 0)) + ((or (= op1 #xc8) (= op1 #xcb)) + (setq skip (%check-anchored-uuo xcf 3)) + (%error (%rsc-string $xarroob) + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc9) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xnotfun + (list (encoded-gpr-lisp xp x8632::temp0)) + frame-ptr)) + ;; #xca = uuo-error-debug-trap + ((= op1 #xcc) + ;; external entry point or foreign variable + (setq skip (%check-anchored-uuo xcf 3)) + (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (fv.addr eep-or-fv)))))) + ((< op1 #xe0) + (setq skip (%check-anchored-uuo xcf 3)) + (if (= op2 x8632::subtag-catch-frame) + (%error (make-condition 'cant-throw-error + :tag (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1))) + nil frame-ptr) + (let* ((typename + (cond ((= op2 x8632::tag-fixnum) 'fixnum) + ((= op2 x8632::subtag-character) 'character) + ((= op2 x8632::fulltag-cons) 'cons) + ((= op2 x8632::tag-misc) 'uvector) + (t (let* ((class (logand op2 x8632::fulltagmask)) + (high5 (ash op2 (- x8632::ntagbits)))) + (cond ((= class x8632::fulltag-nodeheader) + (svref *nodeheader-types* high5)) + ((= class x8632::fulltag-immheader) + (svref *immheader-types* high5)) + (t (list 'bogus op2)))))))) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + :expected-type typename) + nil + frame-ptr)))) + ((< op1 #xf0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + :expected-type 'list) + nil + frame-ptr)) + (t + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + :expected-type 'fixnum) + nil + frame-ptr))) + (%error "Unknown trap: #x~x~%xp=~s" + (list (list op0 op1 op2) xp) + frame-ptr)) + skip)))) + Index: /branches/qres/ccl/level-1/x86-threads-utils.lisp =================================================================== --- /branches/qres/ccl/level-1/x86-threads-utils.lisp (revision 13564) +++ /branches/qres/ccl/level-1/x86-threads-utils.lisp (revision 13564) @@ -0,0 +1,208 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +(defun %frame-backlink (p &optional context) + (declare (ignore context)) + (cond ((fixnump p) (%%frame-backlink p)) + (t (error "~s is not a valid stack frame" p)))) + +(defun bottom-of-stack-p (p context) + (and (fixnump p) + (locally (declare (fixnum p)) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (vs-area (%fixnum-ref tcr target::tcr.vs-area))) + (not (%ptr-in-area-p p vs-area)))))) + + +(defun lisp-frame-p (p context) + (declare (fixnum p)) + (let ((next-frame (%frame-backlink p context))) + (declare (fixnum next-frame)) + (if (bottom-of-stack-p next-frame context) + (values nil t) + (values t nil)))) + + +(defun catch-frame-sp (catch) + (uvref catch + #+x8632-target x8632::catch-frame.ebp-cell + #+x8664-target x8664::catch-frame.rbp-cell)) + +;;; Sure would be nice to have &optional in defppclapfunction arglists +;;; Sure would be nice not to do this at runtime. + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref))))) + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref-natural))))) + + +;;; Sure would be nice to have &optional in defppclapfunction arglists +;;; Sure would be nice not to do this at runtime. + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref))))) + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref-natural))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set-natural))))) + + +#+x8632-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (ldb (byte (- x8632::num-subtag-bits x8632::ntagbits) x8632::ntagbits) subtag))) + (declare (fixnum tagval)) + (case (logand subtag x8632::fulltagmask) + (#. x8632::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus))) + (#. x8632::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus))) + (t nil)))) + +#+x8664-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (logand x8664::fulltagmask subtag)) + (high4 (ash subtag (- x8664::ntagbits)))) + (declare (fixnum tagval high4)) + (not (eq 'bogus + (case tagval + (#.x8664::fulltag-immheader-0 + (%svref *immheader-0-types* high4)) + (#.x8664::fulltag-immheader-1 + (%svref *immheader-1-types* high4)) + (#.x8664::fulltag-immheader-2 + (%svref *immheader-2-types* high4)) + (#.x8664::fulltag-nodeheader-0 + (%svref *nodeheader-0-types* high4)) + (#.x8664::fulltag-nodeheader-1 + (%svref *nodeheader-1-types* high4)) + (t 'bogus)))))) + +#+x8632-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + (#.x8632::fulltag-misc (valid-subtag-p (typecode thing))) + ((#.x8632::fulltag-immheader #.x8632::fulltag-nodeheader) nil) + (t t)))) + +#+x8664-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + ((#.x8664::fulltag-even-fixnum + #.x8664::fulltag-odd-fixnum + #.x8664::fulltag-imm-0 + #.x8664::fulltag-imm-1) + t) + (#.x8664::fulltag-function + (= x8664::subtag-function (typecode (%function-to-function-vector thing)))) + (#.x8664::fulltag-symbol + (= x8664::subtag-symbol (typecode (%symptr->symvector thing)))) + (#.x8664::fulltag-misc + (valid-subtag-p (typecode thing))) + ((#.x8664::fulltag-tra-0 + #.x8664::fulltag-tra-1) + (let* ((disp (%return-address-offset thing))) + (and disp + (let* ((f (%return-address-function thing))) + (and (typep f 'function) (valid-header-p f)))))) + (#.x8664::fulltag-cons t) + (#.x8664::fulltag-nil (null thing)) + (t nil)))) + +#+x8632-target +(defun bogus-thing-p (x) + (when x + (or (not (valid-header-p x)) + (let ((tag (lisptag x)) + (fulltag (fulltag x))) + (unless (or (eql tag x8632::tag-fixnum) + (eql tag x8632::tag-imm) + (in-any-consing-area-p x) + (temporary-cons-p x) + (and (or (typep x 'function) + (typep x 'gvector)) + (on-any-tsp-stack x)) + (and (eql fulltag x8632::fulltag-tra) + (%return-address-offset x)) + (and (typep x 'ivector) + (on-any-csp-stack x)) + (%heap-ivector-p x)) + t))))) + +#+x8664-target +(defun bogus-thing-p (x) + (when x + (or (not (valid-header-p x)) + (let* ((tag (lisptag x))) + (unless (or (eql tag x8664::tag-fixnum) + (eql tag x8664::tag-imm-0) + (eql tag x8664::tag-imm-1) + (in-any-consing-area-p x) + (temporary-cons-p x) + (and (or (typep x 'function) + (typep x 'gvector)) + (on-any-tsp-stack x)) + (and (eql tag x8664::tag-tra) + (eql 0 (%return-address-offset x))) + (and (typep x 'ivector) + (on-any-csp-stack x)) + (%heap-ivector-p x)) + t))))) + Index: /branches/qres/ccl/level-1/x86-trap-support.lisp =================================================================== --- /branches/qres/ccl/level-1/x86-trap-support.lisp (revision 13564) +++ /branches/qres/ccl/level-1/x86-trap-support.lisp (revision 13564) @@ -0,0 +1,484 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; The order in which GPRs appear in an exception context generally +;;; has nothing to do with how they're encoded in instructions/uuos, +;;; and is OS-dependent. + +#+linuxx8664-target +(progn + (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext) + (get-field-offset :mcontext_t.gregs))) + (defmacro xp-gp-regs (xp) xp) + (defconstant flags-register-offset #$REG_EFL) + (defconstant rip-register-offset #$REG_RIP) + (defun xp-mxcsr (xp) + (pref xp :ucontext.uc_mcontext.fpregs.mxcsr)) + (defparameter *encoded-gpr-to-indexed-gpr* + #(13 ;rax + 14 ;rcx + 12 ;rdx + 11 ;rbx + 15 ;rsp + 10 ;rbp + 9 ;rsi + 8 ;rdi + 0 ;r8 + 1 ;r9 + 2 ;r10 + 3 ;r11 + 4 ;r12 + 5 ;r13 + 6 ;r14 + 7 ;r15 + ))) + +#+freebsdx8664-target +(progn + (defconstant gp-regs-offset (get-field-offset :ucontext_t.uc_mcontext)) + (defmacro xp-gp-regs (xp) xp) + (defconstant flags-register-offset 22) + (defconstant rip-register-offset 20) + (defun xp-mxcsr (xp) + (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate))) + (pref state :savefpu.sv_env.en_mxcsr))) + (defparameter *encoded-gpr-to-indexed-gpr* + #(7 ;rax + 4 ;rcx + 3 ;rdx + 8 ;rbx + 23 ;rsp + 9 ;rbp + 2 ;rsi + 1 ;rdi + 5 ;r8 + 6 ;r9 + 10 ;r10 + 11 ;r11 + 12 ;r12 + 13 ;r13 + 14 ;r14 + 15 ;r15 + ))) + +#+darwinx8664-target +(progn + (defconstant gp-regs-offset 0) + (defun xp-mxcsr (xp) + (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr)) + (defmacro xp-gp-regs (xp) + `(pref ,xp :ucontext_t.uc_mcontext.__ss)) + + (defconstant flags-register-offset 17) + (defconstant rip-register-offset 16) + (defparameter *encoded-gpr-to-indexed-gpr* + #(0 ;rax + 2 ;rcx + 3 ;rdx + 1 ;rbx + 7 ;rsp + 6 ;rbp + 5 ;rsi + 4 ;rdi + 8 ;r8 + 9 ;r9 + 10 ;r10 + 11 ;r11 + 12 ;r12 + 13 ;r13 + 14 ;r14 + 15 ;r15 + ))) + +#+solarisx8664-target +(progn + (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext) + (get-field-offset :mcontext_t.gregs))) + (defmacro xp-gp-regs (xp) xp) + (defconstant flags-register-offset #$REG_RFL) + (defconstant rip-register-offset #$REG_RIP) + (defun xp-mxcsr (xp) + (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr)) + (defparameter *encoded-gpr-to-indexed-gpr* + #(14 ;rax + 13 ;rcx + 12 ;rdx + 11 ;rbx + 20 ;rsp + 10 ;rbp + 9 ;rsi + 8 ;rdi + 7 ;r8 + 6 ;r9 + 5 ;r10 + 4 ;r11 + 3 ;r12 + 2 ;r13 + 1 ;r14 + 0 ;r15 + ))) + +#+win64-target +(progn + (defconstant gp-regs-offset (get-field-offset #>CONTEXT.Rax)) + (defmacro xp-gp-regs (xp) xp) + (defconstant rip-register-offset 16) + (defun xp-mxcsr (xp) + (pref xp #>CONTEXT.MxCsr)) + (defparameter *encoded-gpr-to-indexed-gpr* + #(0 ;rax + 1 ;rcx + 2 ;rdx + 3 ;rbx + 4 ;rsp + 5 ;rbp + 6 ;rsi + 7 ;rdi + 8 ;r8 + 9 ;r9 + 10 ;r10 + 11 ;r11 + 12 ;r12 + 13 ;r13 + 14 ;r14 + 15 ;r15 + ))) + +#+darwinx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref ,xp :ucontext_t.uc_mcontext.__ss)) + (defun xp-mxcsr (xp) + (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr)) + (defconstant flags-register-offset 9) + (defconstant eip-register-offset 10) + (defparameter *encoded-gpr-to-indexed-gpr* + #(0 ;eax + 2 ;ecx + 3 ;edx + 1 ;ebx + 7 ;esp + 6 ;ebp + 5 ;esi + 4 ;edi + ))) + +#+linuxx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs)) + (defun xp-mxcsr (xp) + (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs) + :_fpstate.mxcsr)) + (defconstant flags-register-offset #$REG_EFL) + (defconstant eip-register-offset #$REG_EIP) + (defparameter *encoded-gpr-to-indexed-gpr* + (vector + #$REG_EAX ;eax + #$REG_ECX ;ecx + #$REG_EDX ;edx + #$REG_EBX ;ebx + #$REG_ESP ;esp + #$REG_EBP ;ebp + #$REG_ESI ;esi + #$REG_EDI ;edi + ))) + +#+win32-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `,xp) + (defun xp-mxcsr (xp) + (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24)) + (defconstant flags-register-offset 48) + (defconstant eip-register-offset 45) + (defparameter *encoded-gpr-to-indexed-gpr* + #( + 44 ;eax + 43 ;ecx + 42 ;edx + 41 ;ebx + 49 ;esp + 45 ;ebp + 40 ;esi + 39 ;edi + ))) + +#+solarisx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs)) + (defun xp-mxcsr (xp) + (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr)) + (defconstant flags-register-offset #$EFL) + (defconstant eip-register-offset #$EIP) + (defparameter *encoded-gpr-to-indexed-gpr* + (vector + #$EAX + #$ECX + #$EDX + #$EBX + #$ESP + #$EBP + #$ESI + #$EDI) + )) + +#+freebsdx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref ,xp :ucontext_t.uc_mcontext)) + (defun xp-mxcsr (xp) + (pref (pref xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_env.en_mxcsr) +) + (defconstant flags-register-offset 17) + (defconstant eip-register-offset 15) + (defparameter *encoded-gpr-to-indexed-gpr* + #( + 12 ;eax + 11 ;ecx + 10 ;edx + 9 ;ebx + 18 ;esp + 7 ;ebp + 6 ;esi + 5 ;edi + ) + )) + +(defun indexed-gpr-lisp (xp igpr) + (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)))) +(defun (setf indexed-gpr-lisp) (new xp igpr) + (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)) new)) +(defun encoded-gpr-lisp (xp gpr) + (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr))) +(defun (setf encoded-gpr-lisp) (new xp gpr) + (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new)) +(defun indexed-gpr-integer (xp igpr) + #+x8664-target + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) + #+x8632-target + (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift)))) +(defun (setf indexed-gpr-integer) (new xp igpr) + (setf + #+x8664-target + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) + #+x8632-target + (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift))) + new)) +(defun encoded-gpr-integer (xp gpr) + (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr))) +(defun (setf encoded-gpr-integer) (new xp gpr) + (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new)) +(defun indexed-gpr-macptr (xp igpr) + (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)))) +(defun (setf indexed-gpr-macptr) (new xp igpr) + (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new)) +(defun encoded-gpr-macptr (xp gpr) + (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr))) +(defun (setf encoded-gpr-macptr) (new xp gpr) + (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new)) +(defun xp-flags-register (xp) + #+windows-target (pref xp #>CONTEXT.EFlags) + #-windows-target + (progn + #+x8664-target + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift))) + #+x8632-target + (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift))))) + + + +(defun %get-xcf-byte (xcf-ptr delta) + (let* ((containing-object (%get-object xcf-ptr target::xcf.containing-object)) + (byte-offset (%get-object xcf-ptr target::xcf.relative-pc))) + (if containing-object + (locally (declare (optimize (speed 3) (safety 0)) + (type (simple-array (unsigned-byte 8) (*)) containing-object)) + (aref containing-object (the fixnum (+ byte-offset delta)))) + (%get-unsigned-byte (%int-to-ptr byte-offset) delta)))) + +;;; If the byte following a uuo (which is "skip" bytes long, set +;;; the xcf's relative PC to the value contained in the 32-bit +;;; word preceding the current relative PC and return -1, else return skip. +(defun %check-anchored-uuo (xcf skip) + (if (eql 0 (%get-xcf-byte xcf skip)) + (let* ((new-rpc (+ #+x8664-target target::tag-function + #+x8632-target target::fulltag-misc + (logior (ash (%get-xcf-byte xcf -1) 24) + (ash (%get-xcf-byte xcf -2) 16) + (ash (%get-xcf-byte xcf -3) 8) + (%get-xcf-byte xcf -4))))) + (%set-object xcf target::xcf.relative-pc new-rpc) + -1) + skip)) + + +(defun decode-arithmetic-error (xp xcf) + (declare (ignore xp xcf)) + (values 'unknown nil)) + +(eval-when (:compile-toplevel :execute) + (progn + (defun conditional-os-constant (alternatives) + (dolist (c alternatives (error "None of the constants in ~s could be loaded" alternatives)) + (if (load-os-constant c t) + (return (load-os-constant c))))) + + (defconstant integer-divide-by-zero-code + (conditional-os-constant '(os::EXCEPTION_INT_DIVIDE_BY_ZERO os::FPE_INTDIV)) +) + (defconstant float-divide-by-zero-code + (conditional-os-constant '(os::EXCEPTION_FLT_DIVIDE_BY_ZERO os::FPE_FLTDIV))) + (defconstant float-overflow-code + (conditional-os-constant '(os::FPE_FLTOVF os::EXCEPTION_FLT_OVERFLOW))) + (defconstant float-underflow-code + (conditional-os-constant '(os::FPE_FLTUND os::EXCEPTION_FLT_UNDERFLOW))) + (defconstant float-inexact-code + (conditional-os-constant '(os::FPE_FLTRES os::EXCEPTION_FLT_INEXACT_RESULT))))) + +;;; UUOs are handled elsewhere. This should handle all signals other than +;;; those generated by UUOs (and the non-UUO cases of things like SIGSEGV.) +;;; If the signal number is 0, other arguments (besides the exception context XP) +;;; may not be meaningful. +(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int) + (let* ((frame-ptr (macptr->fixnum xcf)) + (skip 0)) + (cond ((zerop signal) ;thread interrupt + (cmain)) + ((< signal 0) + (%err-disp-internal code () frame-ptr)) + ((= signal #$SIGFPE) + (setq code (logand #xffffffff code)) + (multiple-value-bind (operation operands) + (decode-arithmetic-error xp xcf) + (let* ((condition-name + (cond ((or (= code integer-divide-by-zero-code) + (= code float-divide-by-zero-code)) + 'division-by-zero) + ((= code float-overflow-code) + 'floating-point-overflow) + ((= code float-underflow-code) + 'floating-point-underflow) + ((= code float-inexact-code) + 'floating-point-inexact) + (t + 'floating-point-invalid-operation)))) + (%error (make-condition condition-name + :operation operation + :operands operands + :status (xp-mxcsr xp)) + () + frame-ptr)))) + ((= signal #$SIGSEGV) + (cond + ((or (= code 0) (= code 1)) + ;; Stack overflow. + (let* ((on-tsp (= code 1))) + (unwind-protect + (%error + (make-condition + 'stack-overflow-condition + :format-control "Stack overflow on ~a stack." + :format-arguments (list (if on-tsp "temp" "value"))) + nil frame-ptr) + (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit) + :unsigned-fullword code + :void)))) + ((= code 2) + ;; Write to a watched object. + (let* ((offset other) + ;; The kernel exception handler leaves the + ;; watched object on the lisp stack under the + ;; xcf. + (object (%get-object xcf target::xcf.size))) + (multiple-value-bind (insn insn-length) + (ignore-errors (x86-faulting-instruction xp)) + (restart-case (%error (make-condition + 'write-to-watched-object + :offset offset + :object object + :instruction insn) + nil frame-ptr) + #-windows-target + (emulate () + :test (lambda (c) + (declare (ignore c)) + (x86-can-emulate-instruction insn)) + :report + "Emulate this instruction, leaving the object watched." + (flet ((watchedp (object) + (%map-areas #'(lambda (x) + (when (eq object x) + (return-from watchedp t))) + area-watched))) + (let ((result nil)) + (with-other-threads-suspended + (when (watchedp object) + ;; We now trust that the object is in a + ;; static gc area. + (let* ((a (+ (%address-of object) offset)) + (ptr (%int-to-ptr + (logandc2 a (1- *host-page-size*))))) + (#_mprotect ptr *host-page-size* #$PROT_WRITE) + (setq result (x86-emulate-instruction xp insn)) + (#_mprotect ptr *host-page-size* + (logior #$PROT_READ #$PROT_EXEC))))) + (if result + (setq skip insn-length) + (error "could not emulate the instrution"))))) + (skip () + :test (lambda (c) + (declare (ignore c)) + insn) + :report "Skip over this write instruction." + (setq skip insn-length)) + (unwatch () + :report "Unwatch the object and retry the write." + (unwatch object)))))))) + ((= signal #+win32-target 10 #-win32-target #$SIGBUS) + (if (= code -1) + (%error (make-condition 'invalid-memory-operation) + () + frame-ptr) + (%error (make-condition 'invalid-memory-access + :address addr + :write-p (not (zerop code))) + () + frame-ptr)))) + skip)) + +(defun x86-faulting-instruction (xp) + (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8))) + (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset + #+x8664-target rip-register-offset))) + (dotimes (i (length code-bytes)) + (setf (aref code-bytes i) (%get-unsigned-byte pc i))) + (let* ((ds (make-x86-disassembly-state + :mode-64 #+x8664-target t #+x8632-target nil + :code-vector code-bytes + :code-pointer 0)) + (insn (x86-disassemble-instruction ds nil)) + (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds)))) + (values insn len)))) Index: /branches/qres/ccl/lib/.cvsignore =================================================================== --- /branches/qres/ccl/lib/.cvsignore (revision 13564) +++ /branches/qres/ccl/lib/.cvsignore (revision 13564) @@ -0,0 +1,1 @@ +*~.* Index: /branches/qres/ccl/lib/apropos.lisp =================================================================== --- /branches/qres/ccl/lib/apropos.lisp (revision 13564) +++ /branches/qres/ccl/lib/apropos.lisp (revision 13564) @@ -0,0 +1,248 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Apropos.lisp + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require :level-2) + ) + +(defun apropos-list (string &optional package &aux list) + "Like APROPOS, except that it returns a list of the symbols found instead + of describing them." + (setq string (string-arg string)) + (if package + (do-symbols (sym package) + (when (%apropos-substring-p string (symbol-name sym)) + (push sym list))) + (do-all-symbols (sym) + (when (%apropos-substring-p string (symbol-name sym)) + (push sym list)))) + (let* ((last 0) ; not a symbol + (junk #'(lambda (item) + (declare (debugging-function-name nil)) + (or (eq item last) (progn (setq last item) nil))))) + (declare (dynamic-extent junk)) + (setq list (delete-if junk (sort list #'string-lessp)))) + list) + +(defvar *apropos-indent-to-search-string* nil) +(defun apropos-list-aux (theString package indent-to-search-string &aux theList) + (setq theString (string-arg theString)) + (if package + (do-symbols (sym package) + (when (%apropos-substring-p theString (symbol-name sym)) + (pushnew sym theList))) + (do-all-symbols (sym) + (when (%apropos-substring-p theString (symbol-name sym)) + (pushnew sym theList)))) + (let* ((last 0) ; not a symbol + (junk #'(lambda (item) + (declare (debugging-function-name nil)) + (or (eq item last) (progn (setq last item) nil))))) + (declare (dynamic-extent junk)) + (sort-symbol-list (delete-if junk theList) (if indent-to-search-string + theString + nil)))) + +(defun apropos-string-indented (symTuple indent) + (let ((pr-string (prin1-to-string (aref symTuple 0))) + (displayOffset (aref symTuple 3))) + (format nil "~v@a~a" + indent + (subseq pr-string 0 displayOffset) + (subseq pr-string displayOffset)))) + + +(defun apropos-aux (theString symtuple indent) + (declare (ignore theString)) + (let ((sym (aref symtuple 0)) + val) + (format t "~a" (apropos-string-indented symtuple indent)) + (when (setq val (fboundp sym)) + (cond ((functionp val) + (princ ", Def: ") + (prin1 (type-of val))) + ((setq val (macro-function sym)) + (princ ", Def: MACRO ") + (prin1 (type-of val))) + (t (princ ", Special form")))) + (when (boundp sym) + (princ ", Value: ") + (prin1 (symbol-value sym))) + (terpri))) + + +(defun apropos (theString &optional package) + (multiple-value-bind (symVector indent) (apropos-list-aux theString package *apropos-indent-to-search-string*) + (loop for symtuple across symVector + do (apropos-aux theString symtuple indent)) + (values))) + +#| +(defun apropos (string &optional package) + "Briefly describe all symbols which contain the specified STRING. + If PACKAGE is supplied then only describe symbols present in + that package. If EXTERNAL-ONLY then only describe + external symbols in the specified package." + (setq string (string-arg string)) + (if package + (do-symbols (sym package) (apropos-aux string sym)) + (do-all-symbols (sym) (apropos-aux string sym))) + (values)) + +(defun apropos-aux (string sym &aux val) + (when (%apropos-substring-p string (symbol-name sym)) + (prin1 sym) + (when (setq val (fboundp sym)) + (cond ((functionp val) + (princ ", Def: ") + (prin1 (type-of val))) + ((setq val (macro-function sym)) + (princ ", Def: MACRO ") + (prin1 (type-of val))) + (t (princ ", Special form")))) + (when (boundp sym) + (princ ", Value: ") + (prin1 (symbol-value sym))) + (terpri))) +|# + +; (%apropos-substring-p a b) +; Returns true iff a is a substring (case-sensitive) of b. +; Internal subroutine of apropos, does no type-checking. Assumes strings no +; longer than 64K... + + + + +(defun %apropos-substring-p (a b) + (let ((charA0 (%schar a 0)) + (alen (length a)) + (blen (length b))) + (declare (fixnum alen blen) (optimize (speed 3)(safety 0))) + (if (= alen 0) ; "" is substring of every string + t + (if *apropos-case-sensitive-p* + (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen))))) + (declare (fixnum i)) + (when (eq (%schar b i) chara0) + (when + (do ((j 1 (1+ j))) + ((>= j alen) t) + (declare (fixnum j)) + (when (neq (%schar a j)(%schar b (%i+ j i))) + (return nil))) + (return (%i- blen i alen))))) + (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen))))) + (declare (fixnum i)) + (when (eq (char-upcase (%schar b i)) (char-upcase chara0)) + (when + (do ((j 1 (1+ j))) + ((>= j alen) t) + (declare (fixnum j)) + (unless (eq (char-upcase (%schar a j)) (char-upcase (%schar b (%i+ j i)))) + (return nil))) + (return (%i- blen i alen))))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; from Dave Yost +(defun find-sym-alpha-part (sym) + (let* ((str (prin1-to-string sym)) + (sortOffset (let ((sym-start (if (find #\: str) + (loop for ind from (1- (length str)) downto 0 + when (eql #\: (char str ind)) + return (1+ ind)) + 0))) + (+ sym-start (find-alpha-char (subseq str sym-start)))))) + (values str sortOffset sortOffset))) + +(defun find-str-in-sym (str sym) + (let* ((symStr (string-arg (prin1-to-string sym))) + (sortOffset (let ((sym-start (if (find #\: str) + (loop for ind from (1- (length str)) downto 0 + when (eql #\: (char str ind)) + return (1+ ind)) + 0))) + (+ sym-start (find-alpha-char (subseq str sym-start))))) + (displayOffset (let ((sym-start (if (find #\: symStr) + (or (loop for ind from (1- (length symStr)) downto 0 + when (eql #\| (schar symStr ind)) + do (setf ind (loop for ind2 from (1- ind) downto 0 + when (eql #\| (schar symStr ind2)) + return ind2)) + when (eql #\: (char symStr ind)) + return (1+ ind)) + 0) + 0))) + (+ sym-start (search (string-upcase str) (string-upcase (subseq symStr sym-start))))))) + (values symStr sortOffset displayOffset))) + +(defun find-alpha-char (str) + "returns the character position of the first +alphabetic character in str, or the length of str +if it contains no alphabetic characters." + (setq str (string-arg str)) + (dotimes (ind (length str) ind) + (when (alpha-char-p (schar str ind)) + (return ind)))) + +(defun sort-symbol-list (theList search-string) + ;;; First precompute the stylized string form of the symbols as they will be compared + ;;; and calculate the maximum indent + (multiple-value-bind (tmpVector indentation) + (let (sortOffset + displayOffset + str) + (loop for x in thelist do + (multiple-value-setq (str sortOffset displayOffset) + (if search-string + (find-str-in-sym search-string x) + (find-sym-alpha-part x))) + + + maximize displayOffset into indentation1 + collect `#(,x ,(string-arg (subseq str sortOffset)) ,sortOffset ,displayOffset) into tmpList1 + finally (return (values `#(,@tmpList1) indentation1)))) + (setq TMPVECTor (sort tmpVector #'(lambda (symPair1 symPair2) + (string-lessp (aref symPair1 1) (aref symPair2 1))))) + (values tmpVector ; each element is a vector of `#(,sym sortable-string-for-sym) + indentation))) + + +#| +(defun %apropos-substring-p (a b &aux (alen (length a)) + (xlen (%i- (length b) alen))) + (if (%iminusp xlen) nil + (if (eq alen 0) alen + (let ((a0 (schar a 0)) (i 0) j) + (tagbody loop + (when (eq (schar b i) a0) + (setq j 1) + (tagbody subloop + (when (eq j alen) (return-from %apropos-substring-p i)) + (when (eq (schar b (%i+ i j)) (schar a j)) + (setq j (%i+ j 1)) + (go subloop)))) + (unless (eq i xlen) + (setq i (%i+ i 1)) + (go loop))) + nil)))) +|# Index: /branches/qres/ccl/lib/arglist.lisp =================================================================== --- /branches/qres/ccl/lib/arglist.lisp (revision 13564) +++ /branches/qres/ccl/lib/arglist.lisp (revision 13564) @@ -0,0 +1,286 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Record pseudo-arglist info for special operators. +(record-arglist 'catch "tag &body body") +(record-arglist 'progn "&BODY BODY") +(record-arglist 'function "NAME-OR-LAMBDA-EXPRESSION") +(record-arglist 'go "TAG") +(record-arglist 'symbol-macrolet "(&REST BINDINGS) &BODY BODY") +(record-arglist 'locally "DECLARATION* &BODY BODY") +(record-arglist 'setq "[SYMBOL VALUE]*") +(record-arglist 'tagbody "&REST TAGS-OR-FORMS") +(record-arglist 'return-from "BLOCK VALUES") +(record-arglist 'quote '(form)) +(record-arglist 'macrolet "(&REST BINDINGS) &BODY BODY") +(record-arglist 'the '(type-specifier form)) +(record-arglist 'eval-when "(&REST SITUATIONS) &BODY BODY") +(record-arglist 'let* "(&REST BINDINGS) &BODY BODY") +(record-arglist 'let "(&REST BINDINGS) &BODY BODY") +(record-arglist 'load-time-value '(form)) +(record-arglist 'throw '(tag value)) +(record-arglist 'unwind-protect "PROTECTED-FORM &BODY CLEANUP-FORMS") +(record-arglist 'flet "(&REST BINDINGS) &BODY BODY") +(record-arglist 'multiple-value-call '(function &rest values-producing-forms)) +(record-arglist 'block "NAME &BODY BODY") +(record-arglist 'labels "(&REST BINDINGS) &BODY BODY") +(record-arglist 'multiple-value-prog1 "VALUES-PRODUCING-FORM &BODY FORMS-FOR-EFFECT") +(record-arglist 'if '(test true &optional false)) +(record-arglist 'progv "(&REST VARS) (&REST VALUES) &BODY BODY") +(record-arglist 'nfunction '(function-name lambda-expression)) + + +; Returns two values: the arglist & it's functions binding. +; If the second arg is NIL, there was no function binding. +(defun arglist (sym &optional include-bindings) + (%arglist sym include-bindings)) + +(defun arglist-string (sym &optional include-bindings) + (multiple-value-bind (res type) + (%arglist-internal sym include-bindings) + (values + (if (stringp res) + res + (and res (princ-to-string res))) + type))) + +(defun set-arglist (sym arglist) + (let ((real-sym (arglist-sym-and-def sym))) + (when (or real-sym (null sym)) + (if (eq arglist t) + (remhash real-sym %lambda-lists%) + (setf (gethash real-sym %lambda-lists%) arglist))))) + +(defsetf arglist set-arglist) + +; Same as ARGLIST, but has the option of using TEMP-CONS instead of CONS +; to cons up the list. +(defun %arglist (sym &optional include-bindings) + (multiple-value-bind (res type) + (%arglist-internal + sym include-bindings) + (when (stringp res) + (with-input-from-string (stream res) + (setq res nil) + (let ((eof (list nil)) + val errorp) + (declare (dynamic-extent eof)) + (loop + (multiple-value-setq (val errorp) + (ignore-errors (values (read stream nil eof)))) + (when errorp + (push '&rest res) + (push ':unparseable res) + (return)) + (when (eq val eof) + (return)) + (push val res)) + (setq res + (if (and (null (cdr res)) (listp (car res))) + (car res) + (nreverse res)))))) + (values res type))) + +(defun %arglist-internal (sym include-bindings + &aux def type) + (multiple-value-setq (sym def) (arglist-sym-and-def sym)) + (if (generic-function-p def) + (values (generic-function-lambda-list def) :declaration) + (let ((ll (gethash sym %lambda-lists% *eof-value*)) + (macrop (and (symbolp sym) (eq (macro-function sym) def)))) + (flet ((strip (f) (if (stringp f) f (strip-bindings f include-bindings)))) + (declare (dynamic-extent #'strip)) + (cond ((neq ll *eof-value*) (values (strip ll) :declaration)) + ((consp def) + ;; Presumably (lambda (... arglist) ...) + (values (strip (cadr def)) :definition)) + ((neq (setq ll (getf (%lfun-info def) 'arglist *eof-value*)) *eof-value*) + (values ll :definition)) + ((and (not macrop) (setq ll (uncompile-function def))) + (values (strip (cadr ll)) (or type :definition))) + ((lfunp def) + (multiple-value-bind (arglist gotit) + (unless macrop (arglist-from-map def)) + (if gotit + (values arglist :analysis) + (cond (macrop (values nil :unknown)) + (t (values (arglist-from-compiled-def def) :analysis)))))) + (t (values nil nil))))))) + + + +(defun strip-bindings (arglist include-bindings) + (if include-bindings + arglist + (let ((res nil)) + (do ((args arglist (%cdr args))) + ((not (consp args)) (nreconc res args)) + (let ((arg (car args))) + (cond ((atom arg) + (push arg res)) + ((atom (car arg)) + (push (car arg) res)) + (t (push (caar arg) res)))))))) + +(defun arglist-sym-and-def (sym &aux def) + (cond ((functionp sym) + (setq def sym + sym (function-name def)) + (unless (and (symbolp sym) (eq def (fboundp sym))) + (setq sym nil))) + ((listp sym) + (if (eq (car sym) 'setf) + (setq sym (setf-function-name (cadr sym)) + def (find-unencapsulated-definition (fboundp sym))) + (setq sym nil def nil))) + ((standard-method-p sym) + (setq def (closure-function + (find-unencapsulated-definition (%method-function sym))))) + ((and (macro-function sym)) + (setq def (macro-function sym))) + ((special-operator-p sym) + nil) + (t (setq def (find-unencapsulated-definition (fboundp sym))))) + (values sym (if (standard-generic-function-p def) def (closure-function def)))) + +(defun arglist-from-map (lfun) + (multiple-value-bind (nreq nopt restp nkeys allow-other-keys + optinit lexprp + ncells nclosed) + (function-args lfun) + (declare (ignore optinit)) + (if lexprp + (setq restp t)) + (let ((map (car (function-symbol-map lfun)))) + (if map + (let ((total (+ nreq nopt (if restp 1 0) (or nkeys 0))) + (idx (- (length map) nclosed)) + (res nil)) + (if (%izerop total) + (values nil t) + (progn + (dotimes (x nreq) + (declare (fixnum x)) + (push (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)) res)) + (when (neq nopt 0) + (push '&optional res) + (dotimes (x (the fixnum nopt)) + (push (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)) res))) + + (when restp + (push (if lexprp '&lexpr '&rest) res) + (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res)) + (when nkeys + (push '&key res) + (let ((keyvect (lfun-keyvect lfun))) + (dotimes (i (length keyvect)) + (push (elt keyvect i) res)))) + (when allow-other-keys + (push '&allow-other-keys res)))) + (values (nreverse res) t)) + (values nil (zerop ncells)))))) + +(defun arg-names-from-map (lfun pc) + (when lfun + (multiple-value-bind (nreq nopt restp nkeys allow-other-keys + optinit lexprp + ncells nclosed) + (function-args lfun) + (declare (ignore optinit ncells allow-other-keys)) + (collect ((req) + (opt) + (keys)) + (let* ((rest nil) + (map (if (and pc (> pc target::arg-check-trap-pc-limit)) + (car (function-symbol-map lfun))))) + (if (and map pc) + (let ((total (+ nreq nopt (if (or restp lexprp) 1 0) (or nkeys 0))) + (idx (- (length map) nclosed))) + (unless (zerop total) + (progn + (dotimes (x (the fixnum nreq)) + (declare (fixnum x)) + (req (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)))) + (when (neq nopt 0) + (dotimes (x (the fixnum nopt)) + (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x))))) + (when (or restp lexprp) + (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest))) + (when nkeys + (dotimes (i (the fixnum nkeys)) + (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i))))))))) + (values (or (not (null map)) + (and (eql 0 nreq) (eql 0 nopt) (not restp) (null nkeys))) + (req) (opt) rest (keys))))))) + + + + +(defvar *req-arg-names* + #(arg-0 arg-1 arg-2 arg-3 arg-4 arg-5 arg-6 arg-7 arg-8 arg-9)) + +(defvar *opt-arg-names* + #(opt-0 opt-1 opt-2 opt-3 opt-4 opt-5 opt-6 opt-7 opt-8 opt-9)) + + +(defun make-arg (prefix count) + (cond ((and (string= prefix "ARG") (< count (length *req-arg-names*))) + (svref *req-arg-names* count)) + ((and (string= prefix "OPT") (< count (length *opt-arg-names*))) + (svref *opt-arg-names* count)) + (t (intern (format nil "~a-~d" prefix count) :CCL)))) + +(defun arglist-from-compiled-def (lfun &aux (res nil) argnames) + (multiple-value-bind (nreq nopt restp nkeys allow-other-keys + optinit lexprp + ncells nclosed) + (function-args lfun) + (declare (ignore optinit ncells nclosed)) + (flet ((push-various-args (prefix count) + (dotimes (i (the fixnum count)) + (push (make-arg prefix i) res)))) + (declare (dynamic-extent #'push-various-args)) + ;; Treat &LEXPR like &REST. + (if lexprp (setq restp t lexprp nil)) + (cond ((and (eq 0 (+ nreq nopt (or nkeys 0))) (not restp)) + nil) + (t + (if argnames + (setq res (reverse (butlast argnames (- (length argnames) nreq)))) + (push-various-args "ARG" nreq)) + (when (> nopt 0) + (push '&optional res) + (if argnames + (setq res (append (reverse (subseq argnames nreq (+ nreq nopt))) res)) + (push-various-args "OPT" nopt))) + (when restp + (push '&rest res) + (if argnames + (push (nth (+ nreq nopt) argnames) res) + (push 'the-rest res))) + (when nkeys + (push '&key res) + (let ((keyvect (lfun-keyvect lfun))) + (dotimes (i (length keyvect)) + (push (elt keyvect i) res)))) + (when allow-other-keys + (push '&allow-other-keys res)) + (nreverse res)))))) + +; End of arglist.lisp Index: /branches/qres/ccl/lib/arrays-fry.lisp =================================================================== --- /branches/qres/ccl/lib/arrays-fry.lisp (revision 13564) +++ /branches/qres/ccl/lib/arrays-fry.lisp (revision 13564) @@ -0,0 +1,465 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun bit (bit-array &rest subscripts) + "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS." + (declare (dynamic-extent subscripts)) + (unless (eq (array-element-type bit-array) 'bit) + (report-bad-arg bit-array '(array bit))) + (apply #'aref bit-array subscripts)) + +(defun %bitset (bit-array &rest stuff) + (declare (dynamic-extent stuff)) + (unless (eq (array-element-type bit-array) 'bit) + (report-bad-arg bit-array '(array bit))) + (apply #'aset bit-array stuff)) + +(defun sbit (v &optional (sub0 nil sub0-p) &rest others) + "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS." + (declare (dynamic-extent others)) + (if sub0-p + (if others + (apply #'bit v sub0 others) + ( sbit (require-type v 'simple-bit-vector) sub0)) + (bit v))) + +(defun %sbitset (v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1) + (declare (dynamic-extent newval-was-really-sub1)) + (if newval-p + (if newval-was-really-sub1 + (apply #'%bitset v sub0 newval newval-was-really-sub1) + (progn + (unless (typep v 'simple-bit-vector) + (report-bad-arg v 'simple-bit-vector)) + (uvset v sub0 newval))) + (%bitset v sub0))) + +(defun bit-and (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-and bit-array1 bit-array2 result-bit-array)) + +(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGIOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-ior bit-array1 bit-array2 result-bit-array)) + +(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGXOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-xor bit-array1 bit-array2 result-bit-array)) + +(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGEQV on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-eqv bit-array1 bit-array2 result-bit-array)) + +(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGNAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-nand bit-array1 bit-array2 result-bit-array)) + +(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGNOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-nor bit-array1 bit-array2 result-bit-array)) + +(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGANDC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-andc1 bit-array1 bit-array2 result-bit-array)) + +(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGANDC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-andc2 bit-array1 bit-array2 result-bit-array)) + +(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGORC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-orc1 bit-array1 bit-array2 result-bit-array)) + +(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGORC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-orc2 bit-array1 bit-array2 result-bit-array)) + +(defun bit-not (bit-array &optional result-bit-array) + "Performs a bit-wise logical NOT on the elements of BIT-ARRAY, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. Both arrays must have the same rank and dimensions." + (bit-boole boole-nor bit-array bit-array result-bit-array)) + +(defun result-bit-array (bit-array-1 bit-array-2 result) + ; Check that the two bit-array args are bit-arrays with + ; compatible dimensions. If "result" is specified as T, + ; return bit-array-1. If result is unspecified, return + ; a new bit-array of the same dimensions as bit-array-2. + ; Otherwise, make sure that result is a bit-array of the + ; same dimensions as the other two arguments and return + ; it. + (let* ((typecode-1 (typecode bit-array-1)) + (typecode-2 (typecode bit-array-2))) + (declare (fixnum typecode-1 typecode-2)) + (flet ((bit-array-dimensions (bit-array typecode) + (declare (fixnum typecode)) + (if (= typecode target::subtag-bit-vector) + (uvsize bit-array) + (let* ((array-p (= typecode target::subtag-arrayH)) + (vector-p (= typecode target::subtag-vectorH))) + (if (and (or array-p vector-p) + (= (the fixnum (%array-header-subtype bit-array)) target::subtag-bit-vector)) + (if vector-p + (array-dimension bit-array 0) + (array-dimensions bit-array)) + (report-bad-arg bit-array '(array bit)))))) + (check-matching-dimensions (a1 d1 a2 d2) + (unless (equal d1 d2) + (error "~s and ~s have different dimensions." a1 a2)) + a2)) + (let* ((dims-1 (bit-array-dimensions bit-array-1 typecode-1)) + (dims-2 (bit-array-dimensions bit-array-2 typecode-2))) + (check-matching-dimensions bit-array-1 dims-1 bit-array-2 dims-2) + (if result + (if (eq result t) + bit-array-1 + (check-matching-dimensions bit-array-2 dims-2 result (bit-array-dimensions result (typecode result)))) + (make-array dims-2 :element-type 'bit :initial-element 0)))))) + + + + + +(defun bit-boole (opcode array1 array2 result-array) + (unless (eql opcode (logand 15 opcode)) + (setq opcode (require-type opcode '(mod 16)))) + (let* ((result (result-bit-array array1 array2 result-array))) + (if (and (typep array1 'simple-bit-vector) + (typep array2 'simple-bit-vector) + (typep result 'simple-bit-vector)) + (%simple-bit-boole opcode array1 array2 result) + (multiple-value-bind (v1 i1) (array-data-and-offset array1) + (declare (simple-bit-vector v1) (fixnum i1)) + (multiple-value-bind (v2 i2) (array-data-and-offset array2) + (declare (simple-bit-vector v2) (fixnum i2)) + (multiple-value-bind (v3 i3) (array-data-and-offset result) + (declare (simple-bit-vector v3) (fixnum i3)) + (let* ((e3 (+ i3 (the fixnum (array-total-size result))))) + (declare (fixnum e3)) + (do* ( ) + ((= i3 e3) result) + (setf (sbit v3 i3) + (logand (boole opcode (sbit v1 i1) (sbit v2 i2)) 1)) + (incf i1) + (incf i2) + (incf i3))))))))) + + + + + + + + +; shrink-vector is called only in sequences-2. None of the calls depend on +; the side affect of setting the passed-in symbol to the [possibly new] +; returned vector +; Since there hasn't been such a thing as sequences-2 in about 7 years, +; this is especially puzzling. +(eval-when (:compile-toplevel :execute :load-toplevel) + (defmacro shrink-vector (vector to-size) + `(setq ,vector (%shrink-vector ,vector ,to-size))) + ) + + +; new and faulty def +(defun %shrink-vector (vector to-size) + (cond ((eq (length vector) to-size) + vector) + ((array-has-fill-pointer-p vector) + (setf (fill-pointer vector) to-size) + vector) + (t (subseq vector 0 to-size)))) + + +; this could be put into print-db as it was in ccl-pr-4.2 +; Or it (and print-db) could just be flushed ... tough one. +(defun multi-dimension-array-to-list (array) + "Produces a nested list of the elements in array." + (mdal-aux array (array-dimensions array) nil + (array-dimensions array))) + +(defun mdal-aux (array all-dimensions use-dimensions + remaining-dimensions) + (if (= (length all-dimensions) (length use-dimensions)) + (apply 'aref array use-dimensions) + (do ((index 0 (1+ index)) + (d-length (car remaining-dimensions)) + (result nil)) + ((= d-length index) result) + (setq result + (append result (list (mdal-aux array all-dimensions + (append use-dimensions + (list index)) + (cdr remaining-dimensions)))))))) + +(defun adjust-array (array dims + &key (element-type nil element-type-p) + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p) + (fill-pointer nil fill-pointer-p) + displaced-to + displaced-index-offset + &aux (subtype (array-element-subtype array))) + "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." + (when (and element-type-p + (neq (element-type-subtype element-type) subtype)) + (error "~S is not of element type ~S" array element-type)) + (when (integerp dims)(setq dims (list dims))) ; because %displace-array wants the list + (if (neq (list-length dims)(array-rank array)) + (error "~S has wrong rank for adjusting to dimensions ~S" array dims)) + (let ((size 1) + (explicitp nil)) + (dolist (dim dims) + (when (< dim 0)(report-bad-arg dims '(integer 0 *))) + (setq size (* size dim))) + (when (and (neq fill-pointer t) + (array-has-fill-pointer-p array) + (< size (or fill-pointer (fill-pointer array)))) + (error "Cannot adjust array ~S to size less than fill pointer ~S" + array (or fill-pointer (fill-pointer array)))) + (when (and fill-pointer (not (array-has-fill-pointer-p array))) + (error "~S does not have a fill pointer" array)) + (when (and displaced-index-offset (null displaced-to)) + (error "Cannot specify ~S without ~S" :displaced-index-offset :displaced-to)) + (when (and initial-element-p initial-contents-p) + (error "Cannot specify both ~S and ~S" :initial-element :initial-contents)) + (cond + ((not (adjustable-array-p array)) + (let ((new-array (make-array-1 dims + (array-element-type array) T + displaced-to + displaced-index-offset + nil + (or fill-pointer + (and (array-has-fill-pointer-p array) + (fill-pointer array))) + initial-element initial-element-p + initial-contents initial-contents-p + size))) + + (when (and (null initial-contents-p) + (null displaced-to)) + (multiple-value-bind (array-data offs) (array-data-and-offset array) + (let ((new-array-data (array-data-and-offset new-array))) + (cond ((null dims) + (uvset new-array-data 0 (uvref array-data offs))) + (T + (init-array-data array-data offs (array-dimensions array) + new-array-data 0 dims)))))) + (setq array new-array))) + (T (cond + (displaced-to + (if (and displaced-index-offset + (or (not (fixnump displaced-index-offset)) + (< displaced-index-offset 0))) + (report-bad-arg displaced-index-offset '(integer 0 #.most-positive-fixnum))) + (when (or initial-element-p initial-contents-p) + (error "Cannot specify initial values for displaced arrays")) + (unless (eq subtype (array-element-subtype displaced-to)) + (error "~S is not of element type ~S" + displaced-to (array-element-type array))) + (do* ((vec displaced-to (displaced-array-p vec))) + ((null vec) ()) + (when (eq vec array) + (error "Array cannot be displaced to itself."))) + (setq explicitp t)) + (T + (setq displaced-to (%alloc-misc size subtype)) + (cond (initial-element-p + (dotimes (i (the fixnum size)) (uvset displaced-to i initial-element))) + (initial-contents-p + (if (null dims) (uvset displaced-to 0 initial-contents) + (init-uvector-contents displaced-to 0 dims initial-contents)))) + (cond ((null dims) + (uvset displaced-to 0 (aref array))) + ((not initial-contents-p) + (multiple-value-bind (vec offs) (array-data-and-offset array) + (init-array-data vec offs (array-dimensions array) displaced-to 0 dims)))))) + (%displace-array array dims size displaced-to (or displaced-index-offset 0) explicitp))) + (when fill-pointer-p + (cond + ((eq fill-pointer t) + (set-fill-pointer array size)) + (fill-pointer + (set-fill-pointer array fill-pointer)))) + array)) + +(defun array-dims-sizes (dims) + (if (or (atom dims) (null (%cdr dims))) dims + (let ((ndims (array-dims-sizes (%cdr dims)))) + (cons (* (%car dims) (%car ndims)) ndims)))) + +(defun init-array-data (vec off dims nvec noff ndims) + (init-array-data-aux vec off dims (array-dims-sizes (cdr dims)) + nvec noff ndims (array-dims-sizes (cdr ndims)))) + +(defun init-array-data-aux (vec off dims siz nvec noff ndims nsiz) + (when (null siz) + (return-from init-array-data-aux + (init-vector-data vec off (car dims) nvec noff (car ndims)))) + (let ((count (pop dims)) + (size (pop siz)) + (ncount (pop ndims)) + (nsize (pop nsiz))) + (dotimes (i (if (%i< count ncount) count ncount)) + (declare (fixnum i)) + (init-array-data-aux vec off dims siz nvec noff ndims nsiz) + (setq off (%i+ off size) noff (%i+ noff nsize))))) + +(defun init-vector-data (vec off len nvec noff nlen) + (dotimes (i (if (%i< len nlen) len nlen)) + (declare (fixnum i)) + (uvset nvec noff (uvref vec off)) + (setq off (%i+ off 1) noff (%i+ noff 1)))) + +;;; only caller is adjust-array + +(defun %displace-array (array dims size data offset explicitp) + (let* ((typecode (typecode array)) + (array-p (eql typecode target::subtag-arrayH)) + (vector-p (eql typecode target::subtag-vectorH))) + (unless (or array-p vector-p) + (error "Array ~S cannot be displaced" array)) + (unless (fixnump offset) (report-bad-arg offset '(integer 0 #.most-positive-fixnum))) + (unless (adjustable-array-p data) + (multiple-value-bind (ndata noffset) (displaced-array-p data) + (if ndata (setq data ndata offset (%i+ offset noffset))))) + (unless (and (fixnump size) (%i<= (%i+ offset size) (array-total-size data))) + (error "Offset ~S + size ~S must be less than size of array displaced-to" offset size)) + (let* ((flags (%svref array target::vectorH.flags-cell))) + (declare (fixnum flags)) + (setf (%svref array target::vectorH.flags-cell) + (if (> (the fixnum (typecode data)) target::subtag-vectorH) + (bitclr $arh_disp_bit flags) + (bitset $arh_disp_bit flags))) + (setf (%svref array target::vectorH.flags-cell) + (if explicitp + (bitset $arh_exp_disp_bit flags) + (bitclr $arh_exp_disp_bit flags))) + (setf (%svref array target::arrayH.data-vector-cell) data) + (if array-p + (progn + (do ((i target::arrayH.dim0-cell (1+ i))) + ((null dims)) + (declare (fixnum i)) + (setf (%svref array i) (pop dims))) + (setf (%svref array target::arrayH.physsize-cell) size) + (setf (%svref array target::arrayH.displacement-cell) offset)) + (progn + (if (or (not (logbitp $arh_fill_bit flags)) + (> (the fixnum (%svref array target::vectorH.logsize-cell)) size)) + (setf (%svref array target::vectorH.logsize-cell) size)) + (setf (%svref array target::vectorH.physsize-cell) size) + (setf (%svref array target::vectorH.displacement-cell) offset))) + array))) + + + +(defun array-row-major-index (array &lexpr subscripts) + (let ((rank (array-rank array)) + (nsubs (%lexpr-count subscripts)) + (sum 0)) + (declare (fixnum sum rank)) + (unless (eql rank nsubs) + (%err-disp $xndims array nsubs)) + (if (eql 0 rank) + 0 + (do* ((i (1- rank) (1- i)) + (dim (array-dimension array i) (array-dimension array i)) + (last-size 1 size) + (size dim (* dim size))) + (nil) + (declare (fixnum i last-size size)) + (let ((s (%lexpr-ref subscripts nsubs i))) + (unless (fixnump s) + (setq s (require-type s 'fixnum))) + (when (or (< s 0) (>= s dim)) + (%err-disp $XARROOB (%apply-lexpr 'list subscripts) array)) + (incf sum (the fixnum (* s last-size))) + (when (eql i 0) (return sum))))))) + +(defun array-in-bounds-p (array &lexpr subscripts) + "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise." + (let ((rank (array-rank array)) + (nsubs (%lexpr-count subscripts))) + (declare (fixnum nsubs rank)) + (if (not (eql nsubs rank)) + (%err-disp $xndims array nsubs) + (if (eql 0 rank) + 0 + (do* ((i (1- rank) (1- i)) + (dim (array-dimension array i) (array-dimension array i))) + (nil) + (declare (fixnum i dim)) + (let ((s (%lexpr-ref subscripts nsubs i))) + (if (typep s 'fixnum) + (locally (declare (fixnum s)) + (if (or (< s 0)(>= s dim)) (return nil))) + (if (typep s 'bignum) + (return nil) + (report-bad-arg s 'integer))) + (when (eql i 0) (return t)))))))) + +(defun row-major-aref (array index) + "Return the element of array corressponding to the row-major index. This is + SETF'able." + (multiple-value-bind (displaced-to offset) (displaced-array-p array) + (aref (or displaced-to array) (+ index offset)))) + +(defun row-major-aset (array index new) + (multiple-value-bind (displaced-to offset) (displaced-array-p array) + (setf (aref (or displaced-to array) (+ index offset)) new))) + +(defsetf row-major-aref row-major-aset) + + + +; end Index: /branches/qres/ccl/lib/backquote.lisp =================================================================== --- /branches/qres/ccl/lib/backquote.lisp (revision 13564) +++ /branches/qres/ccl/lib/backquote.lisp (revision 13564) @@ -0,0 +1,394 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; + +; Backquote.lisp + +(in-package "CCL") + +#+nil +(progn +;;; Common Lisp backquote implementation, written in Common Lisp. +;;; Author: Guy L. Steele Jr. Date: 27 December 1985 +;;; Texted under Symbolics Common Lisp and Lucid Common Lisp. +;;; This software is in the public domain. + +;;; The following are unique tokens used during processing +;;; They need not be symbols; they need not even be atoms. + +(defvar *comma* (make-symbol "`,")) +(defvar *comma-atsign* (make-symbol "`,@")) +(defvar *comma-dot* (make-symbol "`,.")) +(defvar *bq-list* (make-symbol "BQ-LIST")) +(defvar *bq-append* (make-symbol "BQ-APPEND")) +(defvar *bq-list** (make-symbol "BQ-LIST*")) +(defvar *bq-nconc* (make-symbol "BQ-NCONC")) +(defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE")) +(defvar *bq-quote* (make-symbol "BQ-QUOTE")) +(defvar *bq-quote-nil* (list *bq-quote* nil)) + +;;; Reader macro characters: +;;; `foo is read in as (BACKQUOTE foo) +;;; ,foo is read in as (#:COMMA foo) +;;; ,@foo is read in as (#:COMMA-ATSIGN foo) +;;; ,.foo is read in as (#:COMMA-DOT foo) +;;; where #:COMMA is the value of the variable *COMMA* etc. + +;;; BACKQUOTE is an ordinary macro (not a read-macro) that +;;; processes the expression foo, looking for occurrences of +;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT. It constructs code +;;; in strict accordance with the rules on pages 349-350 of +;;; of the first edition (pages 528-529 of this second edition). +;;; It then optionally applies a code simplifier. + +(set-macro-character #\` + #'(lambda (stream char) + (declare (ignore char)) + (list 'backquote (read stream t nil t)))) + +(set-macro-character #\, + #'(lambda (stream char) + (declare (ignore char)) + (case (peek-char nil stream t nil t) + (#\@ (read-char stream t nil t) + (list *comma-atsign* (read stream t nil t))) + (#\. (read-char stream t nil t) + (list *comma-dot* (read stream t nil t))) + (otherwise (list *comma* (read stream t nil t)))))) + +;;; if the value of *BQ-SIMPLIFY* is non-nil, then BACKQUOTE +;;; processing applies the code simplifier. If the value is NIL, +;;; then the code resulting from BACKQUOTE is exactly that +;;; specified by the official rules. + +(defvar *bq-simplify* t) + +(defmacro backquote (x) + (bq-completely-process x)) + +;;; Backquote processing proceeds in three stages: +;;; +;;; (1) BQ-PROCESS applies the rules to remove occurrences of +;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to +;;; this level of BACKQUOTE. (It also causes embedded calls to +;;; BACKQUOTE to be expanded so that nesting is properly handled.) +;;; Code is produced that is expressed in terms of functions +;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE. This is done +;;; so that the simplifier will simplify only list construction +;;; functions actually generated by backquote and will not involve +;;; any user code in the simplification. #:BQ-LIST means LIST, +;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY +;;; but indicates places where ",." was used and where NCONC may +;;; therefore be introduced by the simplifier for efficiency. +;;; +;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by +;;; BQ-PROCESS to produce equivalent but faster code. The +;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be +;;; introduced into the code. +;;; +;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces +;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on. +;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being +;;; replaced by its argument). #:BQ-LIST* is replaced by either +;;; LIST* or CONS (the latter is used in the two-argument case, +;;; purely to make the resulting code a tad more readable). + +(defun bq-completely-process (x) + (let ((raw-result (bq-process x))) + (bq-remove-tokens (if *bq-simplify* + (bq-simplify raw-result) + raw-result)))) + +; Portable code could just say (coerce list 'vector) +(defun list-to-vector (list) + (unless (listp list) + (setq list (require-type list 'list))) + (%list-to-uvector nil list)) + +(define-compiler-macro list-to-vector (&whole whole form) + (if (quoted-form-p form) + (list-to-vector (cadr form)) + whole)) + +(defun bq-process (x) + (cond ((atom x) + (if (simple-vector-p x) + (list 'list-to-vector (bq-process (coerce x 'list))) + (list *bq-quote* x))) + ((eq (car x) 'backquote) + (bq-process (bq-completely-process (cadr x)))) + ((eq (car x) *comma*) (cadr x)) + ((eq (car x) *comma-atsign*) + (error ",@~S after `" (cadr x))) + ((eq (car x) *comma-dot*) + (error ",.~S after `" (cadr x))) + (t (do ((p x (cdr p)) + (q '() (cons (bracket (car p)) q))) + ((atom p) + (cons *bq-append* + (nreconc q (list (list *bq-quote* p))))) + (when (eq (car p) *comma*) + (unless (null (cddr p)) (error "Malformed ,~S" p)) + (return (cons *bq-append* + (nreconc q (list (cadr p)))))) + (when (eq (car p) *comma-atsign*) + (error "Dotted ,@~S" p)) + (when (eq (car p) *comma-dot*) + (error "Dotted ,.~S" p)))))) + +;;; This implements the bracket operator of the formal rules + +(defun bracket (x) + (cond ((atom x) + (list *bq-list* (bq-process x))) + ((eq (car x) *comma*) + (list *bq-list* (cadr x))) + ((eq (car x) *comma-atsign*) + (cadr x)) + ((eq (car x) *comma-dot*) + (list *bq-clobberable* (cadr x))) + (t (list *bq-list* (bq-process x))))) + +;;; This auxiliary function is like MAPCAR but has two extra +;;; purpoess: (1) it handles dotted lists; (2) it tries to make +;;; the result share with the argument x as much as possible. + +(defun maptree (fn x) + (if (atom x) + (funcall fn x) + (let ((a (funcall fn (car x))) + (d (maptree fn (cdr x)))) + (if (and (eql a (car x)) (eql d (cdr x))) + x + (cons a d))))) + +;;; This predicate is true of a form that when read looked +;;; like ,@foo or ,.foo + +(defun bq-splicing-frob (x) + (and (consp x) + (or (eq (car x) *comma-atsign*) + (eq (car x) *comma-dot*)))) + +;;; This predicate is true of a form that when read +;;; looked like ,@foo or just plain ,foo. + +(defun bq-frob (x) + (and (consp x) + (or (eq (car x) *comma*) + (eq (car x) *comma-atsign*) + (eq (car x) *comma-dot*)))) + +;;; The simplifier essentially looks for calls to #:BQ-APPEND and +;;; tries to simplify them. The arguments to #:BQ-APPEND are +;;; processed from right to left, building up a replacement for. +;;; At each step a number of special cases are handled that, +;;; loosely speaking, look like this: +;;; +;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo) +;;; provided a, b, c are not splicing frobs +;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo)) +;;; provided a, b, c are not splicing frobs +;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo) +;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo) + +(defun bq-simplify (x) + (if (atom x) + x + (let ((x (if (eq (car x) *bq-quote*) + x + (maptree #'bq-simplify x)))) + (if (not (eq (car x) *bq-append*)) + x + (bq-simplify-args x))))) + +(defun bq-simplify-args (x) + (do ((args (reverse (cdr x)) (cdr args)) + (result + nil + (cond ((atom (car args)) + (bq-attach-append *bq-append* (car args) result)) + ((and (eq (caar args) *bq-list*) + (notany #'bq-splicing-frob (cdar args))) + (bq-attach-conses (cdar args) result)) + ((and (eq (caar args) *bq-list**) + (notany #'bq-splicing-frob (cdar args))) + (bq-attach-conses + (reverse (cdr (reverse (cdar args)))) + (bq-attach-append *bq-append* + (car (last (car args))) + result))) + ((and (eq (caar args) *bq-quote*) + (consp (cadar args)) + (not (bq-frob (cadar args))) + (null (cddar args))) + (bq-attach-conses (list (list *bq-quote* + (caadar args))) + result)) + ((eq (caar args) *bq-clobberable*) + (bq-attach-append *bq-nconc* (cadar args) result)) + (t (bq-attach-append *bq-append* + (car args) + result))))) + ((null args) result))) + +(defun null-or-quoted (x) + (or (null x) (and (consp x) (eq (car x) *bq-quote*)))) + +;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND +;;; or #:BQ-NCONC. This produces a form (op item result) but +;;; some simplifications are done on the fly: +;;; +;;; (op '(a b c) '(d e f g)) => '(a b c d e f g) +;;; (op item 'nil) => item, provided item is not a splicable frob +;;; (op item 'nil) => (op item), if item is a splicable frob +;;; (op item (op a b c)) => (op item a b c) + +(defun bq-attach-append (op item result) + (cond ((and (null-or-quoted item) (null-or-quoted result)) + (list *bq-quote* (append (cadr item) (cadr result)))) + ((or (null result) (equal result *bq-quote-nil*)) + (if (bq-splicing-frob item) (list op item) item)) + ((and (consp result) (eq (car result) op)) + (list* (car result) item (cdr result))) + (t (list op item result)))) + +;;; The effec tof BQ-ATTACH-CONSES is to produce a form as if by +;;; `(LIST* ,@items ,result) but some simplifications are done +;;; on the fly. +;;; +;;; (LIST* 'a 'b 'c 'd) => '(a b c . d) +;;; (LIST* a b c 'nil) => (LIST a b c) +;;; (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g) +;;; (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g) + +(defun bq-attach-conses (items result) + (cond ((and (every #'null-or-quoted items) + (null-or-quoted result)) + (list *bq-quote* + (append (mapcar #'cadr items) (cadr result)))) + ((or (null result) (equal result *bq-quote-nil*)) + (cons *bq-list* items)) + ((and (consp result) + (or (eq (car result) *Bq-list*) + (eq (car result) *bq-list**))) + (cons (car result) (append items (cdr result)))) + (t (cons *bq-list** (append items (list result)))))) + +;;; Removes funny toeksn and changes (#:BQ-LIST* a b) into +;;; (CONS a b) instead of (LIST* a b), purely for readability. + +(defun bq-remove-tokens (x) + (cond ((eq x *bq-list*) 'list) + ((eq x *bq-append*) 'append) + ((eq x *bq-nconc*) 'nconc) + ((eq x *bq-list**) 'list*) + ((eq x *bq-quote*) 'quote) + ((atom x) x) + ((eq (car x) *bq-clobberable*) + (bq-remove-tokens (cadr x))) + ((and (eq (car x) *bq-list**) + (consp (cddr x)) + (null (cdddr x))) + (cons 'cons (maptree #'bq-remove-tokens (cdr x)))) + (t (maptree #'bq-remove-tokens x)))) + +) + +#-nil +(progn +(declaim (special *|`,|* *|`,.|* *|`,@|*)) + +;;;Backquote reads in as a call to the BACKQUOTE-EXPANDER macro. +;;;This makes it a little obscure to look at raw, but makes it possible for +;;;the pretty-printer to print things read in with backquote. + +(defvar *backquote-expand* t "If non-NIL, expand at read-time") + +(defmacro backquote-expander (*|`,|* *|`,.|* *|`,@|* form) + (declare (special *|`,|* *|`,.|* *|`,@|*)) + (multiple-value-bind (form constantp) (backquote-aux form) + (backq-form form constantp))) + +(defun backquote-aux (form) + ;;Doesn't try to optimize multiple CONS's into LIST/LIST*'s, leaving it up + ;;to the compiler. The code here is mainly concerned with folding + ;;constants, since the compiler is not allowed to do that in general. + (cond + ((simple-vector-p form) + (let ((elts ()) (i (length form))) + (until (%izerop i) (push (svref form (setq i (%i- i 1))) elts)) + (multiple-value-bind (elts quotedp) (backquote-aux elts) + (if quotedp + (values (list-to-vector elts) t) + (list 'list-to-vector elts))))) + ((self-evaluating-p form) (values form t)) + ((atom form) (values form t)) + ((eq (%car form) 'backquote-expander) (backquote-aux (macroexpand-1 form))) + ((eq (%car form) *|`,|*) (%cdr form)) + ((eq (%car form) *|`,@|*) (error "Misplaced ,@~S after backquote" (%cdr form))) + ((eq (%car form) *|`,.|*) (error "Misplaced ,.~S after backquote" (%cdr form))) + (t (let* ((car (%car form)) + (splice (and (consp car) (if (eq (%car car) *|`,@|*) 'append + (if (eq (%car car) *|`,.|*) 'nconc))))) + (multiple-value-bind (cdr qd) (backquote-aux (%cdr form)) + (if splice + (cond ((null (%cdr car)) (values cdr qd)) + ((null cdr) (values (%cdr car) (self-evaluating-p (%cdr car)))) + (t (list splice (%cdr car) (backq-form cdr qd)))) + (multiple-value-bind (car qa) (backquote-aux car) + (cond ((and qa qd) (values (cons car cdr) t)) + ((null cdr) (list 'list car)) + (t (list 'list* ; was CONS + (backq-form car qa) (backq-form cdr qd))))))))))) + +(defun backq-form (form constantp) + (if (and constantp (not (self-evaluating-p form))) (list 'quote form) form)) + +(defparameter *backquote-stack* ()) + +(set-macro-character + #\` + (nfunction + |` reader| + (lambda (stream char &aux form) + (declare (ignore char)) + (setq form + (let* ((|`,| (make-symbol "`,")) + (|`,.| (make-symbol "`,.")) + (|`,@| (make-symbol "`,@"))) + (list 'backquote-expander |`,| |`,.| |`,@| + (let ((*backquote-stack* (list* |`,| |`,.| |`,@| *backquote-stack*))) + (read stream t nil t))))) + (if *backquote-expand* (values (macroexpand-1 form)) form)))) + +(set-macro-character + #\, + (nfunction + |, reader| + (lambda (stream char &aux (stack *backquote-stack*)) + (when (null stack) + (signal-reader-error stream "Comma not inside backquote")) + (let ((*backquote-stack* (cdddr stack))) + (setq char (tyi stream)) + (cond ((eq char #\@) + (cons (%caddr stack) (read stream t nil t))) + ((eq char #\.) + (cons (%cadr stack) (read stream t nil t))) + (t + (untyi char stream) + (cons (%car stack) (read stream t nil t)))))))) +) + +(provide 'backquote) Index: /branches/qres/ccl/lib/backtrace-lds.lisp =================================================================== --- /branches/qres/ccl/lib/backtrace-lds.lisp (revision 13564) +++ /branches/qres/ccl/lib/backtrace-lds.lisp (revision 13564) @@ -0,0 +1,141 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; backtrace-lds.lisp +;;; low-level support for stack-backtrace dialog (Lisp Development System) + +(in-package "CCL") + + +(defparameter *saved-register-count* + #+x8632-target 0 + #+x8664-target 4 + #+ppc-target 8) + +(defparameter *saved-register-names* + #+x8632-target nil + #+x8664-target #(save3 save2 save1 save0) + #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0)) + +(defun frame-function (frame context) + "Returns the function using the frame, and pc offset within the function, if known" + (declare (ignore context)) + (cfp-lfun (require-type frame 'integer))) + +(defun frame-supplied-arguments (frame context &key (unknown-marker (%unbound-marker))) + "Return a list of supplied arguments to the call which opened this frame, as best we can reconstruct it" + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc) + (if (not valid) + unknown-marker + (if (eq unknown-marker (%unbound-marker)) + args + (substitute unknown-marker (%unbound-marker) args)))))) + +(defun frame-named-variables (frame context &key (unknown-marker (%unbound-marker))) + "Returns an alist of (NAME . VALUE) of all named variables in this frame." + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (multiple-value-bind (args locals) (arguments-and-locals context frame lfun pc unknown-marker) + (if (eq unknown-marker (%unbound-marker)) + (append args locals) + (substitute unknown-marker (%unbound-marker) (append args locals)))))) + + +(defun frame-arguments-and-locals (frame context &key unknown-marker) + "Return two values, the arguments and the locals, known for this frame, as alists of (name . value)" + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (arguments-and-locals context frame lfun pc unknown-marker))) + +;;; Returns three values: (ARG-VALUES TYPES NAMES), solely for the benefit +;;; of the FRAME-ARGUMENTS function in SLIME's swank-openmcl.lisp. +;;; ARG-VALUES is a list of the values of the args supplied to the function +;;; TYPES is a list of (for bad historical reasons) strings .describing +;;; whether they're "required", "optional", etc. SLIME only really +;;; cares about whether this is equal to "keyword" or not. +;;; NAMES is a list of symbols which name the args. +;; 7/13/2009: This is now deprecated. Use frame-supplied-arguments. +(defun frame-supplied-args (frame lfun pc child context) + (declare (ignore child)) + (if (null pc) + (values nil nil nil) + (if (<= pc target::arg-check-trap-pc-limit) + (values (arg-check-call-arguments frame lfun) nil nil) + (multiple-value-bind (arglist valid) (arglist-from-map lfun) + (if (not valid) + (values nil nil nil) + (let* ((args (arguments-and-locals context frame lfun pc)) + (state :required)) + (collect ((arg-values) + (types) + (names)) + (dolist (arg arglist) + (if (or (member arg lambda-list-keywords) + (eq arg '&lexpr)) + (setq state arg) + (let* ((pair (pop args))) + (case state + (&lexpr + (with-list-from-lexpr (rest (cdr pair)) + (dolist (r rest) (arg-values r) (names nil) (types nil))) + (return)) + (&rest + (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil)) + (return)) + (&key + (arg-values arg) + (names nil) + (types nil))) + (let* ((value (cdr pair))) + (if (eq value (%unbound-marker)) + (return)) + (names (car pair)) + (arg-values value) + (types nil))))) + (values (arg-values) (types) (names))))))))) + + +#| +(setq *save-local-symbols* t) + +(defun test (flip flop &optional bar) + (let ((another-one t) + (bar 'quux)) + (break))) + +(test '(a b c d) #\a) + +(defun closure-test (flim flam) + (labels ((inner (x) + (let ((ret (list x flam))) + (break)))) + (inner flim) + (break))) + +(closure-test '(a b c) 'quux) + +(defun set-test (a b) + (break) + (+ a b)) + +(set-test 1 'a) + +||# + + +(provide 'backtrace-lds) + +; End of backtrace-lds.lisp Index: /branches/qres/ccl/lib/backtrace.lisp =================================================================== --- /branches/qres/ccl/lib/backtrace.lisp (revision 13564) +++ /branches/qres/ccl/lib/backtrace.lisp (revision 13564) @@ -0,0 +1,702 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; backtrace.lisp +;;; low-level support for stack-backtrace printing + +(in-package "CCL") + +#+ppc-target (require "PPC-BACKTRACE") +#+x86-target (require "X86-BACKTRACE") + + +(defparameter *backtrace-show-internal-frames* nil) +(defparameter *backtrace-print-level* 2) +(defparameter *backtrace-print-length* 5) + +(defparameter *backtrace-format* #+ccl-0711 :direct #-ccl-0711 :traditional + "If :TRADITIONAL, shows calls to non-toplevel functions using FUNCALL, and shows frame address values. + If :DIRECT, uses a more streamlined format.") + +(defun context-for-suspended-tcr (tcr) + (let ((frame-ptr (%tcr-frame-ptr tcr))) + (new-backtrace-info nil + frame-ptr ;; youngest - not used + frame-ptr ;; oldest - not used + tcr + nil ;; condition - not used + frame-ptr ;; current + #+ppc-target *fake-stack-frames* + #+x86-target frame-ptr + (%fixnum-ref tcr target::tcr.db-link) + 0 ;; break level - not used + ))) + + +(defun backtrace-as-list (&key + context + process + origin + (count target::target-most-positive-fixnum) + (start-frame-number 0) + (print-level *backtrace-print-level*) + (print-length *backtrace-print-length*) + (show-internal-frames *backtrace-show-internal-frames*)) + "Returns a list representing the backtrace. +Each element in the list is a list that describes the call in one stack frame: + (function arg1 arg2 ...) +The arguments are represented by strings, the function is a symbol or a function +object." + (let* ((*backtrace-print-level* print-level) + (*backtrace-print-length* print-length) + (*backtrace-format* :list) + (result nil)) + (map-call-frames (lambda (p context) + (multiple-value-bind (lfun pc) (cfp-lfun p) + (push (if lfun + (backtrace-call-arguments context p lfun pc) + "?????") + result))) + :context context + :process process + :origin origin + :count count + :start-frame-number start-frame-number + :test (and (not show-internal-frames) 'function-frame-p)) + (nreverse result))) + +(defun print-call-history (&key context + process + origin + (detailed-p t) + (count target::target-most-positive-fixnum) + (start-frame-number 0) + (stream *debug-io*) + (print-level *backtrace-print-level*) + (print-length *backtrace-print-length*) + (show-internal-frames *backtrace-show-internal-frames*) + (format *backtrace-format*)) + (let ((*backtrace-print-level* print-level) + (*backtrace-print-length* print-length) + (*backtrace-format* format) + (*standard-output* stream) + (*print-circle* nil) + (frame-number (or start-frame-number 0))) + (map-call-frames (lambda (p context) + (multiple-value-bind (lfun pc) (cfp-lfun p) + (unless (and (typep detailed-p 'fixnum) + (not (= (the fixnum detailed-p) frame-number))) + (%show-stack-frame-label frame-number p context lfun pc detailed-p) + (when detailed-p + (if (or (eq detailed-p :raw) (null lfun)) + (%show-stack-frame p context lfun pc) + (%show-args-and-locals p context lfun pc))) + (incf frame-number)))) + :context context + :process process + :origin origin + :count count + :start-frame-number start-frame-number + :test (and (not show-internal-frames) 'function-frame-p)) + (values))) + +(defun function-frame-p (p context) + (and (not (catch-csp-p p context)) (cfp-lfun p))) + +(defun map-call-frames (fn &key context + process + origin + (count target::target-most-positive-fixnum) + (start-frame-number 0) + test) + (when (and context process (neq (bt.tcr context) (process-tcr process))) + (error "Context ~s doesn't correspond to the process ~s" context process)) + (let ((tcr (cond (context (bt.tcr context)) + (process (process-tcr process)) + (t (%current-tcr)))) + (*print-catch-errors* t) + (*signal-printing-errors* nil)) + (if (eq tcr (%current-tcr)) + (%map-call-frames-internal fn context (or origin (%get-frame-ptr)) count start-frame-number test) + (unwind-protect + (progn + (%suspend-tcr tcr) + (when (null context) + (setq context (context-for-suspended-tcr tcr))) + (%map-call-frames-internal fn context (or origin (bt.current context)) count start-frame-number test)) + (%resume-tcr tcr)))) + nil) + +; RAW case +(defun %show-stack-frame (p context lfun pc) + (handler-case + (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context) + (declare (fixnum count)) + (dotimes (i count) + (multiple-value-bind (var type name) + (nth-value-in-frame p i context lfun pc vsp parent-vsp) + (format t "~& ~D " i) + (when name (format t "~s" name)) + (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (format t ": ~s" var)) + (when type (format t " (~S)" type))))) + (error () (format t "#"))) + (terpri) + (terpri)) + +(defun %show-args-and-locals (p context lfun pc) + (handler-case + (let* ((unavailable (cons nil nil))) + (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable) + (case *backtrace-format* + (:direct + (format t "~& Arguments: ~:s" (arglist-from-map lfun))) + (t (format t "~& ~s" (arglist-from-map lfun)))) + (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (flet ((show-pair (pair prefix) + (destructuring-bind (name . val) pair + (format t "~&~a~s: " prefix name) + (if (eq val unavailable) + (format t "#") + (format t "~s" val))))) + (case *backtrace-format* + (:direct + (when args + (dolist (arg args) + (show-pair arg " "))) + (when locals + ;; This shows all bindings (including specials), but help on debugger + ;; commands refers to "locals", so say both words... + (format t "~& Local bindings:") + (dolist (loc locals) + (show-pair loc " ")))) + (t + (dolist (arg args) + (show-pair arg " ")) + (terpri) + (terpri) + (dolist (loc locals) + (show-pair loc " ")))))))) + (error () (format t "#"))) + (terpri) + (terpri)) + + +(defun backtrace-call-arguments (context cfp lfun pc) + (nconc (let* ((name (function-name lfun))) + (if (function-is-current-definition? lfun) + (list name) + (case *backtrace-format* + (:direct + (list (format nil "~s" (or name lfun)))) + (:list + (list 'funcall (format nil "~s" (or name lfun)))) + (t (list 'funcall `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">"))))))) + (backtrace-supplied-args context cfp lfun pc))) + +(defun backtrace-supplied-args (context frame lfun pc) + (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc) + (if (not valid) + '("???") + (loop for arg in args + collect (if (eq arg (%unbound-marker)) + "?" + (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (format nil "~s" arg))))))) + +;;; Return a list of "interesting" frame addresses in context, most +;;; recent first. +(defun %stack-frames-in-context (context &optional (include-internal *backtrace-show-internal-frames*)) + (collect ((frames)) + (do* ((p (bt.youngest context) (parent-frame p context)) + (q (bt.oldest context))) + ((eql p q) (frames)) + (when (or (not (catch-csp-p p context)) include-internal) + (when (or (cfp-lfun p) include-internal) + (frames p)))))) + +(defun %map-call-frames-internal (fn context origin count skip-initial test) + (when (null skip-initial) (setq skip-initial 0)) + (when (null count) (setq count target::target-most-positive-fixnum)) + (unless (eq (last-frame-ptr context origin) (last-frame-ptr context)) + (error "Origin ~s is not in the stack of ~s" origin context)) + (let ((q (last-frame-ptr context)) + (frame-number 0)) + (do ((p origin (parent-frame p context))) + ((or (null p) (eq p q) (%stack< q p context) (<= count 0)) nil) + (when (or (null test) (funcall test p context)) + (when (<= skip-initial frame-number) + (funcall fn p context) + (decf count)) + (incf frame-number))))) + +(defun %show-stack-frame-label (frame-number p context lfun pc detailed-p) + (case *backtrace-format* + (:direct + (let ((call (backtrace-call-arguments context p lfun pc))) + (format t "~&~3D: ~a ~a~@d~:[~; [Exception]~]" + frame-number + (if lfun + (if detailed-p (car call) call) + "") + "at pc " + pc + (exception-frame-p p)))) + (t (format t "~&~c(~x) : ~D ~a ~d" + (if (exception-frame-p p) #\* #\space) + (index->address p) frame-number + (if lfun (backtrace-call-arguments context p lfun pc)) + pc)))) + + +(defun %access-lisp-data (vstack-index) + (%fixnum-ref vstack-index)) + +(defun %store-lisp-data (vstack-index value) + (setf (%fixnum-ref vstack-index) value)) + +(defun closed-over-value (data) + (if (closed-over-value-p data) + (uvref data 0) + data)) + +(defun set-closed-over-value (value-cell value) + (setf (uvref value-cell 0) value)) + + + +;;; Act as if VSTACK-INDEX points at some lisp data & return that data. +(defun access-lisp-data (vstack-index) + (closed-over-value (%access-lisp-data vstack-index))) + +(defun find-local-name (cellno lfun pc) + (let* ((n cellno)) + (when lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (if (and where (< (1- where) n (+ where (logcount mask)))) + (let ((j *saved-register-count*)) + (decf n where) + (loop (loop (if (logbitp (decf j) mask) (return))) + (if (< (decf n) 0) (return))) + (values (format nil "saved ~a" (aref *saved-register-names* j)) + nil)) + (multiple-value-bind (nreq nopt restp nkeys junk optinitp junk ncells nclosed) + (if lfun (function-args lfun)) + (declare (ignore junk optinitp)) + (if nkeys (setq nkeys (+ nkeys nkeys))) + (values + (if (and ncells (< n ncells)) + (if (< n nclosed) + :inherited + (if (< (setq n (- n nclosed)) nreq) + "required" + (if (< (setq n (- n nreq)) nopt) + "optional" + (progn + (setq n (- n nopt)) + (progn + (if (and nkeys (< n nkeys)) + (if (not (logbitp 0 n)) ; a keyword + "keyword" + "key-supplied-p") + (progn + (if nkeys (setq n (- n nkeys))) + (if (and restp (zerop n)) + "rest" + "opt-supplied-p"))))))))) + (match-local-name cellno (function-symbol-map lfun) pc)))))))) + +(defun map-entry-value (context cfp lfun pc idx unavailable) + (declare (fixnum pc idx)) + (let* ((info (function-symbol-map lfun))) + (if (null info) + unavailable + (let* ((addrs (cdr info)) + (i (* 3 idx)) + (addr (svref addrs i)) + (startpc (svref addrs (the fixnum (+ i 1)))) + (endpc (svref addrs (the fixnum (+ i 2))))) + (declare (fixnum i addr startpc endpc)) + (if (or (< pc startpc) + (>= pc endpc)) + unavailable + (let* ((value (if (= #o77 (ldb (byte 6 0) addr)) + (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6))) + unavailable) + (find-register-argument-value context cfp addr unavailable)))) + (if (typep value 'value-cell) + (uvref value 0) + value))))))) + +;;; Returns non-nil on success (not newval) +(defun set-map-entry-value (context cfp lfun pc idx newval) + (declare (fixnum pc idx)) + (let* ((unavailable (cons nil nil)) + (value (map-entry-value context cfp lfun pc idx unavailable))) + (if (eq value unavailable) + nil + (if (typep value 'value-cell) + (progn (setf (uvref value 0) newval) t) + + (let* ((addrs (cdr (function-symbol-map lfun))) + (addr (svref addrs (the fixnum (* 3 idx))))) + (declare (fixnum addr)) + (if (= #o77 (ldb (byte 6 0) addr)) + (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval) + (set-register-argument-value context cfp addr newval)) + t))))) + + +(defun argument-value (context cfp lfun pc name &optional (quote t)) + (declare (fixnum pc)) + (let* ((info (function-symbol-map lfun)) + (unavailable (%unbound-marker))) + (if (null info) + unavailable + (let* ((names (car info)) + (addrs (cdr info))) + (do* ((nname (1- (length names)) (1- nname)) + (naddr (- (length addrs) 3) (- naddr 3))) + ((or (< nname 0) (< naddr 0)) unavailable) + (declare (fixnum nname naddr)) + (when (eq (svref names nname) name) + (let* ((value + (let* ((addr (svref addrs naddr)) + (startpc (svref addrs (the fixnum (1+ naddr)))) + (endpc (svref addrs (the fixnum (+ naddr 2))))) + (declare (fixnum addr startpc endpc)) + (if (or (< pc startpc) + (>= pc endpc)) + unavailable + (if (= #o77 (ldb (byte 6 0) addr)) + (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6))) + unavailable) + (find-register-argument-value context cfp addr unavailable)))))) + (if (typep value 'value-cell) + (setq value (uvref value 0))) + (if (or (not quote) (self-evaluating-p value)) + (return value) + (return (list 'quote value)))))))))) + + + +(defun raw-frame-ref (cfp context index bad) + (%raw-frame-ref cfp context index bad)) + +(defun raw-frame-set (cfp context index new) + (%raw-frame-set cfp context index new)) + +(defun find-register-argument-value (context cfp regval bad) + (%find-register-argument-value context cfp regval bad)) + +(defun set-register-argument-value (context cfp regval newval) + (%set-register-argument-value context cfp regval newval)) + + + +(defun dbg-form (frame-number) + (when *break-frame* + (let* ((cfp (nth-raw-frame frame-number *break-frame* nil))) + (if (and cfp (not (catch-csp-p cfp nil))) + (multiple-value-bind (function pc) + (cfp-lfun cfp) + (if (and function + (function-is-current-definition? function)) + (block %cfp-form + (collect ((form)) + (multiple-value-bind (nreq nopt restp keys allow-other-keys + optinit lexprp ncells nclosed) + (function-args function) + (declare (ignore ncells)) + (unless (or lexprp restp (> 0 nclosed) (> 0 nopt) keys allow-other-keys + optinit) + (let* ((name (function-name function))) + (multiple-value-bind (arglist win) + (arglist-from-map function) + (when (and win name (symbolp name)) + (form name) + (dotimes (i nreq) + (let* ((val (argument-value nil cfp function pc (pop arglist)))) + (if (closed-over-value-p val) + (setq val (%svref val target::value-cell.value-cell))) + (if (eq val (%unbound-marker)) + (return-from %cfp-form nil)) + (form val)))))))) + (form))))))))) + +(defun function-args (lfun) + "Returns 9 values, as follows: + req = number of required arguments + opt = number of optional arguments + restp = t if rest arg + keys = number of keyword arguments or NIL if &key not mentioned + allow-other-keys = t if &allow-other-keys present + optinit = t if any optional arg has non-nil default value or supplied-p + variable + lexprp = t if function is a lexpr, in which case all other values are + undefined. + ncells = number of stack frame cells used by all arguments. + nclosed = number of inherited values (now counted distinctly from required) + All numeric values (but ncells) are mod 64." + (let* ((bits (lfun-bits lfun)) + (req (ldb $lfbits-numreq bits)) + (opt (ldb $lfbits-numopt bits)) + (restp (logbitp $lfbits-rest-bit bits)) + (keyvect (lfun-keyvect lfun)) + (keys (and keyvect (length keyvect))) + (allow-other-keys (logbitp $lfbits-aok-bit bits)) + (optinit (logbitp $lfbits-optinit-bit bits)) + (lexprp (logbitp $lfbits-restv-bit bits)) + (nclosed (ldb $lfbits-numinh bits))) + (values req opt restp keys allow-other-keys optinit lexprp + (unless (or lexprp) + (+ req opt (if restp 1 0) (if keys (+ keys keys) 0) + (if optinit opt 0) nclosed)) + nclosed))) + +;;; If we can tell reliably, return the function's minimum number of +;;; non-inherited arguments, the maximum number of such arguments (or NIL), +;;; and the actual number of such arguments. We "can't tell" if either +;;; of the arguments to this function are null, and we can't tell reliably +;;; if any of the lfbits fields are full. +(defun min-max-actual-args (fn nargs) + (let* ((lfbits (if (and fn nargs) + (lfun-bits fn) + -1)) + (raw-req (ldb $lfbits-numreq lfbits)) + (raw-opt (ldb $lfbits-numopt lfbits)) + (raw-inh (ldb $lfbits-numinh lfbits))) + (declare (fixnum raw-req raw-opt raw-inh)) + (if (or (eql raw-req (1- (ash 1 (byte-size $lfbits-numreq)))) + (eql raw-opt (1- (ash 1 (byte-size $lfbits-numopt)))) + (eql raw-inh (1- (ash 1 (byte-size $lfbits-numinh))))) + (values nil nil nil) + (values raw-req + (unless (or (lfun-keyvect fn) + (logbitp $lfbits-rest-bit lfbits) + (logbitp $lfbits-restv-bit lfbits)) + (+ raw-req raw-opt)) + (- nargs raw-inh))))) + + + +(defun closed-over-value-p (value) + (eql target::subtag-value-cell (typecode value))) + + +(defun variables-in-scope (lfun pc) + ;; Return a list of all symbol names "in scope" in the function lfun + ;; at relative program counter PC, using the function's symbol map. + ;; The list will be ordered so that least-recent bindings appear first. + ;; Return a list of the matching symbol map entries as a second value + (when pc + (locally (declare (fixnum pc)) + (let* ((map (function-symbol-map lfun)) + (names (car map)) + (info (cdr map))) + (when map + (let* ((vars ()) + (indices ())) + (dotimes (i (length names) (values vars indices)) + (let* ((start-pc (aref info (1+ (* 3 i)))) + (end-pc (aref info (+ 2 (* 3 i))))) + (declare (fixnum start-pc end-pc)) + (when (and (>= pc start-pc) + (< pc end-pc)) + (push i indices) + (push (svref names i) vars)))))))))) + + +(defun arg-value (context cfp lfun pc unavailable name) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (pos (position name vars))) + (if (and pos (< pos nargs)) + (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable) + unavailable)) + unavailable)))) + +(defun local-value (context cfp lfun pc unavailable name) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (names (nthcdr nargs vars)) + (indices (nthcdr nargs map-indices)) + (pos (if (typep name 'unsigned-byte) + name + (position name names :from-end t)))) + (if pos + (map-entry-value context cfp lfun pc (nth pos indices) unavailable) + unavailable)) + unavailable)))) + +(defun set-arg-value (context cfp lfun pc name new) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (pos (position name vars))) + (when (and pos (< pos nargs)) + (set-map-entry-value context cfp lfun pc (nth pos map-indices) new))))))) + +(defun set-local-value (context cfp lfun pc name new) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (names (nthcdr nargs vars)) + (indices (nthcdr nargs map-indices)) + (pos (if (typep name 'unsigned-byte) + name + (position name names :from-end t)))) + (if (and pos (< pos nargs)) + (set-map-entry-value context cfp lfun pc (nth pos indices) new))))))) + + +(defun arguments-and-locals (context cfp lfun pc &optional unavailable) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (collect ((args) + (inherited-indices) + (inherited-vars) + (locals)) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (when valid + (let* ((numinh (ldb $lfbits-numinh (lfun-bits lfun)))) + (dotimes (i numinh) + (inherited-indices (pop map-indices)) + (inherited-vars (pop vars)))) + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (nlocals (- (length vars) nargs)) + (local-vars (append (nthcdr nargs vars) (inherited-vars))) + (local-indices (append (nthcdr nargs map-indices) (inherited-indices))) + (arg-vars (if (<= nlocals 0) vars (nbutlast vars nlocals))) + (arg-indices (if (<= nlocals 0) map-indices (nbutlast map-indices nlocals)))) + (flet ((get-arg-value (name) + (let* ((pos (position name arg-vars :test #'eq))) + (when pos + (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable)))))) + (get-local-value (name) + (when name + (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable)))))) + (dolist (name req) + (get-arg-value name)) + (dolist (name opt) + (get-arg-value name)) + (when rest + (get-arg-value rest)) + (dolist (name keys) + (get-arg-value name)) + (dolist (name local-vars) + (get-local-value name))))) + (values (args) (locals)))))) + +;; Return list of supplied arguments, as best we can reconstruct it. +(defun supplied-argument-list (context frame lfun pc) + (if (null pc) + (values nil nil) + (if (<= pc target::arg-check-trap-pc-limit) + (values (arg-check-call-arguments frame lfun) t) + (multiple-value-bind (params valid) (arglist-from-map lfun) + (if (not valid) + (values nil nil) + (let* ((args (arguments-and-locals context frame lfun pc)) ;overkill, but will do. + (state :required) + (result ())) + (dolist (param params) + (if (or (member param lambda-list-keywords) (eq param '&lexpr)) + (setq state param) + (let* ((pair (pop args)) + (value (cdr pair))) + (case state + (&lexpr + (with-list-from-lexpr (rest value) + (dolist (r rest) (push r result))) + (return)) + (&rest + (dolist (r value) (push r result)) + (return)) + (&key (push param result))) + (push value result)))) + (values (nreverse result) t))))))) + + +(defun safe-cell-value (val) + val) + +(defun closure-closed-over-values (closure) + (when (typep closure 'compiled-lexical-closure) + (let* ((inner (closure-function closure)) + (nclosed (nth-value 8 (function-args inner))) + (names (car (function-symbol-map inner)))) + (when nclosed + (collect ((cells)) + (do* ((i (1- (length names)) (1- i)) + (k 0 (1+ k)) + (idx 2 (1+ idx))) + ((= k nclosed) (reverse (cells))) + (let* ((name (svref names i)) + (imm (nth-immediate closure idx))) + (cells (list name (if (closed-over-value-p imm) + (closed-over-value imm) + imm)))))))))) + + +;;; Find the oldest binding frame that binds the same symbol as +;;; FRAME in context. If found, return the saved value of that +;;; binding, else the value of the symbol in the context's thread. +(defun oldest-binding-frame-value (context frame) + (let* ((oldest nil) + (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) + (do* ((db (db-link context) (%fixnum-ref db 0))) + ((eq frame db) + (if oldest + (%fixnum-ref oldest (ash 2 target::fixnum-shift)) + (let* ((symbol (binding-index-symbol binding-index))) + (if context + (symbol-value-in-tcr symbol (bt.tcr context)) + (%sym-value symbol))))) + (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) + (setq oldest db))))) + +(defun (setf oldest-binding-frame-value) (new context frame) + (let* ((oldest nil) + (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) + (do* ((db (db-link context) (%fixnum-ref db 0))) + ((eq frame db) + (if oldest + (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new) + (let* ((symbol (binding-index-symbol binding-index))) + (if context + (setf (symbol-value-in-tcr symbol (bt.tcr context)) new) + (%set-sym-value symbol new))))) + (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) + (setq oldest db))))) + + + +;;; End of backtrace.lisp Index: /branches/qres/ccl/lib/case-error.lisp =================================================================== --- /branches/qres/ccl/lib/case-error.lisp (revision 13564) +++ /branches/qres/ccl/lib/case-error.lisp (revision 13564) @@ -0,0 +1,70 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;I wanted a read that would not error even when given a #< +; and also allow backspace and such. +(defun read-line-no-error (&optional (stream *standard-output*) &aux result) + (ignore-errors + (setq result (read-from-string (read-line stream) nil)) + (return-from read-line-no-error (values result t))) + (values nil nil)) + + + +;;;; Assert & Check-Type + +;;; Assert-Value-Prompt -- Internal +;;; +;;; Prompt for a new value to set a place to. We do a read-line, +;;; and if there is anything there, we eval it and return the second +;;; value true, otherwise it is false. +;;; +(defun assertion-value-prompt (place) + (let* ((nvals (length (nth-value 2 (get-setf-method-multiple-value place)))) + (vals nil)) + (dotimes (i nvals) + (if (eq nvals 1) + (format *query-io* "Value for ~S: " place) + (format *query-io* "Value ~D for ~S: " i place)) + (let* ((line (read-line *query-io*)) + (object (read-from-string line nil *eof-value*))) + (if (eq object *eof-value*) + (return) + (push (eval object) vals)))) + (values (nreverse vals) (not (null vals))))) + +(defun %assertion-failure (setf-places-p test-form string &rest condition-args) + (cerror + (if setf-places-p + "allow some places to be set and test the assertion again." + "test the assertion again.") + (cond + ((stringp string) + (make-condition 'simple-error + :format-control string + :format-arguments condition-args)) + ((null string) + (make-condition 'simple-error + :format-control "Failed assertion: ~S" + :format-arguments (list test-form))) + ((typep string 'condition) + (when condition-args (error "No args ~S allowed with a condition ~S" condition-args string)) + string) + (t (apply #'make-condition string condition-args))))) + Index: /branches/qres/ccl/lib/ccl-export-syms.lisp =================================================================== --- /branches/qres/ccl/lib/ccl-export-syms.lisp (revision 13564) +++ /branches/qres/ccl/lib/ccl-export-syms.lisp (revision 13564) @@ -0,0 +1,966 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export ;remember "CCL" at end of list + ;setq %ccl-package-export-syms + '( + local + set-local + @ + *elements-per-buffer* + save-application + def-load-pointers + *save-exit-functions* + *restore-lisp-functions* + *lisp-cleanup-functions* + *lisp-startup-functions* + defloadvar + defstatic + defstaticvar + *break-on-warnings* + ; misc + record-source-file + get-source-files + edit-definition + edit-definition-p + *loading-file-source-file* + find-definition-sources + define-definition-type + definition-type + definition-type-name + *save-source-locations* + function-source-note + source-note + source-note-p + source-note-filename + source-note-start-pos + source-note-end-pos + source-note-text + ensure-source-note-text + *record-pc-mapping* + find-source-note-at-pc + caller-functions + *svn-program* + watch + unwatch + + show-documentation + %set-toplevel + toplevel-loop + toplevel-function + repl-function-name + toplevel + *listener-prompt-format* + cancel + catch-cancel + throw-cancel + *backtrace-on-break* + *show-restarts-on-break* + print-call-history + dbg-form + *backtrace-print-level* + *backtrace-print-length* + *backtrace-show-internal-frames* + *backtrace-format* + map-call-frames + frame-function + frame-supplied-arguments + frame-named-variables + apply-in-frame + *quit-on-eof* + *quit-interrupt-hook* + *break-hook* + *top-error-frame* + *select-interactive-process-hook* + interrupt-signal-condition + macroexpand-all + compiler-macroexpand + compiler-macroexpand-1 + compile-user-function + uncompile-function + report-compiler-warning + compiler-warning + style-warning + compiler-warning-source-note + compiler-warning-function-name + *merge-compiler-warnings* + abort-break + *trace-print-level* + *trace-print-length* + *trace-bar-frequency* + trace-function + *ignore-extra-close-parenthesis* + advise + unadvise + advisedp + nfunction + function-name + setf-function-p + setf-function-spec-name + name-of + + assq + bignump + bitp + constant-symbol-p + proclaimed-special-p + delq + fixnump + quit + include + memq + nremove + ;put + ratiop + structure-typep + structurep + type-specifier-p + displaced-array-p + without-interrupts + with-interrupts-enabled + true + false + neq + whitespacep + *print-structure* + *print-simple-vector* + *print-simple-bit-vector* + *print-string-length* + *print-abbreviate-quote* + *signal-printing-errors* + unignore + *warn-if-redefine-kernel* + without-duplicate-definition-warnings + require-type + dovector + debugging-function-name + *make-package-use-defaults* + *autoload-lisp-package* + tyo + tyi + untyi + compiled-lexical-closure ; the type name + lsh + + ;; Arguments, image name, etc. + *command-line-argument-list* + *unprocessed-command-line-arguments* + *heap-image-name* + + ; The MOP + accessor-method-slot-definition + add-dependent + add-direct-method + add-direct-subclass + add-method + class-default-initargs + class-direct-default-initargs + class-direct-slots + class-direct-subclasses + class-direct-superclasses + class-finalized-p + class-precedence-list + class-prototype + class-slots + compute-applicable-methods + compute-applicable-methods-using-classes + compute-class-precedence-list + compute-default-initargs + compute-discriminating-function + compute-effective-method + compute-effective-slot-definition + compute-slots + direct-slot-definition-class + effective-slot-definition-class + ensure-class + ensure-class-using-class + ensure-generic-function-using-class + eql-specializer + eql-specializer-object + extract-lambda-list + extract-specializer-names + finalize-inheritance + find-method-combination + funcallable-standard-instance-access + generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list + generic-function-method-class + generic-function-method-combination + generic-function-methods + generic-function-name + intern-eql-specializer + make-method-lambda + map-dependents + method-function + method-generic-function + method-lambda-list + method-name + method-specializers + method-qualifiers + slot-definition-documentation + slot-definition-allocation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-name + slot-definition-type + slot-definition-readers + slot-definition-writers + slot-definition-location + reader-method-class + remove-dependent + remove-direct-method + remove-direct-subclass + remove-method + set-funcallable-instance-function + slot-boundp-using-class + slot-makunbound-using-class + slot-value-using-class + specializer-direct-generic-functions + specializer-direct-methods + standard-instance-access + update-dependent + validate-superclass + writer-method-class + + metaobject + long-method-combination + short-method-combination + standard-accessor-method + standard-reader-method + standard-writer-method + specializer + + funcallable-standard-class + funcallable-standard-object + forward-referenced-class + standard-direct-slot-definition + standard-effective-slot-definition + + standard-slot-definition + slot-definition + effective-slot-definition + direct-slot-definition + + clear-specializer-direct-methods-caches + *check-call-next-method-with-args* + clear-gf-cache + clear-all-gf-caches + clear-clos-caches + + method-exists-p + method-specializers + class-own-wrapper + specializer-direct-methods + specializer-direct-generic-functions + copy-instance + + override-one-method-one-arg-dcode + optimize-generic-function-dispatching + + ;; Not MOP + string-studlify ;** DO NOT REMOVE, DO NOT DOCUMENT + nstring-studlify ;** DO NOT REMOVE, DO NOT DOCUMENT + + ; User Options + *compile-definitions* + *record-source-file* + *save-doc-strings* + *fasl-save-doc-strings* + *warn-if-redefine* + *break-on-errors* + *save-definitions* + *fasl-save-definitions* + *save-local-symbols* + *fasl-save-local-symbols* + *save-arglist-info* + *always-eval-user-defvars* + + ;These 3 need to be set by the user in order for the correspondingly named + ;functions to return something other than "unspecified". + *short-site-name* + *long-site-name* + machine-owner + + init-list-default + fset + + ; Files. + mac-default-directory + current-directory + directory-pathname-p + full-pathname + temp-pathname + create-file + create-directory + file-create-date + set-file-write-date + set-file-create-date + copy-file + lock-file + unlock-file + file-locked-p + directoryp + + + *module-search-path* + *module-provider-functions* + *.lisp-pathname* + *.fasl-pathname* + *pathname-translations-pathname* + *default-external-format* + *default-line-termination* + pathname-encoding-name + with-filename-cstrs + get-foreign-namestring + native-translated-namestring + native-to-pathname + fasl-concatenate + event-ticks + set-event-ticks + event-dispatch + *ticks-per-second* + + *application* + arglist + arglist-string + arglist-to-stream + function-args + + + get-string-from-user + with-terminal-input + *request-terminal-input-via-break* + add-auto-flush-stream + remove-auto-flush-stream + select-item-from-list + + + ; Low-level + %stack-block + %vstack-block + %get-byte + %get-signed-byte + %get-unsigned-byte + %get-word + %get-signed-word + %get-unsigned-word + %get-long + %get-unsigned-long + %get-signed-long + %%get-signed-longlong + %%get-unsigned-longlong + %get-fixnum + %get-point + %get-ptr + %get-string + %get-cstring + %str-from-ptr + %get-double-float + %get-single-float + %inc-ptr + %incf-ptr + %setf-macptr + %null-ptr + %null-ptr-p + %ptr-eql + %ptr-to-int + %int-to-ptr + %word-to-int + %address-of + ensure-simple-string + %copy-float + with-macptrs + pointerp + macptrp + macptr + rlet + rletz + make-record + pref + rref + paref + with-cstrs + with-encoded-cstrs + with-string-vector + with-pointer-to-ivector + get-encoded-string + +null-ptr+ + free + define-entry-point + define-callback + defcallback + ff-call + %ff-call + %reference-external-entry-point + foreign-symbol-entry + foreign-symbol-address + def-foreign-type + + uvref + uvectorp + uvsize + + ;;Streams (should be made more complete sometime) + input-stream + output-stream + stream-eofp + + open-file-streams + note-open-file-stream + remove-open-file-stream + clear-open-file-streams + stream-line-length + string-output-stream + truncating-string-stream + make-truncating-string-stream + stream-rubout-handler + + + ; Tools + gc + egc + egc-enabled-p + egc-active-p + configure-egc + egc-configuration + gccounts + gctime + lisp-heap-gc-threshold + use-lisp-heap-gc-threshold + set-lisp-heap-gc-threshold + gc-retain-pages + gc-retaining-pages + gc-verbose + gc-verbose-p + weak-gc-method + *trace-max-indent* + *trace-level* + *static-cons-chunk* + static-cons + + population + make-population + population-type + population-contents + + hash-table-weak-p + + compiler-let + + + COMPILER-POLICY + CURRENT-COMPILER-POLICY + CURRENT-FILE-COMPILER-POLICY + FIND-MACTYPE + NEW-COMPILER-POLICY + SET-CURRENT-COMPILER-POLICY + SET-CURRENT-FILE-COMPILER-POLICY + STANDARD-METHOD-COMBINATION + STREAM-DEVICE + STREAM-DIRECTION + *current-process* + PROCESS + all-processes + process-preset + process-reset + process-reset-and-enable + process-enable + process-abort + process-kill + process-interrupt + process-name + process-run-function + make-process + process-suspend-count + process-serial-number + process-initial-form + process-whostate + process-priority + process-total-run-time + process-creation-time + clear-process-run-time + process-resume + process-suspend + process-exhausted-p + let-globally + process-wait + process-wait-with-timeout + process-allow-schedule + process-kill-issued + process-termination-semaphore + process-allocation-quantum + default-allocation-quantum + current-process-allocation-quantum + join-process + + *HOST-PAGE-SIZE* + + make-lock + lock-name + with-lock-grabbed + grab-lock + release-lock + try-lock + lock + read-write-lock + lock-not-owner + + lock-acquisition-status + clear-lock-acquisition-status + lock-acquisition + make-lock-acquisition + + semaphore-notification-status + clear-semaphore-notification-status + semaphore-notification + make-semaphore-notification + + make-read-write-lock + with-read-lock + with-write-lock + symbol-value-in-process + + make-semaphore + wait-on-semaphore + timed-wait-on-semaphore + signal-semaphore + semaphore + + process-input-wait + process-output-wait + ; termination + terminate-when-unreachable + terminate + drain-termination-queue + cancel-terminate-when-unreachable + termination-function + *enable-automatic-termination* + + get-fpu-mode + set-fpu-mode + + ; There's more. Like... + + *listener-indent* + *error-print-circle* + *break-loop-when-uninterruptable* + + application-error + application-name + application-init-file + + cwd + + ;; Old CLtL2 stuff: + + *applyhook* + *evalhook* + applyhook + augment-environment + declaration-information + define-declaration + define-setf-method + evalhook + enclose + function-information + generic-flet + generic-labels + get-setf-method + get-setf-method-multiple-value + parse-macro + variable-information + with-added-methods + + ;; Gray Streams + fundamental-stream + fundamental-input-stream + fundamental-output-stream + fundamental-character-stream + fundamental-character-input-stream + fundamental-character-output-stream + fundamental-binary-stream + fundamental-binary-input-stream + fundamental-binary-output-stream + + stream-read-char + stream-unread-char + stream-read-char-no-hang + stream-peek-char + stream-listen + stream-read-line + stream-clear-input + + stream-write-char + stream-line-column + stream-start-line-p + stream-write-string + stream-terpri + stream-fresh-line + stream-force-output + stream-clear-output + stream-advance-to-column + + stream-read-byte + stream-write-byte + + stream-read-ivector + stream-write-ivector + + stream-read-list + stream-write-list + stream-read-vector + stream-write-vector + + stream-input-timeout + stream-output-timeout + with-input-timeout + with-output-timeout + stream-deadline + + input-timeout + output-timeout + communication-deadline-expired + + make-heap-ivector + dispose-heap-ivector + ;; + external + external-call + open-shared-library + close-shared-library + shlib + external-entry-point + use-interface-dir + unuse-interface-dir + create-interfaces + ;; + run-program + external-process + signal-external-process + external-process-id + external-process-input-stream + external-process-output-stream + external-process-error-stream + external-process-status + ;; + *altivec-available* + altivec-available-p + *altivec-lapmacros-maintain-vrsave-p* + ;; + *alternate-line-terminator* + ;; + set-user-environment + set-development-environment + *resident-editor-hook* + cpu-count + *report-time-function* + ;; + compile-ccl + xcompile-ccl + xload-level-0 + rebuild-ccl + update-ccl + test-ccl + defglobal + + getenv + setenv + + external-format + make-external-format + external-format-character-encoding + external-format-line-termination + character-encoding + define-character-encoding + describe-character-encoding + describe-character-encodings + get-character-encoding + lookup-character-encoding + string-size-in-octets + encode-string-to-octets + count-characters-in-octet-vector + decode-string-from-octets + *terminal-character-encoding-name* + *default-file-character-encoding* + *default-socket-character-encoding* + ;; Mapped files. + map-file-to-ivector + map-file-to-octet-vector + unmap-ivector + unmap-octet-vector + ;; Miscellany + heap-utilization + collect-heap-utilization + parse-unsigned-integer + parse-signed-integer + pui-stream + psi-stream + with-output-to-vector + with-input-from-vector + make-vector-output-stream + make-vector-input-stream + unsigned-integer-to-binary + signed-integer-to-binary + vector-input-stream + vector-output-stream + get-output-stream-vector + *vector-output-stream-default-initial-allocation* + external-process-creation-failure + + ) "CCL" + ) + ) + +;;; Define a package for MOP extensions. +(defpackage "OPENMCL-MOP" + (:use) + (:import-from + "CCL" + "ACCESSOR-METHOD-SLOT-DEFINITION" + "ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "ADD-METHOD" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-NAME" + "METHOD-SPECIALIZERS" + "METHOD-QUALIFIERS" + "SLOT-DEFINITION-DOCUMENTATION" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-TYPE" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-WRITERS" + "SLOT-DEFINITION-LOCATION" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "REMOVE-METHOD" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-DIRECT-SLOT-DEFINITION" + "STANDARD-EFFECTIVE-SLOT-DEFINITION" + "STANDARD-INSTANCE-ACCESS" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS" + + "METAOBJECT" + "LONG-METHOD-COMBINATION" + "SHORT-METHOD-COMBINATION" + "STANDARD-ACCESSOR-METHOD" + "STANDARD-READER-METHOD" + "STANDARD-WRITER-METHOD" + "SPECIALIZER" + + "FUNCALLABLE-STANDARD-CLASS" + "FUNCALLABLE-STANDARD-OBJECT" + "FORWARD-REFERENCED-CLASS" + + "CLEAR-SPECIALIZER-DIRECT-METHODS-CACHES" + "*CHECK-CALL-NEXT-METHOD-WITH-ARGS*" + "CLEAR-GF-CACHE" + "CLEAR-ALL-GF-CACHES" + "CLEAR-CLOS-CACHES" + + "METHOD-EXISTS-P" + "METHOD-SPECIALIZERS" + "CLASS-OWN-WRAPPER" + "SPECIALIZER-DIRECT-METHODS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "COPY-INSTANCE" + "STANDARD-SLOT-DEFINITION" + "SLOT-DEFINITION" + "EFFECTIVE-SLOT-DEFINITION" + "DIRECT-SLOT-DEFINITION" + ) + (:export + "ACCESSOR-METHOD-SLOT-DEFINITION" + "ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "ADD-METHOD" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-NAME" + "METHOD-SPECIALIZERS" + "METHOD-QUALIFIERS" + "SLOT-DEFINITION-DOCUMENTATION" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-TYPE" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-WRITERS" + "SLOT-DEFINITION-LOCATION" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "REMOVE-METHOD" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-DIRECT-SLOT-DEFINITION" + "STANDARD-EFFECTIVE-SLOT-DEFINITION" + "STANDARD-INSTANCE-ACCESS" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS" + + "METAOBJECT" + "LONG-METHOD-COMBINATION" + "SHORT-METHOD-COMBINATION" + "STANDARD-ACCESSOR-METHOD" + "STANDARD-READER-METHOD" + "STANDARD-WRITER-METHOD" + "SPECIALIZER" + + "FUNCALLABLE-STANDARD-CLASS" + "FORWARD-REFERENCED-CLASS" + + + "CLEAR-SPECIALIZER-DIRECT-METHODS-CACHES" + "*CHECK-CALL-NEXT-METHOD-WITH-ARGS*" + "CLEAR-GF-CACHE" + "CLEAR-ALL-GF-CACHES" + "CLEAR-CLOS-CACHES" + + "METHOD-EXISTS-P" + "METHOD-SPECIALIZERS" + "CLASS-OWN-WRAPPER" + "SPECIALIZER-DIRECT-METHODS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "COPY-INSTANCE" + "STANDARD-SLOT-DEFINITION" + "SLOT-DEFINITION" + "EFFECTIVE-SLOT-DEFINITION" + "DIRECT-SLOT-DEFINITION" + )) + +(unless (eq %lisp-system-fixups% T) + (while %lisp-system-fixups% + (let* ((fn.source (car %lisp-system-fixups%)) + (*loading-toplevel-location* (and (source-note-p (cdr fn.source)) (cdr fn.source))) + (*loading-file-source-file* (source-note-filename (cdr fn.source))) + ) + (funcall (car fn.source))) + (setq %lisp-system-fixups% (cdr %lisp-system-fixups%))) + (setq %lisp-system-fixups% T)) + + + + Index: /branches/qres/ccl/lib/chars.lisp =================================================================== --- /branches/qres/ccl/lib/chars.lisp (revision 13564) +++ /branches/qres/ccl/lib/chars.lisp (revision 13564) @@ -0,0 +1,748 @@ +; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;; chars.lisp + +(in-package "CCL") + +(defun character-designator-p (thing) + (or (typep thing 'character) + (typep thing '(string 1)) + (and (typep thing 'symbol) (typep (symbol-name thing) '(string 1))))) + +;;; If object is a character, it is returned. If it is a string of +;;; length 1, then the sole element of the string is returned. If it +;;; is a symbol whose pname is of length 1, then the sole element of +;;; the pname is returned. Else error. + +(defun character (arg) + "Coerce OBJECT into a CHARACTER if possible. Legal inputs are + characters, strings and symbols of length 1." + (if (typep arg 'character) + arg + (if (and (typep arg 'string) + (= (the fixnum (length arg)) 1)) + (char arg 0) + (let* ((pname (if (typep arg 'symbol) (symbol-name arg)))) + (if (and pname (= (the fixnum (length pname)) 1)) + (char pname 0) + (report-bad-arg arg '(satisfies character-designator-p))))))) + + + +(defun digit-char (weight &optional radix) + "All arguments must be integers. Returns a character object that + represents a digit of the given weight in the specified radix. Returns + NIL if no such character exists." + (let* ((r (if radix (require-type radix 'integer) 10))) + (if (and (typep (require-type weight 'integer) 'fixnum) + (>= r 2) + (<= r 36) + (>= weight 0) + (< weight r)) + (locally (declare (fixnum weight)) + (if (< weight 10) + (code-char (the fixnum (+ weight (char-code #\0)))) + (code-char (the fixnum (+ weight (- (char-code #\A) 10))))))))) + + +(declaim (inline %control-char-p)) + +(defun %control-char-p (char) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + ;; If we believe that "most" characters will have relatively + ;; small codes, then doing a linear search on this short + ;; list is probably faster than binary search on a vector + ;; or other approaches. + (dolist (pair '((0 . #x1f) ;c0 + (#x7f . #x9f) ;#\rubout, c1 + (#x34f . #x34f) ;combining grapheme joiner. + (#x200c . #x200f) + (#x202a . #x202e) + (#x2060 . #x2063) + (#x206a . #x206f) + #+darwin-target + (#xf700 . #xf7ff) + (#xfe00 . #xfe0f) + (#xfeff . #xfeff) ;byte-order mark (0-width space). + (#xfff0 . #xfffd) + + (#xe0000 . #xefffd))) + (let* ((low (car pair)) + (high (cdr pair))) + (declare (type (mod #x110000) low high)) + (if (> low code) + (return nil) + (if (<= code high) + (return t))))))) + + + +;;; Characters that aren't control/formatting characters are graphic. +(defun graphic-char-p (c) + "The argument must be a character object. GRAPHIC-CHAR-P returns NIL if the + argument is a Unicode control character, otherwise returns T." + (not (%control-char-p c))) + + +;True for ascii codes 10 and 32-126 inclusive. +(defun standard-char-p (c) + "The argument must be a character object. STANDARD-CHAR-P returns T if the + argument is a standard character -- one of the 95 ASCII printing characters + or ." + (let* ((code (char-code c))) + (or (eq c #\newline) + (and + (>= code (char-code #\space)) + (< code (char-code #\rubout)))))) + + + + + + + +(defun upper-case-p (c) + "The argument must be a character object; UPPER-CASE-P returns T if the + argument is an upper-case character, NIL otherwise." + (let* ((code (char-code c)) + (to-lower *upper-to-lower*)) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) to-lower)) + (and (< code (length to-lower)) + (not (zerop (aref to-lower code)))))) + + + + +(defun both-case-p (c) + "The argument must be a character object. BOTH-CASE-P returns T if the + argument is an alphabetic character and if the character exists in + both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P." + (let* ((code (char-code c)) + (to-upper *lower-to-upper*) + (to-lower *upper-to-lower*)) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) to-lower to-upper)) + (or (and (< code (length to-upper)) + (not (zerop (aref to-upper code)))) + (and (< code (length to-lower)) + (not (zerop (aref to-lower code))))))) + +(defun alphanumericp (c) + "Given a character-object argument, ALPHANUMERICP returns T if the + argument is either numeric or alphabetic." + (let ((code (char-code c))) + (declare (type (mod #x110000) code)) + (or + (and (>= code (char-code #\0)) + (<= code (char-code #\9))) + (let* ((bits *alpha-char-bits*)) + (declare (simple-bit-vector bits)) + (and (< code (length bits)) + (not (eql 0 (sbit bits code)))))))) + +(defun char= (ch &rest others) + "Return T if all of the arguments are the same character." + (declare (dynamic-extent others)) + (unless (typep ch 'character) + (setq ch (require-type ch 'character))) + (dolist (other others t) + (unless (eq other ch) + (unless (typep other 'character) + (setq other (require-type other 'character))) + (return)))) + +(defun char/= (ch &rest others) + "Return T if no two of the arguments are the same character." + (declare (dynamic-extent others)) + (unless (typep ch 'character) + (setq ch (require-type ch 'character))) + (do* ((rest others (cdr rest))) + ((null rest) t) + (let ((other (car rest))) + (if (eq other ch) (return)) + (unless (typep other 'character) + (setq other (require-type other 'character))) + (dolist (o2 (cdr rest)) + (if (eq o2 other)(return-from char/= nil)))))) + + +(defun char-equal (char &rest others) + "Return T if all of the arguments are the same character. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (dolist (c others t) + (when (not (eq c char)) + (unless (eq (char-upcase char) (char-upcase c)) + (return)))))) + +;;; Compares each char against all following chars, not just next one. Tries +;;; to be fast for one or two args. +(defun char-not-equal (char &rest others) + "Return T if no two of the arguments are the same character. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((rest (cdr others))) + (cond + (rest + (setq char (char-code (char-upcase char))) + (do ((list others (cdr list))) + ((null list)) + (rplaca list (char-code (char-upcase (car list))))) + (while others + (when (memq char others) + (return-from char-not-equal nil)) + (setq char (car others) + others rest + rest (cdr others))) + t) + (others ; 2 args, no table + (not (eq (char-upcase char) (char-upcase (car others))))) + (t t))))) + + +(defun char-lessp (char &rest others) + "Return T if the arguments are in strictly increasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (unless (< code (setq code (char-code (char-upcase c)))) + (return)))))) + +(defun char-not-lessp (char &rest others) + "Return T if the arguments are in strictly non-increasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (when (< code (setq code (char-code (char-upcase c)))) + (return)))))) + +(defun char-greaterp (char &rest others) + "Return T if the arguments are in strictly decreasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (unless (> code (setq code (char-code (char-upcase c)))) + (return)))))) + +(defun char-not-greaterp (char &rest others) + "Return T if the arguments are in strictly non-decreasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (when (> code (setq code (char-code (char-upcase c)))) + (return)))))) + + +(defun char> (char &rest others) + "Return T if the arguments are in strictly decreasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i> char (setq char code))) + (return))))))) + +(defun char>= (char &rest others) + "Return T if the arguments are in strictly non-increasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i>= char (setq char code))) + (return))))))) + + +(defun char< (char &rest others) + "Return T if the arguments are in strictly increasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i< char (setq char code))) + (return))))))) + +(defun char<= (char &rest others) + "Return T if the arguments are in strictly non-decreasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i<= char (setq char code))) + (return))))))) + +; This is Common Lisp +(defun char-int (c) + "Return the integer code of CHAR." + (char-code c)) + + +;If char has an entry in the *NAME-CHAR-ALIST*, return first such entry. +;Otherwise, if char is a graphics character, return NIL +;Otherwise, if char code is < 128, return "^C", otherwise "1nn" + +(defun char-name (c) + "Return the name (a STRING) for a CHARACTER object." + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (or (gethash c *char->name*) + (cond ((< code #x7f) + (when (< code (char-code #\space)) + (let ((str (make-string 2 :element-type 'base-char))) + (declare (simple-base-string str)) + (setf (schar str 0) #\^) + (setf (schar str 1)(code-char (logxor code #x40))) + str))) + ((and (< code #x100)(graphic-char-p c)) nil) + (t (format nil "U+~4,'0x" code)))))) + + +(defun string-downcase (string &key (start 0) end) + (setq string (copy-string-arg string)) + (setq end (check-sequence-bounds string start end)) + (%strdown string start end)) + + +(defun %strdown (string start end) + (declare (fixnum start end) + (optimize (speed 3) (safety 0))) + (unless (typep string 'simple-string) + (check-type string simple-string)) + (do* ((i start (1+ i)) + (to-lower *upper-to-lower*) + (n (length to-lower))) + ((>= i end) string) + (declare (fixnum i n) (type (simple-array (signed-byte 16) (*)) to-lower)) + (let* ((ch (schar string i)) + (code (char-code ch)) + (delta (if (< code n) (aref to-lower code) 0))) + (declare (character ch) + (type (mod #x110000) code) + (type (signed-byte 16) delta)) + (unless (zerop delta) + (setf (schar string i) + (code-char (the valid-char-code (+ code delta)))))))) + + + + +(defun copy-string-arg (string &aux (org 0) len) + (etypecase string + (string + (setq len (length string)) + (multiple-value-setq (string org)(array-data-and-offset string))) + (symbol + (setq string (symbol-name string)) + (setq len (length string))) + (character + (return-from copy-string-arg + (make-string 1 :initial-element string )))) + (%substr string org (+ len org))) + +(defun string-upcase (string &key (start 0) end) + (setq string (copy-string-arg string)) + (setq end (check-sequence-bounds string start end)) + (%strup string start end)) + +(defun %strup (string start end) + (declare (fixnum start end) + (optimize (speed 3) (safety 0))) + (unless (typep string 'simple-string) + (check-type string simple-string)) + (do* ((i start (1+ i)) + (to-upper *lower-to-upper*) + (n (length to-upper))) + ((>= i end) string) + (declare (fixnum i n) (type (simple-array (signed-byte 16) (*)) to-upper)) + (let* ((ch (schar string i)) + (code (char-code ch)) + (delta (if (< code n) (aref to-upper code) 0))) + (declare (character ch) + (type (mod #x110000) code) + (type (signed-byte 16) delta)) + (unless (zerop delta) + (setf (schar string i) (code-char (the valid-char-code (+ code delta)))))))) + + + +(defun string-capitalize (string &key (start 0) end) + (setq string (copy-string-arg string)) + (setq end (check-sequence-bounds string start end)) + (%strcap string start end)) + +(defun %strcap (string start end) + (declare (fixnum start end)) + (let ((state :up) + (i start)) + (declare (fixnum i)) + (while (< i end) + (let* ((c (%schar string i)) + (alphap (alphanumericp c))) ; makes no sense + (if alphap + (progn + (setf (%schar string i) + (case state + (:up (char-upcase c)) + (t (char-downcase c)))) + (setq state :down)) + (setq state :up))) + (setq i (1+ i))) + string)) + + + + +(defun nstring-downcase (string &key (start 0) end) + (etypecase string + (string + (setq end (check-sequence-bounds string start end)) + (if (typep string 'simple-string) + (%strdown string start end) + (multiple-value-bind (data offset) (array-data-and-offset string) + (%strdown data (+ start offset) (+ end offset)))) + string))) + +(defun nstring-upcase (string &key (start 0) end) + (etypecase string + (string + (setq end (check-sequence-bounds string start end)) + (if (typep string 'simple-string) + (%strup string start end) + (multiple-value-bind (data offset) (array-data-and-offset string) + (%strup data (+ start offset) (+ end offset)))) + string))) + + +(defun nstring-capitalize (string &key (start 0) end) + (etypecase string + (string + (setq end (check-sequence-bounds string start end)) + (if (typep string 'simple-string) + (%strcap string start end) + (multiple-value-bind (data offset) (array-data-and-offset string) + (%strcap data (+ start offset) (+ end offset)))) + string))) + + + +(defun nstring-studlify (string &key start end) + (declare (ignore start end)) + string) + + +(defun string-compare (string1 start1 end1 string2 start2 end2) + (let ((istart1 (or start1 0))) + (if (and (typep string1 'simple-string)(null start1)(null end1)) + (setq start1 0 end1 (length string1)) + (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1))) + (if (and (typep string2 'simple-string)(null start2)(null end2)) + (setq start2 0 end2 (length string2)) + (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2))) + (setq istart1 (%i- start1 istart1)) + (let* ((val t)) + (declare (optimize (speed 3)(safety 0))) + (do* ((i start1 (%i+ 1 i)) + (j start2 (%i+ 1 j))) + () + (when (eq i end1) + (when (neq j end2) + (setq val -1)) + (return)) + (when (eq j end2) + (setq end1 i) + (setq val 1) + (return)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (fixnum code1 code2)) + (if (and (>= code1 (char-code #\a)) + (<= code1 (char-code #\z))) + (setq code1 (- code1 (- (char-code #\a) (char-code #\A))))) + (if (and (>= code2 (char-code #\a)) + (<= code2 (char-code #\z))) + (setq code2 (- code2 (- (char-code #\a) (char-code #\A))))) + (unless (= code1 code2) + (setq val (if (%i< code1 code2) -1 1)) + (setq end1 i) + (return)))) + (values val (%i- end1 istart1))))) + + +(defun string-greaterp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater than + the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result 1) pos nil))) + +(defun string-not-greaterp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + or equal to the second string, returns the longest common prefix + (using char-equal) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result 1) nil pos))) + +(defun string-not-equal (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is not lexicographically equal + to the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result t) nil pos))) + +(defun string-not-lessp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater + than or equal to the second string, returns the longest common prefix + (using char-equal) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result -1) nil pos))) + +(declaim (inline %string-start-end)) +(defun %string-start-end (string) + (etypecase string + (string (multiple-value-bind (data offset) + (array-data-and-offset string) + (declare (fixnum offset)) + (values data offset (+ offset (length string))))) + (symbol (let* ((pname (symbol-name string))) + (values pname 0 (length pname)))) + (character (let* ((data (make-string 1))) + (setf (schar data 0) string) + (values data 0 1))))) + +;;; This is generally a bit faster then the version that deals with +;;; user-supplied bounds, both because the caller avoids passing +;;; some extra arguments and because those bounds don't need to be +;;; validated. +(defun %fixed-string-equal (string1 string2) + (let* ((start1 0) + (end1 0) + (start2 0) + (end2 0)) + (declare (fixnum start1 end1 start2 end2)) + (if (typep string1 'simple-string) + (setq end1 (uvsize string1)) + (multiple-value-setq (string1 start1 end1) + (%string-start-end string1))) + (if (typep string2 'simple-string) + (setq end2 (uvsize string2)) + (multiple-value-setq (string2 start2 end2) + (%string-start-end string2))) + (locally + (declare (optimize (speed 3)(safety 0)) + (simple-string string1 string2)) + (when (= (the fixnum (- end1 start1)) + (the fixnum (- end2 start2))) + (do* ((i start1 (1+ i)) + (j start2 (1+ j)) + (map *lower-to-upper*)) + ((= i end1) t) + (declare (fixnum i j)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (type (mod #x110000) code1 code2)) + (unless (= code1 code2) + (unless (= (the (mod #x110000) (%char-code-case-fold code1 map)) + (the (mod #x110000) (%char-code-case-fold code2 map))) + (return))))))))) + +;;; Some of the start1/end1/start2/end2 args may be bogus. +(defun %bounded-string-equal (string1 string2 start1 end1 start2 end2) + (let* ((disp1 nil) + (len1 0) + (disp2 nil) + (len2 0)) + (declare (fixnum len1 len2)) + (if (typep string1 'simple-string) + (setq len1 (length (the simple-string string1))) + (etypecase string1 + (string (setq len1 (length string1)) + (multiple-value-setq (string1 disp1) + (array-data-and-offset string1))) + (symbol (setq string1 (symbol-name string1) + len1 (length (the simple-string string1)))) + (character (setq string1 (make-string 1 :initial-element string1) + len1 1)))) + (if (typep string2 'simple-string) + (setq len2 (length (the simple-string string2))) + (etypecase string2 + (string (setq len2 (length string2)) + (multiple-value-setq (string2 disp2) + (array-data-and-offset string2))) + (symbol (setq string2 (symbol-name string2) + len1 (length (the simple-string string2)))) + (character (setq string2 (make-string 1 :initial-element string2) + len1 1)))) + (flet ((bad-index (index vector) (error "Index ~s is invalid for ~s" index vector))) + (if (null start1) + (setq start1 0) + (when (or (not (typep start1 'fixnum)) + (< (the fixnum start1) 0)) + (bad-index start1 string1))) + (if (null end1) + (setq end1 len1) + (when (or (not (typep end1 'fixnum)) + (< (the fixnum end1) 0) + (> (the fixnum end1) len1)) + (bad-index end1 string1))) + (locally (declare (fixnum start1 end1)) + (if (> start1 end1) + (error ":start1 argument ~s exceeds :end1 argument ~s" start1 end1)) + (when disp1 + (locally (declare (fixnum disp1)) + (incf start1 disp1) + (incf end1 disp1))) + (if (null start2) + (setq start2 0) + (when (or (not (typep start2 'fixnum)) + (< (the fixnum start2) 0)) + (bad-index start2 string2))) + (if (null end2) + (setq end2 len2) + (when (or (not (typep end2 'fixnum)) + (< (the fixnum end2) 0) + (> (the fixnum end2) len2)) + (bad-index end2 string2))) + (locally (declare (fixnum start2 end2)) + (if (> start2 end2) + (error ":start2 argument ~s exceeds :end2 argument ~s" start1 end1)) + (when disp2 + (locally (declare (fixnum disp2)) + (incf start2 disp2) + (incf end2 disp2))) + (locally + (declare (optimize (speed 3)(safety 0)) + (simple-string string1 string2)) + (when (= (the fixnum (- end1 start1)) + (the fixnum (- end2 start2))) + (do* ((i start1 (1+ i)) + (j start2 (1+ j)) + (map *lower-to-upper*)) + ((= i end1) t) + (declare (fixnum i j)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (type (mod #x110000) code1 code2)) + (unless (= code1 code2) + (unless (= (the (mod #x110000) (%char-code-case-fold code1 map)) + (the (mod #x110000) (%char-code-case-fold code2 map))) + (return)))))))))))) + +(defun string-equal (string1 string2 &key start1 end1 start2 end2) + "Given two strings (string1 and string2), and optional integers start1, + start2, end1 and end2, compares characters in string1 to characters in + string2 (using char-equal)." + (if (or start1 end1 start2 end2) + (%bounded-string-equal string1 string2 start1 end1 start2 end2) + (%fixed-string-equal string1 string2))) + + + +(defun string-lessp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos)(string-compare string1 start1 end1 string2 start2 end2) + (if (eq result -1) pos nil))) + +;;; forget script-manager - just do codes +(defun string-cmp (string1 start1 end1 string2 start2 end2) + (let ((istart1 (or start1 0))) + (if (and (typep string1 'simple-string)(null start1)(null end1)) + (setq start1 0 end1 (length string1)) + (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1))) + (if (and (typep string2 'simple-string)(null start2)(null end2)) + (setq start2 0 end2 (length string2)) + (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2))) + (setq istart1 (%i- start1 istart1)) + (let* ((val t)) + (declare (optimize (speed 3)(safety 0))) + (do* ((i start1 (%i+ 1 i)) + (j start2 (%i+ 1 j))) + () + (when (eq i end1) + (when (neq j end2)(setq val -1)) + (return)) + (when (eq j end2) + (setq end1 i) + (setq val 1)(return)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (fixnum code1 code2)) + (unless (= code1 code2) + (setq val (if (%i< code1 code2) -1 1)) + (setq end1 i) + (return)))) + (values val (%i- end1 istart1))))) + +(defun string> (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater than + the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result 1) pos nil))) + +(defun string>= (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater + than or equal to the second string, returns the longest common prefix + (using char=) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result -1) nil pos))) + +(defun string< (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result -1) pos nil))) + +(defun string<= (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + or equal to the second string, returns the longest common prefix + (using char=) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result 1) nil pos))) + +; this need not be so fancy? +(defun string/= (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is not lexicographically equal + to the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result t) nil pos))) + + + +(provide 'chars) Index: /branches/qres/ccl/lib/compile-ccl.lisp =================================================================== --- /branches/qres/ccl/lib/compile-ccl.lisp (revision 13564) +++ /branches/qres/ccl/lib/compile-ccl.lisp (revision 13564) @@ -0,0 +1,814 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(require 'systems) + +(defparameter *sysdef-modules* + '(systems compile-ccl)) + +(defparameter *level-1-modules* + '(level-1 + l1-cl-package + l1-boot-1 l1-boot-2 l1-boot-3 + l1-utils l1-init l1-symhash l1-numbers l1-aprims + l1-sort l1-dcode l1-clos-boot l1-clos + l1-unicode l1-streams l1-files l1-io + l1-format l1-readloop l1-reader + l1-sysio l1-pathnames l1-events + l1-boot-lds l1-readloop-lds + l1-lisp-threads l1-application l1-processes + l1-typesys sysutils l1-error-system + l1-error-signal version l1-callbacks + l1-sockets linux-files + )) + +(defparameter *compiler-modules* + '(nx optimizers dll-node arch vreg vinsn + reg subprims backend nx2)) + + +(defparameter *ppc-compiler-modules* + '(ppc32-arch + ppc64-arch + ppc-arch + ppcenv + ppc-asm + risc-lap + ppc-lap + ppc-backend +)) + +(defparameter *x86-compiler-modules* + '(x8632-arch + x8664-arch + x86-arch + x8632env + x8664env + x86-asm + x86-lap + x86-backend +)) + +(defparameter *ppc32-compiler-backend-modules* + '(ppc32-backend ppc32-vinsns)) + +(defparameter *ppc64-compiler-backend-modules* + '(ppc64-backend ppc64-vinsns)) + + +(defparameter *ppc-compiler-backend-modules* + '(ppc2)) + + +(defparameter *x8632-compiler-backend-modules* + '(x8632-backend x8632-vinsns)) + +(defparameter *x8664-compiler-backend-modules* + '(x8664-backend x8664-vinsns)) + +(defparameter *x86-compiler-backend-modules* + '(x862)) + + + + +(defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image )) +(defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image )) +(defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image )) + + +;;; Not too OS-specific. +(defparameter *ppc-xdev-modules* '(ppc-lapmacros )) +(defparameter *x86-xdev-modules* '(x86-lapmacros )) + +(defun target-xdev-modules (&optional (target + (backend-target-arch-name + *host-backend*))) + (case target + ((:ppc32 :ppc64) *ppc-xdev-modules*) + ((:x8632 :x8664) *x86-xdev-modules*))) + +(defun target-xload-modules (&optional (target + (backend-target-arch-name *host-backend*))) + (case target + ((:ppc32 :ppc64) *ppc-xload-modules*) + (:x8632 *x8632-xload-modules*) + (:x8664 *x8664-xload-modules*))) + + + + + + +(defparameter *env-modules* + '(hash backquote lispequ level-2 macros + defstruct-macros lists chars setf setf-runtime + defstruct defstruct-lds + foreign-types + db-io + nfcomp + )) + +(defun target-env-modules (&optional (target + (backend-name *host-backend*))) + (append *env-modules* + (list + (ecase target + (:linuxppc32 'ffi-linuxppc32) + (:darwinppc32 'ffi-darwinppc32) + (:darwinppc64 'ffi-darwinppc64) + (:linuxppc64 'ffi-linuxppc64) + (:darwinx8632 'ffi-darwinx8632) + (:linuxx8664 'ffi-linuxx8664) + (:darwinx8664 'ffi-darwinx8664) + (:freebsdx8664 'ffi-freebsdx8664) + (:solarisx8664 'ffi-solarisx8664) + (:win64 'ffi-win64) + (:linuxx8632 'ffi-linuxx8632) + (:win32 'ffi-win32) + (:solarisx8632 'ffi-solarisx8632) + (:freebsdx8632 'ffi-freebsdx8632))))) + + +(defun target-compiler-modules (&optional (target + (backend-target-arch-name + *host-backend*))) + (case target + (:ppc32 (append *ppc-compiler-modules* + *ppc32-compiler-backend-modules* + *ppc-compiler-backend-modules*)) + (:ppc64 (append *ppc-compiler-modules* + *ppc64-compiler-backend-modules* + *ppc-compiler-backend-modules*)) + (:x8632 (append *x86-compiler-modules* + *x8632-compiler-backend-modules* + *x86-compiler-backend-modules*)) + (:x8664 (append *x86-compiler-modules* + *x8664-compiler-backend-modules* + *x86-compiler-backend-modules*)))) + +(defparameter *other-lib-modules* + '(streams pathnames backtrace + apropos + numbers + dumplisp source-files)) + +(defun target-other-lib-modules (&optional (target + (backend-target-arch-name + *host-backend*))) + (append *other-lib-modules* + (case target + ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble)) + ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch))))) + + +(defun target-lib-modules (&optional (backend-name + (backend-name *host-backend*))) + (let* ((backend (or (find-backend backend-name) *host-backend*)) + (arch-name (backend-target-arch-name backend))) + (append (target-env-modules backend-name) (target-other-lib-modules arch-name)))) + + +(defparameter *code-modules* + '(encapsulate + read misc arrays-fry + sequences sort + method-combination + case-error pprint + format time +; eval step + backtrace-lds ccl-export-syms prepare-mcl-environment)) + + + +(defparameter *aux-modules* + '(number-macros number-case-macro + loop + runtime + mcl-compat + arglist + edit-callers + describe + cover + leaks + core-files + dominance + asdf + defsystem + jp-encode + )) + + + + + + + +(defun target-level-1-modules (&optional (target (backend-name *host-backend*))) + (append *level-1-modules* + (case target + ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64) + '(ppc-error-signal ppc-trap-support + ppc-threads-utils ppc-callback-support)) + ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 + :darwinx8632 :win64 :linuxx8632 :win32 :solarisx8632 + :freebsdx8632) + '(x86-error-signal x86-trap-support + x86-threads-utils x86-callback-support))))) + + +;;; Needed to cross-dump an image + + +(unless (fboundp 'xload-level-0) + (%fhave 'xload-level-0 + #'(lambda (&rest rest) + (in-development-mode + (require-modules (target-xload-modules))) + (apply 'xload-level-0 rest)))) + +(defun find-module (module &optional (target (backend-name *host-backend*)) &aux data fasl sources) + (if (setq data (assoc module *ccl-system*)) + (let* ((backend (or (find-backend target) *host-backend*))) + (setq fasl (cadr data) sources (caddr data)) + (setq fasl (merge-pathnames (backend-target-fasl-pathname + backend) fasl)) + (values fasl (if (listp sources) sources (list sources)))) + (error "Module ~S not defined" module))) + +;compile if needed. +(defun target-compile-modules (modules target force-compile) + (if (not (listp modules)) (setq modules (list modules))) + (in-development-mode + (dolist (module modules t) + (multiple-value-bind (fasl sources) (find-module module target) + (if (needs-compile-p fasl sources force-compile) + (progn + (require'nfcomp) + (compile-file (car sources) + :output-file fasl + :verbose t + :target target))))))) + + +(defun needs-compile-p (fasl sources force-compile) + (if fasl + (if (eq force-compile t) + t + (if (not (probe-file fasl)) + t + (let ((fasldate (file-write-date fasl))) + (if (if (integerp force-compile) (> force-compile fasldate)) + t + (dolist (source sources nil) + (if (> (file-write-date source) fasldate) + (return t))))))))) + + + +;;;compile if needed, load if recompiled. + +(defun update-modules (modules &optional force-compile) + (if (not (listp modules)) (setq modules (list modules))) + (in-development-mode + (dolist (module modules t) + (multiple-value-bind (fasl sources) (find-module module) + (if (needs-compile-p fasl sources force-compile) + (progn + (require'nfcomp) + (let* ((*warn-if-redefine* nil)) + (compile-file (car sources) :output-file fasl :verbose t :load t)) + (provide module))))))) + +(defun compile-modules (modules &optional force-compile) + (target-compile-modules modules (backend-name *host-backend*) force-compile) +) + +(defun compile-ccl (&optional force-compile) + (with-compilation-unit () + (update-modules *sysdef-modules* force-compile) + (update-modules 'nxenv force-compile) + (update-modules *compiler-modules* force-compile) + (update-modules (target-compiler-modules) force-compile) + (update-modules (target-xdev-modules) force-compile) + (update-modules (target-xload-modules) force-compile) + (let* ((env-modules (target-env-modules)) + (other-lib (target-other-lib-modules))) + (require-modules env-modules) + (update-modules env-modules force-compile) + (compile-modules (target-level-1-modules) force-compile) + (update-modules other-lib force-compile) + (require-modules other-lib) + (require-update-modules *code-modules* force-compile)) + (compile-modules *aux-modules* force-compile))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun require-env (&optional force-load) + (require-modules (target-env-modules) + force-load)) + +(defun compile-level-1 (&optional force-compile) + (require-env) + (compile-modules (target-level-1-modules (backend-name *host-backend*)) + force-compile)) + + + + + +(defun compile-lib (&optional force-compile) + (compile-modules (target-lib-modules) + force-compile)) + +(defun compile-code (&optional force-compile) + (compile-modules *code-modules* force-compile)) + + +;Compile but don't load + +(defun xcompile-ccl (&optional force) + (with-compilation-unit () + (compile-modules *sysdef-modules* force) + (compile-modules 'nxenv force) + (compile-modules *compiler-modules* force) + (compile-modules (target-compiler-modules) force) + (compile-modules (target-xdev-modules) force) + (compile-modules (target-xload-modules) force) + (compile-modules (target-env-modules) force) + (compile-modules (target-level-1-modules) force) + (compile-modules (target-other-lib-modules) force) + (compile-modules *code-modules* force) + (compile-modules *aux-modules* force))) + +(defun require-update-modules (modules &optional force-compile) + (if (not (listp modules)) (setq modules (list modules))) + (in-development-mode + (dolist (module modules) + (require-modules module) + (update-modules module force-compile)))) + + +(defun target-xcompile-ccl (target &optional force) + (require-update-modules *sysdef-modules* force) ;in the host + (let* ((backend (or (find-backend target) *target-backend*)) + (arch (backend-target-arch-name backend)) + (*defstruct-share-accessor-functions* nil)) + (target-compile-modules 'nxenv target force) + (target-compile-modules *compiler-modules* target force) + (target-compile-modules (target-compiler-modules arch) target force) + (target-compile-modules (target-level-1-modules target) target force) + (target-compile-modules (target-lib-modules target) target force) + (target-compile-modules *sysdef-modules* target force) + (target-compile-modules *aux-modules* target force) + (target-compile-modules *code-modules* target force) + (target-compile-modules (target-xdev-modules arch) target force))) + +(defun cross-compile-ccl (target &optional force) + (with-cross-compilation-target (target) + (let* ((*target-backend* (find-backend target))) + (target-xcompile-ccl target force)))) + + +(defun require-module (module force-load) + (multiple-value-bind (fasl source) (find-module module) + (setq source (car source)) + (if (if fasl (probe-file fasl)) + (if force-load + (progn + (load fasl) + (provide module)) + (require module fasl)) + (if (probe-file source) + (progn + (if fasl (format t "~&Can't find ~S so requiring ~S instead" + fasl source)) + (if force-load + (progn + (load source) + (provide module)) + (require module source))) + (error "Can't find ~S or ~S" fasl source))))) + +(defun require-modules (modules &optional force-load) + (if (not (listp modules)) (setq modules (list modules))) + (let ((*package* (find-package :ccl))) + (dolist (m modules t) + (require-module m force-load)))) + + +(defun target-xcompile-level-1 (target &optional force) + (target-compile-modules (target-level-1-modules target) target force)) + +(defun standard-boot-image-name (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "ppc-boot.image") + (:linuxppc32 "ppc-boot") + (:darwinppc64 "ppc-boot64.image") + (:linuxppc64 "ppc-boot64") + (:darwinx8632 "x86-boot32.image") + (:linuxx8664 "x86-boot64") + (:freebsdx8664 "fx86-boot64") + (:darwinx8664 "x86-boot64.image") + (:solarisx8664 "sx86-boot64") + (:win64 "wx86-boot64.image") + (:linuxx8632 "x86-boot32") + (:win32 "wx86-boot32.image") + (:solarisx8632 "sx86-boot32") + (:freebsdx8632 "fx86-boot32"))) + +(defun standard-kernel-name (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "dppccl") + (:linuxppc32 "ppccl") + (:darwinppc64 "dppccl64") + (:darwinx8632 "dx86cl") + (:linuxppc64 "ppccl64") + (:linuxx8664 "lx86cl64") + (:freebsdx8664 "fx86cl64") + (:darwinx8664 "dx86cl64") + (:solarisx8664 "sx86cl64") + (:win64 "wx86cl64.exe") + (:linuxx8632 "lx86cl") + (:win32 "wx86cl.exe") + (:solarisx8632 "sx86cl") + (:freebsdx8632 "fx86cl"))) + +(defun standard-image-name (&optional (target (backend-name *host-backend*))) + (concatenate 'string (pathname-name (standard-kernel-name target)) ".image")) + +(defun kernel-build-directory (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "darwinppc") + (:linuxppc32 "linuxppc") + (:darwinppc64 "darwinppc64") + (:linuxppc64 "linuxppc64") + (:darwinx8632 "darwinx8632") + (:linuxx8664 "linuxx8664") + (:freebsdx8664 "freebsdx8664") + (:darwinx8664 "darwinx8664") + (:solarisx8664 "solarisx64") + (:win64 "win64") + (:linuxx8632 "linuxx8632") + (:win32 "win32") + (:solarisx8632 "solarisx86") + (:freebsdx8632 "freebsdx8632"))) + +;;; If we distribute (e.g.) 32- and 64-bit versions for the same +;;; machine and OS in the same svn directory, return the name of the +;;; peer backend, or NIL. For example., the peer of :linuxppc64 is +;;; :linuxppc32. Note that this may change over time. +;;; Return NIL if the concept doesn't apply. +(defun peer-platform (&optional (target (backend-name *host-backend*))) + (let* ((pairs '((:darwinppc32 . :darwinppc64) + (:linuxppc32 . :linuxppc64) + (:darwinx8632 . :darwinx8664) + (:linuxx8632 . :linuxx8664) + (:win32 . :win64) + (:solarisx8632 . :solarisx8664) + (:freebsdx8632 . :freebsdx8664)))) + (or (cdr (assoc target pairs)) + (car (rassoc target pairs))))) + +(defun make-program (&optional (target (backend-name *host-backend*))) + ;; The Solaris "make" program is too clever to understand -C, so + ;; use GNU make (installed as "gmake"). + (case target + ((:solarisx8664 :solarisx8632) "gmake") + (t "make"))) + + +(defun describe-external-process-failure (proc reminder) + "If it appears that the external-process PROC failed in some way, +try to return a string that describes that failure. If it seems +to have succeeded or if we can't tell why it failed, return NIL. +This is mostly intended to describe process-creation/fork/exec failures, +not runtime errors reported by a successfully created process." + (multiple-value-bind (status exit-code) + (external-process-status proc) + (let* ((procname (car (external-process-args proc))) + (string + (case status + (:error + (%strerror exit-code)) + #-windows-target + (:exited + (when(= exit-code #$EX_OSERR) + "generic OS error in fork/exec"))))) + (when string + (format nil "Error executing ~a: ~a~&~a" procname string reminder))))) + +(defparameter *known-optional-features* '(:count-gf-calls :monitor-futex-wait :unique-dcode)) +(defvar *build-time-optional-features* nil) +(defvar *ccl-save-source-locations* :no-text) + +(defun rebuild-ccl (&key update full clean kernel force (reload t) exit + reload-arguments verbose optional-features + (save-source-locations *ccl-save-source-locations*) + (allow-constant-redefinition nil allow-constant-redefinition-p)) + (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features)) + (*features* (append *build-time-optional-features* *features*)) + (*save-source-locations* save-source-locations)) + (when *build-time-optional-features* + (setq full t)) + (when full + (setq clean t kernel t reload t)) + + (when update + (multiple-value-bind (changed conflicts new-binaries) + (update-ccl :verbose (not (eq update :quiet))) + (declare (ignore changed conflicts)) + (when new-binaries + (format t "~&There are new bootstrapping binaries. Please restart +the lisp and run REBUILD-CCL again.") + (return-from rebuild-ccl nil)))) + (when (or clean force) + ;; for better bug reports... + (format t "~&Rebuilding ~a using ~a" + (lisp-implementation-type) + (lisp-implementation-version)) + (unless allow-constant-redefinition-p + (when (or force clean update) + (setq allow-constant-redefinition t)))) + (let* ((cd (current-directory)) + (*cerror-on-constant-redefinition* (not allow-constant-redefinition ))) + (unwind-protect + (progn + (setf (current-directory) "ccl:") + (when clean + (dolist (f (directory + (merge-pathnames + (make-pathname :name :wild + :type (pathname-type *.fasl-pathname*)) + "ccl:**;"))) + (delete-file f))) + (when kernel + (when (or clean force) + ;; Do a "make -k clean". + (run-program "make" + (list "-k" + "-C" + (format nil "lisp-kernel/~a" + (kernel-build-directory)) + "clean"))) + (format t "~&;Building lisp-kernel ...") + (with-output-to-string (s) + (let* ((proc (run-program (make-program) + (list "-k" "-C" + (format nil "lisp-kernel/~a" + (kernel-build-directory)) + "-j" + + (format nil "~d" (1+ (cpu-count)))) + :output s + :error :output))) + (multiple-value-bind (status exit-code) + (external-process-status proc) + (if (and (eq :exited status) (zerop exit-code)) + (progn + (format t "~&;Kernel built successfully.") + (when verbose + (format t "~&;kernel build output:~%~a" + (get-output-stream-string s))) + (sleep 1)) + (error "Error(s) during kernel compilation.~%~a" + (or + (describe-external-process-failure + proc + "Developer tools may not be installed correctly.") + (get-output-stream-string s)))))))) + (compile-ccl (not (null force))) + (if force (xload-level-0 :force) (xload-level-0)) + (when reload + (with-input-from-string (cmd (format nil + "(save-application ~s)" + (standard-image-name))) + (with-output-to-string (output) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program + (format nil "./~a" (standard-kernel-name)) + (list* "--image-name" (standard-boot-image-name) + "--batch" + reload-arguments) + :input cmd + :output output + :error output)) + (if (and (eq status :exited) + (eql exit-code 0)) + (progn + (format t "~&;Wrote heap image: ~s" + (truename (format nil "ccl:~a" + (standard-image-name)))) + (when verbose + (format t "~&;Reload heap image output:~%~a" + (get-output-stream-string output)))) + (error "Errors (~s ~s) reloading boot image:~&~a" + status exit-code + (get-output-stream-string output))))))) + (when exit + (quit))) + (setf (current-directory) cd))))) + + +(defun create-interfaces (dirname &key target populate-arg) + (let* ((backend (if target (find-backend target) *target-backend*)) + (*default-pathname-defaults* nil) + (ftd (backend-target-foreign-type-data backend)) + (d (use-interface-dir dirname ftd)) + (populate (merge-pathnames "C/populate.sh" + (merge-pathnames + (interface-dir-subdir d) + (ftd-interface-db-directory ftd)))) + (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate)))) + (args (list "-c" + (format nil "cd ~a && /bin/sh ~a ~@[~a~]" + (native-translated-namestring cdir) + (native-translated-namestring populate) + populate-arg)))) + (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate) + (force-output t) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "/bin/sh" args :output t)) + (if (and (eq status :exited) + (eql exit-code 0)) + (let* ((f 'parse-standard-ffi-files)) + (require "PARSE-FFI") + (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname) + (funcall f dirname target) + (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]") + (funcall f dirname target)))))) + +(defun update-ccl (&key (verbose t)) + (let* ((changed ()) + (new-binaries ()) + (conflicts ())) + (with-output-to-string (out) + (with-preserved-working-directory ("ccl:") + (when verbose (format t "~&;Running 'svn update'.")) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "svn" '("update" "--non-interactive") :output out :error t)) + (when verbose (format t "~&;'svn update' complete.")) + (if (not (and (eq status :exited) + (eql exit-code 0))) + (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code) + (let* ((sout (get-output-stream-string out)) + (added ()) + (deleted ()) + (updated ()) + (merged ()) + (binaries (list (standard-kernel-name) (standard-image-name ))) + (peer (peer-platform))) + (when peer + (push (standard-kernel-name peer) binaries) + (push (standard-image-name peer) binaries)) + (flet ((svn-revert (string) + (multiple-value-bind (status exit-code) + (external-process-status (run-program "svn" `("revert" ,string))) + (when (and (eq status :exited) (eql exit-code 0)) + (setq conflicts (delete string conflicts :test #'string=)) + (push string updated))))) + (with-input-from-string (in sout) + (do* ((line (read-line in nil nil) (read-line in nil nil))) + ((null line)) + (when (and (> (length line) 2) + (eql #\space (schar line 1))) + (let* ((path (string-trim " " (subseq line 2)))) + (case (schar line 0) + (#\A (push path added)) + (#\D (push path deleted)) + (#\U (push path updated)) + (#\G (push path merged)) + (#\C (push path conflicts))))))) + ;; If the kernel and/or image conflict, use "svn revert" + ;; to replace the working copies with the (just updated) + ;; repository versions. + (setq changed (if (or added deleted updated merged conflicts) t)) + (dolist (f binaries) + (cond ((member f conflicts :test #'string=) + (svn-revert f) + (setq new-binaries t)) + ((or (member f updated :test #'string=) + (member f merged :test #'string=)) + (setq new-binaries t)))) + + ;; If there are any remaining conflicts, offer + ;; to revert them. + (when conflicts + (with-preserved-working-directory () + (cerror "Discard local changes to these files (using 'svn revert')." + "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~}" (length conflicts) conflicts) + (dolist (c (copy-list conflicts)) + (svn-revert c)))) + ;; Report other changes, if verbose. + (when (and verbose + (or added deleted updated merged conflicts)) + (format t "~&;Changes from svn update:") + (flet ((show-changes (herald files) + (when files + (format t "~&; ~a:~{~&; ~a~}" + herald files)))) + (show-changes "Conflicting files" conflicts) + (show-changes "New files/directories" added) + (show-changes "Deleted files/directories" deleted) + (show-changes "Updated files" updated) + (show-changes "Files with local changes, successfully merged" merged))))))))) + (values changed conflicts new-binaries))) + +(defmacro with-preserved-working-directory ((&optional dir) &body body) + (let ((wd (gensym))) + `(let ((,wd (mac-default-directory))) + (unwind-protect + (progn + ,@(when dir `((cwd ,dir))) + ,@body) + (cwd ,wd))))) + +(defun ensure-tests-loaded (&key force update ansi ccl) + (unless (and (find-package "REGRESSION-TEST") (not force)) + (if (probe-file "ccl:tests;ansi-tests;") + (when update + (cwd "ccl:tests;") + (run-program "svn" '("update"))) + (let* ((svn (probe-file "ccl:.svn;entries")) + (repo (and svn (svn-repository))) + (s (make-string-output-stream))) + (when repo + (format t "~&Checking out test suite into ccl:tests;~%") + (cwd "ccl:") + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests") + :output s + :error s)) + (unless (and (eq status :exited) + (eql exit-code 0)) + (error "Failed to check out test suite: ~%~a" (get-output-stream-string s))))))) + (cwd "ccl:tests;ansi-tests;") + (run-program "make" '("-k" "clean")) + (map nil 'delete-file (directory "*.*fsl")) + ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about + ;; it without making the test suite non-portable across platforms... + (handler-bind ((warning (lambda (c) + (when (let ((w (or (and (typep c 'compiler-warning) + (eq (compiler-warning-warning-type c) :program-error) + (car (compiler-warning-args c))) + c))) + (and (typep w 'simple-warning) + (or + (string-equal + (simple-condition-format-control w) + "Clause ~S ignored in ~S form - shadowed by ~S .") + ;; Might as well ignore these as well, they're intentional. + (string-equal + (simple-condition-format-control w) + "Duplicate keyform ~s in ~s statement.")))) + (muffle-warning c))))) + ;; This loads the infrastructure + (load "ccl:tests;ansi-tests;gclload1.lsp") + ;; This loads the actual tests + (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST))) + (progv (list redef-var) (list (if force nil (symbol-value redef-var))) + (when ansi + (load "ccl:tests;ansi-tests;gclload2.lsp")) + ;; And our own tests + (when ccl + (load "ccl:tests;ansi-tests;ccl.lsp"))))))) + +(defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t) + optimization-settings) + (with-preserved-working-directory () + (let* ((*package* (find-package "CL-USER"))) + (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl) + (cwd "ccl:tests;ansi-tests;") + (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST")) + (failed (find-symbol "*FAILED-TESTS*" "REGRESSION-TEST")) + (*print-catch-errors* nil)) + (prog1 + (time (funcall do-tests :verbose verbose :compile t + :catch-errors catch-errors + :optimization-settings (or optimization-settings '((safety 2))))) + ;; Clean up a little + (map nil #'delete-file + (directory (merge-pathnames *.fasl-pathname* "ccl:tests;ansi-tests;temp*")))) + (symbol-value failed))))) Index: /branches/qres/ccl/lib/db-io.lisp =================================================================== --- /branches/qres/ccl/lib/db-io.lisp (revision 13564) +++ /branches/qres/ccl/lib/db-io.lisp (revision 13564) @@ -0,0 +1,1898 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; The "CDB" files used here are similar (but not identical) to those +;;; used in the Unix CDB package . The primary +;;; known & intentional differences are: +;;; +;;; a) key values, record positions, and other 32-bit metadata in the +;;; files are stored in native (vice little-endian) order. +;;; b) hash values are always non-negative fixnums. +;;; +;;; I haven't thought of a compelling reason to attempt full compatibility. +;;; +;;; The basic idea is that the database files are created in a batch +;;; process and are henceforth read-only (e.g., lookup is optimized by +;;; making insertion & deletion impractical or impossible.) That's +;;; just about exactly what we want here. +;;; +;;; Those of you keeping score may notice that this is the third or forth +;;; database format that Clozure CL has used for its interface database. +;;; As always, this will hopefully be the last format change; the fact +;;; that this code is self-contained (doesn't depend on any Unix database +;;; library) should make it easier to port to other platforms. + +(in-package "CCL") + +(defparameter *interface-abi-version* 2) +(defparameter *min-interface-abi-version* 1) + +(defconstant cdb-hash-mask (1- (ash 1 29))) + +(defun cdb-hash (buf len) + (declare (fixnum len)) + (let* ((h 5381)) + (declare (fixnum h)) + (dotimes (i len (logand h cdb-hash-mask)) + (setq h (+ h (the fixnum (logand cdb-hash-mask (ash h 5))))) + (setq h (logxor (the (unsigned-byte 8) (%get-unsigned-byte buf i)) h))))) + +(defconstant cdbm-hplist 1000) + +(defmacro hp-h (v n) + `(aref ,v (* ,n 2))) + +(defmacro hp-p (v n) + `(aref ,v (1+ (* ,n 2)))) + +(defstruct cdbm-hplist + (hp (make-array (* 2 cdbm-hplist) + :element-type '(unsigned-byte 32) + :initial-element 0)) + (next nil) + (num 0)) + + + + + +#+openmcl +(progn + ;;; Given a (possibly logical) PATHNAME, return a corresponding namestring + ;;; suitable for passing to an OS file-open call. + (defun cdb-native-namestring (pathname) + (native-translated-namestring pathname)) + + ;;; Open the file specified by PATHNAME for output and return a + ;;; small integer "file id" (fid). + (defun fid-open-output (pathname) + (let ((dir (make-pathname :type nil :name nil :defaults pathname))) + (unless (probe-file dir) + (error "The directory ~S does not exist, cannot open/create ~S" + dir pathname))) + (let* ((id (fd-open (cdb-native-namestring pathname) + (logior #$O_WRONLY #$O_CREAT #$O_TRUNC)))) + (if (< id 0) + (%errno-disp id pathname) + id))) + + ;;; Open the file specified by PATHNAME for input and return a + ;;; file id. + #-windows-target + (defun fid-open-input (pathname) + (let* ((id (fd-open (cdb-native-namestring pathname) #$O_RDONLY))) + (if (< id 0) + (%errno-disp id pathname) + id))) + ;; On Windows, open() can't open the same file twice, which breaks + ;; bootstrapping. Use CreateFile instead, and tell it to share. + #+windows-target + (defun fid-open-input (pathname) + (with-filename-cstrs ((name (cdb-native-namestring pathname))) + (let* ((handle (#_CreateFileW + name + #$GENERIC_READ + #$FILE_SHARE_READ + (%null-ptr) + #$OPEN_EXISTING + #$FILE_ATTRIBUTE_NORMAL + (%null-ptr)))) + (if (eql handle *windows-invalid-handle*) + (error "Error opening CDB database ~S" pathname) + (%ptr-to-int handle))))) + + ;;; Read N octets from FID into BUF. Return #of octets read or error. + (defun fid-read (fid buf n) + (let* ((count (fd-read fid buf n))) + (if (< count 0) + (%errno-disp count "reading from file") + count))) + + ;;; Write N octets to FID from BUF. Return #of octets written or error. + (defun fid-write (fid buf n) + (let* ((count (fd-write fid buf n))) + (if (< count 0) + (%errno-disp count "writing to file") + count))) + + ;;; Return the absolute (octet) position of FID. + (defun fid-pos (fid) + (fd-tell fid)) + + ;;; Return the current size of the file referenced by FID, in + ;;; octets. + (defun fid-size (fid) + (fd-size fid)) + + ;;; Seek to specified position (relative to file start.) + (defun fid-seek (fid pos) + (fd-lseek fid pos #$SEEK_SET)) + + ;;; Guess what this does ? + (defun fid-close (fid) + (fd-close fid)) + + ;;; Allocate a block of size N bytes (via malloc, #_NewPtr, etc.) + (defun cdb-alloc (n) + (malloc n)) + + ;;; Free a block allocated by cdb-alloc. + (defun cdb-free (block) + (free block)) + ) + +;;; I suppose that if we wanted to store these things in little-endian +;;; order this'd be the place to swap bytes ... +(defun fid-write-u32 (fid val) + (%stack-block ((valptr 4)) + (setf (%get-unsigned-long valptr) val) + (fid-write fid valptr 4) + val)) + +(defun fid-read-u32 (fid) + (%stack-block ((valptr 4)) + (fid-read fid valptr 4) + (%get-unsigned-long valptr))) + + + +;;; Write N elements of a vector of type (UNSIGNED-BYTE 32) to file-id +;;; FID, starting at element START. The vector should be a simple +;;; (non-displaced) array. +(defun fid-write-u32-vector (fid v n start) + (let* ((remaining-octets (* n 4)) + (start-octet (* start 4)) + (bufsize 2048)) + (%stack-block ((buf bufsize)) + (do* () + ((zerop remaining-octets)) + (let* ((chunksize (min remaining-octets bufsize))) + (%copy-ivector-to-ptr v start-octet buf 0 chunksize) + (fid-write fid buf chunksize) + (incf start-octet chunksize) + (decf remaining-octets chunksize)))))) + +(defstruct cdbx + fid ;a small integer denoting a file + pathname) ;that file's pathname + +;;; A CDBM is used to create a database. +(defstruct (cdbm (:include cdbx)) + (final (make-array (* 256 2) + :element-type '(unsigned-byte 32) + :initial-element 0)) + (count (make-array 256 :element-type '(unsigned-byte 32) :initial-element 0)) + (start (make-array 256 :element-type '(unsigned-byte 32) :initial-element 0)) + (head nil) + (split nil) + (hash nil) + (numentries 0) + ) + +(defun cdbm-open (pathname) + (let* ((fid (fid-open-output pathname)) + (cdbm (make-cdbm :fid fid :pathname pathname)) + (final (cdbm-final cdbm))) + ;;; Write the (empty) final table to the start of the file. Twice. + (fid-write-u32-vector fid final (length final) 0) + (fid-write-u32-vector fid final (length final) 0) + cdbm)) + +;;; Note a newly-added pair's file position and hash code. +(defun %cdbm-add-hash-pos (cdbm hash pos) + (let* ((head (cdbm-head cdbm))) + (when (or (null head) + (>= (cdbm-hplist-num head) cdbm-hplist)) + (setq head (make-cdbm-hplist)) + (setf (cdbm-hplist-next head) (cdbm-head cdbm) + (cdbm-head cdbm) head)) + (let* ((num (cdbm-hplist-num head)) + (hp (cdbm-hplist-hp head))) + (setf (hp-h hp num) hash + (hp-p hp num) pos)) + (incf (cdbm-hplist-num head)) + (incf (cdbm-numentries cdbm)))) + +(defun cdbm-put (cdbm key data) + (let* ((fid (cdbm-fid cdbm)) + (pos (fid-pos fid)) + (keylen (pref key :cdb-datum.size)) + (keyptr (pref key :cdb-datum.data)) + (datalen (pref data :cdb-datum.size)) + (hash (cdb-hash keyptr keylen))) + (fid-write-u32 fid keylen) + (fid-write-u32 fid datalen) + (fid-write fid keyptr keylen) + (fid-write fid (pref data :cdb-datum.data) datalen) + (%cdbm-add-hash-pos cdbm hash pos))) + +(defun %cdbm-split (cdbm) + (let* ((count (cdbm-count cdbm)) + (start (cdbm-start cdbm)) + (numentries (cdbm-numentries cdbm))) + (dotimes (i 256) (setf (aref count i) 0)) + (do* ((x (cdbm-head cdbm) (cdbm-hplist-next x))) + ((null x)) + (do* ((i (cdbm-hplist-num x)) + (hp (cdbm-hplist-hp x))) + ((zerop i)) + (decf i) + (incf (aref count (logand 255 (hp-h hp i)))))) + (let* ((memsize 1)) + (dotimes (i 256) + (let* ((u (* 2 (aref count i)))) + (if (> u memsize) + (setq memsize u)))) + (incf memsize numentries) + (let* ((split (make-array (the fixnum (* 2 memsize)) + :element-type '(unsigned-byte 32)))) + (setf (cdbm-split cdbm) split) + (setf (cdbm-hash cdbm) + (make-array (- (* 2 memsize) + (* 2 numentries)) + :element-type '(unsigned-byte 32) + :displaced-to split + :displaced-index-offset (* 2 numentries))) + (let* ((u 0)) + (dotimes (i 256) + (incf u (aref count i)) + (setf (aref start i) u))) + + (do* ((x (cdbm-head cdbm) (cdbm-hplist-next x))) + ((null x)) + (do* ((i (cdbm-hplist-num x)) + (hp (cdbm-hplist-hp x))) + ((zerop i)) + (decf i) + (let* ((idx (decf (aref start (logand 255 (hp-h hp i)))))) + (setf (hp-h split idx) (hp-h hp i) + (hp-p split idx) (hp-p hp i))))))))) + +(defun %cdbm-throw (cdbm pos b) + (let* ((count (aref (cdbm-count cdbm) b)) + (len (* 2 count)) + (hash (cdbm-hash cdbm)) + (split (cdbm-split cdbm))) + (let* ((final (cdbm-final cdbm))) + (setf (aref final (* 2 b)) pos + (aref final (1+ (* 2 b))) len)) + (unless (zerop len) + (dotimes (j len) + (setf (hp-h hash j) 0 + (hp-p hash j) 0)) + (let* ((hpi (aref (cdbm-start cdbm) b))) + (dotimes (j count) + (let* ((where (mod (ash (hp-h split hpi) -8) len))) + (do* () + ((zerop (hp-p hash where))) + (incf where) + (if (= where len) + (setq where 0))) + (setf (hp-p hash where) (hp-p split hpi) + (hp-h hash where) (hp-h split hpi) + hpi (1+ hpi)))))) + len)) + +;;; Write data structures to the file, then close the file. +(defun cdbm-close (cdbm) + (when (cdbm-fid cdbm) + (%cdbm-split cdbm) + (let* ((hash (cdbm-hash cdbm)) + (fid (cdbm-fid cdbm)) + (pos (fid-pos fid))) + (dotimes (i 256) + (let* ((len (%cdbm-throw cdbm pos i))) + (dotimes (u len) + (fid-write-u32 fid (hp-h hash u)) + (fid-write-u32 fid (hp-p hash u)) + (incf pos 8)))) + (write-cdbm-trailer cdbm) + (fid-seek fid (* 256 2 4)) ; skip the empty "final" table, write the new one + (let* ((final (cdbm-final cdbm))) + (fid-write-u32-vector fid final (length final) 0)) + (fid-close fid) + (setf (cdbm-fid cdbm) nil)))) + +(defun write-cdbm-trailer (cdbm) + (let* ((string (format nil "~s ~s ~d " "OpenMCL Interface File" (backend-name *target-backend*) *interface-abi-version*))) + (%stack-block ((buf 512)) + (%cstr-pointer string buf) + (fid-write (cdbm-fid cdbm) buf 512)))) + + +;;; A CDB is used to access a database. +(defstruct (cdb (:include cdbx)) + (lock (make-lock))) + + +;;; Do the bytes on disk match KEY ? +(defun %cdb-match (fid key keylen) + (%stack-block ((buf keylen)) + (fid-read fid buf keylen) + (dotimes (i keylen t) + (unless (= (the fixnum (%get-unsigned-byte key i)) + (the fixnum (%get-unsigned-byte buf i))) + (return))))) + +;;; Seek to file position of data associated with key. Return length +;;; of data (or NIL if no matching key.) +(defun %cdb-seek (fid key keylen) + (let* ((hash (cdb-hash key keylen))) + (fid-seek fid (+ (* 256 2 4) (* 8 (logand hash 255)))) + (let* ((pos (fid-read-u32 fid)) + (lenhash (fid-read-u32 fid))) + (unless (zerop lenhash) + (let* ((h2 (mod (ash hash -8) lenhash))) + (dotimes (i lenhash) + (fid-seek fid (+ pos (* 8 h2))) + (let* ((hashed-key (fid-read-u32 fid)) + (poskd (fid-read-u32 fid))) + (when (zerop poskd) + (return-from %cdb-seek nil)) + (when (= hashed-key hash) + (fid-seek fid poskd) + (let* ((hashed-key-len (fid-read-u32 fid)) + (data-len (fid-read-u32 fid))) + (when (= hashed-key-len keylen) + (if (%cdb-match fid key keylen) + (return-from %cdb-seek data-len))))) + (if (= (incf h2) lenhash) + (setq h2 0))))))))) + +;;; This should only be called with the cdb-lock of the containing cdb +;;; held. +(defun %cdb-get (fid key value) + (setf (pref value :cdb-datum.size) 0 + (pref value :cdb-datum.data) (%null-ptr)) + (when fid + (let* ((datalen (%cdb-seek fid + (pref key :cdb-datum.data) + (pref key :cdb-datum.size)))) + (when datalen + (let* ((buf (cdb-alloc datalen))) + (fid-read fid buf datalen) + (setf (pref value :cdb-datum.size) datalen + (pref value :cdb-datum.data) buf))) + value))) + +(defun cdb-get (cdb key value) + (with-lock-grabbed ((cdb-lock cdb)) + (%cdb-get (cdb-fid cdb) key value))) + +(defun cdb-subdirectory-path (&optional (ftd *target-ftd*)) + (let* ((ftd-name (ftd-interface-db-directory ftd)) + (ftd-dir (pathname-directory ftd-name))) + (assert (equalp (pathname-host ftd-name) "ccl")) + (assert (eq (car ftd-dir) :absolute)) + (cdr ftd-dir))) + +(defvar *interfaces-root* "ccl:") + +(defun open-interface-db-pathname (name d) + (let* ((db-path (make-pathname :host (pathname-host *interfaces-root*) + :directory (append + (or (pathname-directory *interfaces-root*) + '(:absolute)) + (cdb-subdirectory-path *target-ftd*)))) + (path (merge-pathnames name + (merge-pathnames (interface-dir-subdir d) db-path)))) + (cdb-open path))) + +(defun cdb-open (pathname) + (if (probe-file pathname) + (let* ((cdb (make-cdb :fid (fid-open-input (cdb-native-namestring pathname)) + :pathname (namestring pathname)))) + (cdb-check-trailer cdb)) + (progn + (if (probe-file (make-pathname :name nil :type nil :defaults pathname)) + (warn "Interface file ~s does not exist." pathname) + (warn "Interface file ~s does not exist, and the containing directory does not exist.~%This may mean that that the \"ccl:\" logical-pathname host has not been properly initialized. " (translate-logical-pathname pathname))) + (make-cdb :fid nil :pathname (namestring pathname))))) + +(defun cdb-check-trailer (cdb) + (flet ((error-with-cdb (string &rest args) + (error "Error in interface file at ~s: ~a" + (cdb-pathname cdb) (apply #'format nil string args)))) + (let* ((fid (cdb-fid cdb))) + (fid-seek fid (- (fid-size fid) 512)) + (%stack-block ((buf 512)) + (fid-read fid buf 512) + (let* ((string (make-string 512))) + (dotimes (i 512) + (setf (%scharcode string i) (%get-unsigned-byte buf i))) + (with-input-from-string (s string) + (let* ((sig (ignore-errors (read s))) + (target (ignore-errors (read s))) + (version (ignore-errors (read s)))) + (if (equal sig "OpenMCL Interface File") + (if (eq target (backend-name *target-backend*)) + (if (and version + (>= version *min-interface-abi-version*) + (<= version *interface-abi-version*)) + cdb + (error-with-cdb "Wrong interface ABI version. Expected ~d, got ~d" *interface-abi-version* version)) + cdb #+nil(error-with-cdb "Wrong target.")) + (error-with-cdb "Missing interface file signature. Obsolete version?"))))))))) + + + +(defun cdb-close (cdb) + (let* ((fid (cdb-fid cdb))) + (setf (cdb-fid cdb) nil) + (when fid + (fid-close fid)) + t)) + +(defmethod print-object ((cdb cdbx) stream) + (print-unreadable-object (cdb stream :type t :identity t) + (let* ((fid (cdb-fid cdb))) + (format stream "~s [~a]" (cdb-pathname cdb) (or fid "closed"))))) + + +(defun cdb-enumerate-keys (cdb &optional (predicate #'true)) + "Returns a list of all keys (strings) in the open .cdb file CDB which +satisfy the optional predicate PREDICATE." + (with-lock-grabbed ((cdb-lock cdb)) + (let* ((keys ()) + (fid (cdb-fid cdb))) + (dotimes (i 256 keys) + (fid-seek fid (+ (* 256 2 4) (* 8 i))) + (let* ((pos (fid-read-u32 fid)) + (n (fid-read-u32 fid))) + (dotimes (j n) + (fid-seek fid (+ pos (* 8 j) 4)) + (let* ((posk (fid-read-u32 fid))) + (unless (zerop posk) + (fid-seek fid posk) + (let* ((hashed-key-len (fid-read-u32 fid))) + ;; Skip hashed data length + (fid-read-u32 fid) + (let* ((string (make-string hashed-key-len))) + (%stack-block ((buf hashed-key-len)) + (fid-read fid buf hashed-key-len) + (dotimes (k hashed-key-len) + (setf (schar string k) + (code-char (%get-unsigned-byte buf k))))) + (when (funcall predicate string) + (push (copy-seq string) keys)))))))))))) + ; + + + +(defstruct ffi-type + (ordinal nil) + (defined nil) + (string) + (name) ; a keyword, uppercased or NIL +) + +(defmethod print-object ((x ffi-type) out) + (print-unreadable-object (x out :type t :identity t) + (format out "~a" (ffi-type-string x)))) + +(defvar *ffi-prefix* "") + +(defstruct (ffi-mem-block (:include ffi-type)) + fields + (anon-global-id ) + (alt-alignment-bits nil)) + +(defstruct (ffi-union (:include ffi-mem-block) + (:constructor + make-ffi-union (&key + string name + &aux + (anon-global-id + (unless name + (concatenate 'string + *ffi-prefix* + "-" string))))))) + + +(defstruct (ffi-transparent-union (:include ffi-mem-block) + (:constructor + make-ffi-transparent-union (&key + string name + &aux + (anon-global-id + (unless name + (concatenate 'string + *ffi-prefix* + "-" string))))))) +(defstruct (ffi-struct (:include ffi-mem-block) + (:constructor + make-ffi-struct (&key + string name + &aux + (anon-global-id + (unless name + (concatenate 'string + *ffi-prefix* + "-" string))))))) + +(defstruct (ffi-typedef (:include ffi-type)) + (type)) + +(defstruct (ffi-objc-class (:include ffi-type)) + super-foreign-name + protocol-names + own-ivars + ) + +(defstruct (ffi-objc-method) + class-name + arglist + result-type + flags) + +(defstruct (ffi-objc-message (:include ffi-type)) + methods) + + +(defun ffi-struct-reference (s) + (or (ffi-struct-name s) (ffi-struct-anon-global-id s))) + +(defun ffi-union-reference (u) + (or (ffi-union-name u) (ffi-union-anon-global-id u))) + +(defun ffi-transparent-union-reference (u) + (or (ffi-transparent-union-name u) (ffi-transparent-union-anon-global-id u))) + +(defstruct (ffi-function (:include ffi-type)) + arglist + return-value) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant db-string-constant 0) +(defconstant db-read-string-constant 1) +(defconstant db-s32-constant 2) +(defconstant db-u32-constant 3) +(defconstant db-float-constant 4) +(defconstant db-double-constant 5) +(defconstant db-char-constant 6) +(defconstant db-pointer-constant 7) +) + +(defparameter *arg-spec-encoding* + '((#\Space . :void) + (#\a . :address) + (#\F . :signed-fullword) + (#\f . :unsigned-fullword) + (#\H . :signed-halfword) + (#\h . :unsigned-halfword) + (#\B . :signed-byte) + (#\b . :unsigned-byte) + (#\s . :single-float) + (#\d . :double-float) + (#\L . :signed-doubleword) + (#\l . :unsigned-doubleword) + (#\r . :record))) + + + +(defun decode-arguments (string) + (let* ((result nil)) + (collect ((args)) + (do* ((i 0 (1+ i))) + ((= i (length string)) (values (args) result)) + (declare (fixnum i)) + (let* ((ch (schar string i)) + (val (if (or (eql ch #\r) (eql ch #\u) (eql ch #\t)) + (let* ((namelen (char-code (schar string (incf i)))) + (name (make-string namelen))) + (dotimes (k namelen) + (setf (schar name k) + (schar string (incf i)))) + (setq name (escape-foreign-name name)) + (if (eql ch #\r) + `(:struct ,name) + (if (eql ch #\u) + `(:union ,name) + (if (eql ch #\U) + `(:transparent-union ,name) + name)))) + (cdr (assoc ch *arg-spec-encoding*))))) + (if result + (args val) + (setq result val))))))) + + +;;; encoded external function looks like: +;;; byte min-args +;;; byte name-length +;;; name-length bytes of name +;;; result+arg specs + +(defun extract-db-function (datum) + (let* ((val nil) + (dsize (pref datum :cdb-datum.size))) + (with-macptrs ((dptr)) + (%setf-macptr dptr (pref datum :cdb-datum.data)) + (unless (%null-ptr-p dptr) + (let* ((min-args (%get-byte dptr)) + (name-len (%get-byte dptr 1)) + (external-name (%str-from-ptr (%inc-ptr dptr 2) name-len)) + (encoding-len (- dsize (+ 2 name-len))) + (encoding (make-string encoding-len))) + (declare (dynamic-extent encoding)) + (%str-from-ptr (%inc-ptr dptr (+ 2 name-len)) encoding-len encoding) + (cdb-free (pref datum :cdb-datum.data)) + (multiple-value-bind (args result) + (decode-arguments encoding) + (setq val (make-external-function-definition + :entry-name external-name + :arg-specs args + :result-spec result + :min-args min-args)))))) + val)) + +(defun db-lookup-function (cdb name) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-function value))))) + + + + + +(defun extract-db-constant-value (datum) + (let* ((val nil) + (dsize (pref datum :cdb-datum.size))) + (with-macptrs ((dptr)) + (%setf-macptr dptr (pref datum :cdb-datum.data)) + (unless (%null-ptr-p dptr) + (let* ((class (pref dptr :dbm-constant.class))) + (setq val + (ecase class + ((#.db-string-constant #.db-read-string-constant) + (let* ((str (%str-from-ptr (%inc-ptr dptr 4) (- dsize 4)))) + (if (eql class db-read-string-constant) + (read-from-string str) + str))) + (#.db-s32-constant (pref dptr :dbm-constant.value.s32)) + (#.db-u32-constant (pref dptr :dbm-constant.value.u32)) + (#.db-float-constant (pref dptr :dbm-constant.value.single-float)) + (#.db-double-constant (pref dptr :dbm-constant.value.double-float)) + (#.db-char-constant (code-char (pref dptr :dbm-constant.value.u32))) + (#.db-pointer-constant + (let* ((val (pref dptr :dbm-constant.value.u32))) + #+64-bit-target + (if (logbitp 31 val) + (setq val (logior val (ash #xffffffff 32)))) + (%int-to-ptr val ))))) + (cdb-free (pref datum :cdb-datum.data))))) + val)) + + + +(defun db-lookup-constant (cdb name) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-constant-value value))))) + + + +(defun db-define-string-constant (cdbm name val &optional (class db-string-constant)) + (let* ((dsize (+ 4 (length val)))) + (%stack-block ((valbuf dsize)) + (dotimes (i (length val)) + (setf (%get-unsigned-byte valbuf (the fixnum (+ 4 i))) + (%scharcode val i))) + (setf (%get-long valbuf) class) + (rletZ ((content :cdb-datum) + (key :cdb-datum)) + (setf (pref content :cdb-datum.size) dsize + (pref content :cdb-datum.data) valbuf) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.size) (length (string name)) + (pref key :cdb-datum.data) keyname) + (cdbm-put cdbm key content)))))) + +(defun db-define-constant (cdbm name val) + (typecase val + (string (db-define-string-constant cdbm name val)) + ((or (unsigned-byte 32) + (signed-byte 32) + short-float + double-float + character + macptr) + (rletZ ((constant :dbm-constant) + (content :cdb-datum) + (key :cdb-datum)) + (etypecase val + ((signed-byte 32) + (setf (pref constant :dbm-constant.value.s32) val) + (setf (pref constant :dbm-constant.class) db-s32-constant)) + ((unsigned-byte 32) + (setf (pref constant :dbm-constant.value.u32) val) + (setf (pref constant :dbm-constant.class) db-u32-constant)) + (short-float + (setf (pref constant :dbm-constant.value.single-float) val) + (setf (pref constant :dbm-constant.class) db-float-constant)) + (double-float + (setf (pref constant :dbm-constant.value.double-float) val) + (setf (pref constant :dbm-constant.class) db-double-constant)) + (character + (setf (pref constant :dbm-constant.value.u32) (char-code val)) + (setf (pref constant :dbm-constant.class) db-char-constant)) + (macptr + (setf (pref constant :dbm-constant.value.u32) (logand #xffffffff (%ptr-to-int val))) + (setf (pref constant :dbm-constant.class) db-pointer-constant)) + ) + (setf (pref content :cdb-datum.data) constant + (pref content :cdb-datum.size) (record-length :dbm-constant)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name))) + (cdbm-put cdbm key content)))) + (t (db-define-string-constant cdbm name (format nil "~a" val) db-read-string-constant)))) + + + + +(defmacro with-new-db-file ((var pathname) &body body) + (let* ((db (gensym))) + `(let* (,db) + (unwind-protect + (let* ((,var (setq ,db (cdbm-open ,pathname)))) + ,@body) + (when ,db (cdbm-close ,db)))))) + + + +(defun interface-db-pathname (name d &optional (ftd *target-ftd*)) + (merge-pathnames name + (merge-pathnames (interface-dir-subdir d) + (ftd-interface-db-directory ftd)))) + +(def-ccl-pointers reset-db-files () + (do-interface-dirs (d) + (setf (interface-dir-constants-interface-db-file d) nil + (interface-dir-functions-interface-db-file d) nil + (interface-dir-records-interface-db-file d) nil + (interface-dir-types-interface-db-file d) nil + (interface-dir-vars-interface-db-file d) nil + (interface-dir-objc-classes-interface-db-file d) nil + (interface-dir-objc-methods-interface-db-file d) nil))) + +(defun db-constants (dir) + (or (interface-dir-constants-interface-db-file dir) + (setf (interface-dir-constants-interface-db-file dir) + (open-interface-db-pathname "constants.cdb" dir)))) + +(defun db-objc-classes (dir) + (or (interface-dir-objc-classes-interface-db-file dir) + (setf (interface-dir-objc-classes-interface-db-file dir) + (open-interface-db-pathname "objc-classes.cdb" dir)))) + +(defun db-objc-methods (dir) + (or (interface-dir-objc-methods-interface-db-file dir) + (setf (interface-dir-objc-methods-interface-db-file dir) + (open-interface-db-pathname "objc-methods.cdb" dir)))) + +(defun db-vars (dir) + (or (interface-dir-vars-interface-db-file dir) + (setf (interface-dir-vars-interface-db-file dir) + (open-interface-db-pathname "vars.cdb" dir)))) + +(defun db-types (dir) + (or (interface-dir-types-interface-db-file dir) + (setf (interface-dir-types-interface-db-file dir) + (open-interface-db-pathname "types.cdb" dir)))) + +(defun db-records (dir) + (or (interface-dir-records-interface-db-file dir) + (setf (interface-dir-records-interface-db-file dir) + (open-interface-db-pathname "records.cdb" dir)))) + +(defun db-functions (dir) + (or (interface-dir-functions-interface-db-file dir) + (setf (interface-dir-functions-interface-db-file dir) + (open-interface-db-pathname "functions.cdb" dir)))) + +(defun load-os-constant (sym &optional query) + (let* ((val (do-interface-dirs (d) + (let* ((v (db-lookup-constant (db-constants d) sym))) + (when v (return v)))))) + (if query + (not (null val)) + (if val + (let* ((*record-source-file* nil)) + (%defconstant sym val) + val) + (error "Constant not found: ~s" sym))))) + +(defun %load-var (name &optional query-only) + (let* ((ftd *target-ftd*) + (string (if (getf (ftd-attributes ftd) + :prepend-underscores) + (concatenate 'string "_" (string name)) + (string name))) + (fv (gethash string (fvs)))) + (unless fv + (with-cstrs ((cstring string)) + (let* ((type + (do-interface-dirs (d) + (let* ((vars (db-vars d))) + (when vars + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (setf (pref key :cdb-datum.data) cstring + (pref key :cdb-datum.size) (length string) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get vars key value) + (let* ((vartype (extract-db-type value ftd))) + (when vartype (return vartype))))))))) + (when type + (setq fv (%cons-foreign-variable string type)) + (resolve-foreign-variable fv nil) + (setf (gethash string (fvs)) fv))))) + (if query-only + (not (null fv)) + (or fv (error "Foreign variable ~s not found" string))))) + + +(set-dispatch-macro-character + #\# #\& + (qlfun |#&-reader| (stream char arg) + (declare (ignore char arg)) + (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))) + (multiple-value-bind (sym query source) + (%read-symbol-preserving-case + stream + package) + (unless *read-suppress* + (let* ((fv (%load-var sym query))) + (values (if query + fv + (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv)) + (fv.type fv) + 0 + nil)) + source))))))) + + + + +(defstruct objc-message-info + message-name + methods ; all methods + ambiguous-methods ; partitioned by signature + req-args + flags + protocol-methods + lisp-name + selector) + + + + +(defstruct objc-method-info + message-info + class-name + class-pointer ;canonical, in some sense + arglist + result-type + flags + signature + signature-info + ) + + + +(defmethod print-object ((m objc-method-info) stream) + (print-unreadable-object (m stream :type t :identity t) + (format stream "~c[~a ~a]" + (if (getf (objc-method-info-flags m) :class) + #\+ + #\-) + (let* ((name (objc-method-info-class-name m))) + (if (getf (objc-method-info-flags m) :protocol) + (format nil "<~a>" name) + name)) + (objc-message-info-message-name + (objc-method-info-message-info m))))) + +(defun extract-db-objc-message-info (datum message-name info &optional + (ftd *target-ftd*)) + (with-macptrs ((buf)) + (%setf-macptr buf (pref datum :cdb-datum.data)) + (unless (%null-ptr-p buf) + (unless info + (setq info + (make-objc-message-info + :message-name (string message-name)))) + (let* ((p 0) + (nmethods 0) + (nargs 0)) + (multiple-value-setq (nmethods p) (%decode-uint buf p)) + (multiple-value-setq (nargs p) (%decode-uint buf p)) + (dotimes (i nmethods) + (let* ((flag-byte (prog1 (%get-unsigned-byte buf p) + (incf p))) + (is-class-method (logbitp 0 flag-byte)) + (is-protocol-method (logbitp 1 flag-byte)) + (class-name ()) + (result-type ()) + (arg-types ()) + (arg-type ())) + (multiple-value-setq (class-name p) (%decode-name buf p t)) + (multiple-value-setq (result-type p) (%decode-type buf p ftd t)) + (dotimes (i nargs) + (multiple-value-setq (arg-type p) (%decode-type buf p ftd t)) + (push arg-type arg-types)) + (unless (dolist (m (objc-message-info-methods info)) + (when (and (eq (getf (objc-method-info-flags m) :class) is-class-method) + (string= (objc-method-info-class-name m) + class-name)) + (return t))) + (let* ((flags ())) + (if is-class-method + (setf (getf flags :class) t)) + (if is-protocol-method + (setf (getf flags :protocol) t)) + (push (make-objc-method-info + :message-info info + :class-name class-name + :arglist (nreverse arg-types) + :result-type result-type + :flags flags) + (objc-message-info-methods info)))))) + (cdb-free (pref datum :cdb-datum.data)))) + info)) + +(defun db-note-objc-method-info (cdb message-name message-info) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string message-name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string message-name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-objc-message-info value message-name message-info))))) + +(defun lookup-objc-message-info (message-name &optional message-info) + (do-interface-dirs (d) + (setq message-info + (db-note-objc-method-info (db-objc-methods d) message-name message-info))) + message-info) + +(defun %find-objc-class-info (name) + (do-interface-dirs (d) + (let* ((info (db-lookup-objc-class (db-objc-classes d) name))) + (when info (return info))))) + +(defun load-external-function (sym query) + (let* ((def (or (do-interface-dirs (d) + (let* ((f (db-lookup-function (db-functions d) sym))) + (when f (return f)))) + (unless query + (error "Foreign function not found: ~s" sym))))) + (if query + (not (null def)) + (progn + (setf (gethash sym (ftd-external-function-definitions + *target-ftd*)) def) + (setf (macro-function sym) #'%external-call-expander) + sym)))) + +(defun %read-symbol-preserving-case (stream package) + (let* ((case (readtable-case *readtable*)) + (query nil) + (error nil) + (sym nil) + (source nil)) + (let* ((*package* package)) + (unwind-protect + (progn + (setf (readtable-case *readtable*) :preserve) + (when (eq #\? (peek-char t stream nil nil)) + (setq query t) + (read-char stream)) + (multiple-value-setq (sym source error) + (handler-case (read-internal stream nil nil nil) + (error (condition) (values nil nil condition))))) + (setf (readtable-case *readtable*) case))) + (when error + (error error)) + (values sym query source))) + +(set-dispatch-macro-character + #\# #\$ + (qlfun |#$-reader| (stream char arg) + (declare (ignore char)) + (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))) + (multiple-value-bind (sym query source) + (%read-symbol-preserving-case + stream + package) + (unless *read-suppress* + (etypecase sym + (symbol + (let* ((const (load-os-constant sym t))) + (if query + (values const source) + (progn + (if const + (progn + (when (eq (symbol-package sym) package) + (unless arg (setq arg 0)) + (ecase arg + (0 + (unless (and (constant-symbol-p sym) + (not (eq (%sym-global-value sym) + (%unbound-marker-8)))) + (load-os-constant sym))) + (1 (makunbound sym) (load-os-constant sym)))) + (values sym source)) + (let* ((fv (%load-var sym nil))) + (values + (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv)) + (fv.type fv) + 0 + nil) + source))))))) + (string + (let* ((val 0) + (len (length sym))) + (dotimes (i 4 (values val source)) + (let* ((ch (if (< i len) (char sym i) #\space))) + (setq val (logior (ash val 8) (char-code ch))))))))))))) + +(set-dispatch-macro-character #\# #\_ + (qlfun |#_-reader| (stream char arg) + (declare (ignore char)) + (unless arg (setq arg 0)) + (multiple-value-bind (sym query source) + (%read-symbol-preserving-case + stream + (find-package (ftd-interface-package-name *target-ftd*))) + (unless *read-suppress* + (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol)) + (if query + (values (load-external-function sym t) source) + (let* ((def (if (eql arg 0) + (gethash sym (ftd-external-function-definitions + *target-ftd*))))) + (values (if (and def (eq (macro-function sym) #'%external-call-expander)) + sym + (load-external-function sym nil)) + source))))))) + +(set-dispatch-macro-character + #\# #\> + (qlfun |#>-reader| (stream char arg) + (declare (ignore char arg)) + (if *read-suppress* + (progn + (%read-list-expression stream nil) + nil) + (let* ((readtable *readtable*) + (case (readtable-case readtable)) + (string nil) + (error nil)) + (unwind-protect + (progn + (setf (readtable-case readtable) :preserve) + (multiple-value-setq (string error) + (handler-case (read-symbol-token stream) + (error (condition) (values nil condition))))) + (setf (readtable-case *readtable*) case)) + (when error + (error error)) + (escape-foreign-name string))))) + + + + +(eval-when (:compile-toplevel :execute) + (defconstant encoded-type-void 0) + (defconstant encoded-type-signed-32 1) + (defconstant encoded-type-unsigned-32 2) + (defconstant encoded-type-signed-8 3) + (defconstant encoded-type-unsigned-8 4) + (defconstant encoded-type-signed-16 5) + (defconstant encoded-type-unsigned-16 6) + (defconstant encoded-type-signed-n 7) ;N + (defconstant encoded-type-unsigned-n 8) ;N + (defconstant encoded-type-single-float 9) + (defconstant encoded-type-double-float 10) + (defconstant encoded-type-pointer 11) ; + (defconstant encoded-type-array 12) ; + (defconstant encoded-type-named-struct-ref 13); + (defconstant encoded-type-named-union-ref 14) ; + (defconstant encoded-type-named-type-ref 15) ; + (defconstant encoded-type-anon-struct-ref 16) ; + (defconstant encoded-type-anon-union-ref 17) ; + (defconstant encoded-type-bitfield-marker 18) ; + (defconstant encoded-type-named-transparent-union-ref 19) ; + (defconstant encoded-type-anon-transparent-union-ref 20) ; + ) + + +(defconstant encoded-type-type-byte (byte 5 0)) +(defconstant encoded-type-align-byte (byte 3 5) + "alignment in octets, if other than \"natural\" alignment,") + +;;; Constants & function names get saved verbatim. +;;; Record, type, and field names get escaped. + +(defun encode-name (name &optional verbatim) + (if (null name) + (list 0) + (let* ((string + (if (and (typep name 'keyword) + (not verbatim)) + (unescape-foreign-name name) + (string name))) + (length (length string))) + (cons length (map 'list #'char-code string))))) + +(defun encode-ffi-field (field) + (destructuring-bind (name type offset width) field + `(,@(encode-name name) + ,@(encode-ffi-type type) + ,@(encode-uint offset) + ,@(encode-uint width)))) + +(defun encode-ffi-field-list (fields) + (let* ((len (length fields))) + (labels ((encode-fields (fields) + (if fields + `(,@(encode-ffi-field (car fields)) ,@(encode-fields (cdr fields)))))) + `(,@(encode-uint len) ,@(encode-fields fields))))) + +(defun encode-ffi-union (u) + (let* ((name (ffi-union-name u)) + (alt-align-in-bytes-mask (ash (or (ffi-union-alt-alignment-bits u) + 0) + (- 5 3)))) + (if name + `(,(logior encoded-type-named-union-ref alt-align-in-bytes-mask) + ,@(encode-name name) + ,@(encode-ffi-field-list (ffi-union-fields u))) + `(,(logior encoded-type-anon-union-ref alt-align-in-bytes-mask) + ,@(encode-ffi-field-list (ffi-union-fields u)))))) + +(defun encode-ffi-transparent-union (u) + (let* ((name (ffi-transparent-union-name u)) + (alt-align-in-bytes-mask (ash (or (ffi-transparent-union-alt-alignment-bits u) + 0) + (- 5 3)))) + (if name + `(,(logior encoded-type-named-transparent-union-ref alt-align-in-bytes-mask) + ,@(encode-name name) + ,@(encode-ffi-field-list (ffi-union-fields u))) + `(,(logior encoded-type-anon-transparent-union-ref alt-align-in-bytes-mask) + ,@(encode-ffi-field-list (ffi-union-fields u)))))) + +(defun encode-ffi-struct (s) + (let* ((name (ffi-struct-name s)) + (alt-align-in-bytes-mask (ash (or (ffi-struct-alt-alignment-bits s) + 0) + (- 5 3)))) + (if name + `(,(logior encoded-type-named-struct-ref alt-align-in-bytes-mask) + ,@(encode-name (ffi-struct-name s)) + ,@(encode-ffi-field-list (ffi-struct-fields s))) + `(,(logior encoded-type-anon-struct-ref alt-align-in-bytes-mask) + ,@(encode-ffi-field-list (ffi-struct-fields s)))))) + +(defun encode-ffi-objc-class (c) + (let* ((protocols (ffi-objc-class-protocol-names c))) + (labels ((encode-name-list (names) + (if names + `(,@(encode-name (car names) t) + ,@(encode-name-list (cdr names)))))) + `(,@(encode-name (ffi-objc-class-string c)) + ,@(encode-name (ffi-objc-class-super-foreign-name c)) + ,@(encode-uint (length protocols)) + ,@(encode-name-list protocols) + ,@(encode-ffi-field-list (ffi-objc-class-own-ivars c)))))) + + +(defstruct db-objc-class-info + class-name + superclass-name + protocols + ivars + instance-methods + class-methods + ) + +(defun extract-db-objc-class (datum &optional (ftd *target-ftd*)) + (let* ((val nil)) + (with-macptrs ((buf)) + (%setf-macptr buf (pref datum :cdb-datum.data)) + (unless (%null-ptr-p buf) + (let* ((p 0) + (protocol-count 0) + (class-name ()) + (superclass-name ()) + (protocol-name ()) + (ivars ())) + (collect ((protocols)) + (multiple-value-setq (class-name p) (%decode-name buf p t)) + (multiple-value-setq (superclass-name p) (%decode-name buf p t)) + (multiple-value-setq (protocol-count p) (%decode-uint buf p)) + (dotimes (i protocol-count) + (multiple-value-setq (protocol-name p) (%decode-name buf p t)) + (protocols protocol-name)) + (setq ivars (%decode-field-list buf p ftd)) + (cdb-free (pref datum :cdb-datum.data)) + (setq val (make-db-objc-class-info + :class-name class-name + :superclass-name superclass-name + :ivars ivars + :protocols (protocols) + )))))) + val)) + +(defun db-lookup-objc-class (cdb name) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-objc-class value))))) + +(defun encode-u32 (val) + `(,(ldb (byte 8 24) val) + ,(ldb (byte 8 16) val) + ,(ldb (byte 8 8) val) + ,(ldb (byte 8 0) val))) + +(defun encode-uint (val) + (collect ((bytes)) + (do* ((b (ldb (byte 7 0) val) (ldb (byte 7 0) val)) + (done nil)) + (done (bytes)) + (when (zerop (setq val (ash val -7))) + (setq b (logior #x80 b) done t)) + (bytes b)))) + + + +(defun encode-ffi-type (spec) + (case (car spec) + (:primitive + (let ((primtype (cadr spec))) + (if (atom primtype) + (case primtype + (:float `(,encoded-type-single-float)) + (:double `(,encoded-type-double-float)) + (:void `(,encoded-type-void)) + (:signed `(,encoded-type-signed-32)) + (:unsigned `(,encoded-type-unsigned-32)) + ((:long-double :complex-int + :complex-float :complex-double :complex-long-double) + (encode-ffi-type `(:struct ,primtype)))) + (ecase (car primtype) + (* `(,encoded-type-pointer ,@(encode-ffi-type + (if (eq (cadr primtype) t) + `(:primitive :void) + (cadr primtype))))) + (:signed + (case (cadr primtype) + (32 `(,encoded-type-signed-32)) + (16 `(,encoded-type-signed-16)) + (8 `(,encoded-type-signed-8)) + (t `(,encoded-type-signed-n ,(cadr primtype))))) + (:unsigned + (case (cadr primtype) + (32 `(,encoded-type-unsigned-32)) + (16 `(,encoded-type-unsigned-16)) + (8 `(,encoded-type-unsigned-8)) + (t `(,encoded-type-unsigned-n ,(cadr primtype))))))))) + (:struct + (let* ((s (cadr spec)) + (name (ffi-struct-name s)) + (alt-align-bytes-mask (ash (or (ffi-struct-alt-alignment-bits s) + 0) + (- 5 3)))) + `(,(if name + (logior encoded-type-named-struct-ref alt-align-bytes-mask) + (logior encoded-type-anon-struct-ref alt-align-bytes-mask)) + ,@(encode-name (ffi-struct-reference s))))) + (:union + (let* ((u (cadr spec)) + (name (ffi-union-name u)) + (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u) + 0) + (- 5 3))) ) + `(,(if name + (logior encoded-type-named-union-ref alt-align-bytes-mask) + (logior encoded-type-anon-union-ref alt-align-bytes-mask)) + ,@(encode-name (ffi-union-reference u))))) + (:transparent-union + (let* ((u (cadr spec)) + (name (ffi-transparent-union-name u)) + (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u) + 0) + (- 5 3))) ) + `(,(if name + (logior encoded-type-named-transparent-union-ref alt-align-bytes-mask) + (logior encoded-type-anon-transparent-union-ref alt-align-bytes-mask)) + ,@(encode-name (ffi-transparent-union-reference u))))) + (:typedef + `(,encoded-type-named-type-ref ,@(encode-name (ffi-typedef-name (cadr spec))))) + (:pointer + `(,encoded-type-pointer ,@(encode-ffi-type + (if (eq (cadr spec) t) + '(:primitive :void) + (cadr spec))))) + (:array + `(,encoded-type-array ,@(encode-uint (cadr spec)) ,@(encode-ffi-type (caddr spec)))) + (t + (break "Type spec = ~s" spec)))) + +(defun encode-ffi-arg-type (spec) + (case (car spec) + (:primitive + (let ((primtype (cadr spec))) + (if (atom primtype) + (case primtype + (:float `(#\s)) + (:double `(#\d)) + (:void `(#\Space)) + (:signed `(#\F)) + (:unsigned `(f)) + ((:long-double :complex-int + :complex-float :complex-double :complex-long-double) + #|(encode-ffi-arg-type `(:struct ,primtype))|# + `(#\?))) + (ecase (car primtype) + (* `(#\a)) + (:signed + (let* ((nbits (cadr primtype))) + (if (<= nbits 8) + '(#\B) + (if (<= nbits 16) + '(#\H) + (if (<= nbits 32) + '(#\F) + (if (<= nbits 64) + `(#\L) + '(#\?))))))) + (:unsigned + (let* ((nbits (cadr primtype))) + (if (<= nbits 8) + '(#\b) + (if (<= nbits 16) + '(#\h) + (if (<= nbits 32) + '(#\f) + (if (<= nbits 64) + `(#\l) + '(#\?))))))))))) + ((:struct :union :transparent-union) + `(,(ecase (car spec) + (:struct #\r) + (:union #\u) + (:transparent-union #\U)) + ,@(encode-name (ffi-struct-reference (cadr spec))))) + (:typedef + `(#\t ,@(encode-name (ffi-typedef-name (cadr spec))))) + (:pointer + `(#\a)) + (:array + `(#\?)))) + +(defun encode-ffi-arg-list (args) + (if args + `(,@(encode-ffi-arg-type (car args)) ,@(encode-ffi-arg-list (cdr args))))) + +(defvar *prepend-underscores-to-ffi-function-names* nil) + +(defun encode-ffi-function (f) + (let* ((args (ffi-function-arglist f)) + (string (ffi-function-string f)) + (name (if *prepend-underscores-to-ffi-function-names* + (concatenate 'string "_" string) + string)) + (min-args (length args)) + (result (ffi-function-return-value f))) + `(,min-args + ,@(encode-name name t) ; verbatim + ,@(encode-ffi-arg-type result) + ,@(encode-ffi-arg-list args)))) + +(defun encode-ffi-objc-method (m) + (let* ((flag-byte (logior (if (getf (ffi-objc-method-flags m) :class) 1 0) + (if (getf (ffi-objc-method-flags m) :protocol) 2 0)))) + `(,flag-byte + ,@(encode-name (ffi-objc-method-class-name m) t) + ,@(encode-ffi-type (ffi-objc-method-result-type m)) + ,@(apply #'append (mapcar #'encode-ffi-type (ffi-objc-method-arglist m)))))) + +(defun save-ffi-objc-message (cdbm message) + (let* ((methods (ffi-objc-message-methods message)) + (nmethods (length methods)) + (nargs (length (ffi-objc-method-arglist (car methods))))) + (labels ((encode-objc-method-list (ml) + (when ml + `(,@(encode-ffi-objc-method (car ml)) + ,@(encode-objc-method-list (cdr ml)))))) + (db-write-byte-list cdbm + (ffi-objc-message-string message) + `(,@(encode-uint nmethods) + ,@(encode-uint nargs) + ,@(encode-objc-method-list methods)) + t)))) + + +(defun save-byte-list (ptr l) + (do* ((l l (cdr l)) + (i 0 (1+ i))) + ((null l)) + (let* ((b (car l))) + (if (typep b 'character) + (setq b (char-code b))) + (setf (%get-unsigned-byte ptr i) b)))) + +(defun db-write-byte-list (cdbm keyname bytes &optional verbatim) + (let* ((len (length bytes))) + (%stack-block ((p len)) + (save-byte-list p bytes) + (rletZ ((contents :cdb-datum) + (key :cdb-datum)) + (let* ((foreign-name + (if verbatim + keyname + (unescape-foreign-name keyname)))) + (with-cstrs ((keystring foreign-name)) + (setf (pref contents :cdb-datum.data) p + (pref contents :cdb-datum.size) len + (pref key :cdb-datum.data) keystring + (pref key :cdb-datum.size) (length foreign-name)) + (cdbm-put cdbm key contents))))))) + +(defun save-ffi-function (cdbm fun) + (let* ((encoding (encode-ffi-function fun))) + (db-write-byte-list cdbm + (ffi-function-string fun) + encoding + t))) + +(defun save-ffi-typedef (cdbm def) + (db-write-byte-list cdbm + (ffi-typedef-string def) + (encode-ffi-type (ffi-typedef-type def)) + t)) + +(defun save-ffi-struct (cdbm s) + (db-write-byte-list cdbm (ffi-struct-reference s) (encode-ffi-struct s))) + +(defun save-ffi-union (cdbm u) + (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u))) + +(defun save-ffi-transparent-union (cdbm u) + (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u))) + + +(defun db-define-var (cdbm name type) + (db-write-byte-list cdbm + (if *prepend-underscores-to-ffi-function-names* + (concatenate 'string "_" name) + name) + (encode-ffi-type type) t)) + +(defun save-ffi-objc-class (cdbm c) + (db-write-byte-list cdbm (ffi-objc-class-name c) (encode-ffi-objc-class c))) + + +;;; An "uppercase-sequence" is a maximal substring of a string that +;;; starts with an uppercase character and doesn't contain any +;;; lowercase characters. +(defun count-uppercase-sequences (string) + (let* ((state :lower) + (nupper 0)) + (declare (fixnum nupper)) + (dotimes (i (length string) nupper) + (let* ((ch (char string i))) + (case state + (:lower + (when (upper-case-p ch) + (incf nupper) + (setq state :upper))) + (:upper + (unless (upper-case-p ch) + (setq state :lower)))))))) + +(defun escape-foreign-name (in &optional + (count (count-uppercase-sequences in))) + (intern + (if (zerop count) + (string-upcase in) + (let* ((len (length in)) + (j 0) + (out (make-string (+ len (* 2 count)))) + (state :lower)) + (flet ((outch (ch) + (setf (schar out j) ch) + (incf j) + ch)) + (dotimes (i len (progn (if (eq state :upper) (outch #\>)) out)) + (let* ((ch (char in i))) + (cond ((and (upper-case-p ch) (eq state :lower)) + (outch #\<) + (setq state :upper)) + ((and (not (upper-case-p ch)) (eq state :upper)) + (outch #\>) + (setq state :lower))) + (outch (char-upcase ch))))))) + *keyword-package*)) + +(defun unescape-foreign-name (key) + (let* ((string (if (typep key 'symbol) + (string-downcase key) + (string key))) + (nleftbrackets (count #\< string)) + (nrightbrackets (count #\> string)) + (nbrackets (+ nleftbrackets nrightbrackets))) + (declare (fixnum nleftbrackets nrightbrackets nbrackets)) + (if (zerop nbrackets) + string + (if (/= nleftbrackets nrightbrackets) + (error "Mismatched brackets in ~s." key) + (let* ((len (length string)) + (out (make-string (- len nbrackets))) + (j 0) + (state :lower)) + (dotimes (i len out) + (let* ((ch (schar string i))) + (if (or (and (eq ch #\<) + (eq state :upper)) + (and (eq ch #\>) + (eq state :lower))) + (error "Mismatched brackets in ~s." key)) + (case ch + (#\< (setq state :upper)) + (#\> (setq state :lower)) + (t (setf (schar out j) (if (eq state :upper) + (char-upcase ch) + (char-downcase ch)) + j (1+ j))))))))))) + + + +(defun %decode-name (buf p &optional verbatim) + (declare (type macptr buf) (fixnum p)) + (let* ((n (%get-unsigned-byte buf p))) + (declare (fixnum n)) + (if (zerop n) + (values nil (1+ p)) + (let* ((pname (%str-from-ptr (%inc-ptr buf (1+ p)) n))) + (values (if verbatim pname (escape-foreign-name pname)) + (+ p (1+ n))))))) + +(defun %decode-u32 (buf p) + (declare (fixnum p) (type macptr buf)) + (values (dpb + (%get-unsigned-byte buf p) + (byte 8 24) + (dpb + (%get-unsigned-byte buf (+ p 1)) + (byte 8 16) + (dpb + (%get-unsigned-byte buf (+ p 2)) + (byte 8 8) + (%get-unsigned-byte buf (+ p 3))))) + (+ p 4))) + +(defun %decode-uint (buf p) + (do* ((val 0) + (p p (1+ p)) + (shift 0 (+ shift 7)) + (done nil)) + (done (values val p)) + (let* ((b (%get-unsigned-byte buf p))) + (setq done (logbitp 7 b) val (logior val (ash (logand b #x7f) shift)))))) + + +;; Should return a FOREIGN-TYPE structure (except if suppress-typedef-expansion is true, may +;; return a symbol for encoded-type-named-type-ref) +(defun %decode-type (buf p ftd &optional suppress-typedef-expansion) + (declare (type macptr buf) (fixnum p)) + (let* ((q (1+ p))) + (ecase (ldb encoded-type-type-byte (%get-unsigned-byte buf p)) + (#.encoded-type-void (values (parse-foreign-type :void) q)) + (#.encoded-type-signed-32 (values (svref *signed-integer-types* 32) q)) + (#.encoded-type-unsigned-32 (values (svref *unsigned-integer-types* 32) q)) + (#.encoded-type-signed-8 (values (svref *signed-integer-types* 8) q)) + (#.encoded-type-unsigned-8 (values (svref *unsigned-integer-types* 8) q)) + (#.encoded-type-signed-16 (values (svref *signed-integer-types* 16) q)) + (#.encoded-type-unsigned-16 (values (svref *unsigned-integer-types* 16) q)) + (#.encoded-type-signed-n (values (let* ((bits (%get-unsigned-byte buf q))) + (if (<= bits 32) + (svref *signed-integer-types* bits) + (make-foreign-integer-type + :signed t + :bits bits))) + (1+ q))) + (#.encoded-type-unsigned-n (values (let* ((bits (%get-unsigned-byte buf q))) + (if (<= bits 32) + (svref *unsigned-integer-types* bits) + (make-foreign-integer-type + :signed nil + :bits bits))) + (1+ q))) + (#.encoded-type-single-float (values (parse-foreign-type :float) q)) + (#.encoded-type-double-float (values (parse-foreign-type :double) q)) + (#.encoded-type-pointer (multiple-value-bind (target qq) + (%decode-type buf q ftd suppress-typedef-expansion) + (values (make-foreign-pointer-type + :to target + :bits (getf (ftd-attributes ftd) + :bits-per-word) + ) + qq))) + (#.encoded-type-array + (multiple-value-bind (size qq) (%decode-uint buf q) + (multiple-value-bind (target qqq) (%decode-type buf qq ftd) + (let* ((type-alignment (foreign-type-alignment target)) + (type-bits (foreign-type-bits target))) + (values (make-foreign-array-type + :element-type target + :dimensions (list size) + :alignment type-alignment + :bits (if type-bits + (* (align-offset type-bits type-alignment) size))) + qqq))))) + (#.encoded-type-named-type-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (values (if suppress-typedef-expansion + name + (%parse-foreign-type name)) + qq))) + (#.encoded-type-named-struct-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (values (or (info-foreign-type-struct name) + (setf (info-foreign-type-struct name) + (make-foreign-record-type :kind :struct + :name name))) + qq))) + (#.encoded-type-named-union-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (values (or (info-foreign-type-union name) + (setf (info-foreign-type-union name) + (make-foreign-record-type :kind :union + :name name))) + qq))) + (#.encoded-type-named-transparent-union-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (let* ((already (info-foreign-type-union name))) + (when already + (setf (foreign-record-type-kind already) :transparent-union)) + (values (or already + (setf (info-foreign-type-union name) + (make-foreign-record-type :kind :transparent-union + :name name))) + qq)))) + ((#.encoded-type-anon-struct-ref + #.encoded-type-anon-union-ref + #.encoded-type-anon-transparent-union-ref) + (multiple-value-bind (tag qq) (%decode-name buf q t) + (values (load-record tag) qq)))))) + +(defun extract-db-type (datum ftd) + (let* ((data (pref datum :cdb-datum.data))) + (unless (%null-ptr-p data) + (prog1 + (%decode-type data 0 ftd) + (cdb-free data))))) + +(defun %load-foreign-type (cdb name ftd) + (when cdb + (with-cstrs ((string (string name))) + (rletZ ((contents :cdb-datum) + (key :cdb-datum)) + (setf (pref key :cdb-datum.size) (length (string name)) + (pref key :cdb-datum.data) string + (pref contents :cdb-datum.data) (%null-ptr) + (pref contents :cdb-datum.size) 0) + (cdb-get cdb key contents) + (let* ((type (extract-db-type contents ftd))) + (if type + (%def-foreign-type (escape-foreign-name name) type ftd))))))) + +(defun load-foreign-type (name &optional (ftd *target-ftd*)) + (let* ((name (unescape-foreign-name name))) + (do-interface-dirs (d ftd) + (let* ((type (%load-foreign-type (db-types d) name ftd))) + (when type (return type)))))) + +(defun %decode-field (buf p ftd) + (declare (type macptr buf) (fixnum p)) + (multiple-value-bind (name p) (%decode-name buf p) + (multiple-value-bind (type p) (%decode-type buf p ftd) + (multiple-value-bind (offset p) (%decode-uint buf p) + (multiple-value-bind (width p) (%decode-uint buf p) + (values (make-foreign-record-field :type type + :name name + :bits width + :offset offset) + p)))))) + +(defun %decode-field-list (buf p ftd) + (declare (type macptr buf) (fixnum p)) + (let* ((n nil) + (fields nil)) + (multiple-value-setq (n p) (%decode-uint buf p)) + (dotimes (i n (values (nreverse fields) p)) + (multiple-value-bind (field q) (%decode-field buf p ftd) + (push field fields) + (setq p q))))) + +(defun %determine-record-attributes (rtype parsed-fields &optional alt-align) + (let* ((total-bits 0) + (overall-alignment 1) + #+(and darwinppc-target ppc32-target) + (first-field-p t) + (kind (foreign-record-type-kind rtype))) + (dolist (field parsed-fields) + (let* ((field-type (foreign-record-field-type field)) + (bits (ensure-foreign-type-bits field-type)) + (natural-alignment (foreign-type-alignment field-type)) + (alignment (if alt-align + (min natural-alignment alt-align) + #+(and darwinppc-target ppc32-target) + (if first-field-p + (progn + (setq first-field-p nil) + natural-alignment) + (min 32 natural-alignment)) + #-(and darwinppc-target ppc32-target) + natural-alignment))) + (unless bits + (error "Unknown size: ~S" + (unparse-foreign-type field-type))) + (unless alignment + (error "Unknown alignment: ~S" + (unparse-foreign-type field-type))) + (setq overall-alignment (max overall-alignment (if (= alignment 1) 32 alignment))) + (ecase kind + (:struct (let* ((imported-offset (foreign-record-field-offset field)) + (offset (or imported-offset (align-offset total-bits alignment)))) + (unless imported-offset + (setf (foreign-record-field-offset field) offset)) + (setq total-bits (+ offset bits)))) + ((:union :transparent-union) (setq total-bits (max total-bits bits)))))) + (setf (foreign-record-type-fields rtype) parsed-fields + (foreign-record-type-alignment rtype) (or + alt-align + overall-alignment) + (foreign-record-type-bits rtype) (align-offset + total-bits + (or alt-align overall-alignment)) + (foreign-record-type-alt-align rtype) alt-align) + rtype)) + +(defun %decode-record-type (buf p ftd already) + (declare (type macptr buf) (fixnum p)) + (let* ((rbyte (%get-unsigned-byte buf p)) + (rcode (ldb encoded-type-type-byte rbyte)) + (ralign-in-bytes (ldb encoded-type-align-byte rbyte)) + (alt-align (unless (zerop ralign-in-bytes) + (the fixnum (ash ralign-in-bytes 3))))) + (declare (fixnum rbyte rcode ralign-in-bytes)) + (multiple-value-bind (name q) + (case rcode + ((#.encoded-type-anon-struct-ref + #.encoded-type-anon-union-ref + #.encoded-type-anon-transparent-union-ref) + (values nil (1+ p))) + (t + (%decode-name buf (1+ p)))) + (%determine-record-attributes + (or already + (if name + (if (eql rcode encoded-type-named-struct-ref) + (or (info-foreign-type-struct name) + (setf (info-foreign-type-struct name) + (make-foreign-record-type :kind :struct :name name))) + (or (info-foreign-type-union name) + (setf (info-foreign-type-union name) + (make-foreign-record-type :kind + (if (eql rcode encoded-type-named-union-ref) + :union + :transparent-union) + :name name)))) + (make-foreign-record-type + :kind (if (eql rcode encoded-type-anon-struct-ref) + :struct + (if (eql rcode encoded-type-anon-union-ref) + :union + :transparent-union)) + :name name))) + (%decode-field-list buf q ftd) + alt-align)))) + +(defun extract-db-record (datum ftd already) + (let* ((data (pref datum :cdb-datum.data))) + (unless (%null-ptr-p data) + (prog1 + (%decode-record-type data 0 ftd already) + (cdb-free data))))) + + +(defun %load-foreign-record (cdb name ftd already) + (when cdb + (with-cstrs ((string (string name))) + (rlet ((contents :cdb-datum) + (key :cdb-datum)) + (setf (pref key :cdb-datum.size) (length (string name)) + (pref key :cdb-datum.data) string + (pref contents :cdb-datum.data) (%null-ptr) + (pref contents :cdb-datum.size) 0) + (cdb-get cdb key contents) + (extract-db-record contents ftd already))))) + +(defun load-record (name &optional (ftd *target-ftd*)) + ;; Try to destructively modify any info we already have. Use the + ;; "escaped" name (keyword) for the lookup here. + (let* ((already (or (info-foreign-type-struct name ftd) + (info-foreign-type-union name ftd))) + (name (unescape-foreign-name name))) + (do-interface-dirs (d ftd) + (let* ((r (%load-foreign-record (db-records d) name ftd already))) + (when r (return r)))))) + + Index: /branches/qres/ccl/lib/defstruct-lds.lisp =================================================================== --- /branches/qres/ccl/lib/defstruct-lds.lisp (revision 13564) +++ /branches/qres/ccl/lib/defstruct-lds.lisp (revision 13564) @@ -0,0 +1,406 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; defstruct-lds.lisp + +(in-package "CCL") + +(eval-when (eval compile) + (require 'defstruct-macros) +) + + + + +(defun uvector-subtype-p (thing subtype-number) + (= (the fixnum (typecode thing)) subtype-number)) + +(defun uvector (subtype &rest p) + (declare (dynamic-extent p)) + (let ((n (length p)) (uv)) + (setq uv (%alloc-misc n subtype)) + (dotimes (i (the fixnum n)) (declare (fixnum i)) (uvset uv i (pop p))) + uv)) + +;(defmacro test (&rest args) `(macroexpand-1 (defstruct ,@args))) + +;--> To do: compiler transform for copier, possibly constructor. +(defmacro defstruct (options &rest slots &environment env) + "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)} + Define the structure type Name. Instances are created by MAKE-, + which takes &KEY arguments allowing initial slot values to the specified. + A SETF'able function - is defined for each slot to read and + write slot values. -p is a type predicate. + + Popular DEFSTRUCT options (see manual for others): + + (:CONSTRUCTOR Name) + (:PREDICATE Name) + Specify the name for the constructor or predicate. + + (:CONSTRUCTOR Name Lambda-List) + Specify the name and arguments for a BOA constructor + (which is more efficient when keyword syntax isn't necessary.) + + (:INCLUDE Supertype Slot-Spec*) + Make this type a subtype of the structure type Supertype. The optional + Slot-Specs override inherited slot options. + + Slot options: + + :TYPE Type-Spec + Asserts that the value of this slot is always of the specified type. + + :READ-ONLY {T | NIL} + If true, no setter function is defined for this slot." + ;There's too much state to keep around here to break it up into little + ;functions, so what the hell, let's do it all inline... + (prog (struct-name type conc-name constructor copier predicate include + print-function print-object named initial-offset boa-constructors print-p + documentation (slot-list ()) (offset 0) superclasses sd + refnames) + ;Parse options + (if (atom options) + (setq struct-name options options ()) + (setq struct-name (pop options))) + (unless (symbolp struct-name) (signal-program-error $XNotSym struct-name)) + (let (name args constructor-p predicate-p) + (while options + (if (atom (car options)) + (setq name (%car options) args ()) + (setq name (%caar options) args (%cdar options))) + (case name + (:conc-name + (when conc-name (go dup-options)) + (when (cdr args) (go bad-options)) + (setq conc-name (or args (list nil)))) + (:constructor + (when (cddr args) (go bad-options)) + (cond ((cdr args) (push args boa-constructors)) + (t (when constructor (go dup-options)) + (unless (symbolp (%car args)) (go bad-options)) + (setq constructor-p t constructor args)))) + (:copier + (when copier (go dup-options)) + (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options)) + (setq copier args)) + (:predicate + (when predicate (go dup-options)) + (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options)) + (setq predicate-p t predicate args)) + (:include + (when include (go dup-options)) + (when (or (null args) (not (symbolp (car args)))) (go bad-options)) + (setq include args)) + ((:print-function :print-object) + (when print-function (go dup-options)) + (when (or (cdr args) + (not (or (symbolp (%car args)) + (and (consp (%car args)) (eq (%caar args) 'lambda))))) + (go bad-options)) + (setq print-p t + print-function (%car args) + print-object (eq name :print-object))) + (:type + (when type (go dup-options)) + (when (cdr args) (go bad-options)) + (unless (eq (setq type (%car args)) 'list) + (when (eq type 'vector) (setq type '(vector t))) + (when (or (atom type) (neq (%car type) 'vector) (cdr (%cdr type))) + (go bad-options)))) + (:named + (when args (go bad-options)) + (setq named t)) + (:initial-offset + (when initial-offset (go dup-options)) + (when (or (cdr args) (not (fixnump (%car args))) (%i< (%car args) 0)) + (go bad-options)) + (setq initial-offset (%car args))) + (t (go bad-options))) + (setq options (%cdr options))) + ;Options parsed! Do defaulting and some consistency checking. + (cond (type + (when (null (defstruct-reftype type)) ;e.g. (vector NIL) + (bad-named-arg :type type)) + (when print-p + (error "Cannot specify ~S with ~S" :print-function :type)) + (if (and named (consp type) (eq (car type) 'vector) + (cadr type) (not (subtypep 'symbol (cadr type)))) + (error "Cannot specify ~S with type: ~S" :named type)) + ) + ((built-in-type-p struct-name) + (error "Cannot redefine built-in type ~S" struct-name)) + (initial-offset + (error "Cannot use ~S without ~S" :initial-offset :type)) + (t (setq named t))) + (if (not named) + (when predicate-p + (unless (null (setq predicate (%car predicate))) + (error "Cannot specify :PREDICATE for an unnamed structure"))) + (setq predicate (if (null predicate) + (concat-pnames struct-name "-P") + (%car predicate)))) + (setq conc-name + (if (null conc-name) (%str-cat (symbol-name struct-name) "-") + (if (%car conc-name) (string (%car conc-name))))) + (unless (and boa-constructors (not constructor-p)) + (setq constructor + (if (null constructor) + (concat-pnames "MAKE-" struct-name) (%car constructor)))) + (setq copier + (if (null copier) (concat-pnames "COPY-" struct-name) (%car copier)))) + ;Process included slots + (when include + (let* ((included-name (%car include)) + (sub-sd (or (let* ((defenv (definition-environment env))) + (when defenv (%cdr (assq included-name (defenv.structures defenv))))) + (gethash included-name %defstructs%))) + (slots (%cdr include)) + name args ssd) + (unless sub-sd (error "No such structure: ~S" (cons :include include))) + (unless (eq (defstruct-reftype type) + (defstruct-reftype (sd-type sub-sd))) + (error "Incompatible structure type ~S for ~S" + (sd-type sub-sd) (cons :include include))) + (dolist (ssd (sd-slots sub-sd)) (push + (let* ((new-ssd (copy-ssd ssd))) + (ssd-set-inherited new-ssd) + new-ssd) + slot-list)) + (while slots + (if (atom (car slots)) + (setq name (%car slots) args ()) + (setq name (%caar slots) args (%cdar slots))) + (unless (symbolp name) (signal-program-error $XNotSym name)) + (unless (setq ssd (named-ssd name slot-list)) + (error "~S has no ~S slot, in ~S" + (sd-name sub-sd) name (cons :include include))) + (ssd-set-initform ssd (pop args)) + (while args + (when (atom (cdr args)) (signal-program-error "~S is not a proper list" (cdr args))) + (cond ((eq (%car args) :type) ) + ((eq (%car args) :read-only) + (when (and (not (%cadr args)) (ssd-r/o ssd)) + (signal-program-error "Slot ~S in ~S must be read-only" name (sd-name sub-sd))) + (when (%cadr args) (ssd-set-r/o ssd))) + (t (signal-program-error "~S must be (member :type :read-only)." (%car args)))) + (setq args (%cddr args))) + (setq slots (%cdr slots))) + (setq offset (sd-size sub-sd)) + (setq superclasses (sd-superclasses sub-sd)))) + (push struct-name superclasses) + ;Now add own slots + (setq offset (%i+ offset (or initial-offset 0))) + (when (and named (or type (not include))) + (push (make-ssd 0 (if type `',struct-name `',superclasses) offset t) slot-list) + (setq named offset offset (%i+ offset 1))) + (when (stringp (%car slots)) + (setq documentation (%car slots) slots (%cdr slots))) + (let (name args read-only initform slot-type) + (while slots + (if (atom (%car slots)) + (setq name (%car slots) args ()) + (setq name (%caar slots) args (%cdar slots))) + (unless (symbolp name) (go bad-slot)) + (setq read-only nil initform (pop args) slot-type t) + (while args + (when (atom (cdr args)) (go bad-slot)) + ;; To do: check for multiple/incompatible options. + (cond ((eq (%car args) :type) + (setq slot-type (%cadr args))) + ((eq (%car args) :read-only) + (setq read-only (%cadr args))) + (t (go bad-slot))) + (setq args (%cddr args))) + (specifier-type slot-type env) ;; Check for validity (signals program error) + (push (make-ssd name initform offset read-only slot-type) slot-list) + (setq slots (%cdr slots) offset (%i+ offset 1)))) + (setq slot-list (nreverse slot-list)) + (when (and (null type) include) + (ssd-set-initform (car slot-list) `',superclasses)) + (progn ;when conc-name + (dolist (slot slot-list) + (unless (fixnump (ssd-name slot)) + (push (if conc-name + (concat-pnames conc-name (ssd-name slot)) + (ssd-name slot)) + refnames))) + (setq refnames (nreverse refnames))) + (setq sd (vector type slot-list superclasses offset constructor () refnames)) + (return + `(progn + ,@(when (null (sd-type sd)) + `((when (memq ',struct-name *nx-known-declarations*) + (check-declaration-redefinition ',struct-name 'defstruct)))) + (remove-structure-defs ',struct-name) ; lose any previous defs + ,.(defstruct-slot-defs sd refnames env) + ,.(if constructor (list (defstruct-constructor sd constructor))) + ,.(defstruct-boa-constructors sd boa-constructors) + ,.(if copier (defstruct-copier sd copier env)) + ,.(if predicate (defstruct-predicate sd named predicate env)) + (eval-when (:compile-toplevel) + (define-compile-time-structure + ',sd + ',refnames + ,(if (and predicate (null (sd-type sd))) `',predicate) + ,env)) + (%defstruct-do-load-time + ',sd + ,(if (and predicate (null (sd-type sd))) `',predicate) + ,.(if documentation (list documentation))) + ,.(%defstruct-compile sd refnames env) + ;; Wait until slot accessors are defined, to avoid + ;; undefined function warnings in the print function/method. + (%defstruct-set-print-function + ',sd + ,(if print-function + (if (symbolp print-function) + `',print-function + `#',print-function) + (unless print-p (if include 0))) + ,print-object) + ',struct-name)) + + dup-options + (error "Duplicate ~S options not allowed" (%car options)) + bad-options + (signal-program-error "Bad defstruct option ~S." (%car options)) + bad-slot + (signal-program-error "Bad defstruct slot spec ~S." (%car slots)))) + +(defun concat-pnames (name1 name2) + (intern (%str-cat (string name1) (string name2)))) + +(defun wrap-with-type-check (value slot &aux (slot-type (ssd-type slot))) + (if (eq t slot-type) + value + `(require-type ,value ',slot-type))) + +(defun make-class-cells-list (class-names) + (if (and (consp class-names) + (eq (car class-names) 'quote) + (consp (cdr class-names)) + (null (cddr class-names)) + (listp (cadr class-names)) + (every #'symbolp (cadr class-names))) + `',(mapcar (lambda (name) (find-class-cell name t)) (cadr class-names)) + class-names)) + +(defun defstruct-constructor (sd constructor &aux (offset 0) + (args ()) + (values ()) + slot-offset + name) + (dolist (slot (sd-slots sd)) + (setq slot-offset (ssd-offset slot)) + #-bccl (when (%i< slot-offset offset) + (error "slots out of order! ~S" (sd-slots sd))) + (while (%i< offset slot-offset) + (push nil values) + (setq offset (%i+ offset 1))) + (if (fixnump (setq name (ssd-name slot))) + (if (eql 0 name) + (push (make-class-cells-list (ssd-initform slot)) values) + (push (wrap-with-type-check (ssd-initform slot) slot) values)) + (let* ((temp (make-symbol (symbol-name name)))) + (push (list (list (make-keyword name) temp) (ssd-initform slot)) args) + (push (wrap-with-type-check temp slot) values))) + (setq offset (%i+ offset 1))) + (setq values (nreverse values)) + `(defun ,constructor (&key ,@(nreverse args)) + ,(case (setq name (defstruct-reftype (sd-type sd))) + (#.$defstruct-nth `(list ,@values)) + (#.target::subtag-simple-vector `(vector ,@values)) + ((#.target::subtag-struct #.$defstruct-struct) + `(gvector :struct ,@values)) + (t `(uvector ,name ,@values))))) + +(defun defstruct-boa-constructors (sd boas &aux (list ())) + (dolist (boa boas list) + (push (defstruct-boa-constructor sd boa) list))) + +(defun defstruct-boa-constructor (sd boa &aux (args ()) + (used-slots ()) + (values ()) + (offset 0) + arg-kind slot slot-offset) + (unless (verify-lambda-list (cadr boa)) + (error "Invalid lambda-list in ~S ." (cons :constructor boa))) + (dolist (arg (cadr boa)) + (cond ((memq arg lambda-list-keywords) + (setq arg-kind arg)) + ((setq slot (named-ssd arg (sd-slots sd))) + (when (or (eq arg-kind '&optional) (eq arg-kind '&key) + ;; for &aux variables, init value is + ;; implementation-defined, however it's not + ;; supposed to signal a type error until slot is + ;; assigned, so might as well just use the + ;; initform. + (eq arg-kind '&aux)) + (setq arg (list arg (ssd-initform slot)))) + (push slot used-slots)) + ((and (consp arg) (setq slot (named-ssd (if (consp (%car arg)) (%cadar arg) (%car arg)) (sd-slots sd)))) + (push slot used-slots)) + (t nil)) + (push arg args)) + (dolist (slot (sd-slots sd)) + (setq slot-offset (ssd-offset slot)) + #-bccl (when (%i< slot-offset offset) (error "slots out of order! ~S" sd)) + (while (%i< offset slot-offset) + (push nil values) + (setq offset (%i+ offset 1))) + (push (if (memq slot used-slots) (ssd-name slot) + (if (eql 0 (ssd-name slot)) + (make-class-cells-list (ssd-initform slot)) + (if (constantp (ssd-initform slot)) (ssd-initform slot) + (progn + (unless (eq arg-kind '&aux) + (push (setq arg-kind '&aux) args)) + (push (list (ssd-name slot) (ssd-initform slot)) args) + (ssd-name slot))))) + values) + (setq offset (%i+ offset 1))) + (setq values (mapcar #'wrap-with-type-check (nreverse values) (sd-slots sd))) + `(defun ,(car boa) ,(nreverse args) + ,(case (setq slot (defstruct-reftype (sd-type sd))) + (#.$defstruct-nth `(list ,@values)) + (#.target::subtag-simple-vector `(vector ,@values)) + ((#.target::subtag-struct #.$defstruct-struct) + `(gvector :struct ,@values)) + (t `(uvector ,slot ,@values))))) + +(defun defstruct-copier (sd copier env) + `((eval-when (:compile-toplevel) + (record-function-info ',copier ',*one-arg-defun-def-info* ,env)) + (fset ',copier + ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector)) + (record-source-file ',copier 'function))) + +(defun defstruct-predicate (sd named predicate env) + (declare (ignore env)) + (let* ((arg (gensym)) + (sd-name (sd-name sd)) + (body + (case (sd-type sd) + ((nil) `(structure-typep ,arg ',(find-class-cell sd-name t))) + ((list) `(and (consp ,arg) (eq (nth ,named ,arg) ',sd-name))) + (t `(and (uvector-subtype-p ,arg ,(defstruct-reftype (sd-type sd))) + (< ,named (uvsize ,arg)) + (eq (uvref ,arg ,named) ',sd-name)))))) + `((defun ,predicate (,arg) ,body)))) + +; End of defstruct-lds.lisp Index: /branches/qres/ccl/lib/defstruct-macros.lisp =================================================================== --- /branches/qres/ccl/lib/defstruct-macros.lisp (revision 13564) +++ /branches/qres/ccl/lib/defstruct-macros.lisp (revision 13564) @@ -0,0 +1,110 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; This file is needed to compile DEFSTRUCT and anything accessing defstruct +; data structures. + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require "LISPEQU")) + +(defconstant $struct-r/o 24) ; Read-only bit in refinfo fixnum +(defconstant $struct-inherited 25) ; Struct slot is inherited. + + +(defconstant $defstruct-nth 0) ; Anything that won't conflict with array types... +(defconstant $defstruct-struct 8) +(defconstant $defstruct-simple-vector 16) + + +(defmacro ssd-name (ssd) `(car ,ssd)) +;(defmacro ssd-type (ssd) (declare (ignore ssd)) t) +(defmacro ssd-initform (ssd) `(cadr ,ssd)) +;(defmacro ssd-refinfo (ssd) `(cddr ,ssd)) + +(defmacro ssd-update-refinfo ((ssd refinfo-var) new-refinfo-form) + (check-type refinfo-var symbol) + (let ((refinfo-cons (gensym))) + `(let* ((,refinfo-cons (cdr ,ssd)) + (,refinfo-var (cdr ,refinfo-cons))) + (when (consp ,refinfo-var) + (setq ,refinfo-cons ,refinfo-var) + (setq ,refinfo-var (%cdr ,refinfo-cons))) + (%rplacd ,refinfo-cons ,new-refinfo-form)))) + +(defmacro refinfo-offset (refinfo) `(%ilogand2 #xFFFF ,refinfo)) +(defmacro refinfo-r/o (refinfo) `(%ilogbitp $struct-r/o ,refinfo)) +(defmacro refinfo-reftype (refinfo) `(%ilogand2 #xFF (%ilsr 16 ,refinfo))) + +(defmacro ssd-offset (ssd) `(refinfo-offset (ssd-refinfo ,ssd))) +(defmacro ssd-r/o (ssd) `(refinfo-r/o (ssd-refinfo ,ssd))) +(defmacro ssd-reftype (ssd) `(refinfo-reftype (ssd-refinfo ,ssd))) + +(defmacro ssd-set-initform (ssd value) `(rplaca (cdr ,ssd) ,value)) + +#| these are fns now +(defmacro ssd-set-reftype (ssd reftype) ;-> ssd multiply evaluated + `(rplacd (cdr ,ssd) (%ilogior2 (%ilogand2 #x100FFFF (cdr (%cdr ,ssd))) + (%ilsl 16 ,reftype)))) + +(defmacro ssd-set-r/o (ssd) ;-> ssd multiply evaluated + `(rplacd (cdr ,ssd) (%ilogior2 #x1000000 (cdr (%cdr ,ssd))))) + +(defmacro copy-ssd (ssd) ;-> ssd multiply evaluated + `(list* (car ,ssd) (car (%cdr ,ssd)) (%cddr ,ssd))) +|# + +(defmacro named-ssd (name slot-list) `(assq ,name ,slot-list)) + +(defmacro sd-name (sd) `(car (svref ,sd 2))) +(defmacro sd-type (sd) `(svref ,sd 0)) +(defmacro sd-slots (sd) `(svref ,sd 1)) +(defmacro sd-superclasses (sd) `(svref ,sd 2)) +(defmacro sd-size (sd) `(svref ,sd 3)) +(defmacro sd-constructor (sd) `(svref ,sd 4)) +(defmacro sd-print-function (sd) `(svref ,sd 5)) +(defmacro sd-set-print-function (sd value) `(svset ,sd 5 ,value)) +(defmacro sd-refnames (sd) `(svref ,sd 6)) + +(defmacro struct-name (struct) `(class-cell-name (car (uvref ,struct 0)))) +(defmacro struct-def (struct) `(gethash (struct-name ,struct) %defstructs%)) + +;Can use this to let the printer print with print-function, reader read with +;constructor and slot-names, inspector inspect with slot-names. +;Everything else you have to arrange yourself. +#+ignore +(defmacro pretend-i-am-a-structure (name constructor print-function &rest slot-names) + (let ((slots slot-names) (offset 1) (supers (list name))) + (while slots + (%rplaca slots (make-ssd (%car slots) () offset t)) + (ssd-set-reftype (%car slots) $v_struct) + (setq slots (%cdr slots) offset (1+ offset))) + (push (make-ssd 0 `',supers 0 t) slot-names) + (ssd-set-reftype (%car slot-names) $v_struct) + `(puthash ',name %defstructs% + '#(internal-structure ;Make structure-class-p false. + ,slot-names + ,supers + ,offset + ,constructor + ,print-function + nil)))) + +(provide 'defstruct-macros) + +; End of defstruct-macros.lisp Index: /branches/qres/ccl/lib/defstruct.lisp =================================================================== --- /branches/qres/ccl/lib/defstruct.lisp (revision 13564) +++ /branches/qres/ccl/lib/defstruct.lisp (revision 13564) @@ -0,0 +1,309 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Defstruct.lisp + +(eval-when (eval compile) + (require 'defstruct-macros) + +) + +(defvar %structure-refs% (make-hash-table :test #'eq)) +(defvar %defstructs% (make-hash-table :test #'eq)) + +(defun make-ssd (name initform offset r/o &optional (type t)) + (let ((refinfo (%ilogior2 offset (if r/o #x1000000 0)))) + (list* name initform + (if (eq type 't) + refinfo + (cons type refinfo))))) + +(declaim (inline type-and-refinfo-p)) +(defun type-and-refinfo-p (object) + (or (fixnump object) (consp object))) + +(defun ssd-set-reftype (ssd reftype) + (ssd-update-refinfo (ssd refinfo) + (%ilogior2 (%ilogand2 #x300FFFF refinfo) + (%ilsl 16 reftype)))) + +(defun ssd-set-r/o (ssd) + (ssd-update-refinfo (ssd refinfo) + (%ilogior2 #x1000000 refinfo))) + +(defun ssd-set-inherited (ssd) + (ssd-update-refinfo (ssd refinfo) + (bitset $struct-inherited refinfo))) + +(defun copy-ssd (ssd) + (let* ((cdr (cdr ssd)) + (cddr (cdr cdr))) + (list* (%car ssd) (%car cdr) + (if (consp cddr) + (list* (%car cddr) (%cdr cddr)) + cddr)))) + +(declaim (inline ssd-type-and-refinfo)) +(defun ssd-type-and-refinfo (ssd) + (cddr ssd)) + +(defun ssd-type (ssd) + (let ((type-and-refinfo (ssd-type-and-refinfo ssd))) + (if (consp type-and-refinfo) + (%car type-and-refinfo) + 't))) + +(defun ssd-refinfo (ssd) + (let ((type-and-refinfo (ssd-type-and-refinfo ssd))) + (if (consp type-and-refinfo) (%cdr type-and-refinfo) type-and-refinfo))) + +(defun %structure-class-of (thing) + (let* ((cell (car (uvref thing 0)))) + (or (class-cell-class cell) + (setf (class-cell-class cell) + (find-class (class-cell-name cell)))))) + +;These might want to compiler-transform into non-typechecking versions... +(defun struct-ref (struct offset) + (if (structurep struct) (uvref struct offset) + (report-bad-arg struct 'structure-object))) + +(defun struct-set (struct offset value) + (if (structurep struct) (uvset struct offset value) + (report-bad-arg struct 'structure-object))) + +(defsetf struct-ref struct-set) + + +; things for defstruct to do - at load time +(defun %defstruct-do-load-time (sd predicate &optional doc &aux (name (sd-name sd))) + ;(declare (ignore refnames)) + (when (null (sd-type sd)) + (%define-structure-class sd)) + (when (and doc *save-doc-strings*) + (set-documentation name 'type doc)) + (puthash name %defstructs% sd) + (record-source-file name 'structure) + (when (and predicate (null (sd-type sd))) + (puthash predicate %structure-refs% name)) + (when *fasload-print* (format t "~&~S~%" name)) + name) + +(defun %defstruct-set-print-function (sd print-function print-object-p) + (sd-set-print-function sd (if print-object-p + (list print-function) + print-function))) + + +(defun sd-refname-pos-in-included-struct (sd name) + (dolist (included-type (cdr (sd-superclasses sd))) + (let ((sub-sd (gethash included-type %defstructs%))) + (when sub-sd + (let ((refnames (sd-refnames sub-sd))) + (if refnames + (let ((pos (position name refnames :test 'eq))) + (and pos (1+ pos))) + (dolist (slot (sd-slots sub-sd)) + (let ((ssd-name (ssd-name slot))) + (unless (fixnump ssd-name) + (when (eq name ssd-name) + (return-from sd-refname-pos-in-included-struct + (ssd-offset slot)))))))))))) + +;;; return stuff for defstruct to compile +(defun %defstruct-compile (sd refnames env) + (let ((stuff)) + (dolist (slot (sd-slots sd)) + (unless (fixnump (ssd-name slot)) + (let* ((accessor (if refnames (pop refnames) (ssd-name slot))) + (pos (sd-refname-pos-in-included-struct sd accessor))) + (if pos + (let ((offset (ssd-offset slot))) + (unless (eql pos offset) + ; This should be a style-warning + (warn "Accessor ~s at different position than in included structure" + accessor))) + (let ((fn (slot-accessor-fn slot accessor env))) + (push + `(progn + ,.fn + (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot)) + (record-source-file ',accessor 'structure-accessor)) + stuff)))))) + (nreverse stuff))) + + +; no #. for cross compile +(defvar *struct-ref-vector* + (vector #'(lambda (x) (struct-ref x 0)) + #'(lambda (x) (struct-ref x 1)) + #'(lambda (x) (struct-ref x 2)) + #'(lambda (x) (struct-ref x 3)) + #'(lambda (x) (struct-ref x 4)) + #'(lambda (x) (struct-ref x 5)) + #'(lambda (x) (struct-ref x 6)) + #'(lambda (x) (struct-ref x 7)) + #'(lambda (x) (struct-ref x 8)) + #'(lambda (x) (struct-ref x 9)))) + +(defvar *svref-vector* + (vector #'(lambda (x) (svref x 0)) + #'(lambda (x) (svref x 1)) + #'(lambda (x) (svref x 2)) + #'(lambda (x) (svref x 3)) + #'(lambda (x) (svref x 4)) + #'(lambda (x) (svref x 5)) + #'(lambda (x) (svref x 6)) + #'(lambda (x) (svref x 7)) + #'(lambda (x) (svref x 8)) + #'(lambda (x) (svref x 9)))) + + +;;; too bad there isnt a way to suppress generating these darn +;;; functions when you dont want them. Makes no sense to fetch +;;; functions from a vector of 68K functions and send them over to +;;; PPC. So can use that space optimization iff host and target are +;;; the same. + + +(defparameter *defstruct-share-accessor-functions* t) ;; TODO: isn't it time to get rid of this? + +(defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot))) + (cond ((eq ref $defstruct-nth) + (if (and (%i< offset 10) *defstruct-share-accessor-functions*) + `((eval-when (:compile-toplevel) + (record-function-info ',name ',*one-arg-defun-def-info* ,env)) + (fset ',name + ,(symbol-function + (%svref '#(first second third fourth fifth + sixth seventh eighth ninth tenth) offset)))) + `((defun ,name (x) (nth ,offset x))))) + ((eq ref $defstruct-struct) + (if (and (%i< offset 10) *defstruct-share-accessor-functions*) + `((eval-when (:compile-toplevel) + (record-function-info ',name ',*one-arg-defun-def-info* ,env)) + (fset ',name , (%svref *struct-ref-vector* offset))) + `((defun ,name (x) (struct-ref x ,offset))))) + ((or (eq ref target::subtag-simple-vector) + (eq ref $defstruct-simple-vector)) + (if (and (%i< offset 10) *defstruct-share-accessor-functions*) + `((eval-when (:compile-toplevel) + (record-function-info ',name ',*one-arg-defun-def-info* ,env)) + (fset ',name ,(%svref *svref-vector* offset))) + `((defun ,name (x) (svref x ,offset))))) + (t `((defun ,name (x) (uvref x ,offset)))))) + +(defun defstruct-reftype (type) + (cond ((null type) $defstruct-struct) + ((eq type 'list) $defstruct-nth) + (t (element-type-subtype (cadr type))))) + +(defun defstruct-slot-defs (sd refnames env) + (declare (ignore env)) + (let ((ref (defstruct-reftype (sd-type sd))) name defs) + (dolist (slot (sd-slots sd)) + (ssd-set-reftype slot ref) + (unless (fixnump (setq name (ssd-name slot))) ;Ignore fake 'name' slots + (when refnames (setq name (pop refnames))) + (unless (sd-refname-pos-in-included-struct sd name) + (push name defs)))) + (setq defs (nreverse defs)) + `((declaim (inline ,@defs))))) + +;;;Used by nx-transform, setf, and whatever... +(defun defstruct-ref-transform (predicate-or-type-and-refinfo args &optional env) + (if (type-and-refinfo-p predicate-or-type-and-refinfo) + (multiple-value-bind (type refinfo) + (if (consp predicate-or-type-and-refinfo) + (values (%car predicate-or-type-and-refinfo) + (%cdr predicate-or-type-and-refinfo)) + (values 't predicate-or-type-and-refinfo)) + (let* ((offset (refinfo-offset refinfo)) + (ref (refinfo-reftype refinfo)) + (accessor + (cond ((eq ref $defstruct-nth) + `(nth ,offset ,@args)) + ((eq ref $defstruct-struct) + `(struct-ref ,@args ,offset)) + ((eq ref target::subtag-simple-vector) + `(svref ,@args ,offset)) + (ref + `(aref (the (simple-array ,(element-subtype-type ref) (*)) + ,@args) ,offset)) + (t `(uvref ,@args ,offset))))) + (if (eq type 't) + accessor + (if (specifier-type-if-known type env) + `(the ,type ,accessor) + (if (nx-declarations-typecheck env) + `(require-type ,accessor ',type) + ;; Otherwise just ignore the type, it's most likely a forward reference, + ;; and while it means we might be missing out on a possible optimization, + ;; most of the time it's not worth warning about. + accessor))))) + `(structure-typep ,@args ',predicate-or-type-and-refinfo))) + +;;; Should probably remove the constructor, copier, and predicate as +;;; well. Can't remove the inline proclamations for the refnames, +;;; as the user may have explicitly said this. Questionable - but surely +;;; must delete the inline definitions. +;;; Doesn't remove the copier because we don't know for sure what it's name is +(defmethod change-class ((from structure-class) + (to class) + &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (let ((class-name (class-name from))) + (unless (eq from to) ; shouldn't be + (remove-structure-defs class-name) + (remhash class-name %defstructs%))) + (%change-class from to initargs)) + +;;; if redefining a structure as another structure or redefining a +;;; structure as a class +(defun remove-structure-defs (class-name) + (let ((sd (gethash class-name %defstructs%))) + (when sd + (dolist (refname (sd-refnames sd)) + (remhash refname %structure-refs%) + (let ((def (assq refname *nx-globally-inline*))) + (when def (set-function-info refname nil))) + (when (symbolp refname)(fmakunbound refname))) + #| + ;; The print-function may indeed have become obsolete, + ;; but we can't generally remove user-defined code + (let ((print-fn (sd-print-function sd))) + (when (symbolp print-fn) (fmakunbound print-fn))) + |# + (let ((constructor (sd-constructor sd))) + (when (symbolp constructor) (fmakunbound constructor))) + (let ((delete-match #'(lambda (pred struct-name) + (when (eq struct-name class-name) + (remhash pred %structure-refs%) + (fmakunbound pred))))) + (declare (dynamic-extent delete-match)) + ; get rid of the predicate + (maphash delete-match %structure-refs%))))) + +(defun copy-structure (source) + "Return a copy of STRUCTURE with the same (EQL) slot values." + (copy-uvector (require-type source 'structure-object))) + +(provide 'defstruct) + +; End of defstruct.lisp Index: /branches/qres/ccl/lib/describe.lisp =================================================================== --- /branches/qres/ccl/lib/describe.lisp (revision 13564) +++ /branches/qres/ccl/lib/describe.lisp (revision 13564) @@ -0,0 +1,1955 @@ +;;; -*- Mode:Lisp; Package:INSPECTOR -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage "INSPECTOR" + (:use "CL" "CCL") + (:export "MAKE-INSPECTOR" + "COMPUTE-LINE-COUNT" + "LINE-N" + "INSPECTOR-OBJECT" + "INSPECTOR-LINE-COUNT" + + "*INSPECTOR-DISASSEMBLY*")) + + + +(in-package "INSPECTOR") + +(defvar ccl::@) + +;;; The basic inspector object. +;;; Note that this knows nothing about windows. +;;; It merely knows how to number the constituent parts of an object, +;;; How to access a constituent, and how to print a constituent to a stream. +(defclass inspector () + ((object :accessor inspector-object :initarg :object) + (line-count :accessor inspector-line-count :initarg :line-count :initform nil) + ;; so can refresh. + (initargs :reader inspector-initargs :initform nil))) + +(defmethod initialize-instance :before ((i inspector) &rest initargs) + (setf (slot-value i 'initargs) initargs)) + +;;; The usual way to cons up an inspector +(defmethod make-inspector (object) + (multiple-value-bind (class alias) (inspector-class object) + (make-instance class :object (or alias object)))) + +(defmethod initialize-instance :after ((i inspector) &key update-line-count) + (when update-line-count + (update-line-count i))) + +(defmethod refresh-inspector ((i inspector)) + (apply #'make-instance (class-of i) (slot-value i 'initargs))) + +;; New protocol, used by gui inspector instead of the line-n protocol, which isn't quite right. +;; Perhaps tty inspector should use it as well. Returns the line inspector rather than object, +;; and returns the value string rather than having the caller print it. +(defmethod inspector-line ((i inspector) index) + (let ((line-i (multiple-value-bind (value label type) (inspector::line-n i index) + (and (not (eq (parse-type i type) :comment)) + (line-n-inspector i index value label type))))) + (multiple-value-bind (label-string value-string) (line-n-strings i index) + (values line-i label-string value-string)))) + +;; for a comment value = nil, label = "the comment" type = :comment +;;; => line-i = nil + +;;;;;;; +;;; +;;; The protocol for an inspector. +;;; Change these to defgeneric's when it exists. +;;; +;;; Usually, you need to define methods only for +;;; inspector-class, compute-line-count, line-n, and (setf line-n) + +;;; Return the type of inspector for an object +(defmethod inspector-class (object) + (cond ((method-exists-p #'line-n object 0) 'usual-inspector) + ((and (uvectorp object) + (find-class 'uvector-inspector nil)) + 'uvector-inspector) + (t 'basic-inspector))) + +;;; Return three values: the value, label, and type of the nth line of the object +;;; Valid types are: +;;; :NORMAL or NIL - a normal constituent line: changeable +;;; :COLON - a normal line with ": " between the label and the value +;;; :COMMENT - a commentary line - Print only the label +;;; :STATIC - a commentary line with an inspectable value: not changeable +(defmethod line-n ((i inspector) n) + (declare (ignore n))) + +; set the value of line n of the object (the label is fixed) +(defmethod (setf line-n) (value (i inspector) n) + (declare (ignore value n))) + +; Compute the number of lines in the object +(defmethod compute-line-count ((i inspector)) + 0 + ) + +; Compute the number of lines in the object and set the line-count slot +; If the length is greater than the limit, return (list limit) +(defun update-line-count (inspector) + (setf (inspector-line-count inspector) (compute-line-count inspector))) + +; Print the nth line to a stream +(defmethod prin1-line-n ((i inspector) stream n) + (multiple-value-call #'prin1-line i stream (line-n i n))) + +(defmethod prin1-line ((i inspector) stream value &optional label type function) + (unless function + (setq function (inspector-print-function i type))) + (funcall function i stream value label type)) + +(defvar *collect-labels-if-list* t) + +(defmethod end-of-label ((stream string-output-stream)) + (when (listp *collect-labels-if-list*) + (push (get-output-stream-string stream) *collect-labels-if-list*))) + +(defmethod line-n-strings ((i inspector) n) + (let* ((*collect-labels-if-list* ()) + (value-string (with-output-to-string (stream) + (prin1-line-n i stream n))) + (label-string (pop *collect-labels-if-list*)) + (end (or (position-if-not #'whitespacep label-string :from-end t) -1))) + (assert (null *collect-labels-if-list*)) + (unless (and (>= end 0) (eql (char label-string end) #\:)) (incf end)) + (setq label-string (subseq label-string 0 end)) + (values label-string value-string))) + +(defmethod inspector-print-function ((i inspector) type) + (declare (ignore type)) + 'prin1-normal-line) + +; Print a value to a stream. +(defmethod prin1-normal-line ((i inspector) stream value &optional label type + colon-p) + (let* ((type-sym (parse-type i type))) + (if (eq type-sym :colon) (setq colon-p t)) + (when label + (prin1-label i stream value label type) + (if colon-p (princ ": " stream))) + (end-of-label stream) ; used by cacheing code + (unless (eq type-sym :comment) + (prin1-value i stream value label type)))) + +(defun prin1-colon-line (i stream value &optional label type) + (prin1-normal-line i stream value label type t)) + +(defmethod prin1-label ((i inspector) stream value &optional label type) + (declare (ignore value type)) + (if (stringp label) + (write-string label stream) + (princ label stream))) + +(defmethod prin1-value ((i inspector) stream value &optional label type) + (declare (ignore label type)) + (prin1 value stream)) + +;;; Call function on the inspector object and its value, label, & type, for +;;; each line in the selected range (default to the whole thing). +;;; This can avoid (e.g.) doing NTH for each element of a list. +;;; This is the generic-function which the inspector-window uses to +;;; display a screenful. +(defmethod map-lines ((i inspector) function &optional + (start 0) + end) + (when (null (inspector-line-count i)) + (update-line-count i)) + (unless end + (setq end (inspector-line-count i))) + (when (and start end) + (let ((index start)) + (dotimes (c (- end start)) + (multiple-value-call function i index (inspector-line i index)) + (incf index))))) + +;;;;;;; +;;; +;;; Dealing with unbound slots and bogus objects +;;; +(defclass unbound-marker () ()) + +(defvar *unbound-marker* (make-instance 'unbound-marker)) +(defvar *slot-unbound-marker* (make-instance 'unbound-marker)) + +(defmethod print-object ((x unbound-marker) stream) + (print-object (ccl::%unbound-marker) stream)) + +(defclass bogus-object-wrapper () + ((address :initarg :address))) + +(defmethod print-object ((x bogus-object-wrapper) stream) + (print-unreadable-object (x stream) + (format stream "BOGUS object @ #x~x" (slot-value x 'address)))) + +(defvar *bogus-object-hash* + (make-hash-table :test 'eql :weak :value :size 0)) + +(defun bogus-object-wrapper (x) + (let ((address (%address-of x))) + (or (gethash address *bogus-object-hash*) + (setf (gethash address *bogus-object-hash*) + (make-instance 'bogus-object-wrapper :address address))))) + +(defun eliminate-unbound (x) + (cond ((eq x (ccl::%unbound-marker)) + *unbound-marker*) + ((eq x (ccl::%slot-unbound-marker)) + *slot-unbound-marker*) + ((ccl::bogus-thing-p x) + (bogus-object-wrapper x)) + (t x))) + +(defun restore-unbound (x) + (if (eq x *unbound-marker*) + (ccl::%unbound-marker) + (if (eq x *slot-unbound-marker*) + (ccl::%slot-unbound-marker) + x))) + +(defmethod line-n :around ((i inspector) n) + (declare (ignore n)) + (let ((res (multiple-value-list (call-next-method)))) + (declare (dynamic-extent res)) + (apply #'values (eliminate-unbound (car res)) (cdr res)))) + +(defmethod (setf line-n) :around (new-value (i inspector) n) + (call-next-method (restore-unbound new-value) i n)) + + +;;;;;;; +;;; +;;; describe-object +;;; Eventually, this wants to reuse a global inspector rather than +;;; consing one. +(defparameter *describe-pretty* t) + +(defmacro with-errorfree-printing (&body body) + `(let ((*print-readably* nil) + (*signal-printing-errors* nil)) + ,@body)) + +(defun format-line-for-tty (stream label-string value-string) + (when (equal label-string "") (setq label-string nil)) + (when (equal value-string "") (setq value-string nil)) + (format stream "~@[~a~]~@[~a~]~@[~a~]" + label-string + (and label-string + value-string + (not (eql #\space (char label-string (1- (length label-string))))) + ": ") + value-string)) + +(defun describe (object &optional stream) + "Print a description of the object X." + (cond ((null stream) (setq stream *standard-output*)) + ((eq stream t) (setq stream *terminal-io*))) + (setq stream (require-type stream 'stream)) + (let* ((*print-circle* t) + (*print-length* 20)) + (describe-object object stream) + (values))) + +(defmethod describe-object (object stream) + (let ((inspector (make-inspector object))) + (with-errorfree-printing + (let* ((*print-pretty* (or *print-pretty* *describe-pretty*)) + (temp #'(lambda (i index child &optional label-string value-string) + (declare (ignore i index child)) + (format-line-for-tty stream label-string value-string) + (terpri stream)))) + (declare (dynamic-extent temp)) + (map-lines inspector temp)))) + (values)) + +;;; usual-inspector +;;; Objects that know how to inspect themselves but don't need any +;;; special info other than the object can be a usual-inspector. +;;; This class exists mostly to save consing a class for every type +;;; of object in the world. +(defclass usual-inspector (inspector) + ()) + +;;;;;;; +;; +;; formatting-inspector +;; This one prints using a format string. +;; Expects line-n to return (values value label type format-string) + +(defclass formatting-inspector (inspector) ()) +(defclass usual-formatting-inspector (usual-inspector formatting-inspector) ()) + +(defmethod prin1-line ((i formatting-inspector) stream value + &optional label type (format-string "~s")) + (funcall (if (listp format-string) #'apply #'funcall) + #'format-normal-line i stream value label type format-string)) + +(defmethod format-normal-line ((i inspector) stream value &optional + label type (format-string "~s") colon-p) + (let* ((type-sym (parse-type i type))) + (if (eq type-sym :colon) (setq colon-p t)) + (when label + (prin1-label i stream value label type) + (if colon-p (princ ": " stream))) + (end-of-label stream) ; used by cacheing code + (unless (eq type-sym :comment) + (format stream format-string value)))) + +;;;;;;; +;; +;; inspectors for CCL objects +;; + + +(defmethod parse-type ((i inspector) type &optional default1 default2) + (declare (ignore default1 default2)) + (values (if (consp type) (car type) type))) + +;;; Used by the cache-entry-stream class to save the column where the label ends. +(defmethod end-of-label (stream) + (declare (ignore stream))) + + + +;;;;; +;; +;; The default inspector class +;; Used when we don't know what else to do +;; + +(defclass basic-inspector (inspector) ()) + +(defmethod compute-line-count ((i basic-inspector)) + 3) ; type, class, value + +(defun line-n-out-of-range (i n) + (error "~s is not a valid index for line-n of ~s" n i)) + +(defun setf-line-n-out-of-range (i n) + (error "~s is not a valid index for setf-line-n of ~s" n i)) + +(defmethod line-n ((i basic-inspector) n) + (let ((object (inspector-object i))) + (case n + (0 (values object nil :static)) + (1 (values (type-of object) "Type: " :static)) + (2 (values (class-of object) "Class: " :static)) + (t (line-n-out-of-range i n))))) + +;;;;;;; +;; +;; Automate the object being the first line +;; +(defclass object-first-mixin () ()) +(defclass object-first-inspector (object-first-mixin inspector) ()) + +(defmethod compute-line-count :around ((i object-first-mixin)) + (1+ (call-next-method))) + +(defmethod line-n :around ((i object-first-mixin) n) + (if (eql 0 n) + (values (inspector-object i) nil) + (call-next-method i (1- n)))) + +(defmethod (setf line-n) :around (value (i object-first-mixin) n) + (if (eql n 0) + (replace-object i value) + (call-next-method value i (1- n)))) + +(defun replace-object (inspector new-object) + (declare (ignore inspector)) + (make-inspector new-object)) + + +; A mixin that displays the object, its type, and its class as the first three lines. +(defclass basics-first-mixin () ()) + +(defmethod compute-line-count :around ((i basics-first-mixin)) + (+ 3 (call-next-method))) + +(defmethod line-n :around ((i basics-first-mixin) n) + (let ((object (inspector-object i))) + (case n + (0 (values object nil)) + (1 (values (type-of object) "Type: " :static)) + (2 (values (class-of object) "Class: " :static)) + (t (call-next-method i (- n 3)))))) + +(defmethod line-n-inspector :around ((i basics-first-mixin) n value label type) + (if (< n 3) + (make-inspector value) + (call-next-method i (- n 3) value label type))) + +(defmethod (setf line-n) :around (new-value (i basics-first-mixin) n) + (case n + (0 (replace-object i new-value)) + ((1 2) (setf-line-n-out-of-range i n)) + (t (call-next-method new-value i (- n 3))))) + +;;;;;;; +;; +(defclass usual-object-first-inspector (object-first-mixin usual-inspector) + ()) +(defclass usual-basics-first-inspector (basics-first-mixin usual-inspector) + ()) + +(defvar *inspector*) + +(defmethod compute-line-count ((i usual-inspector)) + (let ((*inspector* i)) + (compute-line-count (inspector-object i)))) + +(defmethod line-n ((i usual-inspector) n) + (let ((*inspector* i)) + (line-n (inspector-object i) n))) + +(defmethod (setf line-n) (value (i usual-inspector) n) + (let ((*inspector* i)) + (setf (line-n (inspector-object i) n) value))) + +(defmethod inspector-commands ((i usual-inspector)) + (let ((*inspector* i)) + (inspector-commands (inspector-object i)))) + +(defmethod inspector-commands (random) + (declare (ignore random)) + nil) + +;;;;;;; +;; +;; Bogus objects +;; + +(defclass bogus-object-inspector (object-first-inspector) + ()) + +(defmethod compute-line-count ((i bogus-object-inspector)) + 3) + +(defmethod line-n ((i bogus-object-inspector) n) + (values + nil + (case n + (0 "One cause of a bogus object is when a stack consed object is stored") + (1 "in a register and then control exits the dynamic-extent of the object.") + (2 "The compiler doesn't bother to clear the register since it won't be used again.")) + '(:comment :plain :plain))) + +(defmethod inspector-class :around (object) + (if (ccl::bogus-thing-p object) + 'bogus-object-inspector + (call-next-method))) + +;;;;;;; +;; +;; A general sequence inspector +;; +(defclass sequence-inspector (inspector) + ((print-function :initarg :print-function :initform #'prin1 :reader print-function) + (commands :initarg :commands :initform nil :accessor inspector-commands) + (line-n-inspector :initform nil :initarg :line-n-inspector + :accessor line-n-inspector-function) + (replace-object-p :initform nil :initarg :replace-object-p + :reader replace-object-p) + (resample-function :initform nil :initarg :resample-function + :reader resample-function) + (line-n-function :initform nil :initarg :line-n-function + :reader line-n-function) + (setf-line-n-p :initform t :initarg :setf-line-n-p + :reader setf-line-n-p)) + (:default-initargs :update-line-count t)) + + + +(defmethod compute-line-count ((i sequence-inspector)) + (let ((resample-function (resample-function i))) + (when resample-function + (setf (inspector-object i) (funcall resample-function i)))) + (length (inspector-object i))) + +(defmethod line-n ((i sequence-inspector) n) + (let ((f (line-n-function i))) + (if f + (funcall f i n) + (values (elt (inspector-object i) n) nil (unless (setf-line-n-p i) :static))))) + +(defmethod (setf line-n) (new-value (i sequence-inspector) n) + (if (setf-line-n-p i) + (setf (elt (inspector-object i) n) new-value) + (setf-line-n-out-of-range i n))) + +(defmethod prin1-value ((inspector sequence-inspector) stream value + &optional label type) + (declare (ignore label type)) + (funcall (print-function inspector) value stream)) + +(defmethod line-n-inspector ((i sequence-inspector) n value label type) + (let ((f (line-n-inspector-function i))) + (or (and f (funcall f i n value label type)) (call-next-method)))) + +;;;;;;; +;; +;; standard-object +;; This should be redone to use the exported class query functions +;; (as soon as they exist) +;; +(defclass standard-object-inspector (object-first-inspector) + ()) + +(defmethod inspector-class ((o standard-object)) + 'standard-object-inspector) + +(defmethod compute-line-count ((i standard-object-inspector)) + (standard-object-compute-line-count i)) + +(defun standard-object-compute-line-count (i) + (let* ((object (ccl::maybe-update-obsolete-instance (inspector-object i))) + (class (class-of object)) + (all-slots (ccl::class-slots class))) + (multiple-value-bind (instance-slots class-slots other-slots) (ccl::extract-instance-class-and-other-slotds all-slots) + (let* ((ninstance-slots (length instance-slots)) + (nclass-slots (length class-slots)) + (nother-slots (length other-slots))) + (+ 2 ; class, wrapper + (if (eql 0 ninstance-slots) + 0 + (1+ ninstance-slots)) + (if (eql 0 nclass-slots) + 0 + (1+ nclass-slots)) + (if (eql 0 nother-slots) + 0 + (1+ nother-slots)) + (if (eql 0 (+ nclass-slots ninstance-slots nother-slots)) + 1 + 0)))))) + +(defun slot-value-or-unbound (instance slot-name) + (eliminate-unbound (ccl::slot-value-if-bound instance slot-name + (ccl::%slot-unbound-marker)))) + +(defparameter *standard-object-type* (list nil)) +(defparameter *standard-object-static-type* + (cons :static (cdr *standard-object-type*))) +(defparameter *standard-object-comment-type* + (list :comment)) + +(defmethod line-n ((i standard-object-inspector) n) + (standard-object-line-n i n)) + +(defmethod prin1-label ((i standard-object-inspector) stream value &optional label type) + (declare (ignore value type)) + (if (symbolp label) + (prin1 label stream) + (call-next-method))) + +; Looks like +; Class: +; Wrapper: +; [Instance slots: +; slots...] +; [Class slots: +; slots...] +; [Other slots: +; slots...] + +(defun standard-object-line-n (i n) + (let* ((instance (inspector-object i)) + (class (class-of instance)) + (all-slots (class-slots class)) + (wrapper (or (ccl::standard-object-p instance) + (if (typep instance 'ccl::funcallable-standard-object) + (ccl::gf.instance.class-wrapper instance)))) + (instance-start 2)) + (if (< n instance-start) + (if (eql n 0) + (values class "Class: " :normal) + (values wrapper "Wrapper: " :static)) + (multiple-value-bind (instance-slotds class-slotds other-slotds) + (ccl::extract-instance-class-and-other-slotds all-slots) + (let* ((instance-count (length instance-slotds)) + (shared-start (+ instance-start instance-count + (if (eql 0 instance-count) 0 1)))) + (if (< n shared-start) + (if (eql n instance-start) + (values nil "Instance slots" :comment) + (let ((slot-name (slot-definition-name + (elt instance-slotds (- n instance-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (let* ((shared-count (length class-slotds)) + (shared-end (+ shared-start shared-count + (if (eql shared-count 0) 0 1)))) + (if (< n shared-end) + (if (eql n shared-start) + (values nil "Class slots" :comment) + (let ((slot-name (slot-definition-name + (elt class-slotds (- n shared-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (let* ((other-start shared-end) + (other-end (+ other-start (if other-slotds (1+ (length other-slotds)) 0)))) + (if (< n other-end) + (if (eql n other-start) + (values nil "Other slots" :comment) + (let ((slot-name (slot-definition-name + (elt other-slotds (- n other-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (if (and (eql 0 instance-count) (eql 0 shared-count) (null other-slotds) (eql n other-end)) + (values nil "No Slots" :comment) + (line-n-out-of-range i n)))))))))))) + +(defmethod (setf line-n) (value (i standard-object-inspector) n) + (standard-object-setf-line-n value i n)) + +(defun standard-object-setf-line-n (value i n) + (let* ((instance (inspector-object i)) + (class (class-of instance)) + (instance-start 2)) + (if (< n instance-start) + (cond + ((eql n 0) (change-class instance value) + (update-line-count i)) + (t (setf-line-n-out-of-range i n))) + (let* ((slotds (ccl::extract-instance-effective-slotds class)) + (instance-count (length slotds)) + (shared-start (+ instance-start instance-count + (if (eql 0 instance-count) 0 1)))) + (if (< n shared-start) + (if (eql n instance-start) + (setf-line-n-out-of-range i n) + (let ((slot-name (slot-definition-name + (elt slotds (- n instance-start 1))))) + (setf (slot-value instance slot-name) (restore-unbound value)))) + (let* ((slotds (ccl::extract-class-effective-slotds class)) + (shared-count (length slotds)) + (shared-end (+ shared-start shared-count + (if (eql shared-count 0) 0 1)))) + (if (< n shared-end) + (if (eql n shared-start) + (setf-line-n-out-of-range i n) + (let ((slot-name (slot-definition-name + (elt slotds (- n shared-start 1))))) + (setf (slot-value instance slot-name) + (restore-unbound value)))) + (setf-line-n-out-of-range i n)))))))) + + + +;;;;;;;;;;; Inspector objects for common classes. + +(defparameter *plain-comment-type* '(:comment (:plain))) +(defparameter *bold-comment-type* '(:comment (:bold))) + +(defun resample-it () + ) + +;;;;;;; +;; +;; Lists +;; +(defclass cons-inspector (basics-first-mixin inspector) ()) + +(defclass list-inspector (basics-first-mixin inspector) + ((length :accessor list-inspector-length) + (dotted-p :accessor list-inspector-dotted-p) + (nthcdr :accessor list-inspector-nthcdr) + (n :accessor list-inspector-n))) + +(defmethod inspector-class ((o list)) + (if (listp (cdr o)) + 'list-inspector + 'cons-inspector)) + +; Same as list-length-and-final-cdr, but computes the real length of the list +(defun real-list-length (list) + (multiple-value-bind (len final-cdr max-circ-len) + (ccl::list-length-and-final-cdr list) + (if (null max-circ-len) + (values len final-cdr nil) + (let ((middle (nthcdr max-circ-len list)) + (n 1)) + (loop (when (eq list middle) (return)) + (pop list) + (incf n)) + (pop list) + (loop (when (eq list middle) (return)) + (pop list) + (incf n)) + (values nil nil n))))) + +(defmethod compute-line-count ((i list-inspector)) + (multiple-value-bind (len final-cdr circ-len) (real-list-length (inspector-object i)) + (setf (list-inspector-dotted-p i) final-cdr) + (setf (list-inspector-nthcdr i) (inspector-object i)) + (setf (list-inspector-n i) 0) + (+ 1 ; regular, dotted, or circular + 1 ; length + (abs (setf (list-inspector-length i) + (or len (- circ-len)))) ; the elements + (if final-cdr 2 0)))) ; the final-cdr and it's label + +(defmethod compute-line-count ((i cons-inspector)) + 2) ; car & cdr + +(defmethod line-n ((i list-inspector) en &aux (n en)) + (let* ((circ? (list-inspector-length i)) + (length (abs circ?))) + (cond ((eql 0 n) + (values nil (cond ((list-inspector-dotted-p i) "Dotted List") + ((< circ? 0) "Circular List") + (t "Normal List")) + *plain-comment-type*)) + ((eql 0 (decf n)) (values length "Length: ")) + ((>= (decf n) (setq length length)) ; end of dotted list + (let ((final-cdr (list-inspector-dotted-p i))) + (unless final-cdr (line-n-out-of-range i en)) + (if (eql n length) + (values nil "Non-nil final cdr" *plain-comment-type*) + (values final-cdr (- length 0.5) :colon)))) + (t (let* ((saved-n (list-inspector-n i)) + (nthcdr (if (>= n saved-n) + (nthcdr (- n saved-n) (list-inspector-nthcdr i)) + (nthcdr n (inspector-object i))))) + (setf (list-inspector-nthcdr i) nthcdr + (list-inspector-n i) n) + (values (car nthcdr) n :colon)))))) + +(defmethod line-n ((i cons-inspector) n) + (let ((object (inspector-object i))) + (ecase n + (0 (values (car object) "Car: ")) + (1 (values (cdr object) "Cdr: "))))) + +(defmethod (setf line-n) (value (i list-inspector) n) + (when (< n 2) + (setf-line-n-out-of-range i n)) + (decf n 2) + (setf (elt (inspector-object i) n) value) + (resample-it)) + +(defmethod (setf line-n) (value (i cons-inspector) n) + (let ((object (inspector-object i))) + (ecase n + (0 (setf (car object) value)) + (1 (setf (cdr object) value)))) + (resample-it)) + +;;;;;;; +;; +;; General uvector's +;; +(defclass uvector-inspector (basics-first-mixin inspector) + ((name-list :initarg :name-list :initform nil :accessor name-list))) + +(defmethod uvector-name-list (object) + (let* ((type (type-of object)) + (names (cdr (assq type ccl::*def-accessor-types*))) + (names-size (length names)) + res) + (when names + (dotimes (i (uvsize object)) + (declare (fixnum i)) + (let ((name (and (> names-size i) (aref names i)))) + (if name + (push (if (listp name) (car name) name) res) + (if (and (eql i 0) (typep object 'ccl::internal-structure)) + (push 'type res) + (push i res))))) + (nreverse res)))) + +(defmethod compute-line-count ((i uvector-inspector)) + (setf (name-list i) (uvector-name-list (inspector-object i))) + (uvsize (inspector-object i))) + +(defmethod line-n ((i uvector-inspector) n) + (values (uvref (inspector-object i) n) + (or (let ((name-list (name-list i))) (and name-list (nth n (name-list i)))) + n) + :colon)) + +(defmethod (setf line-n) (new-value (i uvector-inspector) n) + (setf (uvref (inspector-object i) n) new-value)) + +(defmethod inspector-commands ((i uvector-inspector)) + (let ((object (inspector-object i))) + (if (method-exists-p #'inspector-commands object) + (inspector-commands object)))) + +;;;;;;; +;; +;; Vectors & Arrays +;; +(defmethod inspector-class ((v ccl::simple-1d-array)) + 'usual-basics-first-inspector) + +(defmethod compute-line-count ((v ccl::simple-1d-array)) + (+ 1 (length v))) + +(defmethod line-n ((v ccl::simple-1d-array) n) + (cond ((eql 0 n) (values (length v) "Length" :static 'prin1-colon-line)) + (t (decf n 1) + (values (aref v n) n :colon)))) + +(defmethod (setf line-n) (value (v ccl::simple-1d-array) n) + (when (<= n 0) + (setf-line-n-out-of-range v n)) + (decf n 1) + (prog1 (setf (aref v n) value) + (resample-it))) + +(defclass array-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((v array)) + 'array-inspector) + +(defmethod uvector-name-list ((a array)) + (if (eql 1 (array-rank a)) + (if (array-has-fill-pointer-p a) + '("Fill Pointer" "Physical size" "Data vector" "Displacement" "Flags") + '("Logical size" "Physical size" "Data vector" "Displacement" "Flags")) + `("Rank" "Physical size" "Data vector" "Displacement" "Flags" "Dim0" "Dim1" "Dim2" "Dim3"))) + +(defmethod compute-line-count ((i array-inspector)) + (let* ((a (inspector-object i)) + (rank (array-rank a))) + (call-next-method) ; calculate name list + (+ (if (eql rank 1) (1+ (uvsize a)) 7) + (apply #'* (array-dimensions a))))) + +(defmethod line-n ((i array-inspector) n) + (let* ((v (inspector-object i)) + (rank (array-rank v)) + (uvsize (if (eql rank 1) + (+ (uvsize v) 1) + 7))) + (cond ((eql 0 n) (values (array-element-type v) + (if (adjustable-array-p v) + "Adjustable, Element type" + "Element type") + :static 'prin1-colon-line)) + ((eql 5 n) + (values (uvref v target::vectorH.flags-cell) + "Flags: " + :static + #'(lambda (i s v l type) + (format-normal-line i s v l type "#x~x")))) + ((and (eql 6 n) (not (eql rank 1))) + (values (array-dimensions v) "Dimensions: " :static)) + ((< n uvsize) (call-next-method i (1- n))) + (t (let ((index (- n uvsize))) + (values (row-major-aref v index) (array-indices v index) :colon)))))) + +(defmethod (setf line-n) (new-value (i array-inspector) n) + (let* ((v (inspector-object i)) + (rank (array-rank v)) + (uvsize (if (eql rank 1) + (+ (uvsize v) 1) + 7))) + (prog1 + (cond ((or (eql 0 n) (eql 1 n) (and (eql 4 n) (not (eql rank 1)))) + (setf-line-n-out-of-range i n)) + ((< n uvsize) + (if (eql 3 n) + (setq new-value (require-type new-value 'array)) + (setq new-value (require-type new-value 'fixnum))) + (call-next-method new-value i (1- n))) + (t (let ((index (- n uvsize))) + (setf (row-major-aref v index) new-value)))) + (resample-it)))) + +(defun array-indices (a row-major-index) + (let ((rank (array-rank a))) + (if (eql 1 rank) + row-major-index + (let ((res nil) + dim + (dividend row-major-index) + remainder) + (loop + (when (zerop rank) (return res)) + (setq dim (array-dimension a (decf rank))) + (multiple-value-setq (dividend remainder) (floor dividend dim)) + (push remainder res)))))) + +(defmethod prin1-line ((i array-inspector) stream value &optional + label type function) + (declare (ignore stream value type function)) + (if (or (numberp label) (listp label)) ; First line or contents lines + (call-next-method) + (let ((*print-array* nil)) + (call-next-method)))) + +;;;;;;; +;; +;; Numbers +;; +(defmethod inspector-class ((num number)) 'usual-formatting-inspector) + +; floats +(defmethod compute-line-count ((num float)) 5) + +(defmethod line-n ((num float) n) + (let ((type :static)) + (ecase n + (0 (values num "Float: " type)) + (1 (values num "Scientific: " type + (if (< num 0) "~8,2e" "~7,2e"))) + (2 (values (if (zerop num) "illegal" (log num 2)) + "Log base 2: " type "~d")) + (3 (values (rationalize num) + "Ratio equiv: " type)) + (4 (values (round num) + "Nearest integer: " type))))) + +; complex numbers +(defmethod compute-line-count ((num complex)) 3) + +(defmethod line-n ((num complex) n) + (let ((type :static)) + (ecase n + (0 (values num "Complex num: " type)) + (1 (values (realpart num) "Real part: " type)) + (2 (values (imagpart num) "Imaginary part: " type))))) + +; ratios +(defmethod compute-line-count ((num ratio)) 6) + +(defmethod line-n ((num ratio) n) + (let ((type :static)) + (ecase n + (0 (values num "Ratio: " type)) + (1 (values (float num) "Scientific: " type + (if (< num 0) "~8,2e" "~7,2E"))) + (2 (values (if (zerop num) "illegal" (log num 2)) + "Log base 2: " type "~d")) + (3 (values (round num) "Nearest integer: " type)) + (4 (values (numerator num) "Numerator: " type)) + (5 (values (denominator num) "Denominator: " type))))) + +; integers +(defmethod compute-line-count ((num integer)) + (let ((res 12)) + (unless (< 0 num 4000) (decf res)) ; not a roman number + (unless (<= 0 num 255) (decf res)) ; not a character + res)) + +(defmethod line-n ((num integer) n) + (if (and (>= n 7) (not (< 0 num 4000))) (incf n)) ; maybe skip roman. + (if (and (>= n 8) (not (<= 0 num 255))) (incf n)) ; maybe skip character. + (let* ((type :static) + (neg? (< num 0)) + (norm (if neg? + (+ num (expt 2 (max 32 (* 4 (round (+ (integer-length num) 4) 4))))) + num))) + (ecase n + (0 (values num + (if (fixnump num) + "Fixnum: " + "Bignum: ") + type "~s")) + (1 (let ((num (ignore-errors (float num)))) + (values num "Scientific: " type + (cond ((null num) "FLOATING-POINT-OVERFLOW") + ((< num 0) "~8,2e") + (t "~7,2e"))))) + (2 (values (if (zerop num) "illegal" (log num 2)) + "Log base 2: " type "~d")) + (3 (values norm + "Binary: " type + (if neg? "#b...~b" "#b~b"))) + (4 (values norm + "Octal: " type + (if neg? "#o...~o" "#o~o"))) + (5 (values num + "Decimal: " type "~d.")) + (6 (values norm + "Hex: " type + (if neg? "#x...~x" "#x~x"))) + (7 (values (format nil "~@r" num) + "Roman: " type "~a")) + (8 (values (code-char num) + "Character: " type "~s")) + (9 (values (ccl::ensure-simple-string (prin1-to-string num)) + "Abbreviated: " + type #'format-abbreviated-string)) + (10 (values (or (ignore-errors (universal-time-string num)) "#") + "As time: " type "~a")) + (11 (if (< num 0) + (values most-negative-fixnum 'most-negative-fixnum type '("~d." t)) + (values most-positive-fixnum 'most-positive-fixnum type '("~d." t))))))) + +(defun format-abbreviated-string (stream string) + (setq string (require-type string 'simple-string)) + (let ((length (length string))) + (if (< length 7) + (princ string stream) + (format stream "~a <- ~s digits -> ~a" + (subseq string 0 3) + (- length 6) + (subseq string (- length 3) length))))) + +(defun universal-time-string (num) + (multiple-value-bind (second minute hour date month year day) + (decode-universal-time num) + (with-output-to-string (s) + (format s "~d:~2,'0d:~2,'0d " hour minute second) + (princ (nth day '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday" "Sunday")) + s) + (format s ", ~d " date) + (princ (nth month '("" "January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + s) + (format s ", ~d" year)))) + +; Characters +(defmethod compute-line-count ((ch character)) 2) + +(defmethod line-n ((ch character) n) + (let ((type :static)) + (ecase n + (0 (values ch "Character: " type)) + (1 (values (char-code ch) "char-code: " type))))) + +;;;;;;; +;; +;; Symbols +;; +(defun symbol-has-bindings-p (sym) + (or (constantp sym) (proclaimed-special-p sym) (boundp sym) + (special-operator-p sym) (macro-function sym) (fboundp sym) + (type-specifier-p sym) (record-type-p sym nil) + (find-class sym nil))) + +(defmethod inspector-class ((sym symbol)) 'usual-basics-first-inspector) + +(defmethod compute-line-count ((sym symbol)) + (+ (if (symbol-has-bindings-p sym) 1 0) + 1 ; package + 1 ; symbol-name + 1 ; symbol-value + 1 ; symbol-function + (if (fboundp sym) 1 0) ; arglist + 1 ; plist + (if (find-class sym nil) 1 0) ; class + )) + + +(defmethod normalize-line-number ((sym symbol) n) + (if (and (>= n 0) (not (symbol-has-bindings-p sym))) (incf n)) + (if (and (>= n 5) (not (fboundp sym))) (incf n)) + n) + +(defmethod line-n ((sym symbol) n) + (setq n (normalize-line-number sym n)) + (let ((type :normal) + (comment '(:comment (:bold))) + (static :static)) + (ecase n + (0 (values nil (symbol-type-line sym) comment)) + (1 (let ((p (symbol-package sym))) + (if (null p) + (values nil "No home package." comment) + (multiple-value-bind (found kind) (find-symbol (symbol-name sym) p) + (values p + (if (or (null kind) (neq found sym)) + "NOT PRESENT in home package: " + (format nil "~a in package: " kind)) + static))))) + (2 (values (symbol-name sym) "Print name: " static)) + (3 (values (if (boundp sym) (symbol-value sym) *unbound-marker*) + "Value: " type)) + (4 (values (if (fboundp sym) + (cond ((macro-function sym)) + ((special-operator-p sym) sym) + (t (symbol-function sym))) + *unbound-marker*) + "Function: " type)) + (5 (values (and (fboundp sym) (arglist sym)) + "Arglist: " static)) + (6 (values (symbol-plist sym) "Plist: " type)) + (7 (values (find-class sym) "Class: " static))))) + +(defmethod (setf line-n) (value (sym symbol) n) + (let (resample-p) + (setq n (normalize-line-number sym n)) + (setq value (restore-unbound value)) + (ecase n + ((0 1 2 5) (setf-line-n-out-of-range sym n)) + (3 (setf resample-p (not (boundp sym)) + (symbol-value sym) value)) + (4 (setf resample-p (not (fboundp sym)) + (symbol-function sym) value)) + (6 (setf (symbol-plist sym) value))) + (when resample-p (resample-it)) + value)) + +(defun record-type-p (name &optional check-database) + (declare (ignore check-database)) + (and (keywordp name) + (ignore-errors (ccl::%foreign-type-or-record name)))) + +; Add arglist here. +(defun symbol-type-line (sym) + (let ((types (list + (cond ((constantp sym) + "Constant") + ((proclaimed-special-p sym) + "Special Variable") + ((boundp sym) + "Non-special Variable") + (t nil)) + (cond ((special-operator-p sym) + "Special Operator") + ((macro-function sym) + "Macro") + ((fboundp sym) + "Function") + (t nil)) + (if (type-specifier-p sym) "Type Specifier") + (if (record-type-p sym nil) "Record Type") + (if (find-class sym nil) "Class Name"))) + flag) + (with-output-to-string (s) + (dolist (type types) + (when type + (if flag (write-string ", " s)) + (setq flag t) + (write-string type s)))))) + + +(defmethod inspector-commands ((sym symbol)) + (let ((res nil)) + '(push (list "Documentation" #'(lambda () (show-documentation sym))) + res) + (let ((class (find-class sym nil))) + (if class + (push (list "Inspect Class" #'(lambda () (inspect class))) res))) + (if (boundp sym) + (push (list "MAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(makunbound ',sym))) + (makunbound sym) (resample-it)))) + res)) + (if (fboundp sym) + (push (list "FMAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(fmakunbound ',sym))) + (fmakunbound sym) (resample-it)))) + res)) + '(if (record-type-p sym) + (push (list "Inspect Record Type" #'(lambda () (inspect-record-type sym))) + res)) + (nreverse res))) + + +(defmethod line-n-inspector ((sym symbol) n value label type) + (declare (ignore label type)) + (setq n (normalize-line-number sym n)) + (if (eql n 6) + (make-instance 'plist-inspector :symbol sym :object value) + (call-next-method))) + +(defclass plist-inspector (inspector) + ((symbol :initarg :symbol :reader plist-symbol))) + +(defmethod inspector-window-title ((i plist-inspector)) + (format nil "~a of ~s" 'plist (plist-symbol i))) + +(defmethod compute-line-count ((i plist-inspector)) + (+ 3 (/ (length (inspector-object i)) 2))) + +(defmethod line-n ((i plist-inspector) n) + (let* ((plist (inspector-object i))) + (cond ((eql 0 n) (values plist "Plist: ")) + ((eql 1 n) (values (plist-symbol i) "Symbol: " :static)) + ((eql 2 n) (values nil nil :comment)) + (t (let ((rest (nthcdr (* 2 (- n 3)) plist))) + (values (cadr rest) (car rest) :colon)))))) + +(defmethod (setf line-n) (new-value (i plist-inspector) n) + (let* ((plist (inspector-object i))) + (if (eql n 0) + (replace-object i new-value) + (if (< n 3) + (setf-line-n-out-of-range i n) + (let ((rest (nthcdr (* 2 (- n 3)) plist))) + (setf (cadr rest) new-value) + (resample-it)))))) + +(defparameter *inspector-disassembly* nil) + +;;;;;;; +;; +;; Functions +;; +(defclass function-inspector (inspector) + ((header-lines :initform nil :reader header-lines) + (disasm-p :accessor disasm-p :initform *inspector-disassembly*) + (disasm-info :accessor disasm-info) + (pc-width :accessor pc-width) + (pc :initarg :pc :initform nil :accessor pc))) + +(defmethod standard-header-count ((f function-inspector)) (length (header-lines f))) + +(defmethod header-count ((f function-inspector)) (standard-header-count f)) + +(defclass closure-inspector (function-inspector) + ((n-closed :accessor closure-n-closed))) + +(defmethod inspector-class ((f function)) 'function-inspector) +(defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector) + +(defmethod compute-line-count :before ((f function-inspector)) + (let* ((o (inspector-object f)) + (doc (documentation o t)) + (sn (ccl::function-source-note o)) + (lines (nconc (list (list o "")) + (list (list (function-name o) "Name" :colon)) + (list (multiple-value-bind (arglist type) (arglist o) + (let ((label (if type + (format nil "Arglist (~(~a~))" type) + "Arglist unknown"))) + (list arglist label (if type :colon '(:comment (:plain))))))) + (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon))) + (when sn (list (list sn "Source Location" :colon)))))) + (setf (slot-value f 'header-lines) lines))) + +(defmethod compute-line-count ((f function-inspector)) + (+ (header-count f) (compute-disassembly-lines f))) + +(defmethod line-n-strings ((f function-inspector) n) + (if (< (decf n (header-count f)) 0) + (call-next-method) + (disassembly-line-n-strings f n))) + +(defmethod line-n-inspector ((f function-inspector) n value label type) + (declare (ignore value label type)) + (if (< (decf n (header-count f)) 0) + (call-next-method) + (disassembly-line-n-inspector f n))) + +(defmethod line-n ((f function-inspector) n) + (let* ((lines (header-lines f)) + (nlines (length lines))) + (if (< n nlines) + (apply #'values (nth n lines)) + (disassembly-line-n f (- n nlines))))) + +(defmethod compute-line-count :before ((f closure-inspector)) + (let* ((o (inspector-object f)) + (nclosed (nth-value 8 (function-args (ccl::closure-function o))))) + (setf (closure-n-closed f) nclosed))) + +(defmethod header-count ((f closure-inspector)) + (+ (standard-header-count f) + 1 ; the function we close over + 1 ; "Closed over values" + (closure-n-closed f))) + +(defmethod line-n ((f closure-inspector) n) + (let ((o (inspector-object f)) + (nclosed (closure-n-closed f))) + (if (< (decf n (standard-header-count f)) 0) + (call-next-method) + (cond ((< (decf n) 0) + (values (ccl::closure-function o) "Inner lfun: " :static)) + ((< (decf n) 0) + (values nclosed "Closed over values" :comment)) + ((< n nclosed) + (let* ((value (ccl::nth-immediate o (1+ (- nclosed n)))) + (map (car (ccl::function-symbol-map (ccl::closure-function o)))) + (label (or (and map (svref map (+ n (- (length map) nclosed)))) + n)) + (cellp (ccl::closed-over-value-p value))) + (when cellp + (setq value (ccl::closed-over-value value) + label (format nil "(~a)" label))) + (values value label (if cellp :normal :static) #'prin1-colon-line))) + (t (disassembly-line-n f (- n nclosed))))))) + +(defmethod (setf line-n) (new-value (f function-inspector) n) + (let ((o (inspector-object f)) + (standard-header-count (standard-header-count f))) + (if (< n standard-header-count) + (case n + (0 (replace-object f new-value)) + (1 (ccl::lfun-name o new-value) (resample-it)) + (t (setf-line-n-out-of-range f n))) + (set-disassembly-line-n f (- n standard-header-count) new-value))) + new-value) + +(defmethod (setf line-n) (new-value (f closure-inspector) en &aux (n en)) + (let ((o (inspector-object f)) + (nclosed (closure-n-closed f))) + (if (< (decf n (standard-header-count f)) 0) + (call-next-method) + (cond ((< (decf n 2) 0) ; inner-lfun or "Closed over values" + (setf-line-n-out-of-range f en)) + ((< n nclosed) ; closed-over variable + (let* ((value (ccl::nth-immediate o (1+ (- nclosed n)))) + (cellp (ccl::closed-over-value-p value))) + (unless cellp (setf-line-n-out-of-range f en)) + (ccl::set-closed-over-value value new-value))) + (t (set-disassembly-line-n f (- n nclosed) new-value)))))) + +(defun compute-disassembly-lines (f &optional (function (inspector-object f))) + (if (and (functionp function) (disasm-p f)) + (let* ((lines (ccl::disassemble-lines function)) ;; list of (object label instr) + (length (length lines)) + (last-label (loop for n from (1- length) downto 0 as line = (aref lines n) + thereis (and (consp line) (cadr line)))) + (max-pc (if (consp last-label) (cadr last-label) last-label))) + (setf (pc-width f) (length (format nil "~d" max-pc))) + (setf (disasm-info f) lines) + (1+ length)) + 0)) + +(defun disassembly-line-n (f n) + (if (< (decf n) 0) + (values nil "Disassembly:" :comment) + (let ((line (svref (disasm-info f) n))) + (if (consp line) + (destructuring-bind (object label instr) line + (values object (cons label instr) :static)) + (values nil (cons nil line) :static))))) + +(defun disassembly-line-n-inspector (f n) + (unless (< (decf n) 0) + (let ((line (svref (disasm-info f) n))) + (and (consp line) + (car line) + (make-inspector (car line)))))) + +(defun disassembly-line-n-strings (f n) + (if (< (decf n) 0) + (values "Disassembly:" nil) + (let ((line (svref (disasm-info f) n))) + (if (consp line) + (destructuring-bind (object label instr) line + (declare (ignore object)) + (unless (stringp label) + (setq label (with-output-to-string (stream) + (prin1-disassembly-label f stream label)))) + (values label instr)) + (values nil line))))) + +(defun set-disassembly-line-n (f n new-value &optional + (function (inspector-object f))) + (declare (ignore new-value function)) + (setf-line-n-out-of-range f n)) + +(defmethod prin1-label ((f function-inspector) stream value &optional data type) + (declare (ignore value type)) + (if (atom data) ; not a disassembly line + (call-next-method) + (prin1-disassembly-label f stream (car data)))) + +(defun prin1-disassembly-label (f stream label) + (let* ((pc label) + (label-p (and (consp pc) (setq pc (cadr pc)))) + (pc-mark (pc f)) + (pc-width (pc-width f))) + (when pc + (write-char (if (eql pc pc-mark) #\* #\Space) stream) + (format stream "~@[L~d~]~vT~v<[~d]~> " label-p (+ pc-width 3) (+ pc-width 2) pc)))) + +#+x86-target +(defmethod prin1-value ((f function-inspector) stream value &optional data type) + (declare (ignore value type)) + (if (atom data) ;; not a disassembly line + (call-next-method) + (princ (cdr data) stream))) + + +#+ppc-target +(defmethod prin1-value ((f function-inspector) stream value &optional label type) + (if (atom label) ; not a disassembly line + (unless (eq (if (consp type) (car type) type) :comment) + (call-next-method)) + (let ((q (cdr label))) + (write-char #\( stream) + (loop (if (null q) (return)) + (ccl::disasm-prin1 (pop q) stream) + (if q (write-char #\space stream))) + (write-char #\) stream))) + value) + +;; Generic-functions +;; Display the list of methods on a line of its own to make getting at them faster +;; (They're also inside the dispatch-table which is the first immediate in the disassembly). +(defclass gf-inspector (function-inspector) + ((method-count :accessor method-count))) + +(defmethod inspector-class ((f standard-generic-function)) + (if (functionp f) + 'gf-inspector + 'standard-object-inspector)) + +(defmethod compute-line-count :before ((f gf-inspector)) + (let* ((gf (inspector-object f)) + (count (length (generic-function-methods gf)))) + (setf (method-count f) count))) + +(defmethod header-count ((f gf-inspector)) + (+ (standard-header-count f) 1 (method-count f))) + +(defmethod line-n ((f gf-inspector) n) + (let* ((count (method-count f)) + (methods (generic-function-methods (inspector-object f)))) + (cond ((< (decf n (standard-header-count f)) 0) + (call-next-method)) + ((< (decf n) 0) + (values methods "Methods: " :comment)) + ((< n count) + (values (nth n methods) nil :static)) + (t (disassembly-line-n f (- n count)))))) + +(defmethod (setf line-n) (new-value (f gf-inspector) n) + (let* ((count (method-count f)) + (en n)) + (cond ((< (decf n (standard-header-count f)) 0) + (call-next-method)) + ((< (decf n) count) + (setf-line-n-out-of-range f en)) + (t (set-disassembly-line-n f (- n count) new-value))))) + +#| +(defmethod inspector-commands ((f gf-inspector)) + (let* ((function (inspector-object f)) + (method (selected-object (inspector-view f)))) + (if (typep method 'method) + (nconc + (call-next-method) + `(("Remove method" + ,#'(lambda () + (remove-method function method) + (resample-it))))) + (call-next-method)))) +|# + +;;;;;;; +;; +;; Structures +;; +(defmethod inspector-class ((s structure-object)) + 'usual-basics-first-inspector) + +(defun structure-slots (s) + (let ((slots (ccl::sd-slots (ccl::struct-def s)))) + (if (symbolp (caar slots)) + slots + (cdr slots)))) + +(defmethod compute-line-count ((s structure-object)) + (length (structure-slots s))) + +(defmethod line-n ((s structure-object) n) + (let ((slot (nth n (structure-slots s)))) + (if slot + (values (uvref s (ccl::ssd-offset slot)) (ccl::ssd-name slot) :colon) + (line-n-out-of-range s n)))) + +(defmethod (setf line-n) (new-value (s structure-object) n) + (let ((slot (nth n (structure-slots s)))) + (if slot + (setf (uvref s (ccl::ssd-offset slot)) new-value) + (setf-line-n-out-of-range s n)))) + + +(defclass basic-stream-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((bs ccl::basic-stream)) 'basic-stream-inspector) + +;;;;;;; +;; +;; packages +;; +(defclass package-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((p package)) 'package-inspector) + +(defmethod compute-line-count ((i package-inspector)) + (+ 2 (call-next-method))) + +(defmethod line-n ((i package-inspector) n) + (cond ((eql n 0) (values (ccl::%pkgtab-count (ccl::pkg.itab (inspector-object i))) + "Internal Symbols: " :static)) + ((eql n 1) (values (ccl::%pkgtab-count (ccl::pkg.etab (inspector-object i))) + "External Symbols: " :static)) + (t (call-next-method i (- n 2))))) + +(defmethod (setf line-n) (new-value (i package-inspector) n) + (if (< n 2) + (setf-line-n-out-of-range i n) + (call-next-method new-value i (- n 2)))) + +(defmethod inspector-commands ((i package-inspector)) + `(("Inspect all packages" ,#'(lambda () (inspect (list-all-packages)))) + (,(format nil "(setq *package* '~a" (inspector-object i)) + ,#'(lambda () (setq *package* (inspector-object i)))))) + +;;;;;;; +;; +;; Records +;; +(defclass record-inspector (object-first-inspector) + ((record-type :accessor record-type) + (field-names :accessor field-names) + (unlock :initform nil :accessor unlock))) + +(defmethod inspector-class ((o macptr)) + 'record-inspector) + + +;;; Still needs work. +;;; Lots of work. +(defclass thread-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((thread ccl::lisp-thread)) + 'thread-inspector) + +(defmethod compute-line-count :before ((i thread-inspector)) +) + +(defmethod line-n ((thread thread-inspector) n) + (declare (ignorable n)) + (call-next-method) +) + +#| +(defmethod line-n-inspector ((i thread-inspector) n value label type) + (declare (ignore n type)) + (or (and value + (macptrp value) + (not (%null-ptr-p value))) + (call-next-method))) +|# + + +(defmethod line-n-inspector (i n value label type) + (declare (ignore i n label type)) + (make-inspector value)) + +(defmethod line-n-inspector ((i usual-inspector) n value label type) + (let ((object (inspector-object i))) + (if (typep object 'usual-inspector) + (make-inspector value) + (line-n-inspector (inspector-object i) n value label type)))) + + + + + +;;;;;;; +;; +;; an ERROR-FRAME stores the stack addresses that the backtrace window displays +;; + +;; set to list of function you don't want to see +;; Functions can be symbols, nil for kernel, or #'functions +(defparameter *backtrace-internal-functions* + (list :kernel)) + +(defvar *backtrace-hide-internal-functions-p* t) + +(defclass error-frame () + ((addresses :accessor addresses) + (restart-info :accessor restart-info) + (stack-start :initarg :stack-start :reader stack-start) + (stack-end :initarg :stack-end :reader stack-end) + (tcr :initarg :tcr :initform (ccl::%current-tcr) :reader tcr) + (context :initarg :context :reader context) + (frame-count :accessor frame-count) + (ignored-functions :accessor ignored-functions + :initform (and *backtrace-hide-internal-functions-p* + *backtrace-internal-functions*)) + (break-condition :accessor break-condition + :initarg :break-condition) + (unavailable-value-marker :initform (cons nil nil) + :accessor unavailable-value-marker))) + + + +(defmethod initialize-instance ((f error-frame) &key) + (call-next-method) + (initialize-addresses f)) + +(defmethod initialize-addresses ((f error-frame)) + (let* ((addresses (coerce (ccl::%stack-frames-in-context (context f)) 'vector))) + (setf (frame-count f) (length addresses) + (addresses f) addresses))) + +(defmethod compute-frame-info ((f error-frame) n) + (let* ((frame (svref (addresses f) n)) + (context (context f)) + (marker (unavailable-value-marker f))) + + (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame) + (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker) + (list (ccl::arglist-from-map lfun) args locals))))) + +(defun print-error-frame-limits (f stream) + (format stream "#x~x - #x~x" (stack-start f) (stack-end f))) + +(defmethod print-object ((f error-frame) stream) + (print-unreadable-object (f stream :type 'frame-ptr) + (print-error-frame-limits f stream))) + + + +;;;;;;; +;; +;; The inspector for error-frame objects +;; + + + +;;; The "vsp-range" and "tsp-range" slots have to do with +;;; recognizing/validating stack-allocated objects +(defclass stack-inspector (inspector) + ((vsp-range :accessor vsp-range :initarg :vsp-range) + (tsp-range :accessor tsp-range :initarg :tsp-range) + (csp-range :accessor csp-range :initarg :csp-range))) + + + + +(defmethod initialize-instance ((i stack-inspector) &rest initargs &key context) + (declare (dynamic-extent initargs)) + (let* ((start (ccl::child-frame (ccl::parent-frame (ccl::bt.youngest context) context) context)) + (end (ccl::child-frame (ccl::parent-frame (ccl::bt.oldest context) context) context)) + (tcr (ccl::bt.tcr context))) + (apply #'call-next-method + i + :object + (make-instance 'error-frame + :stack-start start + :stack-end end + :tcr tcr + :context context + :break-condition (ccl::bt.break-condition context)) + :tsp-range (make-tsp-stack-range tcr context) + :vsp-range (make-vsp-stack-range tcr context) + :csp-range (make-csp-stack-range tcr context) + initargs))) + +(defmethod print-object ((i stack-inspector) stream) + (print-unreadable-object (i stream :type 'stack-inspector) + (print-error-frame-limits (inspector-object i) stream))) + +(defmethod addresses ((f stack-inspector)) + (addresses (inspector-object f))) + +(defmethod compute-line-count ((f stack-inspector)) + (frame-count (inspector-object f))) + +(defmethod line-n ((f stack-inspector) n) + (let* ((frame (svref (addresses (inspector-object f)) n))) + (ccl::cfp-lfun frame))) + + + + + + +;;; inspecting a single stack frame +;;; The inspector-object is expected to be an error-frame +(defclass stack-frame-inspector (inspector) + ((frame-number :initarg :frame-number :initform nil :reader frame-number) + (frame-info :initform nil :accessor frame-info))) + + +(defmethod initialize-instance ((i stack-frame-inspector) &rest initargs &key + object frame-number) + (declare (dynamic-extent initargs)) + (setq object (require-type object 'error-frame)) + (apply #'call-next-method i + :object object + initargs) + (setf (frame-number i) frame-number)) + + + +(defmethod compute-line-count ((i stack-frame-inspector)) + (let ((frame-number (frame-number i))) + (if (null frame-number) + 0 + (let* ((error-frame (inspector-object i)) + (frame-info (or (frame-info i) + (setf (frame-info i) (compute-frame-info error-frame frame-number))))) + (destructuring-bind (args locals) (cdr frame-info) + (+ 1 (length args) 1 (length locals))))))) + +(defmethod line-n ((i stack-frame-inspector) n) + (unless (< -1 n (inspector-line-count i)) + (line-n-out-of-range i n)) + (destructuring-bind (arglist args locals) (frame-info i) + (if (zerop n) + (values arglist nil :static) + (let* ((nargs (length args))) + (decf n) + (if (< n nargs) + (cons :arg (nth n args)) + (progn + (decf n nargs) + (if (zerop n) + nil + (cons :local (nth (1- n) locals))))))))) + +(defmethod (setf line-n) (value (i stack-frame-inspector) n) + (declare (ignorable value n)) + (error "not yet!")) + + + + + +(defmethod prin1-value ((i stack-frame-inspector) stream value &optional label type) + (declare (ignore label type)) + (when value + (if (or (atom value) (not (typep (car value) 'keyword))) + (prin1 value stream) + (progn + (if (eq (car value) :arg) + (format stream " ") + (format stream " ")) + (when (cdr value) + (destructuring-bind (label . val) (cdr value) + (format stream "~a: " label) + (if (eq val *unbound-marker*) + (format stream "??") + (prin1 val stream)))))))) + +(defmethod (setf frame-number) (frame-number (i stack-frame-inspector)) + (let ((max (1- (frame-count (inspector-object i))))) + (unless (or (null frame-number) + (and (<= 0 frame-number max))) + (setq frame-number (require-type frame-number `(or null (integer 0 ,max)))))) + (unless (eql frame-number (frame-number i)) + (setf (slot-value i 'frame-number) frame-number) + (setf (inspector-line-count i) nil) + frame-number)) + + +;;; Each of these stack ranges defines the entire range of (control/value/temp) +;;; addresses; they can be used to addresses of stack-allocated objects +;;; for printing. +(defun make-tsp-stack-range (tcr bt-info) + (list (cons (ccl::%catch-tsp (ccl::bt.top-catch bt-info)) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.ts-area) + target::area.high)))) + +#+ppc-target +(defun make-vsp-stack-range (tcr bt-info) + (list (cons (ccl::%fixnum-ref + (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell) + target::lisp-frame.savevsp) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) + target::area.high)))) +#+x8632-target +(defun make-vsp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.esp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) + target::area.high)))) + +#+x8664-target +(defun make-vsp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.rsp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) + target::area.high)))) + +#+ppc-target +(defun make-csp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) + target::area.high)))) + +#+x8632-target +(defun make-csp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) + target::area.high)))) + +#+x8664-target +(defun make-csp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) + target::area.high)))) + + +;;; Inspector + + +(defvar *inspector-ui* ()) +(defvar *previous-inspector-ui* nil) + +(defclass inspector-ui () + ((inspector :initarg :inspector :accessor inspector-ui-inspector) + (level :initarg :level :accessor inspector-ui-level))) + +(defclass inspector-tty-ui (inspector-ui) + ((origin :initarg :origin :initform 0 :accessor inspector-tty-ui-origin) + (pagesize :initarg :pagesize :initform 20 :accessor + inspector-tty-ui-pagesize))) + +(defmethod ui-initialize ((ui inspector-tty-ui))) + +(defmethod ui-present ((ui inspector-tty-ui)) + (let* ((inspector (inspector-ui-inspector ui))) + (with-errorfree-printing + (let* ((stream *debug-io*) + (origin (inspector-tty-ui-origin ui)) + (pagesize (inspector-tty-ui-pagesize ui)) + (page-end (+ origin pagesize)) + (n (compute-line-count inspector)) + (end (min page-end n)) + (tag -1) + (*print-pretty* (or *print-pretty* *describe-pretty*)) + (*print-length* 5) + (*print-level* 5) + (func #'(lambda (i index child &optional label-string value-string) + (declare (ignore i)) + (when child (incf tag)) + (unless (< index origin) + (format stream "~@[[~d]~]~8t" (and child tag)) + (format-line-for-tty stream label-string value-string) + (terpri stream))))) + (declare (dynamic-extent func)) + (map-lines inspector func 0 end))) + (values))) + +(ccl::define-toplevel-command + :tty-inspect i (n) + "inspect th item" + (inspector-ui-inspect-nth *inspector-ui* n)) + +(ccl::define-toplevel-command + :tty-inspect pop () + "exit current inspector level" + (invoke-restart 'exit-inspector)) + +(ccl::define-toplevel-command + :tty-inspect q () + "exit inspector" + (invoke-restart 'end-inspect)) + +(ccl::define-toplevel-command + :tty-inspect show () + "re-show currently inspected object (the value of CCL:@)" + (ui-present *inspector-ui*)) + +(defmethod inspector-ui-next-page ((ui inspector-tty-ui)) + (let* ((nlines (compute-line-count (inspector-ui-inspector ui))) + (origin (inspector-tty-ui-origin ui)) + (page-size (inspector-tty-ui-pagesize ui)) + (new-origin (+ origin page-size))) + (if (< new-origin nlines) + (setf (inspector-tty-ui-origin ui) new-origin)) + (ui-present ui))) + +(ccl::define-toplevel-command + :tty-inspect next () + "show next page of object data" + (inspector-ui-next-page *inspector-ui*)) + +(defmethod inspector-ui-prev-page ((ui inspector-tty-ui)) + (let* ((origin (inspector-tty-ui-origin ui)) + (page-size (inspector-tty-ui-pagesize ui)) + (new-origin (max 0 (- origin page-size)))) + (setf (inspector-tty-ui-origin ui) new-origin) + (ui-present ui))) + +(ccl::define-toplevel-command + :tty-inspect prev () + "show previous page of object data" + (inspector-ui-prev-page *inspector-ui*)) + +(ccl::define-toplevel-command + :tty-inspect home () + "show first page of object data" + (progn + (setf (inspector-tty-ui-origin *inspector-ui*) 0) + (ui-present *inspector-ui*))) + +(ccl::define-toplevel-command + :tty-inspect s (n v) + "set the th line of object data to value " + (let* ((ui *inspector-ui*)) + (setf (line-n (inspector-ui-inspector ui) n) v) + (ui-present ui))) + + +(defmethod ui-interact ((ui inspector-tty-ui)) + (let* ((level (inspector-ui-level ui)) + (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui)))))) + (declare (special ccl::*default-integer-command*)) + (restart-case + (ccl:with-terminal-input + (ccl::with-toplevel-commands :tty-inspect + (ccl::read-loop + :prompt-function #'(lambda (stream) + (if (eql level 0) + (format stream "~&Inspect> ") + (format stream "~&Inspect ~d> " level)))))) + (exit-inspector () + (if *previous-inspector-ui* + (ui-present *previous-inspector-ui*) + (terpri *debug-io*)))))) + +(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n) + (let* ((inspector (inspector-ui-inspector ui)) + (new-inspector (block nil + (let* ((tag -1) + (func #'(lambda (i index child &rest strings) + (declare (ignore i index strings)) + (when (and child (eql (incf tag) n)) (return child))))) + (declare (dynamic-extent func)) + (map-lines inspector func)))) + (ccl::@ (inspector-object new-inspector))) + (inspector-ui-inspect + (make-instance 'inspector-tty-ui + :level (1+ (inspector-ui-level ui)) + :inspector new-inspector)))) + +(defparameter *default-inspector-ui-class-name* 'inspector-tty-ui) + +(defmethod inspector-ui-inspect ((ui inspector-ui)) + (let* ((*previous-inspector-ui* *inspector-ui*) + (*inspector-ui* ui)) + (ui-initialize ui) + (ui-present ui) + (ui-interact ui) + (values))) + +(defun tty-inspect (thing) + (inspector-ui-inspect (make-instance *default-inspector-ui-class-name* + :inspector (make-inspector thing) + :level 0))) + +(defparameter *default-inspector-ui-creation-function* 'tty-inspect) + + +(defun inspect (thing) + (let* ((ccl::@ thing)) + (restart-case (funcall *default-inspector-ui-creation-function* thing) + (end-inspect () thing)))) Index: /branches/qres/ccl/lib/distrib-inits.lisp =================================================================== --- /branches/qres/ccl/lib/distrib-inits.lisp (revision 13564) +++ /branches/qres/ccl/lib/distrib-inits.lisp (revision 13564) @@ -0,0 +1,29 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; distrib-inits.lisp + +; Things that are in the development environment that need to be +; added to the distribution environment. + +; This needs to be compiled after everything is loaded. + +(in-package "CCL") + +; *def-accessor-types* is used by the inspector to name slots in uvectors +(dolist (cell '#.*def-accessor-types*) + (add-accessor-types (list (car cell)) (cdr cell))) Index: /branches/qres/ccl/lib/dumplisp.lisp =================================================================== --- /branches/qres/ccl/lib/dumplisp.lisp (revision 13564) +++ /branches/qres/ccl/lib/dumplisp.lisp (revision 13564) @@ -0,0 +1,329 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; Dumplisp.lisp + +(in-package "CCL") + +(defvar *save-exit-functions* nil + "List of (0-arg)functions to call before saving memory image") + +(defvar *restore-lisp-functions* nil + "List of (0-arg)functions to call after restoring saved image") + + +(declaim (special *lisp-system-pointer-functions*)) ; defined in l1-init. + +(defun kill-lisp-pointers () + (setq * nil ** nil *** nil + nil ++ nil +++ nil - nil + / nil // nil /// nil + @ nil) + (clear-open-file-streams) + (setf (*%saved-method-var%*) nil) + (setq *%periodic-tasks%* nil) + (setq *event-dispatch-task* nil) + (setq *interactive-abort-process* nil) + ) + +(defun clear-ioblock-streams () + (%map-areas (lambda (o) + (if (typep o 'basic-stream) + (let ((s (basic-stream.state o))) + (when (and (typep s 'ioblock) + (ioblock-device s) + (>= (ioblock-device s) 0)) + (setf (basic-stream.state o) nil))) + ;; Have to be careful with use of TYPEP here (and + ;; in the little bit of Lisp code that runs before + ;; the image is saved.) We may have just done + ;; things to forget about (per-session) foreign + ;; class addresses, and calling TYPEP on a pointer + ;; to such a class might cause us to remember + ;; those per-session addresses and confuse the + ;; startup code. + (if (and (eql (typecode o) target::subtag-instance) + (typep o 'buffered-stream-mixin) + (slot-boundp o 'ioblock)) + (let ((s (slot-value o 'ioblock))) + (when (and (typep s 'ioblock) + (ioblock-device s) + (>= (ioblock-device s) 0)) + (setf (slot-value o 'ioblock) nil)))))))) + +(defun save-application (filename + &rest rest + &key toplevel-function + init-file + error-handler application-class + clear-clos-caches + (purify t) + impurify + (mode #o644) + prepend-kernel + #+windows-target (application-type :console)) + (declare (ignore toplevel-function error-handler application-class + clear-clos-caches init-file impurify)) + #+windows-target (check-type application-type (member :console :gui)) + (unless (probe-file (make-pathname :defaults nil + :directory (pathname-directory (translate-logical-pathname filename)))) + (error "Directory containing ~s does not exist." filename)) + (let* ((kind (%unix-file-kind (native-translated-namestring filename)))) + (when (and kind (not (eq kind :file ))) + (error "~S is not a regular file." filename))) + (let* ((watched (watch))) + (when watched + (cerror "Un-watch them." "There are watched objects.") + (mapc #'unwatch watched))) + (let* ((ip *initial-process*) + (cp *current-process*)) + (when (process-verify-quit ip) + (let* ((fd (open-dumplisp-file filename + :mode mode + :prepend-kernel prepend-kernel + #+windows-target #+windows-target + :application-type application-type))) + (process-interrupt ip + #'(lambda () + (process-exit-application + *current-process* + #'(lambda () + (apply #'%save-application-internal + fd + :purify purify + rest)))))) + (unless (eq cp ip) + (process-kill cp))))) + +(defun %save-application-internal (fd &key + toplevel-function ;???? + error-handler ; meaningless unless application-class or *application* not lisp-development.. + application-class + mode + (purify t) + (impurify nil) + (init-file nil init-file-p) + (clear-clos-caches t) + prepend-kernel + #+windows-target application-type) + (declare (ignore mode prepend-kernel #+windows-target application-type)) + (when (and application-class (neq (class-of *application*) + (if (symbolp application-class) + (find-class application-class) + application-class))) + (setq *application* (make-instance application-class))) + (if (not toplevel-function) + (setq toplevel-function + #'(lambda () + (toplevel-function *application* + (if init-file-p + init-file + (application-init-file *application*))))) + (let* ((user-toplevel-function (coerce-to-function toplevel-function))) + (setq toplevel-function + (lambda () + (process-run-function "toplevel" (lambda () + (funcall user-toplevel-function) + (quit))) + (%set-toplevel #'housekeeping-loop) + (toplevel))))) + (when error-handler + (make-application-error-handler *application* error-handler)) + + (if clear-clos-caches (clear-clos-caches)) + (save-image #'(lambda () (%save-application fd + (logior (if impurify 2 0) + (if purify 1 0)))) + toplevel-function)) + +(defun save-image (save-function toplevel-function) + (let ((toplevel #'(lambda () (#_exit -1)))) + (%set-toplevel #'(lambda () + (setf (interrupt-level) -1) + (%set-toplevel toplevel) ; in case *save-exit-functions* error + (dolist (f *save-exit-functions*) + (funcall f)) + (kill-lisp-pointers) + (clear-ioblock-streams) + (with-deferred-gc + (let* ((pop *termination-population*)) + (with-lock-grabbed (*termination-population-lock*) + (setf (population.data pop) nil + (population.termination-list pop) nil)))) + (%set-toplevel + #'(lambda () + (%set-toplevel #'(lambda () + (setf (interrupt-level) 0) + (funcall toplevel-function))) + (restore-lisp-pointers))) ; do startup stuff + (funcall save-function))) + (toplevel))) + +;;; If file in-fd contains an embedded lisp image, return the file position +;;; of the start of that image; otherwise, return the file's length. +(defun skip-embedded-image (in-fd) + (let* ((len (fd-lseek in-fd 0 #$SEEK_END))) + (if (< len 0) + (%errno-disp len) + (%stack-block ((trailer 16)) + (let* ((trailer-pos (fd-lseek in-fd -16 #$SEEK_CUR))) + (if (< trailer-pos 0) + len + (if (not (= 16 (the fixnum (fd-read in-fd trailer 16)))) + len + (if (not (dotimes (i 12 t) + (unless (eql (char-code (schar "OpenMCLImage" i)) + (%get-unsigned-byte trailer i)) + (return nil)))) + len + (let* ((header-pos (fd-lseek in-fd + (%get-signed-long + trailer + 12) + #$SEEK_CUR))) + (if (< header-pos 0) + len + header-pos)))))))))) + +;;; Note that Windows executable files are in what they call "PE" +;;; (= "Portable Executable") format, not to be confused with the "PEF" +;;; (= "PowerPC Executable Format" or "Preferred Executable Format") +;;; executable format that Apple used on Classic MacOS. +(defun %prepend-file (out-fd in-fd len #+windows-target application-type) + (declare (fixnum out-fd in-fd len)) + (fd-lseek in-fd 0 #$SEEK_SET) + (let* ((bufsize (ash 1 15)) + #+windows-target (first-buf t)) + (%stack-block ((buf bufsize)) + (loop + (when (zerop len) (return)) + (let* ((nread (fd-read in-fd buf (min len bufsize)))) + (declare (fixnum nread)) + (if (< nread 0) + (%errno-disp nread)) + #+windows-target + (when (shiftf first-buf nil) + (let* ((application-byte (ecase application-type + (:console #$IMAGE_SUBSYSTEM_WINDOWS_CUI) + (:gui #$IMAGE_SUBSYSTEM_WINDOWS_GUI))) + (offset (%get-long buf (get-field-offset #>IMAGE_DOS_HEADER.e_lfanew)))) + (assert (< offset bufsize) () "PE header not within first ~D bytes" bufsize) + (assert (= (%get-byte buf (+ offset 0)) (char-code #\P)) () + "File does not appear to be a PE file") + (assert (= (%get-byte buf (+ offset 1)) (char-code #\E)) () + "File does not appear to be a PE file") + (assert (= (%get-byte buf (+ offset 2)) 0) () + "File does not appear to be a PE file") + (assert (= (%get-byte buf (+ offset 3)) 0) () + "File does not appear to be a PE file") + ;; File is a PE file -- Windows subsystem byte goes at offset 68 in the + ;; "optional header" which appears right after the standard header (20 bytes) + ;; and the PE cookie (4 bytes) + (setf (%get-byte buf (+ offset 4 (record-length #>IMAGE_FILE_HEADER) (get-field-offset #>IMAGE_OPTIONAL_HEADER.Subsystem) )) application-byte))) + (let* ((nwritten (fd-write out-fd buf nread))) + (declare (fixnum nwritten)) + (unless (= nwritten nread) + (error "I/O error writing to fd ~d" out-fd))) + (decf len nread)))))) + + + +(defun kernel-path () + (let* ((p (%null-ptr))) + (declare (dynamic-extent p)) + (%get-kernel-global-ptr 'kernel-path p) + (if (%null-ptr-p p) + (%realpath (car *command-line-argument-list*)) + (let* ((string (%get-utf-8-cstring p))) + #+windows-target (nbackslash-to-forward-slash string) + #+darwin-target (precompose-simple-string string) + #-(or windows-target darwin-target) string)))) + + +(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel + #+windows-target application-type) + (let* ((prepend-path (if prepend-kernel + (if (eq prepend-kernel t) + (kernel-path) + (native-translated-namestring + (pathname prepend-kernel))))) + (prepend-fd (if prepend-path (fd-open prepend-path #$O_RDONLY))) + (prepend-len (if prepend-kernel + (if (and prepend-fd (>= prepend-fd 0)) + (skip-embedded-image prepend-fd) + (signal-file-error prepend-fd prepend-path)))) + (filename (native-translated-namestring path))) + (when (probe-file filename) + (%delete-file filename)) + (when prepend-fd + ;; Copy the execute mode bits from the prepended "kernel". + (let ((prepend-fd-mode (nth-value 1 (%fstat prepend-fd)))) + (setq mode (logior (logand prepend-fd-mode #o111) mode)))) + (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode))) + (unless (>= image-fd 0) (signal-file-error image-fd filename)) + (when prepend-fd + (%prepend-file image-fd prepend-fd prepend-len #+windows-target application-type)) + (fd-chmod image-fd mode) + image-fd))) + + +(defun %save-application (fd &optional (flags 1)) + (let* ((err (%%save-application flags fd))) + (unless (eql err 0) + (%err-disp err)))) + + +(defun restore-lisp-pointers () + (setq *interactive-streams-initialized* nil) + (setq *heap-ivectors* nil) + (setq *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0))) + (%revive-system-locks) + (refresh-external-entrypoints) + (restore-pascal-functions) + (initialize-interactive-streams) + (let ((system-ptr-fns (reverse *lisp-system-pointer-functions*)) + (restore-lisp-fns *restore-lisp-functions*) + (user-pointer-fns *lisp-user-pointer-functions*) + (lisp-startup-fns *lisp-startup-functions*)) + (unwind-protect + (with-simple-restart (abort "Abort (possibly crucial) startup functions.") + (let ((call-with-restart + #'(lambda (f) + (with-simple-restart + (continue "Skip (possibly crucial) startup function ~s." + (if (symbolp f) f (function-name f))) + (funcall f))))) + (dolist (f system-ptr-fns) (funcall call-with-restart f)) + (dolist (f restore-lisp-fns) (funcall call-with-restart f)) + (dolist (f (reverse user-pointer-fns)) (funcall call-with-restart f)) + (dolist (f (reverse lisp-startup-fns)) (funcall call-with-restart f)))) + (setf (interrupt-level) 0))) + nil) + + +(defun restore-pascal-functions () + (reset-callback-storage) + (when (simple-vector-p %pascal-functions%) + (dotimes (i (length %pascal-functions%)) + (let ((pfe (%svref %pascal-functions% i))) + (when (vectorp pfe) + (let* ((name (pfe.sym pfe)) + (descriptor (pfe.routine-descriptor pfe))) + (%revive-macptr descriptor) + (%setf-macptr descriptor (make-callback-trampoline i (pfe.proc-info pfe))) + (when name + (set name descriptor)))))))) + Index: /branches/qres/ccl/lib/edit-callers.lisp =================================================================== --- /branches/qres/ccl/lib/edit-callers.lisp (revision 13564) +++ /branches/qres/ccl/lib/edit-callers.lisp (revision 13564) @@ -0,0 +1,243 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; edit-callers.lisp + +(in-package "CCL") + +(defun global-function-p (random &optional name) + (let* ((thing random) + (name (or name (ignore-errors (function-name thing))))) + (and name + (or (not (or (symbolp name) (setf-function-name-p name))) ; maybe its (setf baz) + (let ((fn (fboundp name))) + (and fn + (progn + ; maybe this is enough for both cases? + (or (eq thing fn) + (and (symbolp name)(eq thing (macro-function name)))))))) + name))) + +(defvar *function-parent-table* nil) +(defvar *function-parent-pool* (%cons-pool)) + +(defun copying-gc-p () ; if nz copying gc is on + nil) + +(defun lfun-closure-p (lfun) + (logbitp $lfbits-trampoline-bit (lfun-bits lfun))) + +; make a macro ? +(defun puthash-parent (im fun) + (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply)) + (if (global-function-p fun) + (setf (gethash im *function-parent-table*) fun) + (let ((ht (gethash im *function-parent-table*))) + (if (not ht) + (setf (gethash im *function-parent-table*) fun) + (unless (eq ht fun) + (if (consp ht) + (when (not (memq fun ht))(nconc ht (list fun))) + (if (not (global-function-p ht)) + (setf (gethash im *function-parent-table*) (list ht fun)))))))))) + + +(defun callers (function &aux cfun callers gccount retry) + ;(declare (special cfun function callers)) + (declare (optimize (speed 3)(safety 0))) + + (let ((*function-parent-table* nil)) + (if (setf-function-name-p function) + (let ((nm (cadr function))) + (setq function (or (%setf-method nm) + (and (symbolp nm) + (setq nm (setf-function-name nm)) + (fboundp nm) + nm) + function)))) + (if (and (symbolp function) (fboundp function)) + (setq cfun (symbol-function function))) + (when (copying-gc-p) (setq gccount (full-gccount))) + (flet ((do-it (fun) + (when (and gccount (neq gccount (full-gccount))) + (throw 'losing :lost)) + (when (possible-caller-function-p fun) + (let* ((nm (ignore-errors (lfun-name fun))) + (globalp (if nm (global-function-p fun nm)))) + (flet ((do-imm (im) + (when (and (or (eq function im) + (and cfun (eq cfun im))) + (neq im nm)) + (push fun callers)) + (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply)) + (if globalp + (setf (gethash im *function-parent-table*) fun) + (let ((ht (gethash im *function-parent-table*))) + (if (not ht) + (setf (gethash im *function-parent-table*) fun) + (unless (eq ht fun) + (if (consp ht) + (when (not (memq fun ht))(nconc ht (list fun))) + (if (not (global-function-p ht)) + (setf (gethash im *function-parent-table*) + (list ht fun))))))))))) + (declare (dynamic-extent #'do-imm)) + (%map-lfimms fun #'do-imm )))))) + (declare (dynamic-extent #'do-it)) + (unwind-protect + (progn + (let* ((pool *function-parent-pool*) + (tbl (pool.data pool))) + (setf (pool.data pool) nil + *function-parent-table* + (if tbl + (clrhash tbl) + (make-hash-table :size 700 :test 'eq :weak :value)))) + (loop + (cond ((eq :lost (catch 'losing + (%map-lfuns #'do-it))) + (when retry (error "Callers is losing")) + (setq callers nil) + (setq retry t)) + (t (return)))) + (delete-if #'(lambda (thing) + (or (functionp thing) + (and (typep thing 'method) + (let ((gf (fboundp (method-name thing)))) + (not (and (typep gf 'standard-generic-function) + (memq thing (%gf-methods gf)))))))) + (delete-duplicates (mapcar 'top-level-caller callers)))) + (setf (pool.data *function-parent-pool*) *function-parent-table* + *function-parent-table* nil))))) + + +(defun top-level-caller (function &optional the-list) + (or (global-function-p function) + (pascal-function-p function) + (let ((name (function-name function))) + (and name (function-encapsulated-p name) name)) + (let ((caller function) next) + (loop + (setq next (gethash caller *function-parent-table*)) + (if next + (cond ((consp next) + (when (null the-list)(push function the-list)) + (return + (dolist (c next) + (when (not (memq c the-list)) + (let ((res (top-level-caller c the-list))) + (when (and res (not (functionp res))) + (return res))))))) + (t (let ((res (global-function-p next))) + (when res (return res))) + (when (null the-list)(push function the-list)) + (when (memq next the-list) (return)) + (push next the-list) + (setq caller next))) + (return caller)))) + function)) + +(defun possible-caller-function-p (fun) + (let ((bits (lfun-bits fun))) + (declare (fixnum bits)) + (not (or (and (logbitp $lfbits-cm-bit bits) + (not (logbitp $lfbits-method-bit bits))) ; combined method + (and (logbitp $lfbits-trampoline-bit bits) + (lfun-closure-p fun) + (not (global-function-p fun))))))) ; closure (interp or compiled) + + +(defun caller-functions (function &aux cfun callers gccount retry) + "Returns a list of all functions (actual function objects, not names) that reference FUNCTION" + (declare (optimize (speed 3)(safety 0)(debug 0))) + (when (setf-function-name-p function) + (let ((nm (cadr function))) + (setq function (or (%setf-method nm) + (and (setq nm (setf-function-name nm)) + (fboundp nm) + nm) + function)))) + (when (valid-function-name-p function) + (setq cfun (or (and (symbolp function) (macro-function function)) + (fboundp function)))) + (when (copying-gc-p) (setq gccount (full-gccount))) + (flet ((do-it (fun) + (when (and gccount (neq gccount (full-gccount))) + (throw 'losing :lost)) + (when (possible-caller-function-p fun) + (let* ((lfv (function-to-function-vector fun)) + (end (%i- (uvsize lfv) 1)) + (bits (%svref lfv end))) + ;; Don't count the function name slot as a reference. + (unless (logbitp $lfbits-noname-bit bits) + (decf end)) + ;; Don't count lfun-info either + (when (logbitp $lfbits-info-bit bits) + (decf end)) + (loop for i from #+ppc-target 1 #+x86-target (%function-code-words fun) below end + as im = (%svref lfv i) + when (or (eq function im) + (and cfun (eq cfun im))) + do (return (pushnew (if (%method-function-p fun) + (%method-function-method fun) + fun) + callers))))))) + (declare (dynamic-extent #'do-it)) + (loop while (eq :lost (catch 'losing + (%map-lfuns #'do-it))) + do (when retry (cerror "Try again" "Callers is losing")) + do (setq callers nil) + do (setq retry t)) + callers)) + +; in 3.x the function in pascal-functions calls the actual function +(defun pascal-function-p (function) + (if (find function %pascal-functions% + :test #'eq + :key #'(lambda (elt) + (if (consp elt) + (let ((one (cdr elt))) + (when (and (eq (function-name one)(function-name function)) + (block blob + (%map-lfimms one #'(lambda (imm) + (when (eq imm function) + (return-from blob function)))))) + function)) + (if elt (aref elt 2))))) + (function-name function))) + + +;;; Calls function f with args (imm) on each immediate in lfv. + +(defun %map-lfimms (function-object f) + (let* ((lfv (function-to-function-vector function-object)) + (n (- (uvsize lfv) 2))) + (declare (fixnum n)) + #+ppc-target + (dotimes (i n) + (funcall f (%svref lfv (%i+ 1 i)))) + #+x86-target + (do* ((i (1- (the fixnum (%function-code-words function-object))) (1+ i))) + ((= i n)) + (declare (fixnum i)) + (funcall f (%svref lfv (%i+ 1 i)))) + )) + + + + +(provide :edit-callers) Index: /branches/qres/ccl/lib/encapsulate.lisp =================================================================== --- /branches/qres/ccl/lib/encapsulate.lisp (revision 13564) +++ /branches/qres/ccl/lib/encapsulate.lisp (revision 13564) @@ -0,0 +1,891 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defvar *loading-removes-encapsulation* nil + "If true, loading a new method definition from a file will remove any tracing and advice on the method") + +(defvar *trace-pfun-list* nil) +(defvar *trace-enable* t) +(defvar *trace-level* 0) +(defparameter *trace-max-indent* 40) +(defvar *trace-print-level* nil) +(defvar *trace-print-length* nil) +;(defparameter *trace-define-if-undefined* nil) +(defparameter *trace-bar-frequency* nil) +(defvar *trace-hook* nil) +(defvar *untrace-hook* nil) +(defvar *trace-print-hook* nil) + +;;; +;;; We support encapsulating three types of objects, i.e. modifying their definition +;;; without changing their identity: +;;; 1. symbol - via the symbol-function slot +;;; 2. method - via the %method-function slot +;;; 3. standard-generic-function - via the %gf-dcode slot +;;; +;;; Encapsulation is effected by creating a new compiled function and storing it in the +;;; slot above. The new function references a gensym fbound to the original definition +;;; (except in the case of a gf, the gensym is fbound to a copy of the gf which in +;;; turn contains the original dcode, since we can't invoke the dcode directly). +;;; In addition, an ENCAPSULATION struct describing the encapsulation is created and +;;; stored in the *encapsulation-table* with the new compiled function as the key. +;;; +;;; + +(defparameter *encapsulation-table* + (make-hash-table :test #'eq :rehash-size 2 :size 2 :weak t)) + +(defstruct (encapsulation) + symbol ; the uninterned name containing original def + type ; trace or advise + spec ; the original function spec + advice-name ; optional + advice-when ; :before, :after, :around + owner ; where encapsulation is installed (can change) +) + +(defun encapsulation-old-def (cap) + (fboundp (encapsulation-symbol cap))) + +(defun setf-function-spec-name (spec) + (if (setf-function-name-p spec) + (let ((name (%setf-method (cadr spec)))) + (if (non-nil-symbol-p name) ; this can be an anonymous function + name + (setf-function-name (cadr spec)))) + spec)) + +(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*))) + (fresh-line *trace-output*) + (dotimes (i (1- n)) + (declare (fixnum i)) + (write-char (if (and *trace-bar-frequency* + (eq 0 (mod i *trace-bar-frequency*))) + #\| #\Space) *trace-output*)) + (if (eq direction :in) + (format *trace-output* "~d> " (1- *trace-level*)) + (format *trace-output* "<~d " (1- *trace-level*)))) + +(defun trace-before (&rest args) + (declare (dynamic-extent args)) + (trace-tab :in) + (let* ((*print-level* *trace-print-level*) + (*print-length* *trace-print-length*) + (*print-readably* nil)) + (format *trace-output* "Calling ~S ~%" args) + (force-output *trace-output*))) + +(defun trace-after (sym &rest args &aux (n (length args))) + (declare (dynamic-extent args)) + (let* ((*print-level* *trace-print-level*) + (*print-length* *trace-print-length*) + (*print-readably* nil)) + (if (eq n 1) + (progn + (trace-tab :out) + (format *trace-output* "~S returned ~S~%" sym (%car args))) + (progn + (trace-tab :out) + (format *trace-output* "~S returned ~S values :" sym n) + (dolist (val args) + (trace-tab :out) + (format *trace-output* " ~S" val)))) + (force-output *trace-output*))) + +(defun forget-encapsulations (name) + (when (%traced-p name) + (format t "~%... Untracing ~a" name) + (%untrace-1 name)) + (when (%advised-p name) + (format t "~%... Unadvising ~a" name) + (%unadvise-1 name)) + nil) + +(defun function-encapsulated-p (fn-or-method) + (get-encapsulation fn-or-method)) + +(defun %encap-fboundp (thing) + (etypecase thing + (symbol (fboundp thing)) + (method (%method-function thing)))) + +(defun %encap-binding (thing) + (require-type (etypecase thing + (symbol (fboundp thing)) + (method (%method-function thing))) + 'function)) + +(defun get-encapsulation (spec) + (let* ((key (typecase spec + (symbol (let* ((def (fboundp spec))) + (if (generic-function-p def) + (%gf-dcode def) + def))) + (method (%method-function spec)) + (standard-generic-function (%gf-dcode spec)) + (function spec))) + (cap (gethash key *encapsulation-table*))) + #+gz (assert (or (null cap) + (let ((fn (%encap-binding (encapsulation-owner cap)))) + (eq (if (standard-generic-function-p fn) (%gf-dcode fn) fn) key)))) + cap)) + +(defun set-encapsulation-owner (fn owner) + (let ((cap (get-encapsulation fn))) + (when cap + (setf (encapsulation-owner cap) owner)))) + +(defun put-encapsulation (fn cap) + (let* ((owner (encapsulation-owner cap)) + (old-def (%encap-binding owner)) + (newsym (encapsulation-symbol cap))) + (setf (gethash fn *encapsulation-table*) cap) + (set-encapsulation-owner old-def newsym) + (etypecase owner + (symbol + (cond ((standard-generic-function-p old-def) + (%fhave newsym (%copy-function old-def)) + (setf (%gf-dcode old-def) fn)) + (t + (%fhave newsym old-def) + (%fhave owner fn)))) + (method + (%fhave newsym old-def) + (setf (%method-function owner) fn) + (remove-obsoleted-combined-methods owner))))) + +(defun remove-encapsulation (cap) + (let* ((owner (encapsulation-owner cap)) + (cur-def (%encap-fboundp owner)) + (old-def (encapsulation-old-def cap))) + (typecase owner + (symbol + (cond ((or (null cur-def) + (not (eq cap (get-encapsulation cur-def)))) + ;; rebound behind our back, oh well. + nil) + ((standard-generic-function-p cur-def) + (remhash (%gf-dcode cur-def) *encapsulation-table*) + (set-encapsulation-owner old-def owner) + (setf (%gf-dcode cur-def) (%gf-dcode old-def))) + (t + (remhash cur-def *encapsulation-table*) + (set-encapsulation-owner old-def owner) + (%fhave owner old-def)))) + (method + (remhash cur-def *encapsulation-table*) + (set-encapsulation-owner old-def owner) + (setf (%method-function owner) old-def) + (remove-obsoleted-combined-methods owner))))) + + +(defun encapsulate (owner newdef type trace-spec newsym &optional advice-name advice-when) + (let ((cap (make-encapsulation + :owner owner + :symbol newsym + :type type + :spec trace-spec + :advice-name advice-name + :advice-when advice-when))) + (put-encapsulation newdef cap) + cap)) + +(defun find-unencapsulated-definition (fn) + (when fn + (loop for cap = (get-encapsulation fn) while cap + do (setq fn (encapsulation-old-def cap))) + fn)) + +(defun set-unencapsulated-definition (cap newdef) + (loop for owner = (encapsulation-symbol cap) + do (setq cap (get-encapsulation owner)) while cap + finally (%fhave owner newdef))) + +(defun %encapsulation-thing (spec &optional define-if-not (error-p t)) + ;; Returns either an fboundp symbol or a method, or nil. + (typecase spec + (symbol + ;; weed out macros and special-forms + (if (or (null spec) (special-operator-p spec) (macro-function spec)) + (if error-p + (error "Cannot trace or advise ~a~S" + (cond ((null spec) "") + ((special-operator-p spec) "special operator ") + (t "macro ")) + spec) + nil) + (if (or (fboundp spec) + (and define-if-not + (progn + (warn "~S was undefined" spec) + (%fhave spec (%function 'trace-null-def)) + t))) + spec + (if error-p + (error "~S is undefined." spec) + nil)))) + (method spec) + (cons + (case (car spec) + (:method + (let ((gf (cadr spec)) + (qualifiers (butlast (cddr spec))) + (specializers (car (last (cddr spec)))) + method) + (setq specializers (require-type specializers 'list)) + (prog () + AGN + (cond ((setq method + (find-method-by-names gf qualifiers specializers)) + (return method)) + (define-if-not + (when (define-undefined-method spec gf qualifiers specializers) + (go AGN))) + (t (if error-p + (error "Method ~s qualifiers ~s specializers ~s not found." + gf qualifiers specializers) + (return nil))))))) + (setf + (let ((name-or-fn (setf-function-spec-name spec))) + (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn)) + ((functionp name-or-fn) ; it's anonymous - give it a name + (let ((newname (gensym))) + (%fhave newname name-or-fn) + (store-setf-method (cadr spec) newname) + newname))))))) + (t (if error-p + (error "Invalid trace spec ~s" spec) + nil)))) + +(defun trace-null-def (&rest ignore) + (declare (ignore ignore))) + +(defun define-undefined-method (spec gf qualifiers specializers) + (let (vars def) + (flet ((blob (e) + (let ((v (gensym))) + (push v vars) + (list v e)))) + (declare (dynamic-extent #'blob)) + (setq def + (let ((lambda-list (mapcar #' blob specializers))) + (eval + `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore) + (declare (ignore ignore ,@vars)))))) + (when def (warn "~S was undefined" spec)) + def))) + +(defun traceable-symbol-p (sym) + (and sym + (not (special-operator-p sym)) + (not (macro-function sym)) + (fboundp sym))) + +(defun %trace-package (pkg &rest args) + (declare (dynamic-extent args)) + (do-present-symbols (sym pkg) + ;; Don't auto-trace imported symbols, because too often these are imported + ;; system functions... + (when (eq (symbol-package sym) pkg) + (when (traceable-symbol-p sym) + (apply #'trace-function sym args)) + (when (or (%setf-method sym) + ;; Not really right. Should construct the name if doesn't exist. + ;; But that would create a lot of garbage for little gain... + (let ((name (existing-setf-function-name sym))) + (traceable-symbol-p name))) + (apply #'trace-function `(setf ,sym) args))))) + +(defun trace-print-body (print-form) + (when print-form + (if (and (consp print-form) (eq (car print-form) 'values)) + `((mapcar #'(lambda (name object) + (trace-tab :in) + (format *trace-output* "~s = ~s" name object)) + ',(cdr print-form) + (list ,@(cdr print-form)))) + `((let ((objects (multiple-value-list ,print-form)) + (i -1)) + (if (and objects (not (cdr objects))) + (progn + (trace-tab :in) + (format *trace-output* "~s = ~s" ',print-form (car objects))) + (dolist (object objects) + (trace-tab :in) + (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object)))))))) + +(defun trace-backtrace-body (test-form) + (when test-form + `((let ((test ,test-form)) + (when test + (multiple-value-bind (detailed-p count) + (cond ((memq test '(:detailed :verbose :full)) + (values t nil)) + ((integerp test) + (values nil test)) + ((and (consp test) + (keywordp (car test)) + (consp (cdr test)) + (null (cddr test))) + (values (memq (car test) '(:detailed :verbose :full)) + (and (integerp (cadr test)) (cadr test)))) + (t (values nil nil))) + (let ((*debug-io* *trace-output*)) + (print-call-history :detailed-p detailed-p + :count (or count most-positive-fixnum)) + (terpri *trace-output*)))))))) + +(defun trace-inside-frame-p (name) + (if (packagep name) + (map-call-frames #'(lambda (p) + (let* ((fn (cfp-lfun p)) + (fname (and fn (function-name fn))) + (sym (typecase fname + (method (method-name fname)) + (cons (and (setf-function-name-p fname) (cadr fname))) + (symbol fname) + (t nil)))) + (when (and sym (eq (symbol-package sym) name)) + (return-from trace-inside-frame-p t))))) + (let ((fn (%encap-binding name))) + (when fn + (map-call-frames #'(lambda (p) + (when (eq (cfp-lfun p) fn) + (return-from trace-inside-frame-p t)))))))) + +(defun trace-package-spec (spec) + (when (or (stringp spec) + (packagep spec) + (and (consp spec) (eq (car spec) :package))) + (let ((pkg (if (consp spec) + (destructuring-bind (pkg) (cdr spec) pkg) + spec))) + (pkg-arg pkg)))) + +(defun trace-function (spec &rest args &key before after methods + (if t) (before-if t) (after-if t) + print print-before print-after + eval eval-before eval-after + break break-before break-after + backtrace backtrace-before backtrace-after + inside + define-if-not + ;; Some synonyms, just to be nice + (condition t) (if-before t) (if-after t) (wherein nil)) + + (declare (dynamic-extent args)) + (let ((pkg (trace-package-spec spec))) + (when pkg + (return-from trace-function (apply #'%trace-package pkg args)))) + + ;; A little bit of dwim, after all this _is_ an interactive tool... + (unless (eq condition t) + (setq if (if (eq if t) condition `(and ,if ,condition)))) + (unless (eq if-before t) + (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before)))) + (unless (eq if-after t) + (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after)))) + (when (and inside (trace-spec-p inside)) + (setq inside (list inside))) + (when wherein + (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein)))) + (case break + (:before (setq break-before (or break-before t) break nil)) + (:after (setq break-after (or break-after t) break nil))) + (case backtrace + (:before (setq backtrace-before (or backtrace-before t) backtrace nil)) + (:after (setq backtrace-after (or backtrace-after t) backtrace nil))) + (case before + (:break (setq before :print break-before t)) + (:backtrace (setq before :print backtrace-before t))) + (case after + (:break (setq after :print break-after t)) + (:backtrace (setq after :print backtrace-after t))) + + (when break + (setq break-before (if break-before + `(and ,break ,break-before) + break)) + (setq break-after (if break-after + `(and ,break ,break-after) + break))) + (unless backtrace-before + (setq backtrace-before backtrace)) + (when (and (consp backtrace-before) (keywordp (car backtrace-before))) + (setq backtrace-before `',backtrace-before)) + (when (and (consp backtrace-after) (keywordp (car backtrace-after))) + (setq backtrace-after `',backtrace-after)) + + (when (and (null before) (null after)) + (setq before :print) + (setq after :print)) + (when (and (null before) backtrace-before) + (setq before :print)) + + (case before + ((:print :default) (setq before #'trace-before))) + (case after + ((:print :default) (setq after #'trace-after))) + + (when (or (non-nil-symbol-p before) (functionp before)) + (setq before `',before)) + (when (or (non-nil-symbol-p after) (functionp after)) + (setq after `',after)) + + (when inside + (let ((tests (loop for spec in inside + as name = (or (trace-package-spec spec) + (%encapsulation-thing spec nil nil) + (error "Cannot trace inside ~s" spec)) + collect `(trace-inside-frame-p ',name)))) + (setq if `(and ,if (or ,@tests))))) + + (setq eval-before `(,@(trace-print-body print-before) + ,@(trace-print-body print) + ,@(and eval-before `(,eval-before)) + ,@(and eval `(,eval)) + ,@(and before `((apply ,before ',spec args))) + ,@(trace-backtrace-body backtrace-before) + ,@(and break-before `((when ,break-before + (force-output *trace-output*) + (break "~s trace entry: ~s" ',spec args)))))) + (setq eval-after `(,@(trace-backtrace-body backtrace-after) + ,@(and after `((apply ,after ',spec vals))) + ,@(and eval `(,eval)) + ,@(and eval-after `(,eval-after)) + ,@(trace-print-body print) + ,@(trace-print-body print-after) + ,@(and break-after `((when ,break-after + (force-output *trace-output*) + (break "~s trace exit: ~s" ',spec vals)))))) + + (prog1 + (block %trace-block + ;; + ;; see if we're a callback + ;; + (when (and (typep spec 'symbol) + (boundp spec) + (macptrp (symbol-value spec))) + (let ((len (length %pascal-functions%)) + (sym-name (symbol-name spec))) + (declare (fixnum len)) + (dotimes (i len) + (let ((pfe (%svref %pascal-functions% i))) + (when (and (vectorp pfe) + (string= sym-name (symbol-name (pfe.sym pfe)))) + (when backtrace + (if (null before) + (setq before :print))) + (setf (pfe.trace-p pfe) + `(,@(if before `((:before . ,before))) + ,@(if after `((:after . ,after))) + ,@(if backtrace `((:backtrace . ,backtrace))))) + (push spec *trace-pfun-list*))))) + (return-from %trace-block)) + ;; + ;; now look for traceable methods. + ;; It's possible, but not likely, that we will be both + ;; a callback and a function or method, if so we trace both. + ;; This isn't possible. + ;; If we're neither, signal an error. + ;; + (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def) + (%untrace-1 trace-thing) + (setq def (%encap-binding trace-thing)) + (when (and methods (typep def 'standard-generic-function)) + (dolist (m (%gf-methods def)) + (apply #'trace-function m args))) + #+old + (when step ; just check if has interpreted def + (if (typep def 'standard-generic-function) + (let ((methods (%gf-methods def))) + ; should we complain if no methods? naah + (dolist (m methods) ; stick :step-gf in advice-when slot + (%trace m :step t) + (let ((e (function-encapsulation m))) + (when e (setf (encapsulation-advice-when e) :step-gf)))) + ; we choose to believe that before and after are intended for the gf + (if (or before after) + (setq step nil) + (return-from %trace-block))) + #|(uncompile-for-stepping trace-thing nil t)|#)) + (let* ((newsym (gensym "TRACE")) + (method-p (typep trace-thing 'method)) + (newdef (trace-global-def + spec newsym if before-if eval-before after-if eval-after method-p))) + (when method-p + (copy-method-function-bits def newdef)) + (encapsulate trace-thing newdef 'trace spec newsym)))) + (when *trace-hook* + (apply *trace-hook* spec args)))) + + +(defun %traced-p (thing) + (let ((cap (get-encapsulation thing))) + (and cap (eq (encapsulation-type cap) 'trace)))) + +(defmacro untrace (&rest syms) + "Remove tracing from the specified functions. With no args, untrace all + functions." + (if syms + `(%untrace-0 ',syms) + `(%untrace-all))) + +(defun %untrace-0 (syms) + (let (val x) + (dolist (symbol syms) + (setq x (%untrace symbol)) + (when x (push x val))) + val)) + +(defun %untrace-all () + (dolist (pfun *trace-pfun-list*) + (%untrace pfun) + (when *untrace-hook* + (funcall *untrace-hook* pfun))) + (loop for cap being the hash-value of *encapsulation-table* + when (eq (encapsulation-type cap) 'trace) + collect (let ((spec (encapsulation-spec cap))) + (remove-encapsulation cap) + (when *untrace-hook* + (funcall *untrace-hook* spec)) + spec))) + +(defun %untrace (sym &aux val) + (when (and (consp sym)(consp (car sym))) + (setq sym (car sym))) + (cond + ((and (typep sym 'symbol) + (boundp sym) + (macptrp (symbol-value sym))) + (%untrace-pfun sym)) + (t + (let* ((trace-thing (%encapsulation-thing sym)) + (def (%encap-binding trace-thing))) + (when (typep def 'standard-generic-function) + (let ((methods (%gf-methods def))) + (dolist (m methods) + (let ((cap (get-encapsulation m))) + (when (and cap (eq (encapsulation-advice-when cap) :step-gf)) + (remove-encapsulation cap) + (push m val)))))) + ; gf could have first been traced :step, and then just plain traced + ; maybe the latter trace should undo the stepping?? + (let ((spec (%untrace-1 trace-thing))) + (when spec + (push spec val)))))) + (when *untrace-hook* + (funcall *untrace-hook* sym)) + (if (null (cdr val)) (car val) val)) + +;; thing is a symbol or method - def is current definition +;; we already know its traced +(defun %untrace-1 (thing) + (let ((cap (get-encapsulation thing))) + (when (and cap (eq (encapsulation-type cap) 'trace)) + (remove-encapsulation cap) + (encapsulation-spec cap)))) + +(defun %untrace-pfun (sym) + (let ((len (length %pascal-functions%)) + (sym-name (symbol-name sym))) + (declare (fixnum len)) + (dotimes (i len) + (let ((pfe (%svref %pascal-functions% i))) + (when (and (vectorp pfe) + (string= sym-name (symbol-name (pfe.sym pfe)))) + (setf (pfe.trace-p pfe) nil + *trace-pfun-list* (remove sym *trace-pfun-list*)) + (return-from %untrace-pfun sym)))) + nil)) + + + +(defmacro trace (&rest syms) + "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }* + +TRACE is a debugging tool that provides information when specified +functions are called." + (if syms + (let ((options (loop while (keywordp (car syms)) + nconc (list (pop syms) (pop syms))))) + `(%trace-0 ',syms ',options)) + `(%trace-list))) + +(defun trace-spec-p (arg) + (or (atom arg) + (memq (car arg) '(:method setf :package)))) + + +(defun %trace-0 (syms &optional global-options) + (dolist (spec syms) + (if (trace-spec-p spec) + (apply #'trace-function spec global-options) + (apply #'trace-function (append spec global-options))))) + +(defun %trace-list () + (let (res) + (loop for x being the hash-value of *encapsulation-table* + when (eq (encapsulation-type x) 'trace) + do (push (encapsulation-spec x) res)) + (dolist (x *trace-pfun-list*) + (push x res)) + res)) + +(defmacro with-traces (syms &body body) + `(unwind-protect + (progn + (let ((*trace-output* (make-broadcast-stream))) + ;; if you're tracing ccl internals you'll get trace output as it encapsulates the + ;; functions so hide all the trace output while eval'ing the trace form itself. + (trace ,@syms)) + ,@body) + (untrace ,@syms))) + +;; this week def is the name of an uninterned gensym whose fn-cell is original def + +(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p) + (let ((saved-method-var (gensym)) + (enable (gensym)) + do-it) + (setq do-it + (cond #+old (step + (setq step-it + `(step-apply-simple ',def args)) + (if (eq step t) + step-it + `(if (apply ',step ',sym args) ; gaak + ,step-it + ,(if (and before method-p) + `(apply-with-method-context ,saved-method-var (symbol-function ',def) args) + `(apply ',def args))))) + (t (if (and eval-before method-p) + `(apply-with-method-context ,saved-method-var (symbol-function ',def) args) + `(apply ',def args))))) + (compile-named-function-warn + `(lambda (,@(and eval-before method-p `(&method ,saved-method-var)) + &rest args) ; if methodp put &method on front of args - vs get-saved-method-var? + (declare (dynamic-extent args)) + (declare (ftype function ,def)) + (let ((*trace-level* (1+ *trace-level*)) + (,enable ,if)) + (declare (special *trace-enable* *trace-level*)) + ,(when eval-before + `(when (and ,enable ,before-if *trace-enable*) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym t)) + (let* ((*trace-enable* nil)) + ,@eval-before) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym nil)))) + ,(if eval-after + `(let ((vals (multiple-value-list ,do-it))) + (when (and ,enable ,after-if *trace-enable*) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym t)) + (let* ((*trace-enable* nil)) + ,@eval-after) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym nil))) + (values-list vals)) + do-it))) + `(traced ,sym) + :keep-symbols t))) + +; &method var tells compiler to bind var to contents of next-method-context +(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist) + (let* ((saved-method-var (gensym))) + `(lambda (,@(if (and method-p (neq when :after)) + `(&method ,saved-method-var)) + &rest arglist) + ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist)))) + (declare (ftype function ,def)) + (let () + ,(ecase + when + (:before + `(block nil + ,stuff + (return ,(if method-p + `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist) + `(apply ',def arglist))))) + (:after + `(block nil + (let ((values (multiple-value-list (apply (function ,def) arglist)))) + ;(declare (dynamic-extent values)) + ,stuff + (return (values-list values))))) + (:around + ;; stuff is e.g. (+ 5 (:do-it)) + (if method-p + `(macrolet ((:do-it () + `(apply-with-method-context ,',saved-method-var + (symbol-function ',',def) + arglist))) + (block nil + (return ,stuff))) + `(macrolet ((:do-it () + `(apply (function ,',def) arglist))) + (block nil + (return ,stuff)))))))))) + + +(defun compile-named-function-warn (fn name &rest keys) + (declare (dynamic-extent keys)) + (multiple-value-bind (result warnings) (apply #'compile-named-function fn :name name keys) + (when warnings + (let ((first t)) + (dolist (w warnings) + (signal-compiler-warning w first nil nil nil) + (setq first nil)))) + result)) + + +(defun %advised-p (thing) + (loop for nx = thing then (encapsulation-symbol cap) + as cap = (get-encapsulation nx) while cap + thereis (eq (encapsulation-type cap) 'advice))) + +(defun %advice-encapsulations (thing when advice-name) + (loop for nx = thing then (encapsulation-symbol cap) + as cap = (get-encapsulation nx) while cap + when (and (eq (encapsulation-type cap) 'advice) + (or (null when) (eq when (encapsulation-advice-when cap))) + (or (null advice-name) (equal advice-name (encapsulation-advice-name cap)))) + collect cap)) + +(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not) + (let* ((advise-thing (%encapsulation-thing function-spec define-if-not)) + orig-sym) + (let ((capsules (%advice-encapsulations advise-thing when advice-name))) + (when capsules + (unadvise-capsules capsules))) + (when (%traced-p advise-thing) + ; make traced call advised + (setq orig-sym + (encapsulation-symbol (get-encapsulation advise-thing)))) + (lfun-name newdef `(advised ',function-spec)) + (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef)) + (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when) + newdef)) + +(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist) + (let* ((newsym (gensym "ADVICE")) + ; WAS typep advise-thing 'method + (method-p (or (typep function 'method) ; can this happen? + (and (consp function)(eq (car function) :method)))) + (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist))) + `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name + ,define-if-not))) + +(defmacro advisedp (function-spec &key when name) + `(advisedp-1 ',function-spec ',when ',name)) + +(defun encapsulation-advice-spec (cap) + (list (encapsulation-spec cap) + (encapsulation-advice-when cap) + (encapsulation-advice-name cap))) + +(defun advisedp-1 (function-spec when name) + (cond ((eq t function-spec) + (loop for c being the hash-value of *encapsulation-table* + when (and (eq (encapsulation-type c) 'advice) + (or (null when)(eq when (encapsulation-advice-when c))) + (or (null name)(equal name (encapsulation-advice-name c)))) + collect (encapsulation-advice-spec c))) + (t (let* ((advise-thing (%encapsulation-thing function-spec)) + (capsules (%advice-encapsulations advise-thing when name))) + (mapcar #'encapsulation-advice-spec capsules))))) + +(defun %unadvise-1 (function-spec &optional when advice-name ignore) + (declare (ignore ignore)) + (let ((advise-thing (%encapsulation-thing function-spec))) + (let ((capsules (%advice-encapsulations advise-thing when advice-name))) + (when capsules (unadvise-capsules capsules))))) + +(defun unadvise-capsules (capsules) + (let (val) + (dolist (capsule capsules) + (push (encapsulation-advice-spec capsule) val) + (remove-encapsulation capsule)) + val)) + +(defmacro unadvise (function &key when name) + (cond ((neq function t) + `(%unadvise-1 ',function ',when ',name)) + (t '(%unadvise-all)))) + +(defun %unadvise-all () + (loop for cap being the hash-value of *encapsulation-table* + when (eq (encapsulation-type cap) 'advice) + collect (progn + (remove-encapsulation cap) + (encapsulation-advice-spec cap)))) + +;; Called from %defun. Return t if we defined it, nil otherwise +(defun %defun-encapsulated-maybe (name newdef) + (assert (not (get-encapsulation newdef))) + (let ((old-def (fboundp name)) cap) + (when (and old-def (setq cap (get-encapsulation name))) + (cond ((or (and *loading-files* *loading-removes-encapsulation*) + ;; redefining a gf as a fn. + (typep old-def 'standard-generic-function)) + (forget-encapsulations name) + nil) + (t (set-unencapsulated-definition cap newdef) + T))))) + +;; Called from clos when change dcode +(defun %set-encapsulated-gf-dcode (gf new-dcode) + (loop with cap = (get-encapsulation gf) + for gf-copy = (encapsulation-old-def cap) + as cur-dcode = (%gf-dcode gf-copy) + do (setq cap (get-encapsulation cur-dcode)) + ;; refresh all the gf copies, in case other info in gf changed + do (%copy-function gf gf-copy) + do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode)) + while cap)) + +;; Called from clos when oldmethod is being replaced by newmethod in a gf. +(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap) + (unless (eq oldmethod newmethod) + (cond ((and *loading-removes-encapsulation* *loading-files*) + (when (%traced-p oldmethod) + (warn "~%... Untracing ~s" (%untrace-1 oldmethod))) + (when (%advised-p oldmethod) + (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod)))) + (t (when (setq cap (get-encapsulation oldmethod)) + (let* ((old-inner-def (find-unencapsulated-definition oldmethod)) + (newdef (%method-function newmethod)) + (olddef (%method-function oldmethod))) + ;; make last encapsulation call new definition + (set-unencapsulated-definition cap newdef) + (setf (%method-function newmethod) olddef) + (set-encapsulation-owner olddef newmethod) + (setf (%method-function oldmethod) old-inner-def) + (loop + for def = olddef then (encapsulation-old-def cap) + for cap = (get-encapsulation def) while cap + do (copy-method-function-bits newdef def)))))))) + +#| + Change History (most recent last): + 2 12/29/94 akh merge with d13 +|# ;(do not edit past this line!!) Index: /branches/qres/ccl/lib/ffi-darwinppc32.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-darwinppc32.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-darwinppc32.lisp (revision 13564) @@ -0,0 +1,258 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; If a record type has a single scalar field, return the type +;;; of that field. +(defun darwin32::record-type-has-single-scalar-field (record-type) + (when (eq (foreign-record-type-kind record-type) :struct) + (require-foreign-type-bits record-type) + (let* ((fields (foreign-record-type-fields record-type))) + (when (null (cdr fields)) + (let* ((f0 (car fields)) + (type (foreign-record-field-type f0))) + (typecase type + ((or foreign-record-type foreign-array-type) nil) + (otherwise type))))))) + +;;; If type denotes a foreign record type, return T if it would +;;; be "returned" by passing it as the first argument to the callee. +;;; On DarwinPPC32, this is true of all record types except for +;;; those for which RECORD-TYPE-HAS-SINGLE-SCALAR-FIELD returns +;;; true. +(defun darwin32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (and (typep ftype 'foreign-record-type) + (not (darwin32::record-type-has-single-scalar-field ftype)))))) + + +;;; Structures that contain a single scalar field are "returned" +;;; as a value with that field's type. +;;; Other structures are "returned" by passing a pointer to a structure +;;; of the appropriate type as the first argument. +;;; Structures that contain a single scalar field are passed by value +;;; by passing the value of that field as a scalar. +;;; Structures that contain more than one field are passed by value +;;; as a sequence of N 32-bit words; %ff-call understands an unsigned +;;; integer argument "type" specifier to denote this. + +(defun darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (enclosing-form nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (let* ((single-scalar (darwin32::record-type-has-single-scalar-field result-type)) + (result-form (pop args))) + (if single-scalar + (progn + (setq enclosing-form `(setf ,(%foreign-access-form result-form single-scalar 0 nil)) + result-type single-scalar + result-type-spec (foreign-type-to-representation-type result-type))) + + (progn + (argforms :address) + (argforms result-form) + (setq result-type *void-foreign-type* + result-type-spec :void))))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (let* ((single-scalar (darwin32::record-type-has-single-scalar-field ftype))) + (if single-scalar + (progn + (argforms (foreign-type-to-representation-type single-scalar)) + (argforms (%foreign-access-form arg-value-form single-scalar 0 nil))) + (let* ((bits (ensure-foreign-type-bits ftype))) + (argforms (ceiling bits 32)) + (argforms arg-value-form)))) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (if enclosing-form + `(,@enclosing-form ,call) + call)))))) + + + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR + +(defun darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec)) + (fp-regs-form nil)) + (flet ((set-fp-regs-form () + (unless fp-regs-form + (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc32::c-frame.unused-1 ppc32::c-frame.param0)))))) + (when (typep rtype 'foreign-record-type) + (if (darwin32::record-type-has-single-scalar-field rtype) + (rlets (list struct-result-name (foreign-record-type-name rtype))) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*))) + (when (typep rtype 'foreign-float-type) + (set-fp-regs-form)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (fp-arg-num 0) + (offset 0 (+ offset delta)) + (delta 4 4) + (bias 0 0) + (use-fp-args nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc32::c-frame.savelr ppc32::c-frame.param0))) + (flet ((next-scalar-arg (argtype) + `(,(cond + ((typep argtype 'foreign-single-float-type) + (if (< (incf fp-arg-num) 14) + (progn + (setq use-fp-args t) + '%get-single-float-from-double-ptr) + (progn + '%get-single-float))) + ((typep argtype 'foreign-double-float-type) + (setq delta 8) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + (setq delta 8) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + (setq delta 8) + '%%get-unsigned-longlong) + ((or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + '%get-ptr) + (t + (cond ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 3) + (if signed + '%get-signed-byte + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 2) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,(if use-fp-args fp-args-ptr stack-ptr) + ,(if use-fp-args (* 8 (1- fp-arg-num)) + (+ offset bias))))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec))) + (if (typep argtype 'foreign-record-type) + (let* ((type0 (darwin32::record-type-has-single-scalar-field argtype))) + (if type0 + (progn + (when name (rlets (list name (foreign-record-type-name argtype)))) + (let* ((init `(setf ,(%foreign-access-form name type0 0 nil) + ,(next-scalar-arg type0)))) + (when name (inits init)))) + (progn + (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4)) + (when name ; no side-efects hers + (lets (list name `(%inc-ptr ,stack-ptr ,offset))))))) + (let* ((pair (list name (next-scalar-arg argtype)))) + (when name (lets pair)))) + #+nil + (when (or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + (dynamic-extent-names name)) + (when use-fp-args (set-fp-regs-form))))))))) + +(defun darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (unless (eq return-type *void-foreign-type*) + ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (when (typep return-type 'foreign-record-type) + ;;; Would have been mapped to :VOID unless record-type contained + ;;; a single scalar field. + (let* ((field0 (car (foreign-record-type-fields return-type)))) + (setq result (%foreign-access-form struct-return-arg + (foreign-record-field-type field0) + 0 + nil) + return-type (foreign-record-field-type field0)))) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (result-ptr (case return-type-keyword + ((:single-float :double-float) + fp-args-ptr) + (t stack-ptr)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) + '%get-double-float) + (:unsigned-fullword '%get-unsigned-long) + (t '%get-long ) + ) ,result-ptr 0) ,result)))) + Index: /branches/qres/ccl/lib/ffi-darwinppc64.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-darwinppc64.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-darwinppc64.lisp (revision 13564) @@ -0,0 +1,543 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; On DarwinPPC64: +;;; Structures whose size is exactly 16 bytes are passed in 2 GPRs, +;;; regardless of the types of their elements, when they are passed +;;; by value. +;;; Structures which contain unions are passed in N GPRs when passed +;;; by value. +;;; All other structures passed by value are passed by passing their +;;; constituent elements as scalars. (Sort of.) GPR's are "consumed" +;;; for and possibly/partly loaded with the contents of each 64-bit +;;; word; FPRs (and vector registers) are consumed/loaded for each +;;; field of the indicated type. +;;; Structures whose size is exactly 16 bytes are returned in GPR3 +;;; and GPR4. +;;; Structures which contain unions are "returned" by passing a pointer +;;; to a structure instance in the first argument. +;;; All other structures are returned by returning their constituent +;;; elements as scalars. (Note that - in some cases - we may need +;;; to reserve space in the foreign stack frame to handle scalar +;;; return values that don't fit in registers. Need a way to tell +;;; %ff-call about this, as well as runtime support.) + + +(defun darwin64::record-type-contains-union (rtype) + ;;; RTYPE is a FOREIGN-RECORD-TYPE object. + ;;; If it, any of its fields, or any fields in an + ;;; embedded structure or array field is a union, + ;;; return true. + ;;; (If this function returns true, we can't + ;;; pass a structure of type RTYPE - or return one - + ;;; by passing or returning the values of all of + ;;; its fields, since some fields are aliased. + ;;; However, if the record's size is exactly 128 + ;;; bits, we can pass/return it in two GPRs.) + (ensure-foreign-type-bits rtype) + (or (eq (foreign-record-type-kind rtype) :union) + (dolist (f (foreign-record-type-fields rtype)) + (let* ((fieldtype (foreign-record-field-type f))) + (if (and (typep fieldtype 'foreign-record-type) + (darwin64::record-type-contains-union fieldtype)) + (return t)) + (if (typep fieldtype 'foreign-array-type) + (let* ((atype (foreign-array-type-element-type fieldtype))) + (if (and (typep atype 'foreign-record-type) + (darwin64::record-type-contains-union atype)) + (return t)))))))) + +;;; On DarwinPPC64, we only have to pass a structure as a first +;;; argument if the type contains a union +(defun darwin64::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (and (typep ftype 'foreign-record-type) + (not (= (ensure-foreign-type-bits ftype) 128)) + (darwin64::record-type-contains-union ftype))))) + + + + + +;;; Generate code to set the fields in a structure R of record-type +;;; RTYPE, based on the register values in REGBUF (8 64-bit GPRs, +;;; followed by 13 64-bit GPRs.) +;;; This also handles the 16-byte structure case. +;;; (It doesn't yet handle embedded arrays or bitfields.) +(defun darwin64::struct-from-regbuf-values (r rtype regbuf) + (let* ((bits (ccl::ensure-foreign-type-bits rtype))) + (collect ((forms)) + (cond ((= bits 128) ;(and (eql day 'tuesday) ...) + (forms `(setf (ccl::%get-signed-long ,r 0) + (ccl::%get-signed-long ,regbuf 0) + (ccl::%get-signed-long ,r 4) + (ccl::%get-signed-long ,regbuf 4) + (ccl::%get-signed-long ,r 8) + (ccl::%get-signed-long ,regbuf 8) + (ccl::%get-signed-long ,r 12) + (ccl::%get-signed-long ,regbuf 12)))) + ;;; One (slightly naive) way to do this is to just + ;;; copy GPRs into the structure until it's full, + ;;; then go back and overwrite float-typed fields + ;;; with FPRs. That'd be very naive if all fields + ;;; were float-typed, slightly naive if some fields + ;;; were properly-aligned DOUBLE-FLOATs or if two + ;;; SINGLE-FLOATs were packed inro a 64-bit word, + ;;; and not that bad if a SINGLE-FLOAT shared a + ;;; 64-bit word with a non-FP field. + (t + (let* ((fpr-offset (* 8 8)) + (fields (foreign-record-type-fields rtype))) + (flet ((next-fpr-offset () + (prog1 fpr-offset + (incf fpr-offset 8)))) + (unless (all-floats-in-field-list fields) + (do* ((b 0 (+ b 32)) + (w 0 (+ w 4))) + ((>= b bits)) + (declare (fixnum b w)) + (forms `(setf (%get-unsigned-long ,r ,w) + (%get-unsigned-long ,regbuf ,w))))) + (when (some-floats-in-field-list fields) + (labels ((do-fp-fields (fields accessors) + (dolist (field fields) + (let* ((field-type (foreign-record-field-type field)) + (field-accessor-list (append accessors (list (foreign-record-field-name field)))) + (valform ())) + (etypecase field-type + (foreign-record-type + (do-fp-fields (foreign-record-type-fields field-type) + field-accessor-list)) + (foreign-double-float-type + (setq valform + `(%get-double-float ,regbuf ,(next-fpr-offset)))) + (foreign-single-float-type + (setq valform + `(%get-single-float-from-double-ptr + ,regbuf ,(next-fpr-offset)))) + (foreign-array-type + (error "Embedded array-type.")) + ) + (when valform + (forms `(setf ,(%foreign-access-form + r + rtype + 0 + field-accessor-list) + ,valform))))))) + (do-fp-fields (foreign-record-type-fields rtype) nil ))))))) + `(progn ,@(forms) nil)))) + +;;; "Return" the structure R of foreign type RTYPE, by storing the +;;; values of its fields in STACK-PTR and FP-ARG-PTR +(defun darwin64::return-struct-to-registers (r rtype stack-ptr fp-args-ptr) + (let* ((bits (require-foreign-type-bits rtype))) + (collect ((forms)) + (cond ((= bits 128) ;(and (eql day 'tuesday) ...) + (forms `(setf (ccl::%get-unsigned-long ,stack-ptr 0) + (ccl::%get-unsigned-long ,r 0) + (ccl::%get-unsigned-long ,stack-ptr 4) + (ccl::%get-unsigned-long ,r 4) + (ccl::%get-unsigned-long ,stack-ptr 8) + (ccl::%get-unsigned-long ,r 8) + (ccl::%get-unsigned-long ,stack-ptr 12) + (ccl::%get-unsigned-long ,r 12)))) + (t + (let* ((fpr-offset 0) + (fields (foreign-record-type-fields rtype))) + (unless (all-floats-in-field-list fields) + (do* ((b 0 (+ b 32)) + (w 0 (+ w 4))) + ((>= b bits)) + (declare (fixnum b w)) + (forms `(setf (%get-unsigned-long ,stack-ptr ,w) + (%get-unsigned-long ,r ,w))))) + (when (some-floats-in-field-list fields) + (flet ((next-fpr-offset () + (prog1 fpr-offset + (incf fpr-offset 8)))) + (labels ((do-fp-fields (fields accessors) + (dolist (field fields) + (let* ((field-type (foreign-record-field-type field)) + (field-accessor-list (append accessors (list (foreign-record-field-name field)))) + (valform ())) + (etypecase field-type + (foreign-record-type + (do-fp-fields (foreign-record-type-fields field-type) + field-accessor-list)) + (foreign-double-float-type + (setq valform + `(%get-double-float ,fp-args-ptr ,(next-fpr-offset)))) + (foreign-single-float-type + (setq valform + `(%get-double-float ,fp-args-ptr ,(next-fpr-offset)))) + + (foreign-array-type + (error "Embedded array-type.")) + ) + (when valform + (let* ((field-form (%foreign-access-form + r + rtype + 0 + field-accessor-list))) + (when (typep field-type 'foreign-single-float-type) + (setq field-form `(float ,field-form 0.0d0))) + (forms `(setf ,valform ,field-form)))))))) + (do-fp-fields fields nil ))))))) + `(progn ,@(forms) nil)))) + +;;; Return an ordered list of all scalar fields in the record type FTYPE. +(defun darwin64::flatten-fields (ftype) + (if (darwin64::record-type-contains-union ftype) + (error "Can't flatten fields in ~s: contains union" ftype)) + (collect ((fields)) + (labels ((flatten (field-list bit-offset) + (dolist (field field-list) + (let* ((field-type (foreign-record-field-type field)) + (next-offset (+ bit-offset (foreign-record-field-offset field)))) + (typecase field-type + (foreign-record-type + (flatten (foreign-record-type-fields field-type) next-offset)) + (foreign-array-type + (let* ((element-type (foreign-array-type-element-type field-type)) + (nbits (foreign-type-bits element-type)) + (align (foreign-type-alignment element-type)) + (dims (foreign-array-type-dimensions field-type)) + (n (or (and (null (cdr dims)) (car dims)) + (error "Can't handle multidimensional foreign arrays"))) + (pos next-offset)) + (dotimes (i n) + (fields (make-foreign-record-field :type element-type + :bits nbits + :offset pos)) + (setq pos (align-offset (+ pos nbits) align))))) + (t + (fields (make-foreign-record-field :type field-type + :bits (foreign-record-field-bits field) + :offset next-offset)))))))) + (flatten (foreign-record-type-fields ftype) 0) + (fields)))) + + + + +(defun darwin64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (regbuf nil) + (result-temp nil) + (result-form nil) + (struct-result-type nil) + (structure-arg-temp nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args) + struct-result-type result-type + result-type *void-foreign-type* + result-type-spec :void) + (if (darwin64::record-type-returns-structure-as-first-arg struct-result-type) + (progn + (argforms :address) + (argforms result-form)) + (progn + (setq regbuf (gensym) + result-temp (gensym)) + (argforms :registers) + (argforms regbuf)))) + (let* ((valform nil)) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec)) + (bits (foreign-type-bits ftype))) + (if (typep ftype 'foreign-record-type) + (if (or (darwin64::record-type-contains-union ftype) + (= bits 128)) + (progn + (argforms (ceiling (foreign-record-type-bits ftype) 64)) + (argforms arg-value-form)) + (let* ((flattened-fields (darwin64::flatten-fields ftype))) + + (flet ((single-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) + (return nil)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-single-float-type)) + (return t))))) + (double-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) + (return nil)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-double-float-type)) + (return t)))))) + (unless structure-arg-temp + (setq structure-arg-temp (gensym))) + (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form)) + (do* ((bit-offset 0 (+ bit-offset 64)) + (byte-offset 0 (+ byte-offset 8))) + ((>= bit-offset bits)) + (if (double-float-at-offset bit-offset) + (progn + (argforms :double-float) + (argforms `(%get-double-float ,valform ,byte-offset))) + (let* ((high-single (single-float-at-offset bit-offset)) + (low-single (single-float-at-offset (+ bit-offset 32)))) + (if high-single + (if low-single + (argforms :hybrid-float-float) + (argforms :hybrid-float-int)) + (if low-single + (argforms :hybrid-int-float) + (argforms :unsigned-doubleword))) + (argforms `(%%get-unsigned-longlong ,valform ,byte-offset)))) + (setq valform structure-arg-temp))))) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (when structure-arg-temp + (setq call `(let* ((,structure-arg-temp (%null-ptr))) + (declare (dynamic-extent ,structure-arg-temp) + (type macptr ,structure-arg-temp)) + ,call))) + (if regbuf + `(let* ((,result-temp (%null-ptr))) + (declare (dynamic-extent ,result-temp) + (type macptr ,result-temp)) + (%setf-macptr ,result-temp ,result-form) + (%stack-block ((,regbuf (+ (* 8 8) (* 8 13)))) + ,call + ,(darwin64::struct-from-regbuf-values result-temp struct-result-type regbuf))) + call))))))) + + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR + +(defun darwin64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec)) + (fp-regs-form nil)) + (flet ((set-fp-regs-form () + (unless fp-regs-form + (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0)))))) + (when (typep rtype 'foreign-record-type) + (if (darwin64::record-type-contains-union rtype) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*) + (rlets (list struct-result-name (or (foreign-record-type-name rtype) + result-spec))))) + (when (typep rtype 'foreign-float-type) + (set-fp-regs-form)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (fp-arg-num 0) + (offset 0) + (delta 0) + (bias 0) + (use-fp-args nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc64::c-frame.savelr ppc64::c-frame.param0))) + (flet ((next-scalar-arg (argtype) + (setq delta 8 bias 0) + (prog1 + `(,(cond + ((typep argtype 'foreign-single-float-type) + (if (< (incf fp-arg-num) 14) + (progn + (setq use-fp-args t) + '%get-single-float-from-double-ptr) + (progn + '%get-single-float))) + ((typep argtype 'foreign-double-float-type) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + (setq delta 8) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + (setq delta 8) + '%%get-unsigned-longlong) + ((or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + '%get-ptr) + (t + (cond ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 7) + (if signed + '%get-signed-byte ' + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 6) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (setq bias 4) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,(if use-fp-args fp-args-ptr stack-ptr) + ,(if use-fp-args (* 8 (1- fp-arg-num)) + (+ offset bias))) + (incf offset delta)))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec)) + (bits (foreign-type-bits argtype))) + (if (typep argtype 'foreign-record-type) + (if (or (darwin64::record-type-contains-union argtype) + (= bits 128)) + (progn (setq delta (* (ceiling bits 64) 8)) + (when name (lets (list name `(%inc-ptr ,stack-ptr ,offset )))) + (incf offset delta)) + + (let* ((flattened-fields (darwin64::flatten-fields argtype))) + (flet ((double-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) (return)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-double-float-type)) + (return t))))) + (single-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) (return)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-single-float-type)) + (return t)))))) + (when name (rlets (list name (or (foreign-record-type-name argtype) + spec)))) + (do* ((bit-offset 0 (+ bit-offset 64)) + (byte-offset 0 (+ byte-offset 8))) + ((>= bit-offset bits)) + (if (double-float-at-offset bit-offset) + (let* ((init `(setf (%get-double-float ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type :double-float))))) + (when name + (inits init))) + (let* ((high-single (single-float-at-offset bit-offset)) + (low-single (single-float-at-offset (+ bit-offset 32))) + (init `(setf (%%get-unsigned-longlong ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type '(:unsigned 64)))))) + (when name (inits init)) + (when high-single + (when (< (incf fp-arg-num) 14) + (set-fp-regs-form) + (when name + (inits `(setf (%get-single-float ,name ,byte-offset) + (%get-single-float-from-double-ptr + ,fp-args-ptr + ,(* 8 (1- fp-arg-num)))))))) + (when low-single + (when (< (incf fp-arg-num) 14) + (set-fp-regs-form) + (when name + (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset)) + (%get-single-float-from-double-ptr + ,fp-args-ptr + ,(* 8 (1- fp-arg-num)))))))))))))) + (let* ((form (next-scalar-arg argtype))) + (when name + (lets (list name form))))) + #+nil + (when (or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + (dynamic-extent-names name)) + (when use-fp-args (set-fp-regs-form))))))))) + +(defun darwin64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (if (typep return-type 'foreign-record-type) + ;;; Would have been mapped to :VOID unless record-type contained + ;;; a single scalar field. + (darwin64::return-struct-to-registers struct-return-arg return-type stack-ptr fp-args-ptr) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (result-ptr (case return-type-keyword + ((:single-float :double-float) + fp-args-ptr) + (t stack-ptr)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) + '%get-double-float) + (:unsigned-fullword '%get-unsigned-long) + (t '%%get-signed-longlong ) + ) ,result-ptr 0) ,result))))) + + Index: /branches/qres/ccl/lib/ffi-darwinx8632.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-darwinx8632.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-darwinx8632.lisp (revision 13564) @@ -0,0 +1,38 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Some small structures are returned in EAX and EDX. Otherwise, +;;; return values are placed at the address specified by the caller. +(defun x86-darwin32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype))) + (nbits (ensure-foreign-type-bits ftype))) + (not (member nbits '(8 16 32 64)))))) + +;;; We don't support the __m64, __m128, __m128d, and __m128i types. +(defun x86-darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/qres/ccl/lib/ffi-darwinx8664.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-darwinx8664.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-darwinx8664.lisp (revision 13564) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, and Darwin all share the same +;;; ABI. + +(defun x86-darwin64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-darwin64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-darwin64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-darwin64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/qres/ccl/lib/ffi-freebsdx8632.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-freebsdx8632.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-freebsdx8632.lisp (revision 13564) @@ -0,0 +1,38 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; On FreeBSD, the C compiler returns small structures in registers +;;; (just like on Darwin, apparently). +(defun x86-freebsd32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype))) + (nbits (ensure-foreign-type-bits ftype))) + (not (member nbits '(8 16 32 64)))))) + +(defun x86-freebsd32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-freebsd32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-freebsd32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) + Index: /branches/qres/ccl/lib/ffi-freebsdx8664.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-freebsdx8664.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-freebsdx8664.lisp (revision 13564) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, and Darwin all share the same +;;; ABI. + +(defun x86-freebsd64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-freebsd64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-freebsd64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-freebsd64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/qres/ccl/lib/ffi-linuxppc32.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-linuxppc32.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-linuxppc32.lisp (revision 13564) @@ -0,0 +1,218 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; LinuxPPC32: +;;; Structures are never actually passed by value; the caller +;;; instead passes a pointer to the structure or a copy of it. +;;; In the EABI (which Linux uses, as opposed to the SVR4 ABI) +;;; structures are always "returned" by passing a pointer to +;;; a caller-allocated structure in the first argument. +(defun linux32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (typep ftype 'foreign-record-type)))) + + +(defun linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (enclosing-form nil) + (result-form nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args)) + (if (linux32::record-type-returns-structure-as-first-arg result-type) + (progn + (setq result-type *void-foreign-type* + result-type-spec :void) + (argforms :address) + (argforms result-form)) + ;; This only happens in the SVR4 ABI. + (progn + (setq result-type (parse-foreign-type :unsigned-doubleword) + result-type-spec :unsigned-doubleword + enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0)))))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (progn + (argforms :address) + (argforms arg-value-form)) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (if enclosing-form + `(,@enclosing-form ,call) + call)))))) + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR +(defun linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (declare (ignore fp-args-ptr)) + (collect ((lets) + (rlets) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec))) + (when (typep rtype 'foreign-record-type) + (let* ((bits (ensure-foreign-type-bits rtype))) + (if (<= bits 64) + (rlets (list struct-result-name (foreign-record-type-name rtype))) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*)))) + (let* ((offset 96) + (gpr 0) + (fpr 32)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs))) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#)) + (let* ((name (car argvars)) + (spec (car argspecs)) + (nextgpr gpr) + (nextfpr fpr) + (nextoffset offset) + (target gpr) + (bias 0) + (argtype (parse-foreign-type spec))) + (if (typep argtype 'foreign-record-type) + (setq argtype (parse-foreign-type :address))) + (let* ((access-form + `(,(cond + ((typep argtype 'foreign-single-float-type) + (incf nextfpr 8) + (if (< fpr 96) + (setq target fpr) + (setq target (+ offset (logand offset 4)) + nextoffset (+ target 8))) + '%get-single-float-from-double-ptr) + ((typep argtype 'foreign-double-float-type) + (incf nextfpr 8) + (if (< fpr 96) + (setq target fpr) + (setq target (+ offset (logand offset 4)) + nextoffset (+ target 8))) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + (if (< gpr 56) + (setq target (+ gpr (logand gpr 4)) + nextgpr (+ 8 target)) + (setq target (+ offset (logand offset 4)) + nextoffset (+ 8 offset))) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + (if (< gpr 56) + (setq target (+ gpr (logand gpr 4)) + nextgpr (+ 8 target)) + (setq target (+ offset (logand offset 4)) + nextoffset (+ 8 offset))) + '%%get-unsigned-longlong) + (t + (incf nextgpr 4) + (if (< gpr 64) + (setq target gpr) + (setq target offset nextoffset (+ offset 4))) + (cond ((typep argtype 'foreign-pointer-type) '%get-ptr) + ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 3) + (if signed + '%get-signed-byte ' + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 2) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,stack-ptr + ,(+ target bias)))) + (when name (lets (list name access-form))) + #+nil + (when (eq spec :address) + (dynamic-extent-names name)) + (setq gpr nextgpr fpr nextfpr offset nextoffset)))))))) + +(defun linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore fp-args-ptr)) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (let* ((return-type-keyword + (if (typep return-type 'foreign-record-type) + (progn + (setq result `(%%get-unsigned-longlong ,struct-return-arg 0)) + :unsigned-doubleword) + (foreign-type-to-representation-type return-type))) + (offset (case return-type-keyword + ((:single-float :double-float) + 8) + (t 0)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) '%get-double-float) + (t '%get-long)) ,stack-ptr ,offset) ,result)))) + + Index: /branches/qres/ccl/lib/ffi-linuxppc64.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-linuxppc64.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-linuxppc64.lisp (revision 13564) @@ -0,0 +1,199 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; LinuxPPC64 +;;; Structures whose size is less than 64 bits are passed "right-justified" +;;; in a GPR. +;;; Larger structures passed by value are passed in GPRs as N doublewords. +;;; If the structure would require > 64-bit alignment, this might result +;;; in some GPRs/parameter area words being skipped. (We don't handle this). +;;; All structures - of any size - are returned by passing a pointer +;;; in the first argument. + +(defun linux64::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (typep ftype 'foreign-record-type)))) + +(defun linux64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void))) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-type *void-foreign-type* + result-type-spec :void) + (argforms :address) + (argforms (pop args))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (let* ((bits (ensure-foreign-type-bits ftype))) + (if (< bits 64) + (progn + (argforms :unsigned-doubleword) + (argforms `(ash (%%get-unsigned-longlong ,arg-value-form 0) ,(- bits 64)))) + (progn + (argforms (ceiling bits 64)) + (argforms arg-value-form)))) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))))) + +(defun linux64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec)) + (fp-regs-form nil)) + (flet ((set-fp-regs-form () + (unless fp-regs-form + (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0)))))) + (when (typep rtype 'foreign-record-type) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*)) + (when (typep rtype 'foreign-float-type) + (set-fp-regs-form)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (fp-arg-num 0) + (offset 0 (+ offset delta)) + (delta 8 8) + (bias 0 0) + (use-fp-args nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc64::c-frame.savelr ppc64::c-frame.param0))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec)) + (bits (ensure-foreign-type-bits argtype))) + (if (and (typep argtype 'foreign-record-type) + (< bits 64)) + (progn + (when name (rlets (list name (foreign-record-type-name argtype)))) + (when name (inits `(setf (%%get-unsigned-longlong ,name 0) + (ash (%%get-unsigned-longlong ,stack-ptr ,offset) + ,(- 64 bits)))))) + (let* ((access-form + `(,(cond + ((typep argtype 'foreign-single-float-type) + (if (< (incf fp-arg-num) 14) + (progn + (setq use-fp-args t) + '%get-single-float-from-double-ptr) + (progn + (setq bias 4) + '%get-single-float))) + ((typep argtype 'foreign-double-float-type) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + '%%get-unsigned-longlong) + ((or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + '%get-ptr) + ((typep argtype 'foreign-record-type) + (setq delta (* (ceiling bits 64) 8)) + '%inc-ptr) + (t + (cond ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 7) + (if signed + '%get-signed-byte ' + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 6) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (setq bias 4) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,(if use-fp-args fp-args-ptr stack-ptr) + ,(if use-fp-args (* 8 (1- fp-arg-num)) + `(+ ,offset ,bias))))) + (when name (lets (list name access-form))) + #+nil + (when (eq spec :address) + (dynamic-extent-names name)) + (when use-fp-args (set-fp-regs-form)))))))))) + + +;;; All structures are "returned" via the implicit first argument; we'll have +;;; already translated the return type to :void in that case. +(defun linux64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore struct-return-arg)) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (result-ptr (case return-type-keyword + ((:single-float :double-float) + fp-args-ptr) + (t stack-ptr)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) + (setq stack-ptr `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0))) + '%get-double-float) + (t '%%get-signed-longlong ) + ) ,result-ptr 0) ,result)))) Index: /branches/qres/ccl/lib/ffi-linuxx8632.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-linuxx8632.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-linuxx8632.lisp (revision 13564) @@ -0,0 +1,28 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun x86-linux32::record-type-returns-structure-as-first-arg (rtype) + (x8632::record-type-returns-structure-as-first-arg rtype)) + +(defun x86-linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) + Index: /branches/qres/ccl/lib/ffi-linuxx8664.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-linuxx8664.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-linuxx8664.lisp (revision 13564) @@ -0,0 +1,36 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, and Darwin all share the same +;;; ABI. + +(defun x86-linux64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-linux64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + + +(defun x86-linux64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-linux64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/qres/ccl/lib/ffi-solarisx8632.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-solarisx8632.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-solarisx8632.lisp (revision 13564) @@ -0,0 +1,27 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun x86-solaris32::record-type-returns-structure-as-first-arg (rtype) + (x8632::record-type-returns-structure-as-first-arg rtype)) + +(defun x86-solaris32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-solaris32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-solaris32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/qres/ccl/lib/ffi-solarisx8664.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-solarisx8664.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-solarisx8664.lisp (revision 13564) @@ -0,0 +1,36 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, Darwin, and Solaris all share +;;; the same ABI. + +(defun x86-solaris64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-solaris64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + + +(defun x86-solaris64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-solaris64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/qres/ccl/lib/ffi-win32.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-win32.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-win32.lisp (revision 13564) @@ -0,0 +1,38 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Cygwin compiler returns small structures in registers +;;; (just like on Darwin, apparently). +(defun win32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype))) + (nbits (ensure-foreign-type-bits ftype))) + (not (member nbits '(8 16 32 64)))))) + +(defun win32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun win32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun win32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) + Index: /branches/qres/ccl/lib/ffi-win64.lisp =================================================================== --- /branches/qres/ccl/lib/ffi-win64.lisp (revision 13564) +++ /branches/qres/ccl/lib/ffi-win64.lisp (revision 13564) @@ -0,0 +1,183 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Win64: +;;; Structures are never actually passed by value; the caller +;;; instead passes a pointer to the structure or a copy of it. +;;; +(defun win64::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (and (typep ftype 'foreign-record-type) + (> (ensure-foreign-type-bits ftype) 64))))) + + +(defun win64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (enclosing-form nil) + (result-form nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args)) + (if (win64::record-type-returns-structure-as-first-arg result-type) + (progn + (setq result-type *void-foreign-type* + result-type-spec :void) + (argforms :address) + (argforms result-form)) + ;; This only happens in the SVR4 ABI. + (progn + (setq result-type (parse-foreign-type :unsigned-doubleword) + result-type-spec :unsigned-doubleword + enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0)))))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (progn + (argforms :address) + (argforms arg-value-form)) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (if enclosing-form + `(,@enclosing-form ,call) + call)))))) + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. +;;; The byte offset of the foreign return address, relative to STACK-PTR +(defun win64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (declare (ignore fp-args-ptr)) + (collect ((lets) + (rlets) + (inits)) + (let* ((rtype (parse-foreign-type result-spec))) + (when (typep rtype 'foreign-record-type) + (if (win64::record-type-returns-structure-as-first-arg rtype) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype :address) + (rlets (list struct-result-name (foreign-record-type-name rtype))))) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (arg-num 0) + (gpr-arg-offset -8) + (fpr-arg-offset -40) + (memory-arg-offset 48) + (fp nil nil)) + ((null argvars) + (values (rlets) (lets) nil (inits) rtype nil 8)) + (flet ((next-gpr () + (if (<= (incf arg-num) 4) + (prog1 + gpr-arg-offset + (decf gpr-arg-offset 8) + (decf fpr-arg-offset 8)) + (prog1 + memory-arg-offset + (incf memory-arg-offset 8)))) + (next-fpr () + (if (<= (incf arg-num) 4) + (prog1 + fpr-arg-offset + (decf fpr-arg-offset 8) + (decf gpr-arg-offset 8)) + (prog1 + memory-arg-offset + (incf memory-arg-offset 8))))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec))) + (if (typep argtype 'foreign-record-type) + (setq argtype :address)) + (let* ((access-form + `(, + (ecase (foreign-type-to-representation-type argtype) + (:single-float (setq fp t) '%get-single-float) + (:double-float (setq fp t) '%get-double-float) + (:signed-doubleword '%%get-signed-longlong) + (:signed-fullword '%get-signed-long) + (:signed-halfword '%get-signed-word) + (:signed-byte '%get-signed-byte) + (:unsigned-doubleword '%%get-unsigned-longlong) + (:unsigned-fullword '%get-unsigned-long) + (:unsigned-halfword '%get-unsigned-word) + (:unsigned-byte '%get-unsigned-byte) + (:address + #+nil + (dynamic-extent-names name) + '%get-ptr)) + ,stack-ptr + ,(if fp (next-fpr) (next-gpr))))) + (when name (lets (list name access-form)))))))))) + +(defun win64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore fp-args-ptr)) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (let* ((return-type-keyword + (if (typep return-type 'foreign-record-type) + (progn + (setq result `(%%get-unsigned-longlong ,struct-return-arg 0)) + :unsigned-doubleword) + (foreign-type-to-representation-type return-type))) + (offset (case return-type-keyword + ((:single-float :double-float) + -24) + (t -8)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) '%get-double-float) + (t '%get-long)) ,stack-ptr ,offset) ,result)))) + + Index: /branches/qres/ccl/lib/foreign-types.lisp =================================================================== --- /branches/qres/ccl/lib/foreign-types.lisp (revision 13564) +++ /branches/qres/ccl/lib/foreign-types.lisp (revision 13564) @@ -0,0 +1,1956 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; This is a slightly-watered-down version of CMUCL's ALIEN-TYPE system. + +(in-package "CCL") + +(defstruct (interface-dir + (:include dll-node) + ) + (name) + (subdir) + (constants-interface-db-file) + (functions-interface-db-file) + (records-interface-db-file) + (types-interface-db-file) + (vars-interface-db-file) + (objc-classes-interface-db-file) + (objc-methods-interface-db-file)) + +(defmethod print-object ((d interface-dir) stream) + (print-unreadable-object (d stream :type t :identity t) + (format stream "~s ~s" + (interface-dir-name d) + (interface-dir-subdir d)))) + +;;; We can't reference foreign types early in the cold load, +;;; but we want things like RLET to be able to set a pointer's +;;; type based on the foreign-type's "ordinal". We therefore +;;; seem to have to arrange that certain types have fixed, +;;; "canonical" ordinals. I doubt if we need more than a handful +;;; of these, but let's burn 100 + +(defconstant max-canonical-foreign-type-ordinal 100) + +;;; Some foreign types are "common" (POSIXy things that're available +;;; on most platforms; some are very platform-specific. It's getting +;;; to be a mess to keep those separate by reader conditionalization, +;;; so use the first 50 ordinals for "common" foreign types and the +;;; next 50 for platform-specific stuff. + +(defconstant max-common-foreign-type-ordinal 50) + +;;; This is intended to try to encapsulate foreign type stuff, to +;;; ease cross-compilation (among other things.) + +(defstruct (foreign-type-data (:conc-name ftd-) + (:constructor make-ftd)) + (translators (make-hash-table :test #'eq)) + (kind-info (make-hash-table :test #'eq)) + (definitions (make-hash-table :test #'eq)) + (struct-definitions (make-hash-table :test #'eq)) + (union-definitions (make-hash-table :test #'eq)) + ;; Do we even use this ? + (enum-definitions (make-hash-table :test #'eq)) + (interface-db-directory ()) + (interface-package-name ()) + (external-function-definitions (make-hash-table :test #'eq)) + (dirlist (make-dll-header)) + (attributes ()) + (ff-call-expand-function ()) + (ff-call-struct-return-by-implicit-arg-function ()) + (callback-bindings-function ()) + (callback-return-value-function ()) + (ordinal max-canonical-foreign-type-ordinal) + (ordinal-lock (make-lock)) + (ordinal-types (make-hash-table :test #'eq :weak :value)) + (pointer-types (make-hash-table :test #'eq)) + (array-types (make-hash-table :test #'equal)) + (platform-ordinal-types ())) + + + + +(defvar *host-ftd* (make-ftd + :interface-db-directory + #.(ecase (backend-name *target-backend*) + (:linuxppc32 "ccl:headers;") + (:darwinppc32 "ccl:darwin-headers;") + (:darwinppc64 "ccl:darwin-headers64;") + (:linuxppc64 "ccl:headers64;") + (:darwinx8632 "ccl:darwin-x86-headers;") + (:linuxx8664 "ccl:x86-headers64;") + (:darwinx8664 "ccl:darwin-x86-headers64;") + (:freebsdx8664 "ccl:freebsd-headers64;") + (:solarisx8664 "ccl:solarisx64-headers;") + (:win64 "ccl:win64-headers;") + (:linuxx8632 "ccl:x86-headers;") + (:win32 "ccl:win32-headers;") + (:solarisx8632 "ccl:solarisx86-headers;") + (:freebsdx8632 "ccl:freebsd-headers;")) + :interface-package-name + #.(ftd-interface-package-name *target-ftd*) + :attributes + '(:bits-per-word #+64-bit-target 64 #+32-bit-target 32 + #+win64-target :bits-per-long #+win64-target 32 + :signed-char #+darwinppc-target t #-darwinppc-target nil + :struct-by-value #+darwinppc-target t #-darwinppc-target nil + :struct-return-in-registers #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil + :struct-return-explicit #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil + :struct-by-value-by-field #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil + + :prepend-underscores #+darwinppc-target t #-darwinppc-target nil) + :ff-call-expand-function + 'os::expand-ff-call + :ff-call-struct-return-by-implicit-arg-function + 'os::record-type-returns-structure-as-first-arg + :callback-bindings-function + 'os::generate-callback-bindings + :callback-return-value-function + 'os::generate-callback-return-value + :platform-ordinal-types + (case (backend-name *target-backend*) + (:win64 '((:struct :_stat64))) + (:win32 '((:struct :__stat64))) + (t + (case (target-os-name *target-backend*) + (:darwin '((:struct :host_basic_info))) + (:solaris '((:struct :lifnum) + (:struct :lifconf))) + (t ())))))) + +(defvar *target-ftd* *host-ftd*) +(setf (backend-target-foreign-type-data *host-backend*) + *host-ftd*) + +(defun next-foreign-type-ordinal (&optional (ftd *target-ftd*)) + (with-lock-grabbed ((ftd-ordinal-lock ftd)) + (incf (ftd-ordinal ftd)))) + + +(defmacro do-interface-dirs ((dir &optional (ftd '*target-ftd*)) &body body) + `(do-dll-nodes (,dir (ftd-dirlist ,ftd)) + ,@body)) + +(defun find-interface-dir (name &optional (ftd *target-ftd*)) + (do-interface-dirs (d ftd) + (when (eq name (interface-dir-name d)) + (return d)))) + +(defun require-interface-dir (name &optional (ftd *target-ftd*)) + (or (find-interface-dir name ftd) + (error "Interface directory ~s not found" name))) + +(defun ensure-interface-dir (name &optional (ftd *target-ftd*)) + (or (find-interface-dir name ftd) + (let* ((d (make-interface-dir + :name name + :subdir (make-pathname + :directory + `(:relative ,(string-downcase name)))))) + (append-dll-node d (ftd-dirlist ftd))))) + +(defun use-interface-dir (name &optional (ftd *target-ftd*)) + "Tell Clozure CL to add the interface directory denoted by dir-id to the +list of interface directories which it consults for foreign type and +function information. Arrange that that directory is searched before any +others. + +Note that use-interface-dir merely adds an entry to a search list. If the +named directory doesn't exist in the file system or doesn't contain a set +of database files, a runtime error may occur when Clozure CL tries to open some +database file in that directory, and it will try to open such a database +file whenever it needs to find any foreign type or function information. +unuse-interface-dir may come in handy in that case." + (let* ((d (ensure-interface-dir name ftd))) + (move-dll-nodes d (ftd-dirlist ftd)) + d)) + +(defun unuse-interface-dir (name &optional (ftd *target-ftd*)) + "Tell Clozure CL to remove the interface directory denoted by dir-id from +the list of interface directories which are consulted for foreign type +and function information. Returns T if the directory was on the search +list, NIL otherwise." + (let* ((d (find-interface-dir name ftd))) + (when d + (remove-dll-node d) + t))) + + +(use-interface-dir :libc) + + + +;;;; Utility functions. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun align-offset (offset alignment) + (let ((extra (rem offset alignment))) + (if (zerop extra) offset (+ offset (- alignment extra))))) + + (defun guess-alignment (bits) + (cond ((null bits) nil) + ((> bits 32) 64) + ((> bits 16) 32) + ((> bits 8) 16) + ((= bits 8) 8) + (t 1))) + + (defstruct foreign-type-class + (name nil #|:type symbol|#) + (include nil :type (or null foreign-type-class)) + (unparse nil :type (or null function)) + (type= nil :type (or null function)) + (lisp-rep nil :type (or null function)) + (foreign-rep nil :type (or null function)) + (extract-gen nil :type (or null function)) + (deposit-gen nil :type (or null function)) + (naturalize-gen nil :type (or null function)) + (deport-gen nil :type (or null function)) + ;; Cast? + (arg-tn nil :type (or null function)) + (result-tn nil :type (or null function)) + (subtypep nil :type (or null function))) + + (defvar *foreign-type-classes* (make-hash-table :test #'eq)) + + (defun info-foreign-type-translator (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-translators ftd))) + (defun (setf info-foreign-type-translator) (val x &optional (ftd *target-ftd*)) + (setf (gethash (make-keyword x) (ftd-translators ftd)) val)) + + (defun note-foreign-type-ordinal (type ftd) + (let* ((ordinal (and type (foreign-type-ordinal type)))) + (when (and ordinal (not (eql 0 ordinal))) + (with-lock-grabbed ((ftd-ordinal-lock ftd)) + (setf (gethash ordinal (ftd-ordinal-types ftd)) type))))) + + (defun info-foreign-type-kind (x &optional (ftd *target-ftd*)) + (if (info-foreign-type-translator x ftd) + :primitive + (or (gethash (make-keyword x) (ftd-kind-info ftd)) :unknown))) + (defun (setf info-foreign-type-kind) (val x &optional (ftd *target-ftd*)) + (setf (gethash (make-keyword x) (ftd-kind-info ftd)) val)) + + (defun info-foreign-type-definition (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-definitions ftd))) + (defun (setf info-foreign-type-definition) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) + (setf (gethash (make-keyword x) (ftd-definitions ftd)) val)) + (defun clear-info-foreign-type-definition (x &optional (ftd *target-ftd*)) + (remhash (make-keyword x) (ftd-definitions ftd))) + + (defun info-foreign-type-struct (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-struct-definitions ftd))) + (defun (setf info-foreign-type-struct) (val x &optional (ftd *target-ftd*)) + (let* ((name (make-keyword x))) + (when (gethash name (ftd-union-definitions ftd)) + (cerror "Define ~s as a struct type" + "~s is already defined as a union type" + name) + (remhash name (ftd-union-definitions ftd))) + (note-foreign-type-ordinal val ftd) + (setf (gethash name (ftd-struct-definitions ftd)) val))) + + (defun info-foreign-type-union (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-union-definitions ftd))) + (defun (setf info-foreign-type-union) (val x &optional (ftd *target-ftd*)) + (let* ((name (make-keyword x))) + (when (gethash name (ftd-struct-definitions ftd)) + (cerror "Define ~s as a union type" + "~s is already defined as a struct type" + name) + (remhash name (ftd-struct-definitions ftd))) + (note-foreign-type-ordinal val ftd) + (setf (gethash name (ftd-union-definitions ftd)) val))) + + (defun info-foreign-type-enum (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-enum-definitions ftd))) + (defun (setf info-foreign-type-enum) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) + (setf (gethash (make-keyword x) (ftd-enum-definitions ftd)) val)) + + (defun require-foreign-type-class (name) + (or (gethash name *foreign-type-classes*) + (error "Unknown foreign type class ~s" name))) + + (defun find-or-create-foreign-type-class (name include) + (let* ((old (gethash name *foreign-type-classes*)) + (include-class (if include (require-foreign-type-class include)))) + (if old + (setf (foreign-type-class-name old) include-class) + (setf (gethash name *foreign-type-classes*) + (make-foreign-type-class :name name :include include-class))))) + + + (defconstant method-slot-alist + '((:unparse . foreign-type-class-unparse) + (:type= . foreign-type-class-type=) + (:subtypep . foreign-type-class-subtypep) + (:lisp-rep . foreign-type-class-lisp-rep) + (:foreign-rep . foreign-type-class-foreign-rep) + (:extract-gen . foreign-type-class-extract-gen) + (:deposit-gen . foreign-type-class-deposit-gen) + (:naturalize-gen . foreign-type-class-naturalize-gen) + (:deport-gen . foreign-type-class-deport-gen) + ;; Cast? + (:arg-tn . foreign-type-class-arg-tn) + (:result-tn . foreign-type-class-result-tn))) + + (defun method-slot (method) + (cdr (or (assoc method method-slot-alist) + (error "No method ~S" method)))) + ) + +(defmethod print-object ((f foreign-type-class) out) + (print-unreadable-object (f out :type t :identity t) + (prin1 (foreign-type-class-name f) out))) + + +;;; We define a keyword "BOA" constructor so that we can reference the slots +;;; names in init forms. +;;; +(defmacro def-foreign-type-class ((name &key include include-args) &rest slots) + (let ((defstruct-name + (intern (concatenate 'string "FOREIGN-" (symbol-name name) "-TYPE")))) + (multiple-value-bind + (include include-defstruct overrides) + (etypecase include + (null + (values nil 'foreign-type nil)) + (symbol + (values + include + (intern (concatenate 'string + "FOREIGN-" (symbol-name include) "-TYPE")) + nil)) + (list + (values + (car include) + (intern (concatenate 'string + "FOREIGN-" (symbol-name (car include)) "-TYPE")) + (cdr include)))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (find-or-create-foreign-type-class ',name ',(or include 'root))) + (defstruct (,defstruct-name + (:include ,include-defstruct + (class ',name) + ,@overrides) + (:constructor + ,(intern (concatenate 'string "MAKE-" + (string defstruct-name))) + (&key class bits alignment + ,@(mapcar #'(lambda (x) + (if (atom x) x (car x))) + slots) + ,@include-args))) + ,@slots))))) + +(defmacro def-foreign-type-method ((class method) lambda-list &rest body) + (let ((defun-name (intern (concatenate 'string + (symbol-name class) + "-" + (symbol-name method) + "-METHOD")))) + `(progn + (defun ,defun-name ,lambda-list + ,@body) + (setf (,(method-slot method) (require-foreign-type-class ',class)) + #',defun-name)))) + +(defmacro invoke-foreign-type-method (method type &rest args) + (let ((slot (method-slot method))) + (once-only ((type type)) + `(funcall (do ((class (require-foreign-type-class (foreign-type-class ,type)) + (foreign-type-class-include class))) + ((null class) + (error "Method ~S not defined for ~S" + ',method (foreign-type-class ,type))) + (let ((fn (,slot class))) + (when fn + (return fn)))) + ,type ,@args)))) + + + +;;;; Foreign-type defstruct. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (find-or-create-foreign-type-class 'root nil)) + +(defstruct (foreign-type + (:constructor make-foreign-type (&key class bits alignment ordinal)) + (:print-object + (lambda (s out) + (print-unreadable-object (s out :type t :identity t) + (prin1 (unparse-foreign-type s) out))))) + (class 'root :type symbol) + (bits nil :type (or null unsigned-byte)) + (alignment (guess-alignment bits) :type (or null unsigned-byte)) + (ordinal (next-foreign-type-ordinal))) + + + +(defmethod make-load-form ((s foreign-type) &optional env) + (if (eq s *void-foreign-type*) + '*void-foreign-type* + (make-load-form-saving-slots s :environment env))) + + + + + +;;;; Type parsing and unparsing. + +(defvar *auxiliary-type-definitions* nil) +(defvar *new-auxiliary-types*) + +;;; WITH-AUXILIARY-FOREIGN-TYPES -- internal. +;;; +;;; Process stuff in a new scope. +;;; +(defmacro with-auxiliary-foreign-types (&body body) + `(let ((*auxiliary-type-definitions* + (if (boundp '*new-auxiliary-types*) + (append *new-auxiliary-types* *auxiliary-type-definitions*) + *auxiliary-type-definitions*)) + (*new-auxiliary-types* nil)) + ,@body)) + +;;; PARSE-FOREIGN-TYPE -- public +;;; +(defun parse-foreign-type (type &optional (ftd *target-ftd*)) + "Parse the list structure TYPE as a foreign type specifier and return + the resultant foreign-type structure." + (if (boundp '*new-auxiliary-types*) + (%parse-foreign-type type ftd) + (let ((*new-auxiliary-types* nil)) + (%parse-foreign-type type ftd)))) + +(defun %parse-foreign-type (type &optional (ftd *target-ftd*)) + (if (consp type) + (let ((translator (info-foreign-type-translator (car type) ftd))) + (unless translator + (error "Unknown foreign type: ~S" type)) + (funcall translator type nil)) + (case (info-foreign-type-kind type) + (:primitive + (let ((translator (info-foreign-type-translator type ftd))) + (unless translator + (error "No translator for primitive foreign type ~S?" type)) + (funcall translator (list type) nil))) + (:defined + (or (info-foreign-type-definition type ftd) + (error "Definition missing for foreign type ~S?" type))) + (:unknown + (let* ((loaded (load-foreign-type type ftd))) + (if loaded + (setq type loaded))) + (or (info-foreign-type-definition type ftd) + (error "Unknown foreign type: ~S" type)))))) + +(defun auxiliary-foreign-type (kind name &optional (ftd *target-ftd*)) + (declare (ignore ftd)) + (flet ((aux-defn-matches (x) + (and (eq (first x) kind) (eq (second x) name)))) + (let ((in-auxiliaries + (or (find-if #'aux-defn-matches *new-auxiliary-types*) + (find-if #'aux-defn-matches *auxiliary-type-definitions*)))) + (if in-auxiliaries + (values (third in-auxiliaries) t))))) + +(defun %set-auxiliary-foreign-type (kind name defn &optional (ftd *target-ftd*)) + (declare (ignore ftd)) + (flet ((aux-defn-matches (x) + (and (eq (first x) kind) (eq (second x) name)))) + (when (find-if #'aux-defn-matches *new-auxiliary-types*) + (error "Attempt to multiple define ~A ~S." kind name)) + (when (find-if #'aux-defn-matches *auxiliary-type-definitions*) + (error "Attempt to shadow definition of ~A ~S." kind name))) + (push (list kind name defn) *new-auxiliary-types*) + defn) + +(defsetf auxiliary-foreign-type %set-auxiliary-foreign-type) + + +(defun ensure-foreign-type (x) + (if (typep x 'foreign-type) + x + (parse-foreign-type x))) + +;;; *record-type-already-unparsed* -- internal +;;; +;;; Holds the list of record types that have already been unparsed. This is +;;; used to keep from outputing the slots again if the same structure shows +;;; up twice. +;;; +(defvar *record-types-already-unparsed*) + +;;; UNPARSE-FOREIGN-TYPE -- public. +;;; +(defun unparse-foreign-type (type) + "Convert the foreign-type structure TYPE back into a list specification of + the type." + (declare (type foreign-type type)) + (let ((*record-types-already-unparsed* nil)) + (%unparse-foreign-type type))) + +;;; %UNPARSE-FOREIGN-TYPE -- internal. +;;; +;;; Does all the work of UNPARSE-FOREIGN-TYPE. It's seperate because we need +;;; to recurse inside the binding of *record-types-already-unparsed*. +;;; +(defun %unparse-foreign-type (type) + (invoke-foreign-type-method :unparse type)) + + + + + +;;;; Foreign type defining stuff. + +(defmacro def-foreign-type-translator (name lambda-list &body body &environment env) + (expand-type-macro '%def-foreign-type-translator name lambda-list body env)) + + +(defun %def-foreign-type-translator (name translator docs) + (declare (ignore docs)) + (setf (info-foreign-type-translator name) translator) + (clear-info-foreign-type-definition name) + #+nil + (setf (documentation name 'foreign-type) docs) + name) + + +(defmacro def-foreign-type (name type) + "If name is non-NIL, define name to be an alias for the foreign type +specified by foreign-type-spec. If foreign-type-spec is a named structure +or union type, additionally defines that structure or union type. + +If name is NIL, foreign-type-spec must be a named foreign struct or union +definition, in which case the foreign structure or union definition is put +in effect. + +Note that there are two separate namespaces for foreign type names, one for +the names of ordinary types and one for the names of structs and unions. +Which one name refers to depends on foreign-type-spec in the obvious manner." + (with-auxiliary-foreign-types + (let ((foreign-type (parse-foreign-type type))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when *new-auxiliary-types* + `((%def-auxiliary-foreign-types ',*new-auxiliary-types*))) + ,@(when name + `((%def-foreign-type ',name ',foreign-type))))))) + +(defun %def-auxiliary-foreign-types (types) + (dolist (info types) + (destructuring-bind (kind name defn) info + (macrolet ((frob (accessor) + `(let ((old (,accessor name))) + (unless (or (null old) (foreign-type-= old defn)) + (warn "Redefining ~A ~S to be:~% ~S,~%was:~% ~S" + kind name defn old)) + (setf (,accessor name) defn)))) + (ecase kind + (:struct (frob info-foreign-type-struct)) + (:union (frob info-foreign-type-union)) + (:enum (frob info-foreign-type-enum))))))) + +(defun %def-foreign-type (name new &optional (ftd *target-ftd*)) + (ecase (info-foreign-type-kind name ftd) + (:primitive + (error "~S is a built-in foreign type." name)) + (:defined + (let ((old (info-foreign-type-definition name ftd))) + (unless (or (null old) (foreign-type-= new old)) + (warn "Redefining ~S to be:~% ~S,~%was~% ~S" name + (unparse-foreign-type new) (unparse-foreign-type old))))) + (:unknown)) + (setf (info-foreign-type-definition name ftd) new) + (setf (info-foreign-type-kind name ftd) :defined) + name) + + + + +;;;; Interfaces to the different methods + +(defun foreign-type-= (type1 type2) + "Return T iff TYPE1 and TYPE2 describe equivalent foreign types." + (or (eq type1 type2) + (and (eq (foreign-type-class type1) + (foreign-type-class type2)) + (invoke-foreign-type-method :type= type1 type2)))) + +(defun foreign-subtype-p (type1 type2) + "Return T iff the foreign type TYPE1 is a subtype of TYPE2. Currently, the + only supported subtype relationships are is that any pointer type is a + subtype of (* t), and any array type first dimension will match + (array nil ...). Otherwise, the two types have to be + FOREIGN-TYPE-=." + (or (eq type1 type2) + (invoke-foreign-type-method :subtypep type1 type2))) + +(defun foreign-typep (object type) + "Return T iff OBJECT is a foreign of type TYPE." + (let ((lisp-rep-type (compute-lisp-rep-type type))) + (if lisp-rep-type + (typep object lisp-rep-type)))) + + +(defun compute-naturalize-lambda (type) + `(lambda (foreign ignore) + (declare (ignore ignore)) + ,(invoke-foreign-type-method :naturalize-gen type 'foreign))) + +(defun compute-deport-lambda (type) + (declare (type foreign-type type)) + (multiple-value-bind + (form value-type) + (invoke-foreign-type-method :deport-gen type 'value) + `(lambda (value ignore) + (declare (type ,(or value-type + (compute-lisp-rep-type type) + `(foreign ,type)) + value) + (ignore ignore)) + ,form))) + +(defun compute-extract-lambda (type) + `(lambda (sap offset ignore) + (declare (type system-area-pointer sap) + (type unsigned-byte offset) + (ignore ignore)) + (naturalize ,(invoke-foreign-type-method :extract-gen type 'sap 'offset) + ',type))) + +(defun compute-deposit-lambda (type) + (declare (type foreign-type type)) + `(lambda (sap offset ignore value) + (declare (type system-area-pointer sap) + (type unsigned-byte offset) + (ignore ignore)) + (let ((value (deport value ',type))) + ,(invoke-foreign-type-method :deposit-gen type 'sap 'offset 'value) + ;; Note: the reason we don't just return the pre-deported value + ;; is because that would inhibit any (deport (naturalize ...)) + ;; optimizations that might have otherwise happen. Re-naturalizing + ;; the value might cause extra consing, but is flushable, so probably + ;; results in better code. + (naturalize value ',type)))) + +(defun compute-lisp-rep-type (type) + (invoke-foreign-type-method :lisp-rep type)) + +(defun compute-foreign-rep-type (type) + (invoke-foreign-type-method :foreign-rep type)) + + + + + + +;;;; Default methods. + +(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0)) + +(def-foreign-type-method (root :unparse) (type) + (if (eq type *void-foreign-type*) + :void + `(!!unknown-foreign-type!! ,(type-of type)))) + +(def-foreign-type-method (root :type=) (type1 type2) + (declare (ignore type1 type2)) + t) + +(def-foreign-type-method (root :subtypep) (type1 type2) + (foreign-type-= type1 type2)) + +(def-foreign-type-method (root :lisp-rep) (type) + (declare (ignore type)) + nil) + +(def-foreign-type-method (root :foreign-rep) (type) + (declare (ignore type)) + '*) + +(def-foreign-type-method (root :naturalize-gen) (type foreign) + (declare (ignore foreign)) + (error "Cannot represent ~S typed foreigns." type)) + +(def-foreign-type-method (root :deport-gen) (type object) + (declare (ignore object)) + (error "Cannot represent ~S typed foreigns." type)) + +(def-foreign-type-method (root :extract-gen) (type sap offset) + (declare (ignore sap offset)) + (error "Cannot represent ~S typed foreigns." type)) + +(def-foreign-type-method (root :deposit-gen) (type sap offset value) + `(setf ,(invoke-foreign-type-method :extract-gen type sap offset) ,value)) + +(def-foreign-type-method (root :arg-tn) (type state) + (declare (ignore state)) + (error "Cannot pass foreigns of type ~S as arguments to call-out" + (unparse-foreign-type type))) + +(def-foreign-type-method (root :result-tn) (type state) + (declare (ignore state)) + (error "Cannot return foreigns of type ~S from call-out" + (unparse-foreign-type type))) + + + + +;;;; The INTEGER type. + +(def-foreign-type-class (integer) + (signed t :type (member t nil))) + +(defvar *unsigned-integer-types* + (let* ((a (make-array 65))) + (dotimes (i 65 a) + (setf (svref a i) (make-foreign-integer-type :signed nil + :bits i + :alignment + (if (= 1 (logcount i)) + i + 1)))))) + +(defvar *signed-integer-types* + (let* ((a (make-array 65))) + (dotimes (i 65 a) + (setf (svref a i) (make-foreign-integer-type :signed t + :bits i + :alignment + (if (= 1 (logcount i)) + i + 1)))))) + + +(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwin-target t #-darwin-target nil)) + + + +(def-foreign-type-method (integer :unparse) (type) + (if (eq type *bool-type*) + : + (let* ((bits (foreign-integer-type-bits type)) + (signed (foreign-integer-type-signed type)) + (alignment (foreign-integer-type-alignment type))) + (if (eql alignment 1) + (if (eql bits 1) + :bit + `(:bitfield ,bits)) + (list (if signed :signed :unsigned) bits))))) + +(def-foreign-type-method (integer :type=) (type1 type2) + (and (eq (foreign-integer-type-signed type1) + (foreign-integer-type-signed type2)) + (= (foreign-integer-type-bits type1) + (foreign-integer-type-bits type2)))) + +(def-foreign-type-method (integer :lisp-rep) (type) + (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte) + (foreign-integer-type-bits type))) + +(def-foreign-type-method (integer :foreign-rep) (type) + (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte) + (foreign-integer-type-bits type))) + +(def-foreign-type-method (integer :naturalize-gen) (type foreign) + (declare (ignore type)) + foreign) + +(def-foreign-type-method (integer :deport-gen) (type value) + (declare (ignore type)) + value) + +(def-foreign-type-method (integer :extract-gen) (type sap offset) + (declare (type foreign-integer-type type)) + (let ((ref-form + (if (foreign-integer-type-signed type) + (case (foreign-integer-type-bits type) + (8 `(%get-signed-byte ,sap (/ ,offset 8))) + (16 `(%get-signed-word ,sap (/ ,offset 8))) + (32 `(%get-signed-long ,sap (/ ,offset 8))) + (64 `(%%get-signed-longlong ,sap (/ ,offset 8)))) + (case (foreign-integer-type-bits type) + (1 `(%get-bit ,sap ,offset)) + (8 `(%get-unsigned-byte ,sap (/ ,offset 8))) + (16 `(%get-unsigned-word ,sap (/ ,offset 8))) + (32 `(%get-unsigned-long ,sap (/ ,offset 8))) + (64 `(%%get-unsigned-longlong ,sap (/ ,offset 8))) + (t `(%get-bitfield ,sap ,offset ,(foreign-integer-type-bits type))))))) + (or ref-form + (error "Cannot extract ~D bit integers." + (foreign-integer-type-bits type))))) + + + + +;;;; The BOOLEAN type. + +(def-foreign-type-class (boolean :include integer :include-args (signed))) + + + +(def-foreign-type-method (boolean :lisp-rep) (type) + (declare (ignore type)) + `(member t nil)) + +(def-foreign-type-method (boolean :naturalize-gen) (type foreign) + (declare (ignore type)) + `(not (zerop ,foreign))) + +(def-foreign-type-method (boolean :deport-gen) (type value) + (declare (ignore type)) + `(if ,value 1 0)) + + +(def-foreign-type-method (boolean :unparse) (type) + `(boolean ,(foreign-boolean-type-bits type))) + + + +;;;; the FLOAT types. + +(def-foreign-type-class (float) + (type () :type symbol)) + +(def-foreign-type-method (float :unparse) (type) + (foreign-float-type-type type)) + +(def-foreign-type-method (float :lisp-rep) (type) + (foreign-float-type-type type)) + +(def-foreign-type-method (float :foreign-rep) (type) + (foreign-float-type-type type)) + +(def-foreign-type-method (float :naturalize-gen) (type foreign) + (declare (ignore type)) + foreign) + +(def-foreign-type-method (float :deport-gen) (type value) + (declare (ignore type)) + value) + + +(def-foreign-type-class (single-float :include (float (bits 32)) + :include-args (type))) + + +(def-foreign-type-method (single-float :extract-gen) (type sap offset) + (declare (ignore type)) + `(%get-single-float ,sap (/ ,offset 8))) + + +(def-foreign-type-class (double-float :include (float (bits 64)) + :include-args (type))) + + +(def-foreign-type-method (double-float :extract-gen) (type sap offset) + (declare (ignore type)) + `(%get-double-float ,sap (/ ,offset 8))) + + + + +;;;; The MACPTR type + +(def-foreign-type-class (macptr)) + + +(def-foreign-type-method (macptr :unparse) (type) + (declare (ignore type)) + 'macptr) + +(def-foreign-type-method (macptr :lisp-rep) (type) + (declare (ignore type)) + 'macptr) + +(def-foreign-type-method (macptr :foreign-rep) (type) + (declare (ignore type)) + 'macptr) + +(def-foreign-type-method (macptr :naturalize-gen) (type foreign) + (declare (ignore type)) + foreign) + +(def-foreign-type-method (macptr :deport-gen) (type object) + (declare (ignore type)) + object) + +(def-foreign-type-method (macptr :extract-gen) (type sap offset) + (declare (ignore type)) + `(%get-ptr ,sap (/ ,offset 8))) + + + +;;;; the FOREIGN-VALUE type. + +(def-foreign-type-class (foreign-value :include macptr)) + +(def-foreign-type-method (foreign-value :lisp-rep) (type) + (declare (ignore type)) + nil) + +(def-foreign-type-method (foreign-value :naturalize-gen) (type foreign) + `(%macptr-foreign ,foreign ',type)) + +(def-foreign-type-method (foreign-value :deport-gen) (type value) + (declare (ignore type)) + `(foreign-macptr ,value)) + + + + +;;;; The POINTER type. + +(def-foreign-type-class (pointer :include (foreign-value)) + (to *void-foreign-type* :type (or symbol foreign-type))) + + + +(def-foreign-type-method (pointer :unparse) (type) + (let ((to (foreign-pointer-type-to type))) + `(:* ,(if to + (%unparse-foreign-type to) + :void)))) + +(def-foreign-type-method (pointer :type=) (type1 type2) + (let ((to1 (foreign-pointer-type-to type1)) + (to2 (foreign-pointer-type-to type2))) + (if to1 + (if to2 + (foreign-type-= to1 to2) + nil) + (null to2)))) + +(def-foreign-type-method (pointer :subtypep) (type1 type2) + (and (foreign-pointer-type-p type2) + (let ((to1 (foreign-pointer-type-to type1)) + (to2 (foreign-pointer-type-to type2))) + (if to1 + (if to2 + (foreign-subtype-p to1 to2) + t) + (null to2))))) + +(def-foreign-type-method (pointer :deport-gen) (type value) + (values + `(etypecase ,value + (null + (%int-to-ptr 0)) + (macptr + ,value) + ((foreign ,type) + (foreign-sap ,value))) + `(or null macptr (foreign ,type)))) + + + +;;;; The MEM-BLOCK type. + + +(def-foreign-type-class (mem-block :include foreign-value)) + +(def-foreign-type-method (mem-block :extract-gen) (type sap offset) + (let* ((nbytes (%foreign-type-or-record-size type :bytes))) + `(%composite-pointer-ref ,nbytes ,sap (/ ,offset 8)))) + +(def-foreign-type-method (mem-block :deposit-gen) (type sap offset value) + (let ((bits (foreign-mem-block-type-bits type))) + (unless bits + (error "Cannot deposit foreigns of type ~S (unknown size)." type)) + `(%copy-macptr-to-macptr ,value 0 ,sap ,offset ',bits))) + + + + +;;;; The ARRAY type. + +(def-foreign-type-class (array :include mem-block) + (element-type () :type foreign-type) + (dimensions () :type list)) + + + +(def-foreign-type-method (array :unparse) (type) + `(array ,(%unparse-foreign-type (foreign-array-type-element-type type)) + ,@(foreign-array-type-dimensions type))) + +(def-foreign-type-method (array :type=) (type1 type2) + (and (equal (foreign-array-type-dimensions type1) + (foreign-array-type-dimensions type2)) + (foreign-type-= (foreign-array-type-element-type type1) + (foreign-array-type-element-type type2)))) + +(def-foreign-type-method (array :subtypep) (type1 type2) + (and (foreign-array-type-p type2) + (let ((dim1 (foreign-array-type-dimensions type1)) + (dim2 (foreign-array-type-dimensions type2))) + (and (= (length dim1) (length dim2)) + (or (and dim2 + (null (car dim2)) + (equal (cdr dim1) (cdr dim2))) + (equal dim1 dim2)) + (foreign-subtype-p (foreign-array-type-element-type type1) + (foreign-array-type-element-type type2)))))) + + + +;;;; The RECORD type. + +(defstruct (foreign-record-field + (:print-object + (lambda (field stream) + (print-unreadable-object (field stream :type t) + (funcall (formatter "~S ~S~@[ ~D@~D~]") + stream + (foreign-record-field-type field) + (foreign-record-field-name field) + (foreign-record-field-bits field) + (foreign-record-field-offset field)))))) + (name () :type symbol) + (type () :type foreign-type) + (bits nil :type (or unsigned-byte null)) + (offset 0 :type unsigned-byte)) + + + +(defmethod make-load-form ((f foreign-record-field) &optional env) + (make-load-form-saving-slots f :environment env)) + +(def-foreign-type-class (record :include mem-block) + (kind :struct :type (member :struct :union :transparent-union)) + (name nil :type (or symbol null)) + (fields nil :type list) + ;; For, e.g., records defined with #pragma options align=mac68k + ;; in effect. When non-nil, this specifies the maximum alignment + ;; of record fields and the overall alignment of the record. + (alt-align nil :type (or unsigned-byte null))) + +(defmethod make-load-form ((r foreign-record-type) &optional environment) + (declare (ignore environment)) + `(parse-foreign-type ',(unparse-foreign-type r))) + + +(defun parse-foreign-record-type (kind name fields &optional (ftd *target-ftd*)) + (let* ((result (if name + (or + (ecase kind + (:struct (info-foreign-type-struct name ftd)) + ((:union :transparent-union) (info-foreign-type-union name ftd))) + (case kind + (:struct (setf (info-foreign-type-struct name ftd) + (make-foreign-record-type :name name :kind :struct))) + ((:union :transparent-union) + (setf (info-foreign-type-union name ftd) + (make-foreign-record-type :name name :kind kind))))) + (make-foreign-record-type :kind kind)))) + (when fields + (multiple-value-bind (parsed-fields alignment bits) + (parse-field-list fields kind (foreign-record-type-alt-align result)) + (let* ((old-fields (foreign-record-type-fields result))) + (setf (foreign-record-type-fields result) parsed-fields + (foreign-record-type-alignment result) alignment + (foreign-record-type-bits result) bits) + (when old-fields + (unless (record-fields-match old-fields parsed-fields 5) + (warn "Redefining ~a ~s fields to be:~%~s~%were~%~s" + kind name parsed-fields old-fields)))))) + (if name + (unless (eq (auxiliary-foreign-type kind name) result) + (setf (auxiliary-foreign-type kind name) result))) + result)) + +;;; PARSE-FOREIGN-RECORD-FIELDS -- internal +;;; +;;; Used by parse-foreign-type to parse the fields of struct and union +;;; types. RESULT holds the record type we are paring the fields of, +;;; and FIELDS is the list of field specifications. +;;; +(defun parse-field-list (fields kind &optional alt-alignment) + (collect ((parsed-fields)) + (let* ((total-bits 0) + (overall-alignment 1) + (first-field-p t) + (attributes (ftd-attributes *target-ftd*)) + (poweropen-alignment (getf attributes :poweropen-alignment))) + + (dolist (field fields) + (destructuring-bind (var type &optional bits) field + (declare (ignore bits)) + (let* ((field-type (parse-foreign-type type)) + (bits (ensure-foreign-type-bits field-type)) + (natural-alignment (foreign-type-alignment field-type)) + (alignment (if alt-alignment + (min natural-alignment alt-alignment) + (if poweropen-alignment + (if first-field-p + (progn + (setq first-field-p nil) + natural-alignment) + (min 32 natural-alignment)) + natural-alignment))) + (parsed-field + (make-foreign-record-field :type field-type + :name var))) + (parsed-fields parsed-field) + (when (null bits) + (error "Unknown size: ~S" + (unparse-foreign-type field-type))) + (when (null alignment) + (error "Unknown alignment: ~S" + (unparse-foreign-type field-type))) + (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment))) + (ecase kind + (:struct + (let ((offset (align-offset total-bits alignment))) + (setf (foreign-record-field-offset parsed-field) offset) + (setf (foreign-record-field-bits parsed-field) bits) + (setf total-bits (+ offset bits)))) + ((:union :transparent-union) + (setf total-bits (max total-bits bits))))))) + (values (parsed-fields) + (or alt-alignment overall-alignment) + (align-offset total-bits (or alt-alignment overall-alignment)))))) + + + +(defun parse-foreign-record-fields (result fields) + (declare (type foreign-record-type result) + (type list fields)) + (multiple-value-bind (parsed-fields alignment bits) + (parse-field-list fields (foreign-record-type-kind result) (foreign-record-type-alt-align result)) + (setf (foreign-record-type-fields result) parsed-fields + (foreign-record-type-alignment result) alignment + (foreign-record-type-bits result) bits))) + + +(def-foreign-type-method (record :unparse) (type) + `(,(case (foreign-record-type-kind type) + (:struct :struct) + (:union :union) + (:transparent-union :transparent-union) + (t '???)) + ,(foreign-record-type-name type) + ,@(unless (member type *record-types-already-unparsed* :test #'eq) + (push type *record-types-already-unparsed*) + (mapcar #'(lambda (field) + `(,(foreign-record-field-name field) + ,(%unparse-foreign-type (foreign-record-field-type field)) + ,@(if (foreign-record-field-bits field) + (list (foreign-record-field-bits field))))) + (foreign-record-type-fields type))))) + +;;; Test the record fields. The depth is limiting in case of cyclic +;;; pointers. +(defun record-fields-match (fields1 fields2 depth) + (declare (type list fields1 fields2) + (type (mod 64) depth)) + (labels ((record-type-= (type1 type2 depth) + (and (eq (foreign-record-type-name type1) + (foreign-record-type-name type2)) + (eq (foreign-record-type-kind type1) + (foreign-record-type-kind type2)) + (= (length (foreign-record-type-fields type1)) + (length (foreign-record-type-fields type2))) + (record-fields-match (foreign-record-type-fields type1) + (foreign-record-type-fields type2) + (1+ depth)))) + (pointer-type-= (type1 type2 depth) + (let ((to1 (foreign-pointer-type-to type1)) + (to2 (foreign-pointer-type-to type2))) + (if to1 + (if to2 + (or (> depth 10) + (type-= to1 to2 (1+ depth))) + nil) + (null to2)))) + (type-= (type1 type2 depth) + (cond ((and (foreign-pointer-type-p type1) + (foreign-pointer-type-p type2)) + (or (> depth 10) + (pointer-type-= type1 type2 depth))) + ((and (foreign-record-type-p type1) + (foreign-record-type-p type2)) + (record-type-= type1 type2 depth)) + (t + (foreign-type-= type1 type2))))) + (do ((fields1-rem fields1 (rest fields1-rem)) + (fields2-rem fields2 (rest fields2-rem))) + ((or (eq fields1-rem fields2-rem) + (endp fields1-rem) + (endp fields2-rem)) + (eq fields1-rem fields2-rem)) + (let ((field1 (first fields1-rem)) + (field2 (first fields2-rem))) + (declare (type foreign-record-field field1 field2)) + (unless (and (eq (foreign-record-field-name field1) + (foreign-record-field-name field2)) + (eql (foreign-record-field-bits field1) + (foreign-record-field-bits field2)) + (eql (foreign-record-field-offset field1) + (foreign-record-field-offset field2)) + (let ((field1 (foreign-record-field-type field1)) + (field2 (foreign-record-field-type field2))) + (type-= field1 field2 (1+ depth)))) + (return nil)))))) + +(def-foreign-type-method (record :type=) (type1 type2) + (and (eq (foreign-record-type-name type1) + (foreign-record-type-name type2)) + (eq (foreign-record-type-kind type1) + (foreign-record-type-kind type2)) + (= (length (foreign-record-type-fields type1)) + (length (foreign-record-type-fields type2))) + (record-fields-match (foreign-record-type-fields type1) + (foreign-record-type-fields type2) 0))) + + + +;;;; The FUNCTION and VALUES types. + +(defvar *values-type-okay* nil) + +(def-foreign-type-class (function :include mem-block) + (result-type () :type foreign-type) + (arg-types () :type list) + (stub nil :type (or null function))) + + + +(def-foreign-type-method (function :unparse) (type) + `(function ,(%unparse-foreign-type (foreign-function-type-result-type type)) + ,@(mapcar #'%unparse-foreign-type + (foreign-function-type-arg-types type)))) + +(def-foreign-type-method (function :type=) (type1 type2) + (and (foreign-type-= (foreign-function-type-result-type type1) + (foreign-function-type-result-type type2)) + (= (length (foreign-function-type-arg-types type1)) + (length (foreign-function-type-arg-types type2))) + (every #'foreign-type-= + (foreign-function-type-arg-types type1) + (foreign-function-type-arg-types type2)))) + + +(def-foreign-type-class (values) + (values () :type list)) + + + +(def-foreign-type-method (values :unparse) (type) + `(values ,@(mapcar #'%unparse-foreign-type + (foreign-values-type-values type)))) + +(def-foreign-type-method (values :type=) (type1 type2) + (and (= (length (foreign-values-type-values type1)) + (length (foreign-values-type-values type2))) + (every #'foreign-type-= + (foreign-values-type-values type1) + (foreign-values-type-values type2)))) + + + + + +;;;; The FOREIGN-SIZE macro. + +(defmacro foreign-size (type &optional (units :bits)) + "Return the size of the foreign type TYPE. UNITS specifies the units to + use and can be either :BITS, :BYTES, or :WORDS." + (let* ((foreign-type (parse-foreign-type type)) + (bits (ensure-foreign-type-bits foreign-type))) + (if bits + (values (ceiling bits + (ecase units + (:bits 1) + (:bytes 8) + (:words 32)))) + (error "Unknown size for foreign type ~S." + (unparse-foreign-type foreign-type))))) + +(defun ensure-foreign-type-bits (type) + (or (foreign-type-bits type) + (and (typep type 'foreign-record-type) + (let* ((name (foreign-record-type-name type))) + (and name + (load-record name) + (foreign-type-bits type)))) + (and (typep type 'foreign-array-type) + (let* ((element-type (foreign-array-type-element-type type)) + (dims (foreign-array-type-dimensions type))) + (if (and (ensure-foreign-type-bits element-type) + (every #'integerp dims)) + (setf (foreign-array-type-alignment type) + (foreign-type-alignment element-type) + (foreign-array-type-bits type) + (* (align-offset (foreign-type-bits element-type) + (foreign-type-alignment element-type)) + (reduce #'* dims)))))))) + +(defun require-foreign-type-bits (type) + (or (ensure-foreign-type-bits type) + (error "Can't determine attributes of foreign type ~s" type))) + +(defun %find-foreign-record (name) + (or (info-foreign-type-struct name) + (info-foreign-type-union name) + (load-record name))) + + +(defun %foreign-type-or-record (type) + (if (typep type 'foreign-type) + type + (if (consp type) + (parse-foreign-type type) + (or (%find-foreign-record type) + (parse-foreign-type type))))) + +(defun %foreign-type-or-record-size (type &optional (units :bits)) + (let* ((info (%foreign-type-or-record type)) + (bits (ensure-foreign-type-bits info))) + (if bits + (values (ceiling bits + (ecase units + (:bits 1) + (:bytes 8) + (:words 32)))) + (error "Unknown size for foreign type ~S." + (unparse-foreign-type info))))) + +(defun %find-foreign-record-type-field (type field-name) + (ensure-foreign-type-bits type) ;load the record type if necessary. + (let* ((fields (foreign-record-type-fields type))) + (or (find field-name fields :key #'foreign-record-field-name :test #'string-equal) + (error "Record type ~a has no field named ~s.~&Valid field names are: ~&~a" + (foreign-record-type-name type) + field-name + (mapcar #'foreign-record-field-name fields))))) + +(defun %foreign-access-form (base-form type bit-offset accessors) + (if (null accessors) + (invoke-foreign-type-method :extract-gen type base-form bit-offset) + (etypecase type + (foreign-record-type + (let* ((field (%find-foreign-record-type-field type (car accessors)))) + (%foreign-access-form base-form + (foreign-record-field-type field) + (+ bit-offset (foreign-record-field-offset field)) + (cdr accessors)))) + (foreign-pointer-type + (%foreign-access-form + (invoke-foreign-type-method :extract-gen type base-form bit-offset) + (foreign-pointer-type-to type) + 0 + accessors))))) + +(defun %foreign-array-access-form (base-form type index-form) + (etypecase type + ((or foreign-pointer-type foreign-array-type) + (let* ((to (foreign-pointer-type-to type)) + (size (foreign-type-bits to)) + (bit-offset `(the fixnum (* ,size (the fixnum ,index-form))))) + (invoke-foreign-type-method :extract-gen to base-form bit-offset))))) + + + + + +;;;; Naturalize, deport, extract-foreign-value, deposit-foreign-value + +(defun naturalize (foreign type) + (declare (type foreign-type type)) + (funcall (coerce (compute-naturalize-lambda type) 'function) + foreign type)) + +(defun deport (value type) + (declare (type foreign-type type)) + (funcall (coerce (compute-deport-lambda type) 'function) + value type)) + +(defun extract-foreign-value (sap offset type) + (declare (type macptr sap) + (type unsigned-byte offset) + (type foreign-type type)) + (funcall (coerce (compute-extract-lambda type) 'function) + sap offset type)) + +(defun deposit-foreign-value (sap offset type value) + (declare (type macptr sap) + (type unsigned-byte offset) + (type foreign-type type)) + (funcall (coerce (compute-deposit-lambda type) 'function) + sap offset type value)) + + + +(defmacro external (name) + "If there is already an EXTERNAL-ENTRY-POINT for the symbol named by name, +find it and return it. If not, create one and return it. + +Try to resolve the entry point to a memory address, and identify the +containing library. + +Be aware that under Darwin, external functions which are callable from C +have underscores prepended to their names, as in '_fopen'." + `(load-eep ,name)) + +(defmacro external-call (name &rest args) + "Call the foreign function at the address obtained by resolving the +external-entry-point associated with name, passing the values of each arg +as a foreign argument of type indicated by the corresponding +arg-type-specifier. Returns the foreign function result (coerced to a +Lisp object of type indicated by result-type-specifier), or NIL if +result-type-specifer is :VOID or NIL" + `(ff-call (%reference-external-entry-point + (load-time-value (external ,name))) ,@args)) + +(defmacro ff-call (entry &rest args) + "Call the foreign function at address entrypoint passing the values of +each arg as a foreign argument of type indicated by the corresponding +arg-type-specifier. Returns the foreign function result (coerced to a +Lisp object of type indicated by result-type-specifier), or NIL if +result-type-specifer is :VOID or NIL" + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,entry) args)) + + + +(defmethod make-load-form ((eep external-entry-point) &optional env) + (declare (ignore env)) + `(load-eep ,(eep.name eep))) + + +(defmethod print-object ((eep external-entry-point) out) + (print-unreadable-object (eep out :type t :identity t) + (format out "~s" (eep.name eep)) + (let* ((addr (eep.address eep)) + (container (eep.container eep))) + (if addr + #+ppc-target + (progn + #+32-bit-target + (format out " (#x~8,'0x) " (logand #xffffffff (ash addr 2))) + #+64-bit-target + (format out " (#x~16,'0x) " (if (typep addr 'integer) + (logand #xffffffffffffffff (ash addr 2)) + (%ptr-to-int addr)))) + #+x8632-target + (format out " (#x~8,'0x) " addr) + #+x8664-target + (format out " (#x~16,'0x) " addr) + (format out " {unresolved} ")) + (when (and container (or (not (typep container 'macptr)) + (not (%null-ptr-p container)))) + (format out "~a" (shlib.soname container)))))) + + + +(defun %cons-foreign-variable (name type &optional container) + (%istruct 'foreign-variable nil name type container)) + +(defmethod make-load-form ((fv foreign-variable) &optional env) + (declare (ignore env)) + `(load-fv ,(fv.name fv) ',(fv.type fv))) + +(defmethod print-object ((fv foreign-variable) out) + (print-unreadable-object (fv out :type t :identity t) + (format out "~s" (fv.name fv)) + (let* ((addr (fv.addr fv)) + (container (fv.container fv))) + (if addr + #+32-bit-target + (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr))) + #+64-bit-target + (format out " (#x~16,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr))) + (format out " {unresolved} ")) + (when (and container (or (not (typep container 'macptr)) + (not (%null-ptr-p container)))) + (format out "~a" (shlib.soname container)))))) + + +(defmethod print-object ((s shlib) stream) + (print-unreadable-object (s stream :type t :identity t) + (format stream "~a" (or (shlib.soname s) (shlib.pathname s))))) + +#-(or darwin-target windows-target) +(defun dlerror () + (with-macptrs ((p)) + (%setf-macptr p (#_dlerror)) + (unless (%null-ptr-p p) (%get-cstring p)))) + +(defstruct (external-function-definition (:conc-name "EFD-") + (:constructor + make-external-function-definition + (&key entry-name arg-specs + result-spec + (min-args (length arg-specs)))) + ) + (entry-name "" :type string) + (arg-specs () :type list) + (result-spec nil :type (or symbol list)) + (min-args 0 :type fixnum)) + + +(defun %external-call-expander (whole env) + (declare (ignore env)) + (destructuring-bind (name &rest args) whole + (collect ((call)) + (let* ((info (or (gethash name (ftd-external-function-definitions + *target-ftd*)) + (error "Unknown external-function: ~s" name))) + (external-name (efd-entry-name info)) + (arg-specs (efd-arg-specs info)) + (result (efd-result-spec info)) + (monitor (eq (car args) :monitor-exception-ports))) + (when monitor + (setq args (cdr args)) + (call :monitor-exception-ports)) + (let* ((rtype (parse-foreign-type result))) + (if (typep rtype 'foreign-record-type) + (call (pop args)))) + (do* ((specs arg-specs (cdr specs)) + (args args (cdr args))) + ((null specs) + (call result) + (if args + (error "Extra arguments in ~s" whole) + `(external-call ,external-name ,@(call)))) + (let* ((spec (car specs))) + (cond ((eq spec :void) + ;; must be last arg-spec; remaining args should be + ;; keyword/value pairs + (unless (evenp (length args)) + (error "Remaining arguments should be keyword/value pairs: ~s" + args)) + (do* () + ((null args)) + (call (pop args)) + (call (pop args)))) + (t + (call spec) + (if args + (call (car args)) + (error "Missing arguments in ~s" whole)))))))))) + +(defun translate-foreign-arg-type (foreign-type-spec) + (let* ((foreign-type (parse-foreign-type foreign-type-spec))) + (etypecase foreign-type + (foreign-pointer-type :address) + (foreign-integer-type + (let* ((bits (foreign-integer-type-bits foreign-type)) + (signed (foreign-integer-type-signed foreign-type))) + (declare (fixnum bits)) + (cond ((<= bits 8) (if signed :signed-byte :unsigned-byte)) + ((<= bits 16) (if signed :signed-halfword :unsigned-halfword)) + ((<= bits 32) (if signed :signed-fullword :unsigned-fullword)) + ((<= bits 64) (if signed :signed-doubleword :unsigned-doubleword)) + (t `(:record ,bits))))) + (foreign-float-type + (ecase (foreign-float-type-bits foreign-type) + (32 :single-float) + (64 :double-float))) + (foreign-record-type + `(:record ,(foreign-record-type-bits foreign-type)))))) + + +(defmacro define-external-function (name (&rest arg-specs) result-spec + &key (min-args (length arg-specs))) + (let* ((entry-name nil) + (package (find-package (ftd-interface-package-name *target-ftd*))) + (arg-keywords (mapcar #'translate-foreign-arg-type arg-specs)) + (result-keyword (unless (and (symbolp result-spec) + (eq (make-keyword result-spec) :void)) + (translate-foreign-arg-type result-spec)))) + (when (and (consp result-keyword) (eq (car result-keyword) :record)) + (push :address arg-keywords) + (setq result-keyword nil)) + (if (consp name) + (setq entry-name (cadr name) name (intern (unescape-foreign-name + (car name)) + package)) + (progn + (setq entry-name (unescape-foreign-name name) + name (intern entry-name package)) + (if (getf (ftd-attributes *target-ftd*) + :prepend-underscore) + (setq entry-name (concatenate 'string "_" entry-name))))) + `(progn + (setf (gethash ',name (ftd-external-function-definitions *target-ftd*)) + (make-external-function-definition + :entry-name ',entry-name + :arg-specs ',arg-keywords + :result-spec ',result-keyword + :min-args ,min-args)) + (setf (macro-function ',name) #'%external-call-expander) + ',name))) + + +#+darwinppc-target +(defun open-dylib (name) + (with-cstrs ((name name)) + (#_NSAddImage name (logior #$NSADDIMAGE_OPTION_RETURN_ON_ERROR + #$NSADDIMAGE_OPTION_WITH_SEARCHING)))) + +(defparameter *foreign-representation-type-keywords* + `(:signed-doubleword :signed-fullword :signed-halfword :signed-byte + :unsigned-doubleword :unsigned-fullword :unsigned-halfword :unsigned-byte + :address + :single-float :double-float + :void)) + +(defun null-coerce-foreign-arg (arg-type-keyword argform) + (declare (ignore arg-type-keyword)) + argform) + +(defun null-coerce-foreign-result (result-type-keyword resultform) + (declare (ignore result-type-keyword)) + resultform) + +(defun foreign-type-to-representation-type (f) + (if (or (member f *foreign-representation-type-keywords*) + (typep f 'unsigned-byte)) + f + (let* ((ftype (if (typep f 'foreign-type) + f + (parse-foreign-type f)))) + (or + (and (eq (foreign-type-class ftype) 'root) :void) + (typecase ftype + ((or foreign-pointer-type foreign-array-type) :address) + (foreign-double-float-type :double-float) + (foreign-single-float-type :single-float) + (foreign-integer-type + (let* ((signed (foreign-integer-type-signed ftype)) + (bits (foreign-integer-type-bits ftype))) + (if signed + (if (<= bits 8) + :signed-byte + (if (<= bits 16) + :signed-halfword + (if (<= bits 32) + :signed-fullword + (if (<= bits 64) + :signed-doubleword)))) + (if (<= bits 8) + :unsigned-byte + (if (<= bits 16) + :unsigned-halfword + (if (<= bits 32) + :unsigned-fullword + (if (<= bits 64) + :unsigned-doubleword))))))) + (foreign-record-type + (if (getf (ftd-attributes *target-ftd*) + :struct-by-value) + (let* ((bits (ensure-foreign-type-bits ftype))) + (ceiling bits (target-word-size-case + (32 32) + (64 64)))) + :address))) + (error "can't determine representation keyword for ~s" f))))) + +(defun foreign-record-accessor-names (record-type &optional prefix) + (collect ((accessors)) + (dolist (field (foreign-record-type-fields record-type) (accessors)) + (let* ((field-name (append prefix (list (foreign-record-field-name field)))) + (field-type (foreign-record-field-type field))) + (if (typep field-type 'foreign-record-type) + (dolist (s (foreign-record-accessor-names field-type field-name)) + (accessors s)) + (accessors field-name)))))) + +;;; Are all (scalar) fields in the field-list FIELDS floats ?' +(defun all-floats-in-field-list (fields) + (dolist (field fields t) + (let* ((field-type (foreign-record-field-type field))) + (cond ((typep field-type 'foreign-record-type) + (unless (all-floats-in-field-list (foreign-record-type-fields field-type)) + (return nil))) + ((typep field-type 'foreign-array-type) + (unless (typep (foreign-array-type-element-type field-type) 'foreign-float-type) + (return nil))) + (t (unless (typep field-type 'foreign-float-type) + (return nil))))))) + +;;; Are any (scalar) fields in the field-list FIELDS floats ? +(defun some-floats-in-field-list (fields) + (dolist (field fields) + (let* ((field-type (foreign-record-field-type field))) + (cond ((typep field-type 'foreign-float-type) + (return t)) + ((typep field-type 'foreign-record-type) + (if (some-floats-in-field-list (foreign-record-type-fields field-type)) + (return t))) + ((typep field-type 'foreign-array-type) + (if (typep (foreign-array-type-element-type field-type) + 'foreign-float-type) + (return t))))))) + +;;; We don't use foreign type ordinals when cross-compiling, +;;; so the read-time conditionalization is OK here. + +#-windows-target +(defparameter *canonical-os-foreign-types* + '((:struct :timespec) + (:struct :stat) + (:struct :passwd) + #>Dl_info + (:array (:struct :pollfd) 1)) ) + +#+windows-target +(defparameter *canonical-os-foreign-types* + `(#>FILETIME + #>SYSTEM_INFO + #>HANDLE + #>PROCESS_INFORMATION + #>STARTUPINFO + (:array #>HANDLE 2) + #>DWORD + (:array #>wchar_t #.#$MAX_PATH) + #>fd_set + #>DWORD_PTR + #>SYSTEMTIME)) + + +(defun canonicalize-foreign-type-ordinals (ftd) + (let* ((canonical-ordinal 0)) ; used for :VOID + (flet ((canonicalize-foreign-type-ordinal (spec) + (let* ((new-ordinal (incf canonical-ordinal))) + (when spec + (let* ((type (parse-foreign-type spec)) + (old-ordinal (foreign-type-ordinal type))) + (unless (eql new-ordinal old-ordinal) + (remhash old-ordinal (ftd-ordinal-types ftd)) + (setf (foreign-type-ordinal type) new-ordinal) + (note-foreign-type-ordinal type ftd)))) + new-ordinal))) + (canonicalize-foreign-type-ordinal :signed) + (canonicalize-foreign-type-ordinal :unsigned) + (canonicalize-foreign-type-ordinal #+64-bit-target :long #-64-bit-target nil) + (canonicalize-foreign-type-ordinal :address) + (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in)) + (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un)) + (canonicalize-foreign-type-ordinal '(:struct :linger)) + (canonicalize-foreign-type-ordinal '(:struct :hostent)) + (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3)) + (canonicalize-foreign-type-ordinal '(:* :char)) + (canonicalize-foreign-type-ordinal '(:struct :in_addr)) + (canonicalize-foreign-type-ordinal '(:struct :cdb-datum)) + (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)) + (canonicalize-foreign-type-ordinal '(:* (:struct :hostent))) + (canonicalize-foreign-type-ordinal '(:array :int 2)) + (canonicalize-foreign-type-ordinal '(:array (:struct :pollfd) 1)) + (canonicalize-foreign-type-ordinal '(:struct :dirent)) + (canonicalize-foreign-type-ordinal '(:struct :timeval)) + (canonicalize-foreign-type-ordinal '(:struct :addrinfo)) + + (setq canonical-ordinal (1- max-common-foreign-type-ordinal)) + + (dolist (spec *canonical-os-foreign-types*) + (canonicalize-foreign-type-ordinal spec)) + (dolist (spec (ftd-platform-ordinal-types ftd)) + (canonicalize-foreign-type-ordinal spec))))) + +(defun install-standard-foreign-types (ftd) + (let* ((*target-ftd* ftd) + (natural-word-size (getf (ftd-attributes ftd) :bits-per-word)) + (long-word-size (or (getf (ftd-attributes ftd) :bits-per-long) + natural-word-size))) + + (def-foreign-type-translator signed (&optional (bits 32)) + (if (<= bits 64) + (svref *signed-integer-types* bits) + (make-foreign-integer-type :bits bits))) + + + (def-foreign-type-translator integer (&optional (bits 32)) + (if (<= bits 64) + (svref *signed-integer-types* bits) + (make-foreign-integer-type :bits bits))) + + (def-foreign-type-translator unsigned (&optional (bits 32)) + (if (<= bits 64) + (svref *unsigned-integer-types* bits) + (make-foreign-integer-type :bits bits :signed nil))) + + (def-foreign-type-translator bitfield (&optional (bits 1)) + (make-foreign-integer-type :bits bits :signed nil :alignment 1)) + + (def-foreign-type-translator root () + (make-foreign-type :class 'root :bits 0 :alignment 0)) + + (def-foreign-type-translator : () *bool-type*) + + (def-foreign-type-translator single-float () + (make-foreign-single-float-type :type 'single-float)) + + (def-foreign-type-translator double-float () + (make-foreign-double-float-type :type 'double-float)) + + (def-foreign-type-translator macptr () + (make-foreign-macptr-type :bits natural-word-size)) + + (def-foreign-type-translator values (&rest values) + (unless *values-type-okay* + (error "Cannot use values types here.")) + (let ((*values-type-okay* nil)) + (make-foreign-values-type + :values (mapcar #'parse-foreign-type values)))) + + (def-foreign-type-translator function (result-type &rest arg-types) + (make-foreign-function-type + :result-type (let ((*values-type-okay* t)) + (parse-foreign-type result-type)) + :arg-types (mapcar #'parse-foreign-type arg-types))) + + (def-foreign-type-translator struct (name &rest fields) + (parse-foreign-record-type :struct name fields)) + + (def-foreign-type-translator union (name &rest fields) + (parse-foreign-record-type :union name fields)) + + (def-foreign-type-translator transparent-union (name &rest fields) + (parse-foreign-record-type :transparent-union name fields)) + + (def-foreign-type-translator array (ele-type &rest dims) + (when dims + ;; cross-compiling kludge. replaces '(or index null) + (unless (typep (first dims) `(or + ,(target-word-size-case + (32 '(integer 0 #.(expt 2 24))) + (64 '(integer 0 #.(expt 2 56)))) + null)) + (error "First dimension is not a non-negative fixnum or NIL: ~S" + (first dims))) + (let ((loser (find-if-not #'(lambda (x) (typep x 'index)) + (rest dims)))) + (when loser + (error "Dimension is not a non-negative fixnum: ~S" loser)))) + + (let* ((type (parse-foreign-type ele-type)) + (pair (cons type dims))) + (declare (dynamic-extent pair)) + (ensure-foreign-type-bits type) + (or (gethash pair (ftd-array-types *target-ftd*)) + (setf (gethash (cons type dims) (ftd-array-types *target-ftd*)) + + (make-foreign-array-type + :element-type type + :dimensions dims + :alignment (foreign-type-alignment type) + :bits (if (and (ensure-foreign-type-bits type) + (every #'integerp dims)) + (* (align-offset (foreign-type-bits type) + (foreign-type-alignment type)) + (reduce #'* dims)))))))) + + (def-foreign-type-translator * (to) + (let* ((ftd *target-ftd*) + (to (if (eq to t) *void-foreign-type* (parse-foreign-type to ftd)))) + (or (gethash to (ftd-pointer-types ftd)) + (setf (gethash to (ftd-pointer-types *target-ftd*)) + (make-foreign-pointer-type + :to to + :bits natural-word-size))))) + + (def-foreign-type-translator boolean (&optional (bits 32)) + (make-foreign-boolean-type :bits bits :signed nil)) + + (def-foreign-type signed-char (signed 8)) + (def-foreign-type signed-byte (signed 8)) + (def-foreign-type short (signed 16)) + (def-foreign-type signed-halfword short) + (def-foreign-type int (signed 32)) + (def-foreign-type signed-fullword int) + (def-foreign-type signed-short (signed 16)) + (def-foreign-type signed-int (signed 32)) + (def-foreign-type signed-doubleword (signed 64)) + (def-foreign-type char #-darwin-target (unsigned 8) + #+darwin-target (signed 8)) + (def-foreign-type unsigned-char (unsigned 8)) + (def-foreign-type unsigned-byte (unsigned 8)) + (def-foreign-type unsigned-short (unsigned 16)) + (def-foreign-type unsigned-halfword unsigned-short) + (def-foreign-type unsigned-int (unsigned 32)) + (def-foreign-type unsigned-fullword unsigned-int) + (def-foreign-type unsigned-doubleword (unsigned 64)) + (def-foreign-type bit (bitfield 1)) + + (def-foreign-type float single-float) + (def-foreign-type double double-float) + + (%def-foreign-type :void *void-foreign-type*) + (def-foreign-type address (* :void)) + (let* ((signed-long-type (parse-foreign-type + `(:signed ,long-word-size))) + (unsigned-long-type (parse-foreign-type + `(:unsigned ,long-word-size)))) + (%def-foreign-type :long signed-long-type ftd) + (%def-foreign-type :signed-long signed-long-type ftd) + (%def-foreign-type :unsigned-long unsigned-long-type ftd)) + ;; + ;; Defining the handful of foreign structures that are used + ;; to build Clozure CL here ensures that all backends see appropriate + ;; definitions of them. + ;; + ;; Don't use DEF-FOREIGN-TYPE here; this often runs too + ;; early in the cold load for that to work. + ;; + (parse-foreign-type + '(:struct :cdb-datum + (:data (* t)) + (:size (:unsigned 32))) + ftd) + (parse-foreign-type + '(:struct :dbm-constant + (:class (:unsigned 32)) + (:pad (:unsigned 32)) + (:value + (:union nil + (:s32 (:signed 32)) + (:u32 (:unsigned 32)) + (:single-float :float) + (:double-float :double)))) + ftd) + ;; This matches the xframe-list struct definition in + ;; "ccl:lisp-kernel;constants.h" + (parse-foreign-type + '(:struct :xframe-list + (:this (:* t #|(struct :ucontext)|#)) + (:prev (:* (:struct :xframe-list)))) + ftd) + )) + +(defmethod make-load-form ((p macptr) &optional env) + (declare (ignore env)) + (let* ((value (%ptr-to-int p))) + (unless (or (< value 65536) + (>= value (- (ash 1 target::nbits-in-word) 65536))) + (error "~&~s can't be referenced as a constant because its address contains more than 16 significant bits." p)) + (if (zerop value) + '+null-ptr+ + `(%int-to-ptr ,value)))) + + + + Index: /branches/qres/ccl/lib/format.lisp =================================================================== --- /branches/qres/ccl/lib/format.lisp (revision 13564) +++ /branches/qres/ccl/lib/format.lisp (revision 13564) @@ -0,0 +1,2627 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Functions to implement FORMAT. +;;; + +(in-package "CCL") + +;;; Special variables local to FORMAT +;;; why do these have top-level bindings ????? - seems wrong or at least unnecessary + +(defvar *format-control-string* "" + "The current FORMAT control string") + +(defvar *format-index* 0 + "The current index into *format-control-string*") + +(defvar *format-length* 0 + "The length of the current FORMAT control string") + +(defvar *format-arguments* () + "Arguments to the current call of FORMAT") + +(defvar *format-original-arguments* () + "Saved arglist from top-level FORMAT call for ~* and ~@*") + +(defvar *format-arguments-variance* nil + "Non-NIL only during compile-time scanning of a format string, in which case it is the +number of additional elements at the front of *format-arguments* that may be already used +up at runtime. I.e. the actual *format-arguments* may be anything between *format-arguments* +and (nthcdr *format-arguments-variance* *format-arguments*)") + +(def-standard-initial-binding *format-stream-stack* nil "A stack of string streams for collecting FORMAT output") + +(defvar *format-pprint* nil + "Has a pprint format directive (~W ~I ~_ ~:T) or logical-block directive been seen?") + +(defvar *format-justification-semi* nil + "Has a ~<...~:;...~> been seen?") + +(defvar *format-colon-rest* nil + ) + +;;; prevent circle checking rest args. Really EVIL when dynamic-extent +(def-standard-initial-binding *format-top-level* nil) + + +;;; ERRORS + +;;; Since errors may occur while an indirect control string is being +;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary +;;; in order to indicate the location in the control string where the +;;; error was detected. To this end, errors detected by format are +;;; signalled by throwing a list of the form ((control-string args)) +;;; to the tag FORMAT-ERROR. This throw will be caught at each level +;;; of indirection, and the list of error messages re-thrown with an +;;; additional message indicating that indirection was present CONSed +;;; onto it. Ultimately, the last throw will be caught by the top level +;;; FORMAT function, which will then signal an error to the Slisp error +;;; system in such a way that all the errror messages will be displayed +;;; in reverse order. + +(defun format-error (complaint &rest args) + (throw 'format-error + (list (list "~1{~:}~%~S~%~V@T^" complaint args + *format-control-string* (1+ *format-index*))))) + + +;;; MACROS + +;;; This macro establishes the correct environment for processing +;;; an indirect control string. CONTROL-STRING is the string to +;;; process, and FORMS are the forms to do the processing. They +;;; invariably will involve a call to SUB-FORMAT. CONTROL-STRING +;;; is guaranteed to be evaluated exactly once. +(eval-when (compile eval #-bccl load) + +; does this need to exist????? +#|| ; put it out of its misery +(defmacro format-with-control-string (control-string &rest forms) + `(let ((string (if (simple-string-p ,control-string) + ,control-string + (coerce ,control-string 'simple-base-string)))) + (declare (simple-string string)) + (let ((error (catch 'format-error + (let ((*format-control-string* string) + (*format-length* (length string)) + (*format-index* 0)) + ,@forms + nil)))) + + (when error + (throw 'format-error + (cons (list "While processing indirect control string~%~S~%~V@T^" + *format-control-string* + (1+ *format-index*)) + error)))))) +||# +(defmacro format-indirect-error (error) + `(throw 'format-error + (cons (list "While processing indirect control string~%~S~%~V@T^" + *format-control-string* + (1+ *format-index*)) + ,error))) + + +(defmacro get-a-format-string-stream () + '(or (pop *format-stream-stack*) (make-string-output-stream :element-type 'base-char))) ; ?? + +;;; This macro rebinds collects output to the standard output stream +;;; in a string. For efficiency, we avoid consing a new stream on +;;; every call. A stack of string streams is maintained in order to +;;; guarantee re-entrancy. + +(defmacro with-format-string-output (stream-sym &rest forms) + `(let ((,stream-sym nil)) + (unwind-protect + (progn + (setq ,stream-sym (get-a-format-string-stream)) + ,@forms + (prog1 + (get-output-stream-string ,stream-sym) + (push ,stream-sym *format-stream-stack*))) + (when ,stream-sym (file-position ,stream-sym 0))))) + +;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION. +;;; PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form +;;; ( ). The FORMS are evaluated in an environment where each +;;; is bound to either the value of the parameter supplied in the +;;; parameter list, or to its value if the parameter was omitted or +;;; explicitly defaulted. + +(defmacro with-format-parameters (parmvar parmdefs &body body &environment env) + (do ((parmdefs parmdefs (cdr parmdefs)) + (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar)) + ,(cadar parmdefs))) + bindings))) + ((null parmdefs) + (multiple-value-bind (forms decls) (parse-body body env) + `(let ,(nreverse bindings) + ,@decls + (when ,parmvar + (format-error "Too many parameters")) + ,@forms))))) + + + +;;; Returns the index of the first occurrence of the specified character +;;; between indices START (inclusive) and END (exclusive) in the control +;;; string. + + +(defmacro format-find-char (char start end) + `(%str-member ,char *format-control-string* + ,start ,end)) + + +) ;end of eval-when for macros + +;;; CONTROL STRING PARSING + +;;; The current control string is kept in *format-control-string*. +;;; The variable *format-index* is the position of the last character +;;; processed, indexing from zero. The variable *format-length* is the +;;; length of the control string, which is one greater than the maximum +;;; value of *format-index*. + + +;;; Gets the next character from the current control string. It is an +;;; error if there is none. Leave *format-index* pointing to the +;;; character returned. + +(defun format-nextchar () + (let ((index (%i+ 1 *format-index*))) + (if (%i< (setq *format-index* index) *format-length*) + (schar *format-control-string* index) + (format-error "Syntax error")))) + + + +;;; Returns the current character, i.e. the one pointed to by *format-index*. + +(defmacro format-peek () + `(schar *format-control-string* *format-index*)) + + + + +;;; Attempts to parse a parameter, starting at the current index. +;;; Returns the value of the parameter, or NIL if none is found. +;;; On exit, *format-index* points to the first character which is +;;; not a part of the recognized parameter. + +(defun format-get-parameter (ch) + (case ch + (#\# (format-nextchar) + (let ((n (or *format-arguments-variance* 0)) + (len (length *format-arguments*))) + (declare (fixnum n len)) + (if (eql n 0) + len + `(the (integer ,(- len n) ,len) (length *format-arguments*))))) + ((#\V #\v) + (prog1 (pop-format-arg) (format-nextchar))) + (#\' (prog1 (format-nextchar) (format-nextchar))) + (t (cond ((or (eq ch #\-) (eq ch #\+) (digit-char-p ch)) + (let ((neg-parm (eq ch #\-))) + (unless (setq ch (digit-char-p ch)) + (unless (setq ch (digit-char-p (format-nextchar))) + (format-error "Illegal parameter"))) + (do ((number ch (+ ch (* number 10)))) + ((not (setq ch (digit-char-p (format-nextchar)))) + (if neg-parm (- number) number))))) + (t nil))))) + +(defun format-skip-parameter (ch) ; only caller is parse-format-operation + "Might someday want to add proper format error checking for negative + parameters" + (let () + (case ch + ((#\V #\v #\#) + (format-nextchar)) + (#\' (format-nextchar) (format-nextchar)) + (#\,) + (t (when (or (eq ch #\-) (eq ch #\+)) (format-nextchar)) + (while (digit-char-p (format-nextchar))))))) + +(defun format-no-semi (char &optional colon atsign) + (when *format-justification-semi* + (format-error "~~~:[~;:~]~:[~;@~]~c illegal in this context" colon atsign char)) + (setq *format-pprint* t)) + +;;; Parses a format directive, including flags and parameters. On entry, +;;; *format-index* should point to the "~" preceding the command. On +;;; exit, *format-index* points to the command character itself. +;;; Returns the list of parameters, the ":" flag, the "@" flag, and the +;;; command character as multiple values. Explicitly defaulted parameters +;;; appear in the list of parameters as NIL. Omitted parameters are simply +;;; not included in the list at all. + +(defun parse-format-operation (&optional get-params) ; only caller is format-find-command + (let ((ch (format-nextchar)) parms colon atsign) + (when (or (digit-char-p ch) + ;(%str-member ch ",#Vv'")) + (memq ch '(#\- #\, #\# #\V #\v #\'))) + (cond (get-params + (setq parms (list (format-get-parameter ch))) + (until (neq (setq ch (format-peek)) #\,) + (setq ch (format-nextchar)) + (push (format-get-parameter ch) parms))) + (t (setq parms t) ; tell caller there were some so we get correct error msgs + (format-skip-parameter ch) + (until (neq (setq ch (format-peek)) #\,) + (setq ch (format-nextchar)) + (format-skip-parameter ch))))) + ; allow either order + (case ch + (#\: (setq colon t ch (format-nextchar)) + (when (eq ch #\@) + (setq atsign t ch (format-nextchar)))) + (#\@ (setq atsign t ch (format-nextchar)) + (when (eq ch #\:) + (setq colon t ch (format-nextchar))))) + (values (if (consp parms) (nreverse parms) parms) + colon + atsign + ch))) + + +;;; Starting at the current value of *format-index*, finds the first +;;; occurrence of one of the specified directives. Embedded constructs, +;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored. And error is +;;; signalled if no satisfactory command is found. Otherwise, the +;;; following are returned as multiple values: +;;; +;;; The value of *format-index* at the start of the search +;;; The index of the "~" character preceding the command +;;; The parameter list of the command +;;; The ":" flag +;;; The "@" flag +;;; The command character +;;; +;;; Implementation note: The present implementation is not particulary +;;; careful with storage allocation. It would be a good idea to have +;;; a separate function for skipping embedded constructs which did not +;;; bother to cons parameter lists and then throw them away. This issue has been addressed. (akh) +;;; +;;; We go to some trouble here to use POSITION for most of the searching. +;;; God only knows why!!!! + +;; and interesting note - the only caller who wants parameters is format-get-segments for +;; ~< .... ~n:; ...~> +(defun format-find-command (command-list &optional get-params evil-commands) + (let* ((start *format-index*) + (length *format-length*) + tilde) + (loop + (setq tilde (format-find-char #\~ *format-index* length)) + (if (not tilde) (format-error "Expecting one of ~S" command-list)) + (setq *format-index* tilde) + (multiple-value-bind (parms colon atsign command) + (parse-format-operation get-params) + (when (memq command command-list) + (return (values start tilde parms colon atsign command))) + (when (and evil-commands + (or (memq command '(#\w #\_ #\i #\W #\I)) + (and colon (memq command '(#\t #\T))))) + (format-error "Illegal in this context")) + (case command + (#\{ (format-nextchar) (format-find-command '(#\}))) + (#\( (format-nextchar) (format-find-command '(#\)))) + (#\[ (format-nextchar) (format-find-command '(#\]))) + (#\< (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\>)) + (declare (ignore prev tilde parms atsign cmd)) + (if (and evil-commands colon) + (format-error "Logical-block directive not allowed inside justification directive")))) + ((#\} #\> #\) #\]) + (format-error "No matching bracket"))))))) + +(defun format-find-command-no-params (command-list &key (colon t) (atsign t)) + (multiple-value-bind (prev tilde parms colon-flag atsign-flag command) + (format-find-command command-list) + (with-format-parameters parms () + (format-no-flags (and (not colon) colon-flag) (and (not atsign) atsign-flag))) + (values prev tilde command colon-flag atsign-flag))) + +;;; This is the FORMAT top-level function. + +(defun format (stream control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (if (null stream) + (with-output-to-string (s) + (apply #'format s control-string format-arguments)) + (if (stringp stream) + (with-output-to-string (s stream) + (apply #'format s control-string format-arguments)) + (let ((*format-top-level* t)) + (when (xp-structure-p stream)(setq stream (xp-stream-stream stream))) ; for xp tests only! They call format on a structure + (setq stream (if (eq stream t) + *standard-output* + (require-type stream 'stream))) + (if (functionp control-string) + (apply control-string stream format-arguments) + (let* ((control-string (ensure-simple-string control-string)) + (*format-control-string* control-string) + (*format-pprint* nil) + (*format-justification-semi* nil)) + (declare (type simple-string control-string)) + (cond + ;; Try to avoid pprint overhead in this case. + ((not (position #\~ control-string)) + (write-string control-string stream)) + ((and (or *print-pretty* *print-circle*) + (not (typep stream 'xp-stream))) + (maybe-initiate-xp-printing + #'(lambda (s o) + (do-sub-format-1 s o)) + stream format-arguments)) + (t + (let ((*format-original-arguments* format-arguments) + (*format-arguments* format-arguments) + (*format-colon-rest* 'error)) ; what should this be?? + (do-sub-format stream)))))) + nil)))) + +(defun format-to-string (string control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (if string + (with-output-to-string (stream string) + (apply #'format stream control-string format-arguments)) + (with-output-to-string (stream) + (apply #'format stream control-string format-arguments)))) + +(defun do-sub-format (stream) + (let (errorp) + (setq errorp + (catch 'format-error + (catch 'format-escape + (sub-format stream 0 (length *format-control-string*))) + nil)) + (when errorp + (error "~%~:{~@?~%~}" (nreverse errorp))))) + + + +;;; This function does the real work of format. The segment of the control +;;; string between indiced START (inclusive) and END (exclusive) is processed +;;; as follows: Text not part of a directive is output without further +;;; processing. Directives are parsed along with their parameters and flags, +;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and +;;; PARMS. +;;; + +;;; POP-FORMAT-ARG also defined in l1-format + +; in l1-format +(def-standard-initial-binding *logical-block-xp* nil) + +(without-duplicate-definition-warnings + (defun pop-format-arg (&aux (args *format-arguments*) (xp *logical-block-xp*) (av *format-arguments-variance*)) + (when (and (null args) (null xp)) + (format-error "Missing argument")) + (when xp + (if (null av) + (when (pprint-pop-check+ args xp) ; gets us level and length stuff in logical block + (throw 'logical-block nil)) + ;; Could record that might exit here, but nobody cares. + #+no (note-format-scan-option *logical-block-options*))) + (if (or (null av) (eql av 0)) + (progn + (setq *format-arguments* (cdr args)) + (%car args)) + (let ((types (loop for x in args as i from 0 below av + collect (nx-form-type x)))) + (when (eql av (length args)) + (setq *format-arguments-variance* (1- av))) + (setq *format-arguments* (cdr args)) + `(the (or ,@types) (car *format-arguments*)))))) + +; SUB-FORMAT is now defined in L1-format.lisp +; DEFFORMAT is also defined there. + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pretty-printing stuff +;;; + +(defformat #\W format-write (stream colon atsign) + (format-no-semi #\W) + (let ((arg (pop-format-arg))) + (cond (atsign + (let ((*print-level* nil) + (*print-length* nil)) + (if colon + (let ((*print-pretty* t)) + (write-1 arg stream)) + (write-1 arg stream)))) + (t (if colon + (let ((*print-pretty* t)) + (write-1 arg stream)) + (write-1 arg stream)))))) + +(defformat #\I format-indent (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (declare (ignore atsign)) + (format-no-semi #\I) + (with-format-parameters parms ((n 0)) + (pprint-indent (if colon :current :block) n stream))) + +(defformat #\_ format-conditional-newline (stream colon atsign) + (format-no-semi #\_) + (let ((option + (cond (atsign + (cond (colon :mandatory) + (t :miser))) + (colon :fill) + (t :linear)))) + (pprint-newline option stream))) + +;;; Tabulation ~T + +(defformat #\T format-tab (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-no-semi #\T t)) + (with-format-parameters parms ((colnum 1) (colinc 1)) + (cond ((or (typep stream 'xp-stream) (xp-structure-p stream)) + (let ((kind (if colon + (if atsign :section-relative :section) + (if atsign :line-relative :line)))) + (cond ((xp-structure-p stream) + (pprint-tab+ kind colnum colinc stream)) + ((typep stream 'xp-stream) + (pprint-tab+ kind colnum colinc + (slot-value stream 'xp-structure)))))) + ((not colon) + (pprint-tab-not-pretty stream colnum colinc atsign))))) + +(defun pprint-tab-not-pretty (stream colnum colinc &optional atsign) + (let* ((position (column stream)) + (count (if atsign + (if position + (if (zerop colinc) + colnum (+ colnum (mod (- (+ position colnum)) colinc))) + colnum) + (if position + (if (<= colnum position) + (if (zerop colinc) + 0 (- colinc (mod (- position colnum) colinc))) + (- colnum position)) + 2)))) + (while (> count 0) + (write-string " " + stream :start + 0 :end (min count 80)) + (setq count (- count 80))))) + + +;;; ~/ call function +(defformat #\/ format-call-function (stream colon atsign &rest parms) + (let* ((string *format-control-string*) + (ipos (1+ *format-index*)) + (epos (format-find-char #\/ ipos *format-length*))) + ; the spec is DUMB here - it requires that : and :: be treated the same + (when (not epos) (format-error "Unmatched ~~/")) + (let ((cpos (format-find-char #\: ipos epos)) + package) + (cond (cpos + (setq package (or (find-package (string-upcase (%substr string ipos cpos))) + (format-error "Unknown package"))) + (when (eql #\: (schar string (%i+ 1 cpos))) + (setq cpos (%i+ cpos 1))) + (setq ipos (%i+ cpos 1))) + (t (setq package (find-package "CL-USER")))) + (let ((thing (intern (string-upcase (%substr string ipos epos)) package))) + (setq *format-index* epos) ; or 1+ epos? + (apply thing stream (pop-format-arg) colon atsign parms))))) + +;;; Conditional case conversion ~( ... ~) + +#| coral's old version +(defformat #\( format-capitalization (stream colon atsign) + (format-nextchar) + (multiple-value-bind (prev tilde) (format-find-command-no-params '(#\))) + (let* (finished + (string (with-format-string-output stream + (setq finished (catch 'format-escape (sub-format stream prev tilde) t))))) + (write-string + (cond ((and atsign colon) + (nstring-upcase string)) + (colon + (nstring-capitalize string)) + (atsign + (let ((strlen (length string))) + ;; Capitalize the first word only + (nstring-downcase string) + (do ((i 0 (1+ i))) + ((or (<= strlen i) (alpha-char-p (char string i))) + (setf (char string i) (char-upcase (char string i))) + string)))) + (t (nstring-downcase string))) + stream :start + 0 :end (length string)) + (unless finished (throw 'format-escape nil))))) + +|# + +(defformat #\( format-capitalization (stream colon atsign) + (format-nextchar) + (multiple-value-bind (prev tilde) (format-find-command-no-params '(#\))) + (let (catchp) + (cond ((typep stream 'xp-stream) + (let ((xp (slot-value stream 'xp-structure))) + (push-char-mode xp (cond ((and colon atsign) :UP) + (colon :CAP1) + (atsign :CAP0) + (T :DOWN))) + (setq catchp + (catch 'format-escape + (sub-format stream prev tilde) + nil)) + (pop-char-mode xp))) + (t + (let* ((string (with-format-string-output stream + (setq catchp (catch 'format-escape + (sub-format stream prev tilde) + nil))))) + (write-string + (cond ((and atsign colon) + (nstring-upcase string)) + (colon + (nstring-capitalize string)) + (atsign + ;; Capitalize the first word only + (nstring-downcase string) + (dotimes (i (length string) string) + (let ((ch (char string i))) + (when (alpha-char-p ch) + (setf (char string i) (char-upcase ch)) + (return string))))) + (t (nstring-downcase string))) + stream :start + 0 :end (length string))))) + (when catchp + (throw 'format-escape catchp)) + ))) + +;;; Up and Out (Escape) ~^ + +(defformat #\^ format-escape (stream colon atsign &optional p1 p2 p3) + (declare (ignore stream)) + (when atsign + (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon)) + (when (cond (p3 (etypecase p2 + (real + (<= p1 p2 p3)) + (character + (char< p1 p2 p3)))) + (p2 (equal p1 p2)) + (p1 (eql p1 0)) + (t (null (if colon *format-colon-rest* *format-arguments*)))) + (throw 'format-escape (if colon 'format-colon-escape t)))) + +;;; Conditional expression ~[ ... ] + + +;;; ~[ - Maybe these guys should deal with ~^ too - i.e. catch format-escape etc. +;;; but I cant think of a case where just throwing to the { catcher fails + +(defun format-untagged-condition (stream) + (let ((test (pop-format-arg))) + (unless (integerp test) + (format-error "Argument to ~~[ must be integer - ~S" test)) + (do ((count 0 (1+ count))) + ((= count test) + (multiple-value-bind (prev tilde cmd colon atsign) + (format-find-command-no-params '(#\; #\]) :atsign nil) + (declare (ignore colon atsign)) + (sub-format stream prev tilde) + (unless (eq cmd #\]) + (format-find-command '(#\]))))) + (multiple-value-bind (prev tilde cmd colon atsign) + (format-find-command-no-params '(#\; #\]) :atsign nil) + (declare (ignore prev tilde atsign)) + (when (eq cmd #\]) (return)) + (format-nextchar) + (when colon + (multiple-value-bind (prev tilde cmd colon atsign) + (format-find-command-no-params '(#\; #\])) + (declare (ignore colon atsign)) + (sub-format stream prev tilde) + (unless (eq cmd #\]) + (format-find-command-no-params '(#\])))) + (return)))))) + + +;;; ~@[ + +(defun format-funny-condition (stream) + (multiple-value-bind (prev tilde) (format-find-command-no-params '(#\])) + (if *format-arguments* + (if (car *format-arguments*) + (sub-format stream prev tilde) + (pop *format-arguments*)) + (format-error "Missing argument")))) + + +;;; ~:[ + +(defun format-boolean-condition (stream) + (multiple-value-bind (prev tilde command) (format-find-command-no-params '(#\; #\])) + (when (eq command #\]) + (format-error "Two clauses separated by ~~; are required for ~~:[")) + (format-nextchar) + (if (pop-format-arg) + (multiple-value-bind (prev tilde) + (format-find-command-no-params '(#\]) :colon nil :atsign nil) + (sub-format stream prev tilde)) + (progn + (sub-format stream prev tilde) + (format-find-command-no-params '(#\])))))) + + +(defformat #\[ format-condition (stream colon atsign &optional p) + (when p (push p *format-arguments*)) + (format-nextchar) + (cond (colon + (when atsign + (format-error "~~:@[ undefined")) + (format-boolean-condition stream)) + (atsign + (format-funny-condition stream)) + (t (format-untagged-condition stream)))) + + +;;; Iteration ~{ ... ~} + +(defformat #\{ format-iteration (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (with-format-parameters parms ((max-iter -1)) + (format-nextchar) + (multiple-value-bind (prev tilde end-cmd end-colon end-atsign) + (format-find-command-no-params '(#\}) :atsign nil) + (declare (ignore end-cmd end-atsign)) + (if (= prev tilde) + ;; Use an argument as the control string if ~{~} is empty + (let ((string (pop-format-arg))) + (cond ((stringp string) + (when (not (simple-string-p string)) ; fix here too + (setq string (coerce string 'simple-string)))) + ((not (functionp string)) + (format-error "Control string is not a string or function"))) + (let ((error + (catch 'format-error + (cond + ((stringp string) + (let* ((length (length (the simple-string string))) + (*format-control-string* string) + (*format-length* length) + (*format-index* 0)) + (format-do-iteration stream 0 length + max-iter colon atsign end-colon))) + (t ;(functionp string) + (format-do-iteration stream string nil + max-iter colon atsign end-colon))) + nil))) + (when error (format-indirect-error error)))) + (format-do-iteration stream prev tilde + max-iter colon atsign end-colon))))) + + +;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here +;;; to correctly implement ~^ and ~:^. The former aborts only the current +;;; iteration, but the latter aborts the entire iteration process. +;;; ~{ arg is a list ~:{ arg is list of sublists, ~@{ arg is spread ~:@{ spread lists +;;; We have nuked two catch tags. Instead throw two different values: +;;; T if ~^ and 'format-colon-escape if ~:^ + +(defun format-do-iteration (stream start end max-iter colon atsign at-least-once-p) + (flet ((do-iteration-1 (stream start end colon at-least-once-p) + (let (catchp) + (do* ((count 0 (1+ count))) + ((or (= count max-iter) + (and (null *format-arguments*) + (if (= count 0) (not at-least-once-p) t)))) + (setq catchp + (catch 'format-escape + (if colon + (let* ((args (unless (and at-least-once-p (null *format-arguments*)) + (pop-format-arg))) + (*format-top-level* nil) + (*format-colon-rest* *format-arguments*) + (*format-arguments* args) + (*format-original-arguments* args)) + (unless (listp *format-arguments*) + (report-bad-arg *format-arguments* 'list)) + (if (functionp start) + (apply start stream args) + (sub-format stream start end))) + (let ((*format-original-arguments* *format-arguments*)) + (if (functionp start) + (setq *format-arguments* (apply start stream *format-arguments*)) + (sub-format stream start end)))) + nil)) + (when (or (eq catchp 'format-colon-escape) + (and catchp (null colon))) + (return-from do-iteration-1 nil)))))) + (if atsign + (do-iteration-1 stream start end colon at-least-once-p) + ; no atsign - munch on first arg + (let* ((*format-arguments* (pop-format-arg)) + (*format-top-level* nil) + (*format-original-arguments* *format-arguments*)) + (unless (listp *format-arguments*) + (report-bad-arg *format-arguments* 'list)) + (do-iteration-1 stream start end colon at-least-once-p))))) + + +;;; Justification ~< ... ~> + +;;; Parses a list of clauses delimited by ~; and terminated by ~>. +;;; Recursively invoke SUB-FORMAT to process them, and return a list +;;; of the results, the length of this list, and the total number of +;;; characters in the strings composing the list. + + +(defun format-get-trailing-segments () + (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\>) nil T) + (with-format-parameters parms () + (when colon + (format-error "~~:; allowed only after first segment in ~~<")) + (format-no-flags nil atsign)) + (let ((str (catch 'format-escape + (with-format-string-output stream + (sub-format stream prev tilde))))) + (if (stringp str) + (if (eq cmd #\;) + (multiple-value-bind + (segments numsegs numchars) + (format-get-trailing-segments) + (values (cons str segments) + (1+ numsegs) + (+ numchars + (length str)))) + (values (list str) + 1 + (length str))) + (progn + (unless (eq cmd #\>) (format-find-command '(#\>) nil T)) + (values () 0 0)))))) + + +;;; Gets the first segment, which is treated specially. Call +;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest. + +(defun format-get-segments () + (let (ignore) + (declare (ignore-if-unused ignore)) ; why?? + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\>) nil T) ; skipping + (when atsign + (format-error "Atsign flag not allowed")) + ;(setq *format-arguments* blech) + (let ((first-seg (catch 'format-escape + (with-format-string-output stream + (sub-format stream prev tilde))))) + (if (stringp first-seg) + (if (eq cmd #\;) + (progn + (when parms + (setq *format-index* tilde) + ; now get the parameters if any - do this way cause of the V thingies + ; maybe only necessary in the : case + (multiple-value-setq (ignore ignore parms) + (format-find-command '(#\; #\>) t T))) + (multiple-value-bind + (segments numsegs numchars) + (format-get-trailing-segments) + (if colon + (values first-seg parms segments numsegs numchars) + (values nil nil (cons first-seg segments) + (1+ numsegs) + (+ (length first-seg) numchars))))) + (values nil nil (list first-seg) 1 (length first-seg))) + (progn + (unless (eq cmd #\>) (format-find-command '(#\>) nil T)) + (values nil nil () 0 0))))))) + + +#| +;;; Given the total number of SPACES needed for padding, and the number +;;; of padding segments needed (PADDINGS), returns a list of such segments. +;;; We try to allocate the spaces equally to each segment. When this is +;;; not possible, we allocate the left-over spaces randomly, to improve the +;;; appearance of many successive lines of justified text. +;;; +;;; Query: Is this right? Perhaps consistency might be better for the kind +;;; of applications ~<~> is used for. + +(defun make-pad-segs (spaces paddings) + (do* ((extra-space () (and (plusp extra-spaces) + (< (random (float 1)) (/ segs extra-spaces)))) + (result () (cons (if extra-space (1+ min-space) min-space) result)) + (min-space (truncate spaces paddings)) + (extra-spaces (- spaces (* paddings min-space)) + (if extra-space (1- extra-spaces) extra-spaces)) + (segs paddings (1- segs))) + ((zerop segs) result))) +|# +(defun make-pad-segs (spaces segments) + (multiple-value-bind (min-space extra-spaces) (truncate spaces segments) + (declare (fixnum min-space extra-spaces)) + (let* ((result (make-list segments :initial-element min-space)) + (res result)) + (setq min-space (1+ min-space)) + (dotimes (i extra-spaces) + (rplaca res min-space) + (setq res (%cdr res))) + result))) + +;;; Determine the actual width to be used for a field requiring WIDTH +;;; characters according to the following rule: If WIDTH is less than or +;;; equal to MINCOL, use WIDTH as the actual width. Otherwise, round up +;;; to MINCOL + k * COLINC for the smallest possible positive integer k. + +(defun format-round-columns (width mincol colinc) + (if (< width mincol) + (+ width (* colinc (ceiling (- mincol width) colinc))) + width)) + +(defun format-justification-round-columns (width mincol colinc) + (if (< width mincol) + mincol + (+ mincol (* colinc (ceiling (- width mincol) colinc))))) + +(defformat #\< format-justification (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (multiple-value-bind (start tilde ecmd ecolon eatsign) + (format-find-command-no-params '(#\>)) ; bumps format-index + (declare (ignore tilde ecmd)) + (cond + (ecolon + (format-logical-block stream colon atsign eatsign start *format-index* parms)) + (t (setq *format-index* start) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (unless (integerp mincol) + (format-error "Mincol must be an integer - ~S" mincol)) + (unless (and (integerp colinc) (plusp colinc)) + (format-error "Colinc must be a positive integer - ~S" colinc)) + (unless (integerp minpad) + (format-error "Minpad must be an integer - ~S" minpad)) + (unless (characterp padchar) + (if (typep padchar `(integer 0 #.char-code-limit)) + (setq padchar (code-char padchar)) + (format-error "Padchar must be a character or integer from 0 to ~a - ~S" + char-code-limit padchar))) + (format-nextchar) + (multiple-value-bind (special-arg special-parms segments numsegs numchars) + (format-get-segments) + (when (= numsegs 1) (setq minpad 0)) + (when segments + (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0) + (1- numsegs) + (if atsign 1 0))) + (width (format-justification-round-columns (+ numchars (* minpad padsegs)) + mincol colinc)) + (spaces (if (and atsign (not colon) (= numsegs 1)) ;dirty but works + (list 0 (- width numchars)) + (append (if (or colon (= numsegs 1)) () '(0)) + (make-pad-segs (- width numchars) padsegs) + (if atsign () '(0)))))) + (when special-arg + (if *format-pprint* + (format-error "Justification illegal in this context")) + (setq *format-justification-semi* t) + (with-format-parameters special-parms ((spare 0) + (linel (stream-line-length stream))) + + (let ((pos (column stream))) + (when (> (+ pos width spare) linel) + (stream-write-entire-string stream special-arg))))) + (do ((segs segments (cdr segs)) + (spcs spaces (cdr spcs))) + ((null segs) (dotimes (i (car spcs)) (write-char padchar stream))) + (dotimes (i (car spcs)) (write-char padchar stream)) + (stream-write-entire-string stream (car segs))))))))))) + + +(defun format-logical-block (stream colon atsign end-atsign start end &rest parms) + (declare (ignore parms)) + (flet ((format-check-simple (str) + (when (and str (or (%str-member #\~ str) (%str-member #\newline str))) + (format-error "Suffix and prefix must be simple"))) + (first-block-p (start) + (let* ((*format-index* 0)) + (loop + (parse-format-operation) + (when (eq (format-peek) #\<) + (cond ((eq *format-index* start) + (return t)) + (t (return nil)))))))) + (format-no-semi #\<) + (let ((format-string *format-control-string*) + (prefix (if colon "(" "")) + (suffix (if colon ")" "")) + body-string start1 tilde ignore colon1 atsign1 per-line-p) + (declare (ignore-if-unused ignore colon1)) + (setq *format-index* start) + (multiple-value-setq (start1 tilde ignore colon1 atsign1) + (format-find-command '(#\; #\>))) + (setq body-string (%substr format-string (1+ start) tilde)) + (when (not (eql *format-index* end)) ; > 1 segment + (setq prefix body-string) + (if atsign1 (setq per-line-p t)) + (multiple-value-setq (start1 tilde) + (format-find-command '(#\; #\>))) + (setq body-string (%substr format-string (1+ start1) tilde)) + (when (neq *format-index* end) + (multiple-value-setq (start1 tilde)(format-find-command '(#\; #\>))) + (setq suffix (%substr format-string (1+ start1) tilde)) + (when (neq *format-index* end) + (format-error "Too many chunks")))) + (when end-atsign (setq body-string (format-fill-transform body-string))) + (format-check-simple prefix) + (format-check-simple suffix) + (let ((args (if (not atsign) + ; This piece of garbage is needed to avoid double length counting from (formatter ...) things + ; but also to allow (flet . t) not to barf. + ; Was formerly simply (if *format-arguments* (pop-format-arg)) + ; Actually wanna not count the arg iff the ~< is at the top level + ; in a format string i.e. "is this the first ~< in THIS string?" + (when *format-arguments* + (if (and (listp *format-arguments*) + (first-block-p start)) + (pop *format-arguments*) ; dont count + (pop-format-arg))) ; unless not listp or not first + (prog1 *format-arguments* + (setq *format-arguments* nil)))) + (*format-control-string* body-string) + (*format-top-level* (and atsign *format-top-level*))) + (let ((*logical-block-p* t) + (xp-struct (cond ((xp-structure-p stream) stream) + ((typep stream 'xp-stream) + (slot-value stream 'xp-structure))))) + ; lets avoid unnecessary closures + (cond (xp-struct (logical-block-sub xp-struct args prefix suffix per-line-p atsign)) + (t (maybe-initiate-xp-printing + #'(lambda (s o) + (logical-block-sub s o prefix suffix per-line-p atsign)) + stream args)))))))) + + + +; flet? +(defun logical-block-sub (stream args prefix suffix per-line-p atsign) + ;(push (list args body-string) barf) + (let ((circle-chk (not (or *format-top-level* (and atsign (eq *current-length* -1)))))) ; i.e. ~<~@< + (let ((*current-level* (1+ *current-level*)) ; these are for pprint + (*current-length* -1)) + (declare (special *current-level* *current-length*)) + (unless (check-block-abbreviation stream args circle-chk) ;(neq args *format-original-arguments*)) ;?? + (start-block stream prefix per-line-p suffix) + (let ((*logical-block-xp* stream) ; for pop-format-arg + (my-stream (if (xp-structure-p stream) (get-xp-stream stream) stream))) + (catch 'logical-block + (do-sub-format-1 my-stream args))) + (end-block stream suffix))))) + +; bash in fill conditional newline after white space (except blanks after ~) +; I think this is silly! +(defun format-fill-transform (string) + (let ((pos 0)(end (length (the string string)))(result "") ch) + (while (%i< pos end) + (let ((wsp-pos (min (or (%str-member #\space string pos) end) + (or (%str-member #\tab string pos) end))) + (yes nil)) + (when (%i< wsp-pos end) + (when (not (and (%i> wsp-pos 1) + (eq (schar string (%i- wsp-pos 1)) #\newline) + (or (eq (setq ch (schar string (%i- wsp-pos 2))) #\~) + (and (%i> wsp-pos 2) + (memq ch '(#\: #\@)) + (eq (schar string (%i- wsp-pos 3)) #\~))))) + (setq yes t)) + (loop + (while (%i< wsp-pos end) + (setq ch (schar string wsp-pos)) + (when (Not (%str-member ch wsp)) (return)) + (setq wsp-pos (%i+ 1 wsp-pos))) + (return))) + (setq result (%str-cat result (%substr string pos wsp-pos) (if yes "~:_" ""))) + (setq pos wsp-pos))) + result)) + + +;;;;some functions needed for dealing with floats + +;;;; Floating Point printing +;;; +;;; Written by Bill Maddox +;;; +;;; +;;; +;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of +;;; the work for all printing of floating point numbers in the printer and in +;;; FORMAT. It converts a floating point number to a string in a free or +;;; fixed format with no exponent. The interpretation of the arguments is as +;;; follows: +;;; +;;; X - The floating point number to convert, which must not be +;;; negative. +;;; WIDTH - The preferred field width, used to determine the number +;;; of fraction digits to produce if the FDIGITS parameter +;;; is unspecified or NIL. If the non-fraction digits and the +;;; decimal point alone exceed this width, no fraction digits +;;; will be produced unless a non-NIL value of FDIGITS has been +;;; specified. Field overflow is not considerd an error at this +;;; level. +;;; FDIGITS - The number of fractional digits to produce. Insignificant +;;; trailing zeroes may be introduced as needed. May be +;;; unspecified or NIL, in which case as many digits as possible +;;; are generated, subject to the constraint that there are no +;;; trailing zeroes. +;;; SCALE - If this parameter is specified or non-NIL, then the number +;;; printed is (* x (expt 10 scale)). This scaling is exact, +;;; and cannot lose precision. +;;; FMIN - This parameter, if specified or non-NIL, is the minimum +;;; number of fraction digits which will be produced, regardless +;;; of the value of WIDTH or FDIGITS. This feature is used by +;;; the ~E format directive to prevent complete loss of +;;; significance in the printed value due to a bogus choice of +;;; scale factor. +;;; +;;; Most of the optional arguments are for the benefit for FORMAT and are not +;;; used by the printer. +;;; +;;; Returns: +;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) +;;; where the results have the following interpretation: +;;; +;;; DIGIT-STRING - The decimal representation of X, with decimal point. +;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. +;;; LEADING-POINT - True if the first character of DIGIT-STRING is the +;;; decimal point. +;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the +;;; decimal point. +;;; POINT-POS - The position of the digit preceding the decimal +;;; point. Zero indicates point before first digit. +;;; NZEROS - number of zeros after point +;;; +;;; WARNING: For efficiency, there is a single string object *digit-string* +;;; which is modified destructively and returned as the value of +;;; FLONUM-TO-STRING. Thus the returned value is not valid across multiple +;;; calls. +;;; +;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. +;;; Specifically, the decimal number printed is the closest possible +;;; approximation to the true value of the binary number to be printed from +;;; among all decimal representations with the same number of digits. In +;;; free-format output, i.e. with the number of digits unconstrained, it is +;;; guaranteed that all the information is preserved, so that a properly- +;;; rounding reader can reconstruct the original binary number, bit-for-bit, +;;; from its printed decimal representation. Furthermore, only as many digits +;;; as necessary to satisfy this condition will be printed. +;;; +;;; +;;; FLOAT-STRING actually generates the digits for positive numbers. The +;;; algorithm is essentially that of algorithm Dragon4 in "How to Print +;;; Floating-Point Numbers Accurately" by Steele and White. The current +;;; (draft) version of this paper may be found in [CMUC]tradix.press. +;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING +;;; THE PAPER! + + + + +(defun flonum-to-string (n &optional width fdigits scale) + (let ((*print-radix* nil)) + (cond ((zerop n)(values "" 0 0)) + ((and (not (or width fdigits scale)) + (double-float-p n) + ; cheat for the only (?) number that fails to be aesthetically pleasing + (= n 1e23)) + (values "1" 24 23)) + (t (let ((string (make-array 12 :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (multiple-value-bind (sig exp)(integer-decode-float n) + (float-string string sig exp (integer-length sig) width fdigits scale))))))) + +;;; if width given and fdigits nil then if exponent is >= 0 returns at +;;; most width-1 digits if exponent is < 0 returns (- width (- exp) 1) +;;; digits if fdigits given width is ignored, returns fdigits after +;;; (implied) point The Steele/White algorithm can produce a leading +;;; zero for 1e23 which lies exactly between two double floats - +;;; rounding picks the float whose rational is +;;; 99999999999999991611392. This guy wants to print as +;;; 9.999999999999999E+22. The untweaked algorithm generates a leading +;;; zero in this case. (actually wants to print as 1e23!) If we +;;; choose s such that r < s - m/2, and r = s/10 - m/2 (which it does +;;; in this case) then r * 10 < s => first digit is zero and +;;; (remainder (* r 10) s) is r * 10 = new-r, 10 * m = new-m new-r = s +;;; - new-m/2 so high will be false and she won't round up we do r * +;;; (expt 2 (- e (- scale))) and s * (expt 5 (- scale)) i.e. both less +;;; by (expt 2 (- scale)) + +(defun float-string (string f e p &optional width fdigits scale) + (macrolet ((nth-digit (n) `(%code-char (%i+ ,n (%char-code #\0))))) + (let ((r f)(s 1)(m- 1)(m+ 1)(k 0) cutoff roundup (mm nil)) + (when (= f (if (eql p 53) #.(ash 1 52) (ash 1 (1- p)))) + (setq mm t)) + (when (or (null scale)(zerop scale)) + ; approximate k + (let ((fudge 0)) + (setq fudge (truncate (* (%i+ e p) .301))) + (when (neq fudge 0) + (setq k fudge) + (setq scale (- k))))) + (when (and scale (not (eql scale 0))) + (if (minusp scale) + (setq s (* s (5-to-e (- scale)))) + (let ((scale-factor (5-to-e scale))) + (setq r (* r scale-factor)) + (setq m+ scale-factor) + (when mm (setq m- scale-factor))))) + (let ((shift (- e (if scale (- scale) 0)))) + (declare (fixnum shift)) + ;(print (list e scale shift)) + (cond ((> shift 0) + (setq r (ash f shift)) + (setq m+ (ash m+ shift)) + (when mm (setq m- (ash m- shift)))) + ((< shift 0) + (setq s (ash s (- shift)))))) + (when mm + (setq m+ (+ m+ m+)) + (setq r (+ r r)) + (setq s (+ s s))) + (let ((ceil (ceiling s 10))(fudge 1)) + (while (< r ceil) + (setq k (1- k)) + (setq r (* r 10)) + (setq fudge (* fudge 10))) + (when (> fudge 1) + (setq m+ (* m+ fudge)) + (when mm (setq m- (* m- fudge))))) + (let ((2r (+ r r))) + (loop + (let ((2rm+ (+ 2r m+))) + (while + (if (not roundup) ; guarantee no leading zero + (> 2rm+ (+ s s)) + (>= 2rm+ (+ s s))) + (setq s (* s 10)) + (setq k (1+ k)))) + (when (not (or fdigits width))(return)) + (cond + (fdigits (setq cutoff (- fdigits))) + (width + (setq cutoff + (if (< k 0) (- 1 width)(1+ (- k width)))) + ;(if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))) + )) + (let ((a (if cutoff (- cutoff k) 0)) + (y s)) + (DECLARE (FIXNUM A)) + (if (>= a 0) + (when (> a 0)(setq y (* y (10-to-e a)))) + (setq y (ceiling y (10-to-e (the fixnum (- a)))))) + (when mm (setq m- (max y m-))) + (setq m+ (max y m+)) + (when (= m+ y) (setq roundup t))) + (when (if (not roundup) ; tweak as above + (<= (+ 2r m+)(+ s s)) + (< (+ 2r m+)(+ s s))) + (return)))) + (let* ((h k) + (half-m+ (* m+ 5)) ; 10 * m+/2 + (half-m- (if mm (* m- 5))) + u high low + ) + ;(print (list r s m+ roundup)) + (unless (and fdigits (>= (- k) fdigits)) + (loop + (setq k (1- k)) + (multiple-value-setq (u r) (truncate (* r 10) s)) + (setq low (< r (if mm half-m- half-m+))) + (setq high + (if (not roundup) + (> r (- s half-m+)) + (>= r (- s half-m+)))) + (if (or low high) + (return) + (progn + (vector-push-extend (nth-digit u) string))) + (when mm (setq half-m- (* half-m- 10) )) + (setq half-m+ (* half-m+ 10))) + ;(print (list r s high low h k)) + (vector-push-extend + (nth-digit (cond + ((and low (not high)) u) + ((and high (not low))(+ u 1)) + + (t ;(and high low) + (if (<= (+ r r) s) u (1+ u))))) + string)) + ; second value is exponent, third is exponent - # digits generated + (values string h k))))) + + +(defparameter integer-powers-of-10 (make-array (+ 12 (floor 324 12)))) + +; e better be positive +(defun 10-to-e (e) + (declare (fixnum e)(optimize (speed 3)(safety 0))) + (if (> e 335) + (* (10-to-e 334) (10-to-e (%i- e 334))) + (if (< e 12) + (svref integer-powers-of-10 e) + (multiple-value-bind (q r) (truncate e 12) + (declare (fixnum q r)) + (if (eql r 0) + (svref integer-powers-of-10 (%i+ q 11)) + (* (svref integer-powers-of-10 r) + (svref integer-powers-of-10 (%i+ q 11)))))))) + + +(let ((array integer-powers-of-10)) + (dotimes (i 12) + (setf (svref array i) (expt 10 i))) + (dotimes (i (floor 324 12)) + (setf (svref array (+ i 12)) (expt 10 (* 12 (1+ i)))))) +#| +(defun 10-to-e (e) + (ash (5-to-e e) e)) +|# + + + + +;;; Given a non-negative floating point number, SCALE-EXPONENT returns a +;;; new floating point number Z in the range (0.1, 1.0] and and exponent +;;; E such that Z * 10^E is (approximately) equal to the original number. +;;; There may be some loss of precision due the floating point representation. +;;; JUST do the EXPONENT since thats all we use + + +(defconstant long-log10-of-2 0.30103d0) + +#| +(defun scale-exponent (x) + (if (floatp x ) + (scale-expt-aux (abs x) 0.0d0 1.0d0 1.0d1 1.0d-1 long-log10-of-2) + (report-bad-arg x 'float))) + +#|this is the slisp code that was in the place of the error call above. + before floatp was put in place of shortfloatp. + ;(scale-expt-aux x (%sp-l-float 0) (%sp-l-float 1) %long-float-ten + ; %long-float-one-tenth long-log10-of-2))) +|# + +; this dies with floating point overflow (?) if fed least-positive-double-float + +(defun scale-expt-aux (x zero one ten one-tenth log10-of-2) + (let ((exponent (nth-value 1 (decode-float x)))) + (if (= x zero) + (values zero 1) + (let* ((e (round (* exponent log10-of-2))) + (x (if (minusp e) ;For the end ranges. + (* x ten (expt ten (- -1 e))) + (/ x ten (expt ten (1- e)))))) + (do ((d ten (* d ten)) + (y x (/ x d)) + (e e (1+ e))) + ((< y one) + (do ((m ten (* m ten)) + (z y (* z m)) + (e e (1- e))) + ((>= z one-tenth) (values x e))))))))) +|# + +(defun scale-exponent (n) + (let ((exp (nth-value 1 (decode-float n)))) + (values (round (* exp long-log10-of-2))))) + + +;;; Page ~| + +(defformat #\| format-page (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-no-flags colon atsign) + (with-format-parameters parms ((repeat-count 1)) + (declare (fixnum repeat-count)) + (dotimes (i repeat-count) (write-char #\page stream)))) + + +(defun format-eat-whitespace () + (do* ((i *format-index* (1+ i)) + (s *format-control-string*) + (n *format-length*)) + ((or (= i n) + (not (whitespacep (schar s i)))) + (setq *format-index* (1- i))))) + +(defun format-newline (stream colon atsign parms) + (with-format-parameters parms () + (cond (colon + (when atsign + (format-error "~:@ is undefined"))) + (atsign (terpri stream) (format-eat-whitespace)) + (t (format-eat-whitespace))))) + +(defformat #\newline format-newline (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-newline stream colon atsign parms)) + +(defformat #\return format-newline (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-newline stream colon atsign parms)) + +;;; Indirection ~? + +(defformat #\? format-indirection (stream colon atsign) + (format-no-flags colon nil) + (let ((string (pop-format-arg))) + (unless (or (stringp string)(functionp string)) + (format-error "Indirected control string is not a string or function")) + (when (and (stringp string) (not (simple-string-p string))) + (setq string (coerce string 'simple-string))) + (catch 'format-escape + (let ((error + (catch 'format-error + (cond + ((stringp string) + (let* ((length (length (the simple-string string))) + (*format-control-string* string) + (*format-length* length) + (*format-index* 0)) + (if atsign + (sub-format stream 0 length) + (let ((args (pop-format-arg))) + (let ((*format-top-level* nil) + (*format-arguments* args) + (*format-original-arguments* args)) + (sub-format stream 0 length)))))) + (T ;(functionp string) + (if (not atsign) + (apply string stream (pop-format-arg)) + ; account for the args it eats + (setq *format-arguments* (apply string stream *format-arguments*))))) + nil))) + (when error (format-indirect-error error)))))) + + + + +;;; Ascii ~A + +(defformat #\A format-princ (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (let ((arg (pop-format-arg))) + (if (null parms) + (princ (or arg (if colon "()" nil)) stream) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-write-field + stream + (if (or arg (not colon)) + (princ-to-string arg) + "()") + mincol colinc minpad padchar atsign))))) + + + +;;; S-expression ~S + +(defformat #\S format-prin1 (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (let ((arg (pop-format-arg))) + (if (null parms) + (if (or arg (not colon)) (prin1 arg stream) (princ "()" stream)) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-write-field + stream + (if (or arg (not colon)) + (prin1-to-string arg) + "()") + mincol colinc minpad padchar atsign))))) + + + +;;; Character ~C + +(defformat #\C format-print-character (stream colon atsign) + (let* ((char (character (pop-format-arg))) + (code (char-code char)) + (name (char-name char))) + (cond ((and atsign (not colon)) + (prin1 char stream)) + (colon + (if (or (eql char #\space) + (not (graphic-char-p char))) + (princ name stream) + (write-char char stream))) + ((not (or atsign colon)) + (write-char char stream)) + ((and (< code 32) atsign) + (setq char (code-char (logxor code 64))) + (if (or colon (%str-member char "@CGHIJKLM[\\]^_")) + (princ name stream) + (progn + (write-char #\^ stream) + (write-char char stream))) + (princ " (" stream) + (princ "Control " stream) + (write-char char stream) + (write-char #\) stream)) + (name (princ name stream)) + (t (write-char char stream))))) + + +;;; NUMERIC PRINTING + + + +;;; Output a string in a field at MINCOL wide, padding with PADCHAR. +;;; Pads on the left if PADLEFT is true, else on the right. If the +;;; length of the string plus the minimum permissible padding, MINPAD, +;;; is greater than MINCOL, the actual field size is rounded up to +;;; MINCOL + k * COLINC for the smallest possible positive integer k. + +(defun format-write-field (stream string mincol colinc minpad padchar padleft) + (unless (or (null mincol) + (integerp mincol)) + (format-error "Mincol must be an integer - ~S" mincol)) + (unless (and (integerp colinc) (plusp colinc)) + (format-error "Colinc must be a positive integer - ~S" colinc)) + (unless (integerp minpad) + (format-error "Minpad must be an integer - ~S" minpad)) + (unless (characterp padchar) + (if (typep padchar `(integer 0 #.char-code-limit)) + (setq padchar (code-char padchar)) + (format-error "Padchar must be a character or integer from 0 to ~a - ~S" + char-code-limit padchar))) + (let* ((strlen (length (the string string))) + (strwid (+ strlen minpad)) + (width (if mincol + (format-round-columns strwid mincol colinc) + strwid))) + (if padleft + (dotimes (i (the fixnum (- width strlen))) (write-char padchar stream))) + (write-string string stream :start 0 :end strlen) + (unless padleft + (dotimes (i (the fixnum (- width strlen))) (write-char padchar stream))))) + + +;;; This functions does most of the work for the numeric printing +;;; directives. The parameters are interpreted as defined for ~D. + +(defun format-print-number (stream number radix print-commas-p print-sign-p parms) + (declare (dynamic-extent parms)) + (declare (type t number) (type fixnum radix)) + #+wrong + (when (> (length parms) 2) (setq print-commas-p t)) ; print commas if char or interval provided + (if (not (integerp number)) + (let ((*print-base* radix) + (*print-escape* nil) + (*print-radix* nil)) + (declare (special *print-base* *print-radix*)) + (princ number stream)) + (with-format-parameters parms + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + ; look out for ",0D" - should be ",'0D" + (unless (characterp padchar) + (error "Use '~A instead of ~A for padchar in format directive" padchar padchar)) + (setq print-sign-p + (cond ((and print-sign-p (>= number 0)) #\+) + ((< number 0) #\-))) + (setq number (abs number)) + (block HAIRY + (block SIMPLE + (if (and (not print-commas-p) (eql 0 mincol)) + (return-from SIMPLE)) + (let ((lg 0) + (commas 0)) + (declare (type fixnum lg commas)) + (do ((n (abs number) (floor n radix))) + ((%i< n radix)) + (declare (type integer n)) + (setq lg (%i+ lg 1))) ; lg is 1- significant digits + (setq commas (if print-commas-p + (floor lg commainterval) + 0)) + (when print-sign-p + (setq lg (1+ lg))) + (when (and (eq commas 0) + (%i<= mincol lg)) + (return-from SIMPLE)) + ;; Cons-o-rama no more ! + (let* ((s (make-string-output-stream))) + (when (neq padchar #\space) + (dotimes (i (- mincol (+ lg commas) 1)) + (write-char padchar s))) + (when print-sign-p (write-char print-sign-p s)) + (%pr-integer number radix s) + (dotimes (i (the fixnum commas)) (write-char commachar s)) + (let ((text (get-output-stream-string s))) + (declare (type string text)) + ;; -1234567,, => -1,234,567 + (when (%i> commas 0) + (do* ((dest (%i- (length text) 1)) + (source (%i- dest commas))) + ((= source dest)) + (declare (type fixnum dest source)) + (dotimes (i (the fixnum commainterval)) + (setf (char text dest) (char text source) + dest (1- dest) + source (1- source))) + (setf (char text dest) commachar + dest (1- dest)))) + (format-write-field stream text mincol 1 0 padchar t) + (return-from HAIRY))))) + ;; SIMPLE case + (when print-sign-p (write-char print-sign-p stream)) + (%pr-integer number radix stream)))) + nil) + +;;; Print a cardinal number in English + +(eval-when (:compile-toplevel :execute) +(defmacro cardinal-ones () + "Table of cardinal ones-place digits in English" + '#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) +(defmacro cardinal-tens () + "Table of cardinal tens-place digits in English" + '#(nil nil "twenty" "thirty" "forty" + "fifty" "sixty" "seventy" "eighty" "ninety")) +(defmacro cardinal-teens () + '#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD + "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) +) + + +(defun format-print-small-cardinal (stream n) + (multiple-value-bind (hundreds rem) (truncate n 100) + (when (plusp hundreds) + (write-string (svref (cardinal-ones) hundreds) stream) + (write-string " hundred" stream) + (when (plusp rem) (write-char #\space stream))) ; ; ; RAD + (when (plusp rem) + (multiple-value-bind (tens ones) (truncate rem 10) + (cond ((< 1 tens) + (write-string (svref (cardinal-tens) tens) stream) + (when (plusp ones) + (write-char #\- stream) + (write-string (svref (cardinal-ones) ones) stream))) + ((= tens 1) + (write-string (svref (cardinal-teens) ones) stream)) + ((plusp ones) + (write-string (svref (cardinal-ones) ones) stream))))))) + +(eval-when (:compile-toplevel :execute) + (defmacro cardinal-periods () + "Table of cardinal 'teens' digits in English" + '#("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion")) +) + + +(defun format-print-cardinal (stream n) + (cond ((minusp n) + (stream-write-entire-string stream "negative ") + (format-print-cardinal-aux stream (- n) 0 n)) + ((zerop n) + (stream-write-entire-string stream "zero")) + (t (format-print-cardinal-aux stream n 0 n)))) + +(defun format-print-cardinal-aux (stream n period err) + (multiple-value-bind (beyond here) (truncate n 1000) + (unless (<= period 10) + (format-error "Number too large to print in English: ~:D" err)) + (unless (zerop beyond) + (format-print-cardinal-aux stream beyond (1+ period) err)) + (unless (zerop here) + (unless (zerop beyond) (write-char #\space stream)) + (format-print-small-cardinal stream here) + (stream-write-entire-string stream (svref (cardinal-periods) period))))) + + +;;; Print an ordinal number in English + + +(eval-when (:compile-toplevel :execute) +(defmacro ordinal-ones () + "Table of ordinal ones-place digits in English" + '#(nil "first" "second" "third" "fourth" + "fifth" "sixth" "seventh" "eighth" "ninth")) +(defmacro ordinal-tens () + "Table of ordinal tens-place digits in English" + '#(nil "tenth" "twentieth" "thirtieth" "fortieth" + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) +) + +(defun format-print-ordinal (stream n) + (when (minusp n) + (stream-write-entire-string stream "negative ")) + (let ((number (abs n))) + (multiple-value-bind (top bot) (truncate number 100) + (unless (zerop top) (format-print-cardinal stream (- number bot))) + (when (and (plusp top) (plusp bot)) (write-char #\space stream)) + (multiple-value-bind (tens ones) (truncate bot 10) + (cond ((= bot 12) (stream-write-entire-string stream "twelfth")) + ((= tens 1) + (stream-write-entire-string stream (svref (cardinal-teens) ones));;;RAD + (stream-write-entire-string stream "th")) + ((and (zerop tens) (plusp ones)) + (stream-write-entire-string stream (svref (ordinal-ones) ones))) + ((and (zerop ones)(plusp tens)) + (stream-write-entire-string stream (svref (ordinal-tens) tens))) + ((plusp bot) + (stream-write-entire-string stream (svref (cardinal-tens) tens)) + (write-char #\- stream) + (stream-write-entire-string stream (svref (ordinal-ones) ones))) + ((plusp number) (write-string "th" stream :start 0 :end 2)) + (t (stream-write-entire-string stream "zeroth"))))))) + + +;;; Print Roman numerals + +(defun format-print-old-roman (stream n) + (unless (< 0 n 5000) + (format-error "Number out of range for old Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val)))) + ((< i cur-val) i)))) + ((zerop start)))) + + +(defun format-print-roman (stream n) + (unless (< 0 n 4000) + (format-error "Number out of range for Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) + (sub-val '(100 10 10 1 1 0) (cdr sub-val)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (cur-sub-char #\C (car sub-chars)) + (cur-sub-val 100 (car sub-val)) + (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val)))) + ((< i cur-val) + (cond ((<= (- cur-val cur-sub-val) i) + (write-char cur-sub-char stream) + (write-char cur-char stream) + (- i (- cur-val cur-sub-val))) + (t i)))))) + ((zerop start)))) + + +;;; Decimal ~D + +(defformat #\D format-print-decimal (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 10 colon atsign parms)) + + +;;; Binary ~B + +(defformat #\B format-print-binary (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 2 colon atsign parms)) + + +;;; Octal ~O + +(defformat #\O format-print-octal (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 8 colon atsign parms)) + + +;;; Hexadecimal ~X + +(defformat #\X format-print-hexadecimal (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 16 colon atsign parms)) + + +;;; Radix ~R + +(defformat #\R format-print-radix (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (let ((number (pop-format-arg)) + (parm (if parms (pop parms) nil))) + (if parm + (format-print-number stream number parm colon atsign parms) + (if atsign + (if colon + (format-print-old-roman stream number) + (format-print-roman stream number)) + (if colon + (format-print-ordinal stream number) + (format-print-cardinal stream number)))))) + +;;; FLOATING-POINT NUMBERS + + +;;; Fixed-format floating point ~F + +(defformat #\F format-fixed (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + ;;Note that the scale factor k defaults to nil. This is interpreted as + ;;zero by flonum-to-string, but more efficiently. + (let ((number (pop-format-arg))(*print-escape* nil)) + (if (floatp number) + (format-fixed-aux stream number w d k ovf pad atsign) + (if (rationalp number) + (format-fixed-aux stream (coerce number 'float) w d k ovf pad atsign) + (let ((*print-base* 10)) + (format-write-field stream (princ-to-string number) w 1 0 #\space t))))))) + +; do something ad hoc if d > w - happens if (format nil "~15g" (- 2.3 .1)) +; called with w = 11 d = 16 - dont do it after all. + +(defun format-fixed-aux (stream number w d k ovf pad atsign) + (and w (<= w 0) (setq w nil)) ; if width is unreasonable, ignore it. + (if (not (or w d)) ; perhaps put this back when prin1 is better + (prin1 number stream) + (let ((spaceleft w) + (abs-number (abs number)) + strlen zsuppress flonum-to-string-width) + (when (and w (or atsign (minusp number))) + (decf spaceleft)) + (when (and d w (<= w (+ 1 d (if atsign 1 0)))) + (setq zsuppress t)) + (when (and d (minusp d)) + (format-error "Illegal value for d")) + (setq flonum-to-string-width + (and w + (if (and (< abs-number 1) (not zsuppress)) + (1- spaceleft) ; room for leading 0 + spaceleft))) + (when (and w (not (plusp flonum-to-string-width))) + (if ovf + (progn + (dotimes (i w) (write-char ovf stream)) + (return-from format-fixed-aux)) + (setq spaceleft nil w nil))) + (multiple-value-bind (str before-pt after-pt) + (flonum-to-string abs-number + flonum-to-string-width + d k) + (setq strlen (length str)) + (cond (w (decf spaceleft (+ (max before-pt 0) 1)) + (when (and (< before-pt 1) (not zsuppress)) + (decf spaceleft)) + (if d + (decf spaceleft d) + (setq d (max (min spaceleft (- after-pt)) + (if (> spaceleft 0) 1 0)) + spaceleft (- spaceleft d)))) + ((null d) (setq d (max (- after-pt) 1)))) + (cond ((and w (< spaceleft 0) ovf) + ;;field width overflow + (dotimes (i w) (declare (fixnum i)) (write-char ovf stream))) + (t (when w (dotimes (i spaceleft) (declare (fixnum i)) (write-char pad stream))) + (if (minusp (float-sign number)) ; 5/25 + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (cond + ((> before-pt 0) + (cond ((> strlen before-pt) + (write-string str stream :start 0 :end before-pt) + (write-char #\. stream) + (write-string str stream :start before-pt :end strlen) + (dotimes (i (- d (- strlen before-pt))) + (write-char #\0 stream))) + (t ; 0's after + (stream-write-entire-string stream str) + (dotimes (i (- before-pt strlen)) + (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i d) + (write-char #\0 stream))))) + (t (unless zsuppress (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i (- before-pt)) + (write-char #\0 stream)) + (stream-write-entire-string stream str) + (dotimes (i (+ d after-pt)) + (write-char #\0 stream)))))))))) +#| +; (format t "~7,3,-2f" 8.88) +; (format t "~10,5,2f" 8.88) +; (format t "~10,5,-2f" 8.88) +; (format t "~10,5,2f" 0.0) +; (format t "~10,5,2f" 9.999999999) +; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ?? +; (format t "~10,,2f" 8.88) +; (format t "~10,,-2f" 8.88) +; (format t "~10,,2f" 0.0) +; (format t "~10,,2f" 0.123454) +; (format t "~10,,2f" 9.9999999) + (defun foo (x) + (format nil "~6,2f|~6,2,1,'*f|~6,2,,'?f|~6f|~,2f|~F" + x x x x x x)) + +|# + + + +;;; Exponential-format floating point ~E + + +(defformat #\E format-exponential (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil)) + (let ((number (pop-format-arg))) + (if (floatp number) + (format-exp-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-exp-aux stream (coerce number 'float) w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field stream (princ-to-string number) w 1 0 #\space t))))))) +#| +(defun format-exponent-marker (number) + (if (typep number *read-default-float-format*) + #\E + (cond ((double-floatp) #\D) + ((short-floatp number) #\S) + ((single-floatp number) #\F) + ((long-floatp) #\L)))) +|# +(eval-when (eval compile #-bccl load) + (defmacro format-exponent-marker (number) + `(float-exponent-char ,number)) +) + +;;;Here we prevent the scale factor from shifting all significance out of +;;;a number to the right. We allow insignificant zeroes to be shifted in +;;;to the left right, athough it is an error to specify k and d such that this +;;;occurs. Perhaps we should detect both these condtions and flag them as +;;;errors. As for now, we let the user get away with it, and merely guarantee +;;;that at least one significant digit will appear. +;;; THE ABOVE COMMENT no longer applies + +(defun format-exp-aux (stream number w d e k ovf pad marker atsign &optional string exp) + (when (not k) (setq k 1)) + (if (not (or w d e marker (neq k 1))) + (print-a-float number stream t) + (prog () + (when d + (when (or (minusp d) + (and (plusp k)(>= k (+ d 2))) + (and (minusp k)(< k (- d)))) + (format-error "incompatible values for k and d"))) + (when (not exp) (setq exp (scale-exponent number))) + AGAIN + (let* ((expt (- exp k)) + (estr (let ((*print-base* 10)) + (princ-to-string (abs expt)))) + (elen (max (length estr) (or e 0))) + (spaceleft (if w (- w 2 elen) nil)) + (fwidth) scale) + (when (and w (or atsign (minusp (float-sign number)))) ; 5/25 + (setq spaceleft (1- spaceleft))) + (if w + (progn + (setq fwidth (if d + (if (> k 0)(+ d 2)(+ d k 1)) + (if (> k 0) spaceleft (+ spaceleft k)))) + (when (minusp exp) ; i don't claim to understand this + (setq fwidth (- fwidth exp)) + (when (< k 0) (setq fwidth (1- fwidth))))) + (when (and d (not (zerop number))) ; d and no w + (setq scale (- 2 k exp)))) ; 2 used to be 1 - 5/31 + (when (or (and w e ovf (> elen e))(and w fwidth (not (plusp fwidth)))) + ;;exponent overflow + (dotimes (i w) (declare (fixnum i)) (write-char ovf stream)) + (if (plusp fwidth) + (return-from format-exp-aux nil) + (setq fwidth nil))) + (when (not string) + (multiple-value-bind (new-string before-pt) (flonum-to-string number fwidth + (if (not fwidth) d) + (if (not fwidth) scale)) + (setq string new-string) + (when scale (setq before-pt (- (+ 1 before-pt) k scale))) ; sign right? + (when (neq exp before-pt) + ;(print (list 'agn exp before-pt)) + ;(setq string new-string) + (setq exp before-pt) + (go again)))) + (let ((strlen (length string))) + (when w + (if d + (setq spaceleft (- spaceleft (+ d 2))) + (if (< k 1) + (setq spaceleft (- spaceleft (+ 2 (- k)(max strlen 1)))) + (setq spaceleft (- spaceleft (+ 1 k (max 1 (- strlen k)))))))) + (when (and w (< spaceleft 0)) + (if (and ovf (or (plusp k)(< spaceleft -1))) + (progn (dotimes (i w) (declare (fixnum i)) (write-char ovf stream)) + (return-from format-exp-aux nil)))) + (when w + (dotimes (i spaceleft) + (declare (fixnum i)) + (write-char pad stream))) + (if (minusp (float-sign number)) ; 5/25 + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (cond + ((< k 1) + (when (not (minusp spaceleft))(write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i (- k)) + (write-char #\0 stream)) + (if (and (eq strlen 0)(not d)) + (write-char #\0 stream) + (stream-write-entire-string stream string)) + (if d + (dotimes (i (- (+ d k) strlen)) + (write-char #\0 stream)))) + (t + (write-string string stream :start 0 :end (min k strlen)) + (dotimes (i (- k strlen)) + (write-char #\0 stream)) + (write-char #\. stream) + (when (> strlen k) + (write-string string stream :start k :end strlen)) + (if (not d) + (when (<= strlen k)(write-char #\0 stream)) + (dotimes (i (1+ (- d k (max 0 (- strlen k))))) + (write-char #\0 stream))))) + (write-char (if marker + marker + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (declare (fixnum i)) + (write-char #\0 stream))) + (stream-write-entire-string stream estr)))))) +#| +; (format t "~7,3,,-2e" 8.88) s.b. .009e+3 +; (format t "~10,5,,2e" 8.888888888) ; "88.8889E-1" +; (format t "~10,5,,-2e" 8.88) "0.00888E+3" +; (format t "~10,5,,-2e" .00123445) ; "0.00123E+0" +; (format t "~10,5,,-3e" .00123445) ; "0.00012E+1" +; (format t "~10,,,-2e" .123445) +; (format t "~10,5,,2e" .0012349999e-4) +; (format t "~10,5,,2e" 9.9999999) +; (format t "~10,5,,2e" 0.0) +; (format t "~10,5,,0e" 40000000.0) +; (format t "~10,5,,2e" 9.9999999) +; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ?? +; (format t "~10,,,2e" 8.888888) +; (format t "~10,,,-2e" 8.88) +; (format t "~10,,,-2e" 0.0) +; (format t "~10,,,2e" 0.0) +; (format t "~10,,,2e" 9.9999999) +; (format t "~10,,,2e" 9.9999999e100) +; (format t "~10,5,3,2,'xe" 10e100) +; (format t "~9,3,2,-2e" 1100.0) +(defun foo (x) + (format nil + "~9,2,1,,'*e|~10,3,2,2,'?,,'$e|~9,3,2,-2,'%@e|~9,2e" + x x x x)) +|# + + +;;; General Floating Point - ~G + +(defformat #\G format-general-float (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (marker nil)) + (let ((number (pop-format-arg))) + ;;The Excelsior edition does not say what to do if + ;;the argument is not a float. Here, we adopt the + ;;conventions used by ~F and ~E. + (if (floatp number) + (format-general-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-general-aux stream (coerce number 'float) w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field stream (princ-to-string number) w 1 0 #\space t))))))) + +#| +; completely broken +(defun foo (x) + (format nil + "~9,2,1,,'*g|~10,3,2,2,'?,,'$g|~9,3,2,-2,'%@g|~9,2g" + x x x x)) +|# + + +(defun format-general-aux (stream number w d e k ovf pad marker atsign) + (multiple-value-bind (str n #|after-pt|#)(flonum-to-string number) + ;;Default d if omitted. The procedure is taken directly + ;;from the definition given in the manual, and is not + ;;very efficient, since we generate the digits twice. + ;;Future maintainers are encouraged to improve on this. + (let* ((d2 (or d (max (length str) (min n 7)))) + (ee (if e (+ e 2) 4)) + (ww (if w (- w ee) nil)) + (dd (- d2 n))) + (cond ((<= 0 dd d2) + ; this causes us to print 1.0 as 1. - seems weird + (format-fixed-aux stream number ww dd nil ovf pad atsign) + (dotimes (i ee) (declare (fixnum i)) (write-char #\space stream))) + (t (format-exp-aux stream number w d e (or k 1) ovf pad marker atsign nil n)))))) + + +;;; Dollars floating-point format ~$ + +(defformat #\$ format-dollars (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space)) + (let* ((number (float (pop-format-arg))) + (signstr (if (minusp (float-sign number)) "-" (if atsign "+" ""))) + (spaceleft) + strlen) + (multiple-value-bind (str before-pt after-pt) (flonum-to-string number nil d) + (setq strlen (length str)) + (setq spaceleft (- w (+ (length signstr) (max before-pt n) 1 d))) + (when colon (stream-write-entire-string stream signstr)) + (dotimes (i spaceleft) (write-char pad stream)) + (unless colon (stream-write-entire-string stream signstr)) + (cond + ((> before-pt 0) + (cond ((> strlen before-pt) + (dotimes (i (- n before-pt)) + (write-char #\0 stream)) + (write-string str stream :start 0 :end before-pt) + (write-char #\. stream) + (write-string str stream :start before-pt :end strlen) + (dotimes (i (- d (- strlen before-pt))) + (write-char #\0 stream))) + (t ; 0's after + (stream-write-entire-string stream str) + (dotimes (i (- before-pt strlen)) + (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i d) + (write-char #\0 stream))))) + (t (dotimes (i n) + (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i (- before-pt)) + (write-char #\0 stream)) + (stream-write-entire-string stream str) + (dotimes (i (+ d after-pt)) + (write-char #\0 stream)))))))) + +(defun y-or-n-p (&optional format-string &rest arguments &aux response) + "Y-OR-N-P prints the message, if any, and reads characters from + *QUERY-IO* until the user enters y or Y as an affirmative, or either + n or N as a negative answer. It asks again if you enter any other + characters." + (declare (dynamic-extent arguments)) + (with-terminal-input + (clear-input *query-io*) + (loop + (when format-string + (fresh-line *query-io*) + (apply 'format *query-io* format-string arguments)) + (princ " (y or n) " *query-io*) + (setq response (read-char *query-io*)) + ;; Consume input up to trailing newline + (when (peek-char #\NewLine *query-io* nil) + ;; And consume the #\newline + (read-char *query-io*)) + (clear-input *query-io*) + (if (char-equal response #\y) (return t)) + (if (char-equal response #\n) (return nil)) + (format *query-io* "Please answer y or n.")))) + +(defun yes-or-no-p (&optional format-string &rest arguments &aux response) + "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the + input buffer, beeps, and uses READ-LINE to get the strings + YES or NO." + (declare (dynamic-extent arguments)) + (with-terminal-input + (loop + (when format-string + (fresh-line *query-io*) + (apply 'format *query-io* format-string arguments)) + (princ " (yes or no) " *query-io*) + (format *query-io* "~A" #\Bell) + (setq response (read-line *query-io*)) + (clear-input *query-io*) + (when response + (setq response (string-trim wsp response)) + (if (string-equal response "yes") (return t)) + (if (string-equal response "no") (return nil)) + (format *query-io* "Please answer yes or no."))))) + + + +;; Compile-time format-scanning support. +;; +;; All this assumes it's called from the compiler, but it has to be kept in sync with code +;; here more than with the code in the compiler, so keep it in here. + +(defun note-format-scan-option (cell) + (when cell + (if (null (cdr cell)) + (setf (car cell) *format-arguments* (cdr cell) *format-arguments-variance*) + (let* ((new-args *format-arguments*) + (new-var *format-arguments-variance*) + (new-max (length new-args)) + (old-args (car cell)) + (old-var (cdr cell)) + (old-max (length old-args)) + (min (min (- new-max new-var) (- old-max old-var)))) + (if (>= new-max old-max) + (setf (car cell) new-args (cdr cell) (- new-max min)) + (setf (cdr cell) (- old-max min)))))) + cell) + +(defmacro with-format-scan-options ((var) &body body) + (let ((cell (gensym))) + ;; CELL is used to record range of arg variations that should be deferred til the end + ;; of BODY because they represent possible non-local exits. + `(let* ((,cell (cons nil nil)) + (,var ,cell)) + (declare (dynamic-extent ,cell)) + (prog1 + (progn + ,@body) + (setq *format-arguments* (car ,cell) + *format-arguments-variance* (cdr ,cell)))))) + +(defvar *format-escape-options* nil) + +(defun nx1-check-format-call (control-string format-arguments &optional (env *nx-lexical-environment*)) + "Format-arguments are expressions that will evaluate to the actual arguments. + Pre-scan process the format string, nx1-whine if find errors" + (let* ((*nx-lexical-environment* env) + (*format-top-level* t) + (*logical-block-xp* nil) + (*format-pprint* nil) + (*format-justification-semi* nil)) + (let ((error (catch 'format-error + (format-scan control-string format-arguments 0) + nil))) + (when error + (setf (cadar error) (concatenate 'string (cadar error) " in format string:")) + (nx1-whine :format-error (nreverse error)) + t)))) + +(defun format-scan (string args var) + (let ((*format-original-arguments* args) + (*format-arguments* args) + (*format-arguments-variance* var) + (*format-colon-rest* 'error) + (*format-control-string* (ensure-simple-string string))) + (with-format-scan-options (*format-escape-options*) + (catch 'format-escape + (sub-format-scan 0 (length *format-control-string*)) + (note-format-scan-option *format-escape-options*))) + (when (> (length *format-arguments*) *format-arguments-variance*) + (format-error "Too many format arguments")))) + +(defun sub-format-scan (i end) + (let ((*format-index* i) + (*format-length* end) + (string *format-control-string*)) + (loop while (setq *format-index* (position #\~ string :start *format-index* :end end)) do + (multiple-value-bind (params colon atsign char) (parse-format-operation t) + (setq char (char-upcase char)) + (let ((code (%char-code char))) + (unless (and (< -1 code (length *format-char-table*)) + (svref *format-char-table* code)) + (format-error "Unknown directive ~c" char))) + (format-scan-directive char colon atsign params) + (incf *format-index*))))) + +(defun nx-could-be-type (form type &optional transformed &aux (env *nx-lexical-environment*)) + (unless transformed (setq form (nx-transform form env))) + (if (nx-form-constant-p form env) + (typep (nx-form-constant-value form env) type env) + (not (types-disjoint-p (nx-form-type form env) type env)))) + +(defun format-require-type (form type &optional description) + (unless (nx-could-be-type form type) + (format-error "~a must be of type ~s" (or description form) type))) + + +(defun format-scan-directive (char colon atsign parms) + (ecase char + ((#\% #\& #\~ #\|) + (with-format-parameters parms ((repeat-count 1)) + (format-no-flags colon atsign) + (format-require-type repeat-count '(integer 0)))) + ((#\newline #\return) + (with-format-parameters parms () + (when (and atsign colon) (format-error "~:@ is undefined")) + (unless colon + (format-eat-whitespace)))) + ((#\P) + (with-format-parameters parms () + (when colon + (loop with end = *format-arguments* + for list on *format-original-arguments* + when (eq (cdr list) end) return (setq *format-arguments* list) + finally (if (> (or *format-arguments-variance* 0) 0) + (decf *format-arguments-variance*) + (format-error "No previous argument")))) + (pop-format-arg))) + ((#\A #\S) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-require-type mincol 'integer "mincol (first parameter)") + (format-require-type colinc '(integer 1) "colinc (second parameter)") + (format-require-type minpad 'integer "minpad (third parameter)") + (format-require-type padchar '(or (integer 0 #.char-code-limit) character) "padchar (fourth parameter)")) + (pop-format-arg)) + ((#\I) + (with-format-parameters parms ((n 0)) + (format-no-flags nil atsign) + (format-no-semi char) + (format-require-type n 'real))) + ((#\_) + (with-format-parameters parms () + (format-no-semi char))) + ((#\T) + (with-format-parameters parms ((colnum 1) (colinc 1)) + (when colon + (format-no-semi char t)) + (format-require-type colnum 'integer "colnum (first parameter)") + (format-require-type colinc 'integer "colinc (second parameter)"))) + ((#\W) + (with-format-parameters parms () + (format-no-semi #\W)) + (pop-format-arg)) + ((#\C) + (with-format-parameters parms ()) + (format-require-type (pop-format-arg) '(or character fixnum (string 1)))) + ((#\D #\B #\O #\X #\R) + (when (eql char #\R) + (let ((radix (pop parms))) + (when radix + (format-require-type radix '(integer 2 36))))) + (with-format-parameters parms ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + (format-require-type mincol 'integer "mincol (first parameter)") + (format-require-type padchar 'character "padchar (second parameter)") + (format-require-type commachar 'character "comma char (third parameter)") + (format-require-type commainterval 'integer "comma interval (fourth parameter)")) + (pop-format-arg)) + ((#\F) + (format-no-flags colon nil) + (with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + (format-require-type w '(or null (integer 0)) "w (first parameter)") + (format-require-type d '(or null (integer 0)) "d (second parameter)") + (format-require-type k '(or null integer) "k (third parameter)") + (format-require-type ovf '(or null character) "overflowchar (fourth parameter)") + (format-require-type pad '(or null character) "padchar (fifth parameter)")) + (pop-format-arg)) + ((#\E #\G) + (format-no-flags colon nil) + (with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil)) + (format-require-type w '(or null (integer 0)) "w (first parameter)") + (format-require-type d '(or null (integer 0)) "d (second parameter)") + (format-require-type e '(or null (integer 0)) "e (third parameter)") + (format-require-type k '(or null integer) "k (fourth parameter)") + (format-require-type ovf '(or null character) "overflowchar (fifth parameter)") + (format-require-type pad '(or null character) "padchar (sixth parameter)") + (format-require-type marker '(or null character) "exponentchar (seventh parameter)")) + (pop-format-arg)) + ((#\$) + (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space)) + (format-require-type d '(or null (integer 0)) "d (first parameter)") + (format-require-type n '(or null (integer 0)) "n (second parameter)") + (format-require-type w '(or null (integer 0)) "w (third parameter)") + (format-require-type pad '(or null character) "pad (fourth parameter)")) + (format-require-type (pop-format-arg) 'real)) + ((#\*) + (with-format-parameters parms ((count nil)) + (when count + (format-require-type count 'integer "count parameter")) + (if (typep (setq count (nx-transform count)) '(or null integer)) + (format-scan-goto colon atsign count) + ;; Else can't tell how much going back or forth, could be anywhere. + (setq *format-arguments* *format-original-arguments* + *format-arguments-variance* (length *format-arguments*))))) + ((#\?) + (with-format-parameters parms () + (format-no-flags colon nil)) + (let ((string (pop-format-arg))) + (format-require-type string '(or string function)) + (if atsign + (setq *format-arguments-variance* (length *format-arguments*)) + (let ((arg (pop-format-arg))) + (format-require-type arg 'list))))) + ((#\/) + (let* ((string *format-control-string*) + (ipos (1+ *format-index*)) + (epos (format-find-char #\/ ipos *format-length*))) + (when (not epos) (format-error "Unmatched ~~/")) + (let* ((cpos (format-find-char #\: ipos epos)) + (name (if cpos + (prog1 + (string-upcase (%substr string ipos cpos)) + (when (eql #\: (schar string (%i+ 1 cpos))) + (setq cpos (%i+ cpos 1))) + (setq ipos (%i+ cpos 1))) + "CL-USER")) + (package (find-package name)) + (sym (and package (find-symbol (string-upcase (%substr string ipos epos)) package))) + (arg (pop-format-arg))) + (setq *format-index* epos) ; or 1+ epos? + ;; TODO: should we complain if the symbol doesn't exit? Perhaps it will be defined + ;; later, and to detect that would need to intern it. What if the package doesn't exist? + ;; Would need to extend :undefined-function warnings to handle previously-undefined package. + (when sym + (when (nx1-check-typed-call sym (list* '*standard-output* arg colon atsign parms)) + ;; Whined, just get out now. + (throw 'format-error nil)))))) + ((#\[) + (when (and colon atsign) (format-error "~~:@[ undefined")) + (format-nextchar) + (cond (colon + (format-scan-boolean-condition parms)) + (atsign + (format-scan-funny-condition parms)) + (t (format-scan-untagged-condition parms)))) + ((#\() + (with-format-parameters parms () + (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\))) + (with-format-parameters parms () (format-no-flags colon atsign)) + (sub-format-scan prev tilde)))) + ((#\^) + (format-no-flags nil atsign) + (with-format-parameters parms ((p1 nil) (p2 nil) (p3 nil)) + (let ((val (nx-transform (cond (p3 + (if (every (lambda (p) (nx-could-be-type p 'real)) parms) + ;; If the params could also be chars, don't know enough to constant fold + ;; anyway, so this test will do. + `(< ,p1 ,p2 ,p3) + (if (every (lambda (p) (nx-could-be-type p 'character)) parms) + `(char< ,p1 ,p2 ,p3) + ;; At least one can't be real, at least one can't be char. + (format-error "Wrong type of parameters for three-way comparison")))) + (p2 `(equal ,p1 ,p2)) + (p1 `(eq ,p1 0)) + (t (null (if colon *format-colon-rest* *format-arguments*))))))) + (when val + (note-format-scan-option *format-escape-options*) + (unless (nx-could-be-type val 'null t) + (throw 'format-escape t)))))) + ((#\{) + (with-format-parameters parms ((max-iter -1)) + (format-require-type max-iter 'integer "max-iter parameter") + (format-nextchar) + (multiple-value-bind (prev tilde end-parms end-colon end-atsign) (format-find-command '(#\})) + (declare (ignore end-colon)) + (with-format-parameters end-parms () (format-no-flags nil end-atsign)) + (when (= prev tilde) + ;; Use an argument as the control string if ~{~} is empty + (let ((string (pop-format-arg))) + (unless (nx-could-be-type string '(or string function)) + (format-error "Control string is not a string or function")))) + ;; Could try to actually scan the iteration if string is a compile-time string, + ;; by that seems unlikely. + (if atsign + (setq *format-arguments-variance* (length *format-arguments*)) + (format-require-type (pop-format-arg) 'list))))) + ((#\<) + (multiple-value-bind (start tilde eparms ecolon eatsign) (format-find-command '(#\>)) + (declare (ignore tilde eparms eatsign)) + (setq *format-index* start) + (if ecolon + (format-logical-block-scan colon atsign parms) + (format-justification-scan colon atsign parms)))) + )) + +(defun format-justification-scan (colon atsign parms) + (declare (ignore colon atsign)) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-require-type mincol 'integer "mincol (first parameter)") + (format-require-type colinc '(integer 1) "colinc (second parameter)") + (format-require-type minpad 'integer "minpad (third parameter)") + (format-require-type padchar `(or character (integer 0 #.char-code-limit)) "padchar (fourth parameter)")) + (let ((first-parms nil) (first-colon nil) (count 0)) + (with-format-scan-options (*format-escape-options*) + (loop + (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\>) nil T) + (if (and (eql count 0) (eql cmd #\;) colon) + (progn + (format-no-flags nil atsign) + (setq first-colon t) + (setq *format-index* tilde) + (setq first-parms (nth-value 2 (format-find-command '(#\; #\>) t T)))) + (with-format-parameters parms () + (format-no-flags colon atsign))) + (when (catch 'format-escape + (sub-format-scan prev tilde) + nil) + (unless (eq cmd #\>) (format-find-command '(#\>) nil t)) + (return)) + (incf count) + (when (eq cmd #\>) + (return)))) + (note-format-scan-option *format-escape-options*)) + (when first-colon + (when *format-pprint* + (format-error "Justification illegal in this context")) + (setq *format-justification-semi* t) + (with-format-parameters first-parms ((spare 0) (linel 0)) + (format-require-type spare 'integer "spare (first parameter)") + (format-require-type linel 'integer "line length (second parameter)"))))) + + + +(defun format-logical-block-scan (colon atsign params) + (declare (ignore colon)) + (with-format-parameters params () + (format-no-semi #\<)) + ;; First section can be termined by ~@; + (let ((format-string *format-control-string*) + (prefix "") + (suffix "") + (body-string nil)) + (multiple-value-bind (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>)) + (setq body-string (%substr format-string (1+ start1) tilde)) + (with-format-parameters parms1 ()) + (when (eq cmd #\;) + (format-no-flags colon1 nil) + (setq prefix body-string) + (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>))) + (with-format-parameters parms1 ()) + (setq body-string (%substr format-string (1+ start1) tilde)) + (when (eq cmd #\;) + (format-no-flags colon1 atsign1) + (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>))) + (with-format-parameters parms1 ()) + (setq suffix (%substr format-string (1+ start1) tilde)) + (when (eq cmd #\;) + (format-error "Too many sections"))))) + (flet ((format-check-simple (str where) + (when (and str (or (%str-member #\~ str) (%str-member #\newline str))) + (format-error "~A must be simple" where)))) + (format-check-simple prefix "Prefix") + (format-check-simple suffix "Suffix")) + (if atsign + (let ((*logical-block-p* t)) + (format-scan body-string *format-arguments* *format-arguments-variance*) + (setq *format-arguments* nil *format-arguments-variance* 0)) + ;; If no atsign, we just use up an arg. Don't bother trying to scan it, unlikely to be a constant. + (when *format-arguments* + (pop-format-arg))))) + + +(defun format-scan-untagged-condition (parms) + (with-format-parameters parms ((index nil)) + (unless index (setq index (pop-format-arg))) + (format-require-type index 'integer) + (with-format-scan-options (cond-options) + (loop with default = nil do + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\])) + (when (and default (eq cmd #\;)) + (format-error "~:; must be the last clause")) + (with-format-parameters parms () + (format-no-flags (if (eq cmd #\]) colon) atsign) + (when colon (setq default t))) + (format-scan-optional-clause prev tilde cond-options) + (when (eq cmd #\]) + (unless default ;; Could just skip the whole thing + (note-format-scan-option cond-options)) + (return)) + (format-nextchar)))))) + +(defun format-scan-funny-condition (parms) + (with-format-parameters parms ()) + (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\])) + (with-format-parameters parms () + (format-no-flags colon atsign)) + (when (null *format-arguments*) (pop-format-arg)) ;; invoke std error + (with-format-scan-options (cond-options) + (let ((arg (nx-transform (car *format-arguments*)))) + (when (nx-could-be-type arg 'null t) + (let ((*format-arguments* *format-arguments*) + (*format-arguments-variance* *format-arguments-variance*)) + (when (eql *format-arguments-variance* (length *format-arguments*)) + (decf *format-arguments-variance*)) + (pop *format-arguments*) + (note-format-scan-option cond-options))) + (when arg + (format-scan-optional-clause prev tilde cond-options)))))) + + +(defun format-scan-boolean-condition (parms) + (with-format-parameters parms ()) + (multiple-value-bind (prev tilde parms colon atsign cmd) (format-find-command '(#\; #\])) + (when (eq cmd #\]) + (format-error "Two clauses separated by ~~; are required for ~~:[")) + (with-format-parameters parms () (format-no-flags colon atsign)) + (format-nextchar) + (with-format-scan-options (cond-options) + (let ((arg (nx-transform (pop-format-arg)))) + (when (nx-could-be-type arg 'null t) + (format-scan-optional-clause prev tilde cond-options)) + (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\])) + (with-format-parameters parms () (format-no-flags colon atsign)) + (when arg + (format-scan-optional-clause prev tilde cond-options))))))) + + +(defun format-scan-optional-clause (start end cond-option) + (let ((*format-arguments* *format-arguments*) + (*format-arguments-variance* *format-arguments-variance*)) + ;; Let the branch points collect in outer *format-escape-options*, but don't + ;; throw there because need to consider the other clauses. + (catch 'format-escape + (sub-format-scan start end) + (note-format-scan-option cond-option) + nil))) + +(defun format-scan-goto (colon atsign count) + (if atsign + (let* ((orig *format-original-arguments*) + (orig-pos (- (length orig) (length *format-arguments*))) + (new-pos (or count 0))) + (format-no-flags colon nil) + ;; After backing up, we may not use up all the arguments we backed over, + ;; so even though real variance here is 0, increase variance so we don't + ;; complain. + (setq *format-arguments-variance* (max 0 (- orig-pos new-pos))) + (setq *format-arguments* (nthcdr-no-overflow new-pos orig))) + (progn + (when (null count)(setq count 1)) + (when colon (setq count (- count))) + (cond ((> count 0) + (when (> count (length *format-arguments*)) + (format-error "Target position for ~~* out of bounds")) + (setq *format-arguments* (nthcdr count *format-arguments*)) + (when *format-arguments-variance* + (setq *format-arguments-variance* + (min *format-arguments-variance* (length *format-arguments*))))) + ((< count 0) + (let* ((orig *format-original-arguments*) + (orig-pos (- (length orig) (length *format-arguments*))) + (pos (+ orig-pos count)) + (max-pos (+ pos (or *format-arguments-variance* 0)))) + (when (< max-pos 0) + (format-error "Target position for ~~* out of bounds")) + ;; After backing up, we may not use up all the arguments we backed over. + ;; Increase the variance allowed to cover those arguments, so we don't + ;; complain about not using them. E.g. (format t "~a ~a ~2:*~a" 1 2) should + ;; be ok, (format t "~a ~a ~2:*" 1 2) should warn. + (setq max-pos (1- (- max-pos count))) + (if (< pos 0) + (setq *format-arguments* orig + *format-arguments-variance* max-pos) + (setq *format-arguments* (nthcdr pos orig) + *format-arguments-variance* (- max-pos pos))))))))) Index: /branches/qres/ccl/lib/hash.lisp =================================================================== --- /branches/qres/ccl/lib/hash.lisp (revision 13564) +++ /branches/qres/ccl/lib/hash.lisp (revision 13564) @@ -0,0 +1,456 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; This is just the stuff (make-load-form, print-object) that can't be fasloaded earlier. + + +;;;;;;;;;;;;; +;; +;; hash.lisp +;; New hash table implementation + +;;;;;;;;;;;;; +;; +;; Things I didn't do +;; +;; Save the 32-bit hash code along with the key so that growing the table can +;; avoid calling the hashing function (at least until a GC happens during growing). +;; +;; Maybe use Knuth's better method for hashing: +;; find two primes N-2, N. N is the table size. +;; First probe is at primary = (mod (funcall (nhash.keytransF h) key) N) +;; Secondary probes are spaced by (mod (funcall (nhash.keytransF h) key) N-2) +;; This does a bit better scrambling of the secondary probes, but costs another divide. +;; +;; Rethink how finalization is reported to the user. Maybe have a finalization function which +;; is called with the hash table and the deleted key & value. + + +;;;;;;;;;;;;; +;; +;; Documentation +;; +;; MAKE-HASH-TABLE is extended to accept a :HASH-FUNCTION keyword arg which +;; defaults for the 4 Common Lisp defined :TEST's. Also, any fbound symbol can +;; be used for the :TEST argument. The HASH-FUNCTION is a function of one +;; argument, the key, which returns one or two values: +;; +;; 1) HASH-CODE +;; 2) ADDRESSP +;; +;; The HASH-CODE can be any object. If it is a relocateable object (not a +;; fixnum, short float, or immediate) then ADDRESSP will default to :KEY +;; and it is an error if NIL is returned for ADDRESSP. +;; +;; If ADDRESSP is NIL, the hashing code assumes that no addresses were used +;; in computing the HASH-CODE. If ADDRESSP is :KEY (which is the default +;; if the hash function returns only one value and it is relocateable) then +;; the hashing code assumes that only the KEY's address was used to compute +;; the HASH-CODE. Otherwise, it is assumed that the address of a +;; component of the key was used to compute the HASH-CODE. +;; +;; +;; +;; Some (proposed) functions for using in user hashing functions: +;; +;; (HASH-CODE object) +;; +;; returns two values: +;; +;; 1) HASH-CODE +;; 2) ADDRESSP +;; +;; HASH-CODE is the object transformed into a fixnum by changing its tag +;; bits to a fixnum's tag. ADDRESSP is true if the object was +;; relocateable. ;; +;; +;; (FIXNUM-ADD o1 o2) +;; Combines two objects additively and returns a fixnum. +;; If the two objects are fixnums, will be the same as (+ o1 o2) except +;; that the result can not be a bignum. +;; +;; (FIXNUM-MULTIPLY o1 o2) +;; Combines two objects multiplicatively and returns a fixnum. +;; +;; (FIXNUM-FLOOR dividend &optional divisor) +;; Same as Common Lisp's FLOOR function, but converts the objects into +;; fixnums before doing the divide and returns two fixnums: quotient & +;; remainder. +;; +;;;;;;;;;;;;; +;; +;; Implementation details. +;; +;; Hash table vectors have a header that the garbage collector knows +;; about followed by alternating keys and values. Empty slots have a +;; key of (%UNBOUND-MARKER), deleted slots are denoted by a key of +;; (%SLOT-UNBOUND-MARKER), except in the case of "lock-free" hash +;; tables, which see below. +;; +;; Four bits in the nhash.vector.flags fixnum interact with the garbage +;; collector. This description uses the symbols that represent bit numbers +;; in a fixnum. $nhash_xxx_bit has a corresponding $nhash_lap_xxx_bit which +;; gives the byte offset of the bit for LAP code. The two bytes in +;; question are at offsets $nhash.vector-weak-byte and +;; $nhash.vector-track-keys-byte offsets from the tagged vector. +;; The raw 32 bits of the fixnum at nhash.vector.flags look like: +;; +;; TKEC0000 00000000 WVFZ0000 00000000 +;; +;; +;; $nhash_track_keys_bit "T" in the diagram above +;; Sign bit of the longword at $nhash.vector.flags +;; or the byte at $nhash.vector-track-keys-byte. +;; If set, GC tracks relocation of keys in the +;; vector. +;; $nhash_key_moved_bit "K" in the diagram above +;; Set by GC to indicate that a key moved. +;; If $nhash_track_keys_bit is clear, this bit is set to +;; indicate that any GC will require a rehash. +;; GC never clears this bit, but may set it if +;; $nhash_track_keys_bit is set. +;; $nhash_component_address_bit "C" in the diagram above. +;; Ignored by GC. Set to indicate that the +;; address of a component of a key was used. +;; Means that $nhash_track_keys_bit will +;; never be set until all such keys are +;; removed. +;; $nhash_weak_bit "W" in the diagram above +;; Sign bit of the byte at $nhash.vector-weak-byte +;; Set to indicate a weak hash table +;; $nhash_weak_value_bit "V" in the diagram above +;; If clear, the table is weak on key +;; If set, the table is weak on value +;; $nhash_finalizeable_bit "F" in the diagram above +;; If set the table is finalizeable: +;; If any key/value pairs are removed, they will be added to +;; the nhash.vector.finalization-alist using cons cells +;; from nhash.vector.free-alist +;; $nhash_keys_frozen_bit "Z" in diagram above. +;; If set, GC will remove weak entries by setting the +;; value to (%slot-unbound-marker), leaving key unchanged. + +(in-package "CCL") + + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + +(defvar *hash-table-class* + (progn +; #+sparc-target (dbg) + (find-class 'hash-table))) + +(setf (type-predicate 'hash-table) 'hash-table-p) + + +(defmethod print-object ((table hash-table) stream) + (print-unreadable-object (table stream :type t :identity t) + (format stream "~S ~S size ~D/~D" + ':test (hash-table-test table) + (hash-table-count table) + (hash-table-size table)) + (when (readonly-hash-table-p table) + (format stream " (Readonly)")))) + + +#+vaporware +;;; Of course, the lisp version of this would be too slow ... +(defun hash-table-finalization-list (hash-table) + (unless (hash-table-p hash-table) + (report-bad-arg hash-table 'hash-table)) + (let* ((vector (nhash.vector hash-table)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (if (logbitp $nhash_finalizeable_bit flags) + (nhash.vector.finalization-alist vector) + (error "~S is not a finalizeable hash table" hash-table)))) + +#+vaporware +(defun (setf hash-table-finalization-list) (value hash-table) + (unless (hash-table-p hash-table) + (report-bad-arg hash-table 'hash-table)) + (let* ((vector (nhash.vector hash-table)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (if (logbitp $nhash_finalizeable_bit flags) + (setf (nhash.vector.finalization-alist vector) value) + (error "~S is not a finalizeable hash table" hash-table)))) + +(defsetf gethash puthash) + +; Returns nil, :key or :value +(defun hash-table-weak-p (hash) + (unless (hash-table-p hash) + (setq hash (require-type hash 'hash-table))) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector))) + (when (logbitp $nhash_weak_bit flags) + (if (logbitp $nhash_weak_value_bit flags) + :value + :key)))) + +;;; It would be pretty complicated to offer a way of doing (SETF +;;; HASH-TABLE-WEAK-P) after the hash-table's been created, and +;;; it's not clear that that'd be incredibly useful. + + + +;;;;;;;;;;;;; +;; +;; Mapping functions +;; + + + +(defun next-hash-table-iteration-1 (state) + (do* ((index (nhti.index state) (1+ index)) + (keys (nhti.keys state)) + (values (nhti.values state)) + (nkeys (nhti.nkeys state))) + ((>= index nkeys) + (setf (nhti.index state) nkeys) + nil) + (declare (fixnum index nkeys) + (simple-vector keys)) + (let* ((key (svref keys index)) + (value (svref values index))) + (setf (nhti.index state) (1+ index)) + (return (values t key value))))) + + + +(defun maphash (function hash-table) + "For each entry in HASH-TABLE, call the designated two-argument function + on the key and value of the entry. Return NIL." + (with-hash-table-iterator (m hash-table) + (loop + (multiple-value-bind (found key value) (m) + (unless found (return)) + (funcall function key value))))) + + + +(defmethod make-load-form ((hash hash-table) &optional env) + (declare (ignore env)) + (%normalize-hash-table-count hash) + (let ((keytransF (nhash.keytransF hash)) + (compareF (nhash.compareF hash)) + (vector (nhash.vector hash)) + (private (if (nhash.owner hash) '*current-process*)) + (lock-free-p (logtest $nhash.lock-free (the fixnum (nhash.lock hash))))) + (flet ((convert (f) + (if (or (fixnump f) (symbolp f)) + `',f + `(symbol-function ',(function-name f))))) + (values + `(%cons-hash-table + nil nil nil ,(nhash.grow-threshold hash) ,(nhash.rehash-ratio hash) ,(nhash.rehash-size hash) + nil nil ,private ,lock-free-p) + `(%initialize-hash-table ,hash ,(convert keytransF) ,(convert compareF) ',vector))))) + +(defun needs-rehashing (hash) + (%set-needs-rehashing hash)) + +(defun %initialize-hash-table (hash keytransF compareF vector) + (setf (nhash.keytransF hash) keytransF + (nhash.compareF hash) compareF) + (setf (nhash.find hash) + (case comparef + (0 #'eq-hash-find) + (-1 #'eql-hash-find) + (t #'general-hash-find)) + (nhash.find-new hash) + (case comparef + (0 #'eq-hash-find-for-put) + (-1 #'eql-hash-find-for-put) + (t #'general-hash-find-for-put))) + (setf (nhash.vector hash) vector) + (%set-needs-rehashing hash)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Support for locking hash tables while fasdumping +;; + + +(defun fasl-lock-hash-table (hash-table) + (setq hash-table (require-type hash-table 'hash-table)) + (without-interrupts + (let* ((lock (nhash.exclusion-lock hash-table))) + (if lock + (progn + (if (hash-lock-free-p hash-table) + ;; For lock-free hash tables, this only makes sure nobody is + ;; rehashing the table. It doesn't necessarily stop readers + ;; or writers (unless they need to rehash). + (grab-lock lock) + (write-lock-rwlock lock)) + (push hash-table *fcomp-locked-hash-tables*)) + (unless (eq (nhash.owner hash-table) *current-process*) + (error "Current process doesn't own hash-table ~s" hash-table)))))) + +(defun fasl-unlock-hash-tables () + (dolist (h *fcomp-locked-hash-tables*) + (let* ((lock (nhash.exclusion-lock h))) + (if (hash-lock-free-p h) + (release-lock lock) + (unlock-rwlock lock))))) + + + + + +#+not-yet +(progn +;;;;;;;;;;;;; +;; +;; Replacement for population +;; +(def-accessors (weak-table) %svref + nil ; 'weak-table + weak-table.vector ; a $v_nhash vector + weak-table.index ; index for next entry + weak-table.grow-threshold ; number of entries left in vector + ) + +(defun make-weak-table (&optional (size 20)) + (%istruct 'weak-table + (%cons-nhash-vector + size (+ (ash 1 $nhash_weak_bit))) + 0 + size)) + +(defun weak-table-p (weak-table) + (istruct-typep weak-table 'weak-table)) + +(setf (type-predicate 'weak-table) 'weak-table-p) + +(defun weak-table-count (weak-table) + (setq weak-table (require-type weak-table 'weak-table)) + (- (weak-table.index weak-table) + (nhash.vector.weak-deletions-count (weak-table.vector weak-table)))) + +(defun weak-table-push (key weak-table &optional value) + (setq weak-table (require-type weak-table 'weak-table)) + (let ((thresh (weak-table.grow-threshold weak-table)) + (vector (weak-table.vector weak-table)) + (index (weak-table.index weak-table))) + (declare (fixnum thresh index)) + (if (> thresh 0) + (progn + (lap-inline (index) + (:variable vector key value) + (move.l (varg vector) atemp0) + (lea (atemp0 arg_z.l $nhash_data) atemp0) + (move.l (varg key) atemp0@+) + (move.l (varg value) @atemp0)) + (setf (weak-table.index weak-table) (the fixnum (1+ index)) + (weak-table.grow-threshold weak-table) (the fixnum (1- thresh))) + value) + (let ((deletions (nhash.vector.weak-deletions-count vector))) + (declare (fixnum deletions)) + (if (> deletions 0) + ; GC deleted some entries, we can compact the table + (progn + (lap-inline (index) + (:variable vector) + (getint arg_z) ; length + (move.l (varg vector) atemp0) + (lea (atemp0 $nhash_data) atemp0) + (move.l atemp0 atemp1) + (move.l ($ $undefined) da) + ; Find the first deleted entry + (dbfloop.l arg_z + (if# (ne (cmp.l @atemp0 da)) + (add.l ($ 1) arg_z) + (bra @move)) + (add.w ($ 8) atemp0)) + ; copy the rest of the table up + @move + (dbfloop.l arg_z + (move.l atemp0@+ db) + (if# (eq (cmp.l db da)) + (add.w ($ 4) atemp0) + else# + (move.l db atemp1@+) + (move.l atemp0@+ atemp1@+))) + ; Write over the newly emptied part of the table + (while# (ne (cmp.l atemp0 atemp1)) + (move.l da @atemp1) + (add.l ($ 8) atemp1))) + (setf (nhash.vector.weak-deletions-count vector) 0 + (weak-table.index weak-table) (the fixnum (- index deletions)) + (weak-table.grow-threshold weak-table) (the fixnum (+ thresh deletions))) + (weak-table-push key weak-table value)) + ; table is full. Grow it by a factor of 1.5 + (let* ((new-size (+ index (the fixnum (ash (the fixnum (1+ index)) -1)))) + (new-vector (%cons-nhash-vector new-size (ash 1 $nhash_weak_bit)))) + (declare (fixnum new-size)) + (lap-inline (index) + (:variable vector new-vector count) + (move.l (varg vector) atemp0) + (move.l (varg new-vector) atemp1) + (lea (atemp0 $nhash_data) atemp0) + (lea (atemp1 $nhash_data) atemp1) + (getint arg_z) ; table length + (dbfloop.l arg_z + (move.l atemp0@+ atemp1@+) + (move.l atemp0@+ atemp1@+))) + (setf (weak-table.vector weak-table) new-vector + (weak-table.grow-threshold weak-table) (the fixnum (- new-size index))) + ; It's possible that GC deleted some entries while consing the new vector + (setf (nhash.vector.weak-deletions-count new-vector) + (nhash.vector.weak-deletions-count vector)) + (weak-table-push key weak-table value))))))) + +; function gets two args: key & value +(defun map-weak-table (function weak-table) + (setq weak-table (require-type weak-table 'weak-table)) + (let* ((vector (weak-table.vector weak-table)) + (index (weak-table.index weak-table)) + (flags (nhash.vector.flags vector))) + (unwind-protect + (progn + (setf (nhash.vector.flags vector) 0) ; disable deletion by GC + (lap-inline () + (:variable function vector index) + (while# (gt (move.l (varg index) da)) + (sub.l '1 da) + (move.l da (varg index)) + (move.l (varg vector) atemp0) + (move.l (atemp0 da.l $nhash_data) arg_y) + (if# (ne (cmp.w ($ $undefined) arg_y)) + (move.l (atemp0 da.l (+ $nhash_data 4)) arg_z) + (set_nargs 2) + (move.l (varg function) atemp0) + (jsr_subprim $sp-funcall)))) + nil) + (setf (nhash.vector.flags vector) flags)))) + +; function gets one arg, the key +(defun map-weak-table-keys (function weak-table) + (flet ((f (key value) + (declare (ignore value)) + (funcall function key))) + (declare (dynamic-extent #'f)) + (map-weak-table #'f weak-table))) + +) ; #+not-yet + +; end Index: /branches/qres/ccl/lib/late-clos.lisp =================================================================== --- /branches/qres/ccl/lib/late-clos.lisp (revision 13564) +++ /branches/qres/ccl/lib/late-clos.lisp (revision 13564) @@ -0,0 +1,70 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Maybe compile specialized discriminating code (dcode) for generic +;;; functions, if it seems likely that that might perform better than +;;; the general generic-function-dispatch mechanism. + + +;;; If the GF accepts a fixed number of arguments, return its +;;; lambda list. +(defun gf-fixed-arg-lambda-list (gf) + (let* ((lambda-list (generic-function-lambda-list gf))) + (dolist (arg lambda-list lambda-list) + (when (member arg lambda-list-keywords) + (return nil))))) + +(defun generate-conformance-test (arg-name specializer) + (cond ((typep specializer 'eql-specializer) + `(eql ,arg-name ',(eql-specializer-object specializer))) + ((eq specializer *t-class*)) + ((typep specializer 'standard-class) + (let* ((wrapper (gensym))) + `(let* ((,wrapper (if (= (the fixnum (typecode ,arg-name)) + target::subtag-instance) + (instance.class-wrapper ,arg-name)))) + (and ,wrapper + (memq ,specializer (or (%wrapper-cpl ,wrapper) + (%inited-class-cpl + (%wrapper-class ,wrapper)))))))) + (t `(typep ,arg-name ',(class-name specializer))))) + +(defun generate-conformance-clause (args method) + `((and ,@(mapcar #'generate-conformance-test args (method-specializers method))) + (funcall ,(method-function method) ,@args))) + +;;; Generate code to call the single fixed-arg primary method +;;; defined on GF if all args are conformant, or to call +;;; NO-APPLICABLE-METHOD otherwise. +;;; Note that we can often do better than this for accessor +;;; methods (especially reader methods) as a very late (delivery-time) +;;; optimization. +(defun dcode-for-fixed-arg-singleton-gf (gf) + (let* ((methods (generic-function-methods gf)) + (method (car methods)) + (args (gf-fixed-arg-lambda-list gf))) + (when (and method + args + (null (cdr methods)) + (null (method-qualifiers method)) + (dolist (spec (method-specializers method)) + (unless (eq spec *t-class*) (return t)))) + (compile nil + `(lambda ,args + (cond ,(generate-conformance-clause args method) + (t (no-applicable-method ,gf ,@args)))))))) + +(register-non-dt-dcode-function #'dcode-for-fixed-arg-singleton-gf) Index: /branches/qres/ccl/lib/level-2.lisp =================================================================== --- /branches/qres/ccl/lib/level-2.lisp (revision 13564) +++ /branches/qres/ccl/lib/level-2.lisp (revision 13564) @@ -0,0 +1,483 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Level-2.lisp + +(in-package "CCL") + +(eval-when (eval compile) + (require "LEVEL-2") + (require "BACKQUOTE") + (require "DEFSTRUCT-MACROS")) + + + +(eval-when (eval compile) + (require "LISPEQU")) + + + + + + + + +; This incredibly essential thing is part of ANSI CL; put it in the +; right package someday. +; Like maybe when it says something about doc strings, or otherwise +; becomes useful. + +(defun parse-macro (name arglist body &optional env) + (values (parse-macro-1 name arglist body env))) + +; Return a list containing a special declaration for SYM +; if SYM is declared special in decls. +; This is so we can be pedantic about binding &WHOLE/&ENVIRONMENT args +; that have been scarfed out of a macro-like lambda list. +; The returned value is supposed to be suitable for splicing ... +(defun hoist-special-decls (sym decls) + (when sym + (dolist (decl decls) + (dolist (spec (cdr decl)) + (when (eq (car spec) 'special) + (dolist (s (%cdr spec)) + (when (eq s sym) + (return-from hoist-special-decls `((declare (special ,sym))))))))))) + +(defun parse-macro-1 (name arglist body &optional env) + (parse-macro-internal name arglist body env nil)) + +(defun parse-macro-internal (name arglist body env default-initial-value) + (unless (verify-lambda-list arglist t t t) + (error "Invalid lambda list ~s" arglist)) + (multiple-value-bind (lambda-list whole environment) + (normalize-lambda-list arglist t t) + (multiple-value-bind (body local-decs doc) + (parse-body body env t) + (let ((whole-var (gensym "WHOLE")) + (env-var (gensym "ENVIRONMENT"))) + (multiple-value-bind (bindings binding-decls) + (%destructure-lambda-list lambda-list whole-var nil nil + :cdr-p t + :whole-p nil + :use-whole-var t + :default-initial-value default-initial-value) + (when environment + (setq bindings (nconc bindings (list `(,environment ,env-var))))) + (when whole + (setq bindings (nconc bindings (list `(,whole ,whole-var))))) + (values + `(lambda (,whole-var ,env-var) + (declare (ignorable ,whole-var ,env-var)) + (block ,name + (let* ,(nreverse bindings) + ,@(when binding-decls `((declare ,@binding-decls))) + ,@local-decs + ,@body))) + doc)))))) + + +(defun %destructure-lambda-list (lambda-list wholeform lets decls + &key cdr-p (whole-p t) use-whole-var default-initial-value) + (unless (and (listp lambda-list) + (verify-lambda-list lambda-list t whole-p)) + (signal-simple-program-error "Invalid lambda list: ~s" lambda-list)) + (multiple-value-bind (normalized whole) (normalize-lambda-list + lambda-list whole-p) + (let* ((argstate :required) + (allow-other-keys nil) + (rest-arg-name nil) + (w (if use-whole-var wholeform (or whole (gensym "WHOLE")))) + (argptr (gensym "ARGS")) + (has-&key nil) + (most-recent-binding nil) + (keywords ()) + (first-keyword-init ()) + (restp nil)) + (labels ((simple-var (var &optional (initform `,default-initial-value)) + (let* ((binding `(,var ,initform))) + (unless (eq argstate :aux) + (setq most-recent-binding binding)) + (push binding lets) + binding)) + (structured-var (context sub-lambda-list initform) + (let* ((v (gensym (string context)))) + (simple-var v initform) + (multiple-value-setq (lets decls) + (%destructure-lambda-list + sub-lambda-list + v + lets + decls + :default-initial-value default-initial-value +)) + v))) + (unless use-whole-var + (if (atom w) + (simple-var w wholeform) + (progn + (setq w (structured-var "WHOLE" w (if cdr-p `(cdr ,wholeform) wholeform)) + cdr-p nil)))) + (simple-var argptr `(make-destructure-state ,@(if cdr-p `((cdr ,w)) `(,w)) ,w ',lambda-list)) + (setq most-recent-binding nil) + (push `(dynamic-extent ,argptr) decls) + (do* ((tail normalized (cdr tail))) + ((null tail) + (if has-&key + (let* ((key-check-form `(check-keywords + ',(nreverse keywords) + ,rest-arg-name ,allow-other-keys))) + (if first-keyword-init + (rplaca (cdr first-keyword-init) + `(progn + ,key-check-form + ,(cadr first-keyword-init))) + (let* ((check-var (gensym "CHECK"))) + (push `(ignorable ,check-var) decls) + (simple-var check-var key-check-form)))) + (unless restp + (let* ((checkform `(%check-extra-arguments ,argptr)) + (b most-recent-binding) + (b-init (cadr b))) + (if b + (rplaca (cdr b) `(prog1 ,b-init ,checkform)) + (let* ((junk (gensym "JUNK"))) + (simple-var junk checkform) + (push `(ignorable ,junk) decls)))))) + (values lets decls)) + (let* ((var (car tail))) + (cond ((or (eq var '&rest) (eq var '&body)) + (let* ((r (cadr tail)) + (init `(destructure-state.current ,argptr))) + (if (listp r) + (setq rest-arg-name + (structured-var "REST" r init)) + (progn + (setq rest-arg-name (gensym "REST")) + (simple-var rest-arg-name init) + (simple-var r rest-arg-name )))) + (setq restp t) + (setq tail (cdr tail))) + ((eq var '&optional) (setq argstate :optional)) + ((eq var '&key) + (setq argstate :key) + (setq has-&key t) + (unless restp + (setq restp t + rest-arg-name (gensym "KEYS")) + (push `(ignorable ,rest-arg-name) decls) + (simple-var rest-arg-name + `(destructure-state.current ,argptr)))) + ((eq var '&allow-other-keys) + (setq allow-other-keys t)) + ((eq var '&aux) + (setq argstate :aux)) + ((listp var) + (case argstate + (:required + (structured-var "REQ" var `(%pop-required-arg-ptr ,argptr))) + (:optional + (let* ((variable (car var)) + (initform (if (cdr var) + (cadr var) + `,default-initial-value)) + (spvar (if (cddr var) + (caddr var) + (gensym "OPT-SUPPLIED-P"))) + (varinit `(if ,spvar + (%default-optional-value ,argptr) + ,initform))) + (simple-var spvar + `(not (null (destructure-state.current ,argptr)))) + (if (listp variable) + (structured-var "OPT" variable varinit) + (simple-var variable varinit)))) + (:key + (let* ((explicit-key (consp (car var))) + (variable (if explicit-key + (cadar var) + (car var))) + (keyword (if explicit-key + (caar var) + (make-keyword variable))) + (initform (if (cdr var) + (cadr var) + `,default-initial-value)) + (spvar (if (cddr var) + (caddr var) + (gensym "KEY-SUPPLIED-P")))) + (push keyword keywords) + (let* ((sp-init (simple-var spvar + `(%keyword-present-p + ,rest-arg-name + ',keyword))) + (var-init `(if ,spvar + (getf ,rest-arg-name ',keyword) + ,initform))) + (unless first-keyword-init + (setq first-keyword-init sp-init)) + (if (listp variable) + (structured-var "KEY" variable var-init) + (simple-var variable var-init))))) + (:aux + (simple-var (car var) (cadr var))) + (t (error "NYI: ~s" argstate)))) + ((symbolp var) + (case argstate + (:required + (simple-var var `(%pop-required-arg-ptr ,argptr))) + (:optional + (simple-var var `(%default-optional-value ,argptr + ',default-initial-value))) + (:key + (let* ((keyword (make-keyword var))) + (push keyword keywords) + (let* ((init (simple-var + var + `(getf ,rest-arg-name + ',keyword + ,@(if default-initial-value + `(',default-initial-value)))))) + (unless first-keyword-init + (setq first-keyword-init init))))) + (:aux + (simple-var var))))))))))) + + + + + + +(defun apply-to-htab-syms (function pkg-vector) + (let* ((sym nil) + (foundp nil)) + (dotimes (i (uvsize pkg-vector)) + (declare (fixnum i)) + (multiple-value-setq (sym foundp) (%htab-symbol pkg-vector i)) + (when foundp (funcall function sym))))) + +(defun iterate-over-external-symbols (pkg-spec function) + (apply-to-htab-syms function (car (pkg.etab (pkg-arg (or pkg-spec *package*)))))) + +(defun iterate-over-present-symbols (pkg-spec function) + (let ((pkg (pkg-arg (or pkg-spec *package*)))) + (apply-to-htab-syms function (car (pkg.etab pkg))) + (apply-to-htab-syms function (car (pkg.itab pkg))))) + +(defun iterate-over-accessable-symbols (pkg-spec function) + (let* ((pkg (pkg-arg (or pkg-spec *package*))) + (used (pkg.used pkg)) + (shadowed (pkg.shadowed pkg))) + (iterate-over-present-symbols pkg function) + (when used + (if shadowed + (flet ((ignore-shadowed-conflicts (var) + (unless (%name-present-in-package-p (symbol-name var) pkg) + (funcall function var)))) + (declare (dynamic-extent #'ignore-shadowed-conflicts)) + (dolist (u used) (iterate-over-external-symbols u #'ignore-shadowed-conflicts))) + (dolist (u used) (iterate-over-external-symbols u function)))))) + +(defun iterate-over-all-symbols (function) + (dolist (pkg %all-packages%) + (iterate-over-present-symbols pkg function))) + + + +;;;Eval definitions for things open-coded by the compiler. +;;;Don't use DEFUN since it should be illegal to DEFUN compiler special forms... +;;;Of course, these aren't special forms. +(macrolet ((%eval-redef (name vars &rest body) + (when (null body) (setq body `((,name ,@vars)))) + `(setf (symbol-function ',name) + (qlfun ,name ,vars ,@body)))) + (declare (optimize (speed 1) (safety 1))) + (%eval-redef %ilsl (n x)) + (%eval-redef %ilsr (n x)) + (%eval-redef neq (x y)) + (%eval-redef not (x)) + (%eval-redef null (x)) + (%eval-redef rplaca (x y)) + (%eval-redef rplacd (x y)) + (%eval-redef set-car (x y)) + (%eval-redef set-cdr (x y)) + (%eval-redef int>0-p (x)) + (%eval-redef %get-byte (ptr &optional (offset 0)) (%get-byte ptr offset)) + (%eval-redef %get-word (ptr &optional (offset 0)) (%get-word ptr offset)) + (%eval-redef %get-signed-byte (ptr &optional (offset 0)) (%get-signed-byte ptr offset)) + (%eval-redef %get-signed-word (ptr &optional (offset 0)) (%get-signed-word ptr offset)) + (%eval-redef %get-long (ptr &optional (offset 0)) (%get-long ptr offset)) + (%eval-redef %get-fixnum (ptr &optional (offset 0)) (%get-fixnum ptr offset)) + (%eval-redef %get-signed-long (ptr &optional (offset 0)) (%get-signed-long ptr offset)) + (%eval-redef %get-unsigned-long (ptr &optional (offset 0)) (%get-unsigned-long ptr offset)) + (%eval-redef %get-ptr (ptr &optional (offset 0)) (%get-ptr ptr offset)) + (%eval-redef %get-full-long (ptr &optional (offset 0)) (%get-full-long ptr offset)) + (%eval-redef %int-to-ptr (int)) + (%eval-redef %ptr-to-int (ptr)) + (%eval-redef %ptr-eql (ptr1 ptr2)) + (%eval-redef %setf-macptr (ptr1 ptr2)) + (%eval-redef %null-ptr-p (ptr)) + + + (%eval-redef %iasr (x y)) + + + (%eval-redef %set-byte (p o &optional (new (prog1 o (setq o 0)))) + (%set-byte p o new)) + (%eval-redef %set-unsigned-byte (p o &optional (new (prog1 o (setq o 0)))) + (%set-unsigned-byte p o new)) + (%eval-redef %set-word (p o &optional (new (prog1 o (setq o 0)))) + (%set-word p o new)) + (%eval-redef %set-unsigned-word (p o &optional (new (prog1 o (setq o 0)))) + (%set-unsigned-word p o new)) + (%eval-redef %set-long (p o &optional (new (prog1 o (setq o 0)))) + (%set-long p o new)) + (%eval-redef %set-unsigned-long (p o &optional (new (prog1 o (setq o 0)))) + (%set-unsigned-long p o new)) + (%eval-redef %set-ptr (p o &optional (new (prog1 o (setq o 0)))) + (%set-ptr p o new)) + + + (%eval-redef %word-to-int (word)) + (%eval-redef %inc-ptr (ptr &optional (by 1)) (%inc-ptr ptr by)) + + (%eval-redef char-code (x)) + (%eval-redef code-char (x)) + (%eval-redef 1- (n)) + (%eval-redef 1+ (n)) + + (%eval-redef uvref (x y)) + (%eval-redef uvset (x y z)) + (%eval-redef uvsize (x)) + + (%eval-redef svref (x y)) + (%eval-redef svset (x y z)) + + + + (%eval-redef car (x)) + (%eval-redef cdr (x)) + (%eval-redef cons (x y)) + (%eval-redef endp (x)) + + (progn + (%eval-redef typecode (x)) + (%eval-redef lisptag (x)) + (%eval-redef fulltag (x)) + (%eval-redef %unbound-marker ()) + (%eval-redef %slot-unbound-marker ()) + (%eval-redef %slot-ref (v i)) + (%eval-redef %alloc-misc (count subtag &optional (initial nil initial-p)) + (if initial-p + (%alloc-misc count subtag initial) + (%alloc-misc count subtag))) + (%eval-redef %setf-double-float (x y)) + (%eval-redef %lisp-word-ref (x y)) + (%eval-redef %temp-cons (x y)) + (%eval-redef require-fixnum (x)) + (%eval-redef require-symbol (x)) + (%eval-redef require-list (x)) + (%eval-redef require-real (x)) + (%eval-redef require-simple-string (x)) + (%eval-redef require-simple-vector (x)) + (%eval-redef require-character (x)) + (%eval-redef require-number (x)) + (%eval-redef require-integer (x)) + (%eval-redef require-s8 (x)) + (%eval-redef require-u8 (x)) + (%eval-redef require-s16 (x)) + (%eval-redef require-u16 (x)) + (%eval-redef require-s32 (x)) + (%eval-redef require-u32 (x)) + (%eval-redef require-s64 (x)) + (%eval-redef require-u64 (x)) + (%eval-redef %reference-external-entry-point (x)) + ) + + (%eval-redef %get-bit (ptr offset)) + (%eval-redef %set-bit (ptr offset val)) + (%eval-redef %get-double-float (ptr &optional (offset 0)) + (%get-double-float ptr offset)) + (%eval-redef %get-single-float (ptr &optional (offset 0)) + (%get-single-float ptr offset)) + (%eval-redef %set-double-float (p o &optional (new (prog1 o (setq o 0)))) + (%set-double-float p o new)) + (%eval-redef %set-single-float (p o &optional (new (prog1 o (setq o 0)))) + (%set-single-float p o new)) + (%eval-redef assq (item list)) +) + +; In the spirit of eval-redef ... + + +;; pointer hacking stuff +; +; + + + +;;; I'd guess that the majority of bitfields in the world whose width is +;;; greater than 1 have a width of two. If that's true, this is probably +;;; faster than trying to be more clever about it would be. +(defun %get-bitfield (ptr start-bit width) + (declare (fixnum start-bit width)) + (do* ((bit #+big-endian-target start-bit + #+little-endian-target (the fixnum (1- (the fixnum (+ start-bit width)))) + #+big-endian-target (1+ bit) + #+little-endian-target (1- bit)) + (i 0 (1+ i)) + (val 0)) + ((= i width) val) + (declare (fixnum val i bit)) + (setq val (logior (ash val 1) (%get-bit ptr bit))))) + +(defun %set-bitfield (ptr start width val) + (declare (fixnum val start width)) + (do* ((v val (ash v -1)) + (bit #+big-endian-target (1- (+ start width)) + #+little-endian-target start + #+big-endian-target (1- bit) + #+little-endian-target (1+ bit)) + (i 0 (1+ i))) + ((= i width) val) + (declare (fixnum v bit i)) + (setf (%get-bit ptr bit) (logand v 1)))) + +; expands into compiler stuff + +(setf (symbol-function '%get-unsigned-byte) (symbol-function '%get-byte)) +(setf (symbol-function '%get-unsigned-word) (symbol-function '%get-word)) +(setf (symbol-function '%get-signed-long) (symbol-function '%get-long)) + +(defun decompose-record-accessor (accessor &aux ret) + (do* ((str (symbol-name accessor) (%substr str (+ i 1) len)) + (len (length str) (length str)) + (i (%str-member #\. str) (%str-member #\. str)) + (field (%substr str 0 (or i len)) (%substr str 0 (or i len)))) + ((not i) (nreverse (cons (make-keyword field) ret))) + (push (make-keyword field) ret))) + + + + +(provide 'level-2) + + + + +;; end of level-2.lisp + Index: /branches/qres/ccl/lib/lists.lisp =================================================================== --- /branches/qres/ccl/lib/lists.lisp (revision 13564) +++ /branches/qres/ccl/lib/lists.lisp (revision 13564) @@ -0,0 +1,898 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (eval compile) + (require 'backquote) + (require 'level-2)) + + + +;;; These functions perform basic list operations: + +#| +(defun caar (list) (car (car list))) +(defun cadr (list) (car (cdr list))) +(defun cdar (list) (cdr (car list))) +(defun cddr (list) (cdr (cdr list))) + +(defun caaar (list) (car (caar list))) +(defun caadr (list) (car (cadr list))) +(defun cadar (list) (car (cdar list))) +(defun caddr (list) (car (cddr list))) +(defun cdaar (list) (cdr (caar list))) +(defun cdadr (list) (cdr (cadr list))) +(defun cddar (list) (cdr (cdar list))) +(defun cdddr (list) (cdr (cddr list))) +|# + + +(defun caaaar (list) + "Return the car of the caaar of a list." + (car (caaar list))) + +(defun caaadr (list) + "Return the car of the caadr of a list." + (car (caadr list))) + +(defun caadar (list) + "Return the car of the cadar of a list." + (car (cadar list))) + +(defun caaddr (list) + "Return the car of the caddr of a list." + (car (caddr list))) + +(defun cadaar (list) + "Return the car of the cdaar of a list." + (car (cdaar list))) + +(defun cadadr (list) + "Return the car of the cdadr of a list." + (car (cdadr list))) + +(defun caddar (list) + "Return the car of the cddar of a list." + (car (cddar list))) + +(defun cdaaar (list) + "Return the cdr of the caaar of a list." + (cdr (caaar list))) + +(defun cdaadr (list) + "Return the cdr of the caadr of a list." + (cdr (caadr list))) + +(defun cdadar (list) + "Return the cdr of the cadar of a list." + (cdr (cadar list))) + +(defun cdaddr (list) + "Return the cdr of the caddr of a list." + (cdr (caddr list))) + +(defun cddaar (list) + "Return the cdr of the cdaar of a list." + (cdr (cdaar list))) + +(defun cddadr (list) + "Return the cdr of the cdadr of a list." + (cdr (cdadr list))) + +(defun cdddar (list) + "Return the cdr of the cddar of a list." + (cdr (cddar list))) + +(defun cddddr (list) + "Return the cdr of the cdddr of a list." + (cdr (cdddr list))) + +(defun tree-equal (x y &key (test (function eql)) test-not) + "Returns T if X and Y are isomorphic trees with identical leaves." + (if test-not + (tree-equal-test-not x y test-not) + (tree-equal-test x y test))) + +(defun tree-equal-test-not (x y test-not) + (cond ((and (atom x) (atom y)) + (if (and (not x) (not y)) ;must special case end of both lists. + t + (if (not (funcall test-not x y)) t))) + ((consp x) + (and (consp y) + (tree-equal-test-not (car x) (car y) test-not) + (tree-equal-test-not (cdr x) (cdr y) test-not))) + (t ()))) + +(defun tree-equal-test (x y test) + (if (atom x) + (if (atom y) + (if (funcall test x y) t)) + (and (consp y) + (tree-equal-test (car x) (car y) test) + (tree-equal-test (cdr x) (cdr y) test)))) + +(defun first (list) + "Return the 1st object in a list or NIL if the list is empty." + (car list)) + +(defun second (list) + "Return the 2nd object in a list or NIL if there is no 2nd object." + (cadr list)) + +(defun third (list) + "Return the 3rd object in a list or NIL if there is no 3rd object." + (caddr list)) + +(defun fourth (list) + "Return the 4th object in a list or NIL if there is no 4th object." + (cadddr list)) + +(defun fifth (list) + "Return the 5th object in a list or NIL if there is no 5th object." + (car (cddddr list))) + +(defun sixth (list) + "Return the 6th object in a list or NIL if there is no 6th object." + (cadr (cddddr list))) + +(defun seventh (list) + "Return the 7th object in a list or NIL if there is no 7th object." + (caddr (cddddr list))) + +(defun eighth (list) + "Return the 8th object in a list or NIL if there is no 8th object." + (cadddr (cddddr list))) + +(defun ninth (list) + "Return the 9th object in a list or NIL if there is no 9th object." + (car (cddddr (cddddr list)))) + +(defun tenth (list) + "Return the 10th object in a list or NIL if there is no 10th object." + (cadr (cddddr (cddddr list)))) + +(defun rest (list) + "Means the same as the cdr of a list." + (cdr list)) +;;; List* is done the same as list, except that the last cons is made a +;;; dotted pair + + +;;; List Copying Functions + +;;; The list is copied correctly even if the list is not terminated by () +;;; The new list is built by cdr'ing splice which is always at the tail +;;; of the new list + + +(defun copy-alist (alist) + "Return a new association list which is EQUAL to ALIST." + (unless (endp alist) + (let ((result + (cons (if (endp (car alist)) + (car alist) + (cons (caar alist) (cdar alist)) ) + '() ))) + (do ((x (cdr alist) (cdr x)) + (splice result + (cdr (rplacd splice + (cons + (if (endp (car x)) + (car x) + (cons (caar x) (cdar x))) + '() ))) )) + ((endp x) result))))) + +;;; More Commonly-used List Functions + +(defun revappend (x y) + "Return (append (reverse x) y)." + (dolist (a x y) (push a y))) + + + + +(defun butlast (list &optional (n 1 n-p)) + "Returns a new list the same as List without the N last elements." + (setq list (require-type list 'list)) + (when (and n-p + (if (typep n 'fixnum) + (< (the fixnum n) 0) + (not (typep n 'unsigned-byte)))) + (report-bad-arg n 'unsigned-byte)) + (let* ((length (alt-list-length list))) + (declare (fixnum length)) ;guaranteed + (when (< n length) + (let* ((count (- length (the fixnum n))) + (head (cons nil nil)) + (tail head)) + (declare (fixnum count) (cons head tail) (dynamic-extent head)) + ;; Return a list of the first COUNT elements of list + (dotimes (i count (cdr head)) + (setq tail (cdr (rplacd tail (cons (pop list) nil))))))))) + + +(defun nbutlast (list &optional (n 1 n-p)) + "Modifies List to remove the last N elements." + (setq list (require-type list 'list)) + (when (and n-p + (if (typep n 'fixnum) + (< (the fixnum n) 0) + (not (typep n 'unsigned-byte)))) + (report-bad-arg n 'unsigned-byte)) + (let* ((length (alt-list-length list))) + (declare (fixnum length)) ;guaranteed + (when (< n length) + (let* ((count (1- (the fixnum (- length (the fixnum n))))) + (tail list)) + (declare (fixnum count) (list tail)) + (dotimes (i count (rplacd tail nil)) + (setq tail (cdr tail))) + list)))) + + +(defun ldiff (list object) + "Return a new list, whose elements are those of LIST that appear before + OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned. + LIST must be a proper list or a dotted list." + (do* ((list (require-type list 'list) (cdr list)) + (result (cons nil nil)) + (splice result)) + ((atom list) + (if (eql list object) + (cdr result) + (progn (rplacd splice list) (cdr result)))) + (declare (dynamic-extent result) + (cons splice result)) + (if (eql list object) + (return (cdr result)) + (setq splice (cdr (rplacd splice (list (car list)))))))) + + +;;; Functions to alter list structure + +;;; The following are for use by SETF. + +(defun %setnth (n list newval) + "Sets the Nth element of List (zero based) to Newval." + (if (%i< n 0) + (error "~S is an illegal N for SETF of NTH." n) + (do ((count n (%i- count 1))) + ((%izerop count) (rplaca list newval) newval) + (if (endp (cdr list)) + (error "~S is too large an index for SETF of NTH." n) + (setq list (cdr list)))))) + +(defun test-not-error (test test-not) + (%err-disp $xkeyconflict :test test :test-not test-not)) + +;;; Use this with the following keyword args: +;;; (&key (key #'identity) (test #'eql testp) (test-not nil notp)) + +(eval-when (eval compile #-bccl load) + (defmacro with-set-keys (funcall) + `(cond (notp ,(append funcall '(:key key :test-not test-not))) + (t ,(append funcall '(:key key :test test))))) + +;;; Works with the above keylist. We do three clauses so that if only test-not +;;; is supplied, then we don't test eql. In each case, the args should be +;;; multiply evaluable. + +(defmacro elements-match-p (elt1 elt2) + `(or (and testp + (funcall test (funcall key ,elt1) (funcall key ,elt2))) + (and notp + (not (funcall test-not (funcall key ,elt1) (funcall key ,elt2)))) + (eql (funcall key ,elt1) (funcall key ,elt2)))) + + + +) +;;; Substitution of expressions + +;subst that doesn't call labels +(defun subst (new old tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitutes new for subtrees matching old." + (if (and testp notp) + (test-not-error test test-not)) + (subst-aux new old tree key test test-not)) + +(defun subst-aux (new old subtree key test test-not) + (flet ((satisfies-the-test (item elt) + (let* ((val (if key (funcall key elt) elt))) + (if test-not + (not (funcall test-not item val)) + (funcall test item val))))) + (declare (inline satisfies-the-test)) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (let ((car (subst-aux new old (car subtree) + key test test-not )) + (cdr (subst-aux new old (cdr subtree) + key test test-not))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + +;;;subst-if without a call to labels +;;; I've always wondered how those calls to a special operator +;;; should best be avoided. Clearly, the answer involves +;;; lots of recursion. +(defun subst-if (new test tree &key key) + "Substitutes new for subtrees for which test is true." + (unless key (setq key #'identity)) + (cond ((funcall test (funcall key tree)) new) + ((atom tree) tree) + (t (let ((car (subst-if new test (car tree) :key key)) + (cdr (subst-if new test (cdr tree) :key key))) + (if (and (eq car (car tree)) + (eq cdr (cdr tree))) + tree + (cons car cdr)))))) + +;subst-if-not without a call to labels +(defun subst-if-not (new test tree &key key) + "Substitutes new for subtrees for which test is false." + (unless key (setq key #'identity)) + (cond ((not (funcall test (funcall key tree))) new) + ((atom tree) tree) + (t (let ((car (subst-if-not new test (car tree) :key key)) + (cdr (subst-if-not new test (cdr tree) :key key))) + (if (and (eq car (car tree)) + (eq cdr (cdr tree))) + tree + (cons car cdr)))))) + +(defun nsubst (new old tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitute NEW for subtrees matching OLD." + (if (and testp notp) + (test-not-error test test-not)) + (nsubst-aux new old tree (or key #'identity) test test-not)) + +(defun nsubst-aux (new old subtree key test test-not) + (flet ((satisfies-the-test (item elt) + (let* ((val (if key (funcall key elt) elt))) + (if test-not + (not (funcall test-not item val)) + (funcall test item val))))) + (declare (inline satisfies-the-test)) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (satisfies-the-test old subtree) + (set-cdr last new))) + (if (satisfies-the-test old subtree) + (return (set-cdr last new)) + (set-car subtree + (nsubst-aux new old (car subtree) + key test test-not)))) + subtree)))) + +(defun nsubst-if (new test tree &key key) + "Substitute NEW for subtrees of TREE for which TEST is true." + (unless key (setq key #'identity)) + (cond ((funcall test (funcall key tree)) new) + ((atom tree) tree) + (t (do* ((last nil tree) + (tree tree (cdr tree))) + ((atom tree) + (if (funcall test (funcall key tree)) + (set-cdr last new))) + (if (funcall test (funcall key tree)) + (return (set-cdr last new)) + (set-car tree + (nsubst-if new test (car tree) :key key)))) + tree))) + +(defun nsubst-if-not (new test tree &key key) + "Substitute NEW for subtrees of TREE for which TEST is false." + (unless key (setq key #'identity)) + (cond ((not (funcall test (funcall key tree))) new) + ((atom tree) tree) + (t (do* ((last nil tree) + (tree tree (cdr tree))) + ((atom tree) + (if (not (funcall test (funcall key tree))) + (set-cdr last new))) + (if (not (funcall test (funcall key tree))) + (return (set-cdr (cdr last) new)) + (set-car tree + (nsubst-if-not new test (car tree) :key key)))) + tree))) + +(defun sublis (alist tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitute from ALIST into TREE nondestructively." + (if (and testp notp) + (test-not-error test test-not)) + (sublis-aux alist tree (or key #'identity) test test-not notp)) + +(defun sublis-aux (alist subtree key test test-not notp) + (let ((assoc (if notp + (assoc (funcall key subtree) alist :test-not test-not) + (assoc (funcall key subtree) alist :test test)))) + (cond (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (sublis-aux alist (car subtree) + key test test-not notp)) + (cdr (sublis-aux alist (cdr subtree) + key test test-not notp))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + +(eval-when (compile eval) + (defmacro nsublis-macro () + '(if notp + (assoc (funcall key subtree) alist :test-not test-not) + (assoc (funcall key subtree) alist :test test))) + ) + +(defun nsublis (alist tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitute from ALIST into TRUE destructively." + (if (and testp notp) + (test-not-error test test-not)) + (nsublis-aux alist tree (or key #'identity) test test-not notp)) + +(defun nsublis-aux (alist subtree key test test-not notp &optional temp) + (cond ((setq temp (nsublis-macro)) + (cdr temp)) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (setq temp (nsublis-macro)) + (set-cdr last (cdr temp)))) + (if (setq temp (nsublis-macro)) + (return (set-cdr last (cdr temp))) + (set-car subtree + (nsublis-aux alist (car subtree) key test + test-not notp temp)))) + subtree))) + +;;; Functions for using lists as sets + + +(defun member-if (test list &key key ) + "Return tail of LIST beginning with first element satisfying TEST." + (unless key (setq key #'identity)) + (do ((list list (Cdr list))) + ((endp list) nil) + (if (funcall test (funcall key (car list))) + (return list)))) + +(defun member-if-not (test list &key key) + "Return tail of LIST beginning with first element not satisfying TEST." + (unless key (setq key #'identity)) + (do ((list list (cdr list))) + ((endp list) ()) + (if (not (funcall test (funcall key (car list)))) + (return list)))) + +(defun tailp (sublist list) ;Definition "B" + "Return true if OBJECT is the same as some tail of LIST, otherwise + returns false. LIST must be a proper list or a dotted list." + (do ((list list (%cdr list))) + ((atom list) (eql list sublist)) + (if (eq sublist list) + (return t)))) + + + +(defun union (list1 list2 &key + key + (test #'eql testp) + (test-not nil notp)) + "Returns the union of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res list2)) + (dolist (elt list1) + (if (not (with-set-keys (member (funcall key elt) list2))) + (push elt res))) + res)) + + + + + + +(eval-when (eval compile #-bccl load) +;;; Destination and source are setf-able and many-evaluable. +;;; Sets the source to the cdr, and "conses" the 1st elt of +;;; source to destination. +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (cdr ,source) + (cdr temp) ,destination + ,destination temp))) +) + +(defun nunion (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return the union of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res list2)) + (do () + ((endp list1)) + (if (not (with-set-keys (member (funcall key (car list1)) list2))) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + + + + +(defun intersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Return the intersection of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (dolist (elt list1) + (if (with-set-keys (member (funcall key elt) list2)) + (push elt res))) + res)) + +(defun nintersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return the intersection of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (do () ((endp list1)) + (if (with-set-keys (member (funcall key (car list1)) list2)) + (steve-splice list1 res) + (setq list1 (Cdr list1)))) + res)) + +(defun set-difference (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Return the elements of LIST1 which are not in LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (dolist (elt list1) + (if (not (with-set-keys (member (funcall key elt) list2))) + (push elt res))) + res)) + +(defun nset-difference (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return the elements of LIST1 which are not in LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (do () ((endp list1)) + (if (not (with-set-keys (member (funcall key (car list1)) list2))) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + +#| spice version +(defun set-exclusive-or (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Returns new list of elements appearing exactly once in List1 and List2. + If an element appears > once in a list and does not appear at all in the + other list, that element will appear >1 in the output list." + (let ((result nil)) + (dolist (elt list1) + (unless (with-set-keys (member (funcall key elt) list2)) + (setq result (cons elt result)))) + (dolist (elt list2) + (unless (with-set-keys (member (funcall key elt) list1)) + (setq result (cons elt result)))) + result)) +|# + +(defun set-exclusive-or (list1 list2 &key key + (test #'eql testp) (test-not nil notp) + &aux result elt1-compare elt2-compare) + "Return new list of elements appearing exactly once in LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (dolist (elt1 list1) + (setq elt1-compare (funcall key elt1)) + (if (if notp + (dolist (elt2 list2 t) + (if (not (funcall test-not elt1-compare (funcall key elt2))) + (return nil))) + (dolist (elt2 list2 t) + (if (funcall test elt1-compare (funcall key elt2)) + (return nil)))) + (push elt1 result))) + (dolist (elt2 list2) + (setq elt2-compare (funcall key elt2)) + (if (if notp + (dolist (elt1 list1 t) + (if (not (funcall test-not (funcall key elt1) elt2-compare)) + (return nil))) + (dolist (elt1 list1 t) + (if (funcall test (funcall key elt1) elt2-compare) + (return nil)))) + (push elt2 result))) + result) + +#| the description of the below SpiceLisp algorthm used for implementing + nset-exclusive-or sounds counter to CLtL. Furthermore, it fails +on the example (nset-exclusive-or (list 1 1) (list 1)) + [returns (1) but should return NIL.] ... fry + +;;; The outer loop examines list1 while the inner loop examines list2. If an +;;; element is found in list2 "equal" to the element in list1, both are +;;; spliced out. When the end of list1 is reached, what is left of list2 is +;;; tacked onto what is left of list1. The splicing operation ensures that +;;; the correct operation is performed depending on whether splice is at the +;;; top of the list or not + +(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) + (key #'identity)) + "Return a list with elements which appear but once in List1 and List2." + (do ((x list1 (cdr x)) + (splicex ())) + ((endp x) + (if (null splicex) + (setq list1 list2) + (rplacd splicex list2)) + list1) + (do ((y list2 (cdr y)) + (splicey ())) + ((endp y) (setq splicex x)) + (cond ((if notp + (not (funcall test-not (funcall key (car x)) + (funcall key (car y)))) + (funcall test (funcall key (car x)) + (funcall key (car y)))) + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (return ())) ; assume lists are really sets + (t (setq splicey y)))))) +|# + +(defun nset-exclusive-or (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return a list with elements which appear but once in LIST1 + and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (if notp + (set-exclusive-or list1 list2 :key key :test-not test-not) + (set-exclusive-or list1 list2 :key key :test test) + )) + +(defun subsetp (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Return T if every element in LIST1 is also in LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (dolist (elt list1) + (unless (with-set-keys (member (funcall key elt) list2)) + (return-from subsetp nil))) + T) + + +;;; Functions that operate on association lists + +(defun acons (key datum a-list) + "Construct a new alist by adding the pair (KEY . DATUM) to ALIST." + (cons (cons key datum) a-list)) + +(defun pairlis (keys data &optional (alist '())) + "Construct an association list from KEYS and DATA (adding to ALIST)." + (do ((x keys (cdr x)) + (y data (cdr y))) + ((and (endp x) (endp y)) alist) + (if (or (endp x) (endp y)) + (error "The lists of keys and data are of unequal length.")) + (setq alist (acons (car x) (car y) alist)))) + +(defun default-identity-key (key) + (and key (neq key 'identity) (neq key #'identity) (coerce-to-function key))) + +(defun assoc-if (predicate alist &key key) + "Return the first cons in ALIST whose CAR satisfies PREDICATE. If + KEY is supplied, apply it to the CAR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (funcall predicate + (if key (funcall key (car pair)) + (car pair)))) + (return pair)))) + +(defun assoc-if-not (predicate alist &key key) + "Return the first cons in ALIST whose CAR does not satisfy PREDICATE. + If KEY is supplied, apply it to the CAR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (not (funcall predicate + (if key (funcall key (car pair)) + (car pair))))) + (return pair)))) + +(defun rassoc-if (predicate alist &key key) + "Return the first cons in ALIST whose CDR satisfies PREDICATE. If KEY + is supplied, apply it to the CDR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (funcall predicate + (if key (funcall key (cdr pair)) + (cdr pair)))) + (return pair)))) + +(defun rassoc-if-not (predicate alist &key key) + "Return the first cons in ALIST whose CDR does not satisfy PREDICATE. + If KEY is supplied, apply it to the CDR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (not (funcall predicate + (if key (funcall key (cdr pair)) + (cdr pair))))) + (return pair)))) + + +(defun map1 (function original-arglists accumulate take-car) + "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. + It Maps function over the arglists in the appropriate way. It is done when any + of the arglists runs out. Until then, it CDRs down the arglists calling the + function and accumulating results as desired." + (let* ((length (length original-arglists)) + (arglists (make-list length)) + (args (make-list length)) + (ret-list (list nil)) + (temp ret-list)) + (declare (dynamic-extent arglists args ret-list)) + (let ((argstail arglists)) + (dolist (arg original-arglists) + (setf (car (the cons argstail)) arg) + (pop argstail))) + (do ((res nil) + (argstail args args)) + ((memq nil arglists) + (if accumulate + (cdr ret-list) + (car original-arglists))) + (do ((l arglists (cdr l))) + ((not l)) + (setf (car (the cons argstail)) (if take-car (car (car l)) (car l))) + (rplaca l (cdr (car l))) + (pop argstail)) + (setq res (apply function args)) + (case accumulate + (:nconc + (setq temp (last (nconc temp res)))) + (:list (rplacd temp (list res)) + (setq temp (cdr temp))))))) + +(defun mapc (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists. Return the second argument." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists nil t)))) + +(defun mapcar (function list &rest more-lists) + "Apply FUNCTION to successive elements of LIST. Return list of FUNCTION + return values." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :list t)))) + +(defun mapcan (function list &rest more-lists) + "Apply FUNCTION to successive elements of LIST. Return NCONC of FUNCTION + results." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :nconc t)))) + +(defun mapl (function list &rest more-lists) + "Apply FUNCTION to successive CDRs of list. Return NIL." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists nil nil)))) + +(defun maplist (function list &rest more-lists) + "Apply FUNCTION to successive CDRs of list. Return list of results." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :list nil)))) + +(defun mapcon (function list &rest more-lists) + "Apply FUNCTION to successive CDRs of lists. Return NCONC of results." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :nconc nil)))) + +;;; Functions for compatibility sake: + +(defun delq (item a-list &optional (n 0 np)) + "Returns list with all (up to n) elements with all elements EQ to ITEM + deleted" + ;(%print "a-list = " a-list) + (declare (type list a-list) (type integer n)) + ;(%print "a-list = " a-list) + (do ((x a-list (cdr x)) + (splice '())) + ((or (endp x) + (and np (zerop n))) + a-list) + ; (%print "a-list = " a-list) + (cond ((eq item (car x)) + (setq n (- n 1)) + (if (null splice) + (setq a-list (cdr x)) + (rplacd splice (cdr x)))) + (T (setq splice x))))) ; move splice along to include element + +(defun list-length-and-final-cdr (list) + "First value reutrned is length of regular list. + [for (a b . c), returns 2] + [for circular lists, returns NIL] + Second value is the final cdr. + [ for (a b), returns NIL + for (a b . c), returns c + for circular lists, returns NIL] + Third value only returned if we have a circular list. It is + the MAX possible length of the list until the repeat." + (do* ((n 0 (+ n 2)) + (fast list (cddr fast)) + (slow list (cdr slow))) + () + (declare (fixnum n)) + (cond ((null fast) + (return (values n nil))) + ((not (consp fast)) + (return (values n fast))) + ((null (cdr fast)) + (return (values (1+ n) nil))) + ((and (eq fast slow) (> n 0)) ;circular list + (return (values nil nil n))) + ((not (consp (cdr fast))) + (return (values (1+ n) (cdr fast))))))) + +(provide 'lists) Index: /branches/qres/ccl/lib/macros.lisp =================================================================== --- /branches/qres/ccl/lib/macros.lisp (revision 13564) +++ /branches/qres/ccl/lib/macros.lisp (revision 13564) @@ -0,0 +1,3843 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Macros (and functions/constants used at macroexpand-time) ONLY. + +(in-package "CCL") + +(eval-when (eval compile) + (require "LEVEL-2") + (require "BACKQUOTE") + (require "DEFSTRUCT-MACROS")) + +;; Constants + +(defmacro defconstant (sym val &optional (doc () doc-p) &environment env) + "Define a global constant, saying that the value is constant and may be + compiled into code. If the variable already has a value, and this is not + EQL to the new value, the code is not portable (undefined behavior). The + third argument is an optional documentation string for the variable." + (setq sym (require-type sym 'symbol) + doc (if doc-p (require-type doc 'string))) + `(progn + (eval-when (:compile-toplevel) + (define-compile-time-constant ',sym ',val ,env)) + (eval-when (:load-toplevel :execute) + (%defconstant ',sym ,val ,@(if doc-p (list doc)))))) + +;; Lists + +(defmacro %car (x) + `(car (the list ,x))) + +(defmacro set-%car (x y) + `(setf (car (the cons ,x)) ,y)) + +(defmacro %cdr (x) + `(cdr (the list ,x))) + +(defmacro set-%cdr (x y) + `(setf (cdr (the cons ,x)) ,y)) + +(defmacro %caar (x) + `(%car (%car ,x))) + +(defmacro %cadr (x) + `(%car (%cdr ,x))) + +(defmacro %cdar (x) + `(%cdr (%car ,x))) + +(defmacro %cddr (x) + `(%cdr (%cdr ,x))) + +(defmacro %caaar (x) + `(%car (%car (%car ,x)))) + +(defmacro %caadr (x) + `(%car (%car (%cdr ,x)))) + +(defmacro %cadar (x) + `(%car (%cdr (%car ,x)))) + +(defmacro %caddr (x) + `(%car (%cdr (%cdr ,x)))) + +(defmacro %cdaar (x) + `(%cdr (%car (%car ,x)))) + +(defmacro %cdadr (x) + `(%cdr (%car (%cdr ,x)))) + +(defmacro %cddar (x) + `(%cdr (%cdr (%car ,x)))) + +(defmacro %cdddr (x) + `(%cdr (%cdr (%cdr ,x)))) + +(defmacro %rplaca (x y) + `(rplaca (the cons ,x) ,y)) + +(defmacro %rplacd (x y) + `(rplacd (the cons ,x) ,y)) + +; These are open-coded by the compiler to isolate platform +; dependencies. + +(defmacro %unbound-marker-8 () + `(%unbound-marker)) + +(defmacro %slot-missing-marker () + `(%illegal-marker)) + + + + +(defmacro %null-ptr () '(%int-to-ptr 0)) + +;;;Assorted useful macro definitions + +(defmacro def-accessors (ref &rest names) + (define-accessors ref names)) + +(defmacro def-accessor-macros (ref &rest names) + (define-accessors ref names t)) + +(defun define-accessors (ref names &optional no-constants + &aux (arg (gensym)) (index 0) progn types) + (when (listp ref) + (setq types ref + ref (pop names))) + (dolist (name names) + (when name + (unless (listp name) (setq name (list name))) + (dolist (sym name) + (when sym + (push `(defmacro ,sym (,arg) (list ',ref ,arg ,index)) progn) + (unless no-constants + (push `(defconstant ,sym ,index) progn))))) + (setq index (1+ index))) + `(progn + ,.(nreverse progn) + ,@(if types `((add-accessor-types ',types ',names))) + ,index)) + +(defmacro specialv (var) + `(locally (declare (special ,var)) ,var)) + + +(defmacro prog1 (valform &rest otherforms) + (let ((val (gensym))) + `(let ((,val ,valform)) + ,@otherforms + ,val))) + +(defmacro prog2 (first second &rest others) + `(progn ,first (prog1 ,second ,@others))) + +(defmacro prog (inits &body body &environment env) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(block nil + (let ,inits + ,@decls + (tagbody ,@forms))))) + +(defmacro prog* (inits &body body &environment env) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(block nil + (let* ,inits + ,@decls + (tagbody ,@forms))))) + + +(defmacro %stack-block ((&rest specs) &body forms &aux vars lets) + (dolist (spec specs) + (destructuring-bind (var ptr &key clear) spec + (push var vars) + (push `(,var (%new-ptr ,ptr ,clear)) lets))) + `(let* ,(nreverse lets) + (declare (dynamic-extent ,@vars)) + (declare (type macptr ,@vars)) + (declare (unsettable ,@vars)) + ,@forms)) + +(defmacro %vstack-block (spec &body forms) + `(%stack-block (,spec) ,@forms)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun extract-bound-decls-for-dolist-var (var decls env) + (if (null decls) + (values nil nil) + (collect ((var-decls) + (other-decls)) + (dolist (declform decls + (let* ((vdecls (var-decls)) + (others (other-decls))) + (values (if vdecls `((declare ,@vdecls))) + (if others `((declare ,@others)))))) + ;; (assert (eq (car declform) 'declare)) + (dolist (decl (cdr declform)) + (if (atom decl) + (other-decls decl) + (let* ((spec (car decl))) + (if (specifier-type-if-known spec env) + (setq spec 'type + decl `(type ,@decl))) + (case spec + (type + (destructuring-bind (typespec &rest vars) (cdr decl) + (cond ((member var vars :test #'eq) + (setq vars (delete var vars)) + (var-decls `(type ,typespec ,var)) + (when vars + (other-decls `(type ,typespec ,@vars)))) + (t (other-decls decl))))) + ((special ingore ignorable ccl::ignore-if-unused) + (let* ((vars (cdr decl))) + (cond ((member var vars :test #'eq) + (setq vars (delete var vars)) + (var-decls `(,spec ,var)) + (when vars + (other-decls `(,spec ,@vars)))) + (t (other-decls decl))))) + (t (other-decls decl)))))))))) +) + + + +(defmacro dolist ((varsym list &optional ret) &body body &environment env) + (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym)) + (multiple-value-bind (forms decls) (parse-body body env nil) + (multiple-value-bind (var-decls other-decls) + (extract-bound-decls-for-dolist-var varsym decls env) + (let* ((lstsym (gensym))) + `(do* ((,lstsym ,list (cdr (the list ,lstsym)))) + ((null ,lstsym) + ,@(if ret `((let* ((,varsym ())) + (declare (ignorable ,varsym)) + ,ret)))) + ,@other-decls + (let* ((,varsym (car ,lstsym))) + ,@var-decls + (tagbody ,@forms))))))) + +(defmacro dovector ((varsym vector &optional ret) &body body &environment env) + (if (not (symbolp varsym))(signal-program-error $XNotSym varsym)) + (let* ((toplab (gensym)) + (tstlab (gensym)) + (lengthsym (gensym)) + (indexsym (gensym)) + (vecsym (gensym))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,vecsym ,vector) + (,lengthsym (length ,vecsym)) + (,indexsym 0) + ,varsym) + ,@decls + ,@(let ((type (nx-form-type vector env))) + (unless (eq type t) + `((declare (type ,type ,vecsym))))) + (block nil + (tagbody + (go ,tstlab) + ,toplab + (setq ,varsym (locally (declare (optimize (speed 3) (safety 0))) + (aref ,vecsym ,indexsym)) + ,indexsym (%i+ ,indexsym 1)) + ,@forms + ,tstlab + (if (%i< ,indexsym ,lengthsym) (go ,toplab))) + ,@(if ret `((progn (setq ,varsym nil) ,ret)))))))) + +(defmacro report-bad-arg (&rest args) + `(values (%badarg ,@args))) + +(defmacro %cons-restart (name action report interactive test) + `(%istruct 'restart ,name ,action ,report ,interactive ,test)) + +(defmacro restart-bind (clauses &body body) + "Executes forms in a dynamic context where the given restart bindings are + in effect. Users probably want to use RESTART-CASE. When clauses contain + the same restart name, FIND-RESTART will find the first such clause." + (let* ((restarts (mapcar #'(lambda (clause) + (list (make-symbol (symbol-name (require-type (car clause) 'symbol))) + `(%cons-restart nil nil nil nil nil))) + clauses)) + (bindings (mapcar #'(lambda (clause name) + `(make-restart ,(car name) ',(car clause) + ,@(cdr clause))) + clauses restarts)) + (cluster (gensym))) + `(let* (,@restarts) + (declare (dynamic-extent ,@(mapcar #'car restarts))) + (let* ((,cluster (list ,@bindings)) + (%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent ,cluster %restarts%)) + (progn + ,@body))))) + +(defmacro handler-bind (clauses &body body) + "(HANDLER-BIND ( {(type handler)}* ) body) + Executes body in a dynamic context where the given handler bindings are + in effect. Each handler must take the condition being signalled as an + argument. The bindings are searched first to last in the event of a + signalled condition." + (let* ((fns) + (decls) + (bindings (mapcan #'(lambda (clause) + (destructuring-bind (condition handler) clause + (if (and (consp handler)(eq (car handler) 'function) + (consp (cadr handler))(eq (car (cadr handler)) 'lambda)) + (let ((fn (gensym))) + (push `(,fn ,handler) fns) + (push `(declare (dynamic-extent ,fn)) decls) + `(',condition ,fn)) + (list `',condition + `,handler)))) + clauses)) + (cluster (gensym))) + (if (null bindings) + `(progn ,@body) + `(let* (,@fns + (,cluster (list ,@bindings)) + (%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent ,cluster %handlers%)) + ,@decls + ,@body)))) + +(defmacro restart-case (&environment env form &rest clauses) + "(RESTART-CASE form + {(case-name arg-list {keyword value}* body)}*) + The form is evaluated in a dynamic context where the clauses have special + meanings as points to which control may be transferred (see INVOKE-RESTART). + When clauses contain the same case-name, FIND-RESTART will find the first + such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or + macroexpands into such) then the signalled condition will be associated with + the new restarts." + (let ((cluster nil)) + (when clauses (setq cluster (gensym) form (restart-case-form form env cluster))) + (flet ((restart-case-1 (name arglist &rest forms) + (let (interactive report test) + (loop + (case (car forms) + (:interactive (setq interactive (cadr forms))) + (:report (setq report (cadr forms))) + (:test (setq test (cadr forms))) + (t (return nil))) + (setq forms (cddr forms))) + (when (and report (not (stringp report))) + (setq report `#',report)) + (when interactive + (setq interactive `#',interactive)) + (when test + (setq test `#',test)) + (values (require-type name 'symbol) arglist report interactive test forms)))) + (cond ((null clauses) form) + ((and (null (cdr clauses)) (null (cadr (car clauses)))) + (let ((block (gensym)) + (restart-name (gensym))) + (multiple-value-bind (name arglist report interactive test body) + (apply #'restart-case-1 (car clauses)) + (declare (ignore arglist)) + `(block ,block + (let* ((,restart-name (%cons-restart ',name () ,report ,interactive ,test)) + (,cluster (list ,restart-name))) + (declare (dynamic-extent ,restart-name ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + (return-from ,block ,form)))) + ,@body)))) + (t + (let ((block (gensym)) (val (gensym)) + (index -1) restarts restart-names restart-name cases) + (while clauses + (setq index (1+ index)) + (multiple-value-bind (name arglist report interactive test body) + (apply #'restart-case-1 (pop clauses)) + (push (setq restart-name (make-symbol (symbol-name name))) restart-names) + (push (list restart-name `(%cons-restart ',name ,index ,report ,interactive ,test)) + restarts) + (when (null clauses) (setq index t)) + (push `(,index (apply #'(lambda ,arglist ,@body) ,val)) + cases))) + `(block ,block + (let ((,val (let* (,@restarts + (,cluster (list ,@(reverse restart-names)))) + (declare (dynamic-extent ,@restart-names ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + (return-from ,block ,form)))))) + (case (pop ,val) + ,@(nreverse cases)))))))))) + + +; Anything this hairy should die a slow and painful death. +; Unless, of course, I grossly misunderstand... +(defun restart-case-form (form env clustername) + (let ((expansion (macroexpand form env)) + (head nil)) + (if (and (listp expansion) ; already an ugly hack, made uglier by %error case ... + (memq (setq head (pop expansion)) '(signal error cerror warn %error))) + (let ((condform nil) + (signalform nil) + (cname (gensym))) + (case head + (cerror + (destructuring-bind + (continue cond &rest args) expansion + (setq condform `(condition-arg ,cond (list ,@args) 'simple-error) + signalform `(cerror ,continue ,cname)))) + ((signal error warn) + (destructuring-bind + (cond &rest args) expansion + (setq condform `(condition-arg ,cond (list ,@args) ,(if (eq head 'warning) + ''simple-warning + (if (eq head 'error) + ''simple-error + ''simple-condition))) + signalform `(,head ,cname)))) + (t ;%error + (destructuring-bind (cond args fp) expansion + (setq condform `(condition-arg ,cond ,args 'simple-error) + signalform `(%error ,cname nil ,fp))))) + `(let ((,cname ,condform)) + (with-condition-restarts ,cname ,clustername + ,signalform))) + form))) + + +(defmacro handler-case (form &rest clauses) + "(HANDLER-CASE form + { (type ([var]) body) }* ) + Execute FORM in a context with handlers established for the condition + types. A peculiar property allows type to be :NO-ERROR. If such a clause + occurs, and form returns normally, all its values are passed to this clause + as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one + var specification." + (let* ((no-error-clause (assoc :no-error clauses))) + (if no-error-clause + (let* ((normal-return (gensym)) + (error-return (gensym))) + `(block ,error-return + (multiple-value-call #'(lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause clauses))))))) + (flet ((handler-case (type var &rest body) + (when (eq type :no-error) + (signal-program-error "Duplicate :no-error clause. ")) + (values type var body))) + (cond ((null clauses) form) + ((null (cdr clauses)) + (let ((block (gensym)) + (cluster (gensym))) + (multiple-value-bind (type var body) + (apply #'handler-case (car clauses)) + (if var + `(block ,block + ((lambda ,var ,@body) + (let* ((,cluster (list ',type))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent %handlers%)) + (return-from ,block ,form)))))) + `(block ,block + (let* ((,cluster (list ',type))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent %handlers%)) + (return-from ,block ,form))) + (locally ,@body))))))) + (t (let ((block (gensym)) (cluster (gensym)) (val (gensym)) + (index -1) handlers cases) + (while clauses + (setq index (1+ index)) + (multiple-value-bind (type var body) + (apply #'handler-case (pop clauses)) + (push `',type handlers) + (push index handlers) + (when (null clauses) (setq index t)) + (push (if var + `(,index ((lambda ,var ,@body) ,val)) + `(,index (locally ,@body))) cases))) + `(block ,block + (let ((,val (let* ((,cluster (list ,@(nreverse handlers)))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent %handlers%)) + (return-from ,block ,form)))))) + (case (pop ,val) + ,@(nreverse cases))))))))))) + +(defmacro with-simple-restart ((restart-name format-string &rest format-args) + &body body + &aux (cluster (gensym)) (temp (make-symbol (symbol-name restart-name)))) + "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) + body) + If restart-name is not invoked, then all values returned by forms are + returned. If control is transferred to this restart, it immediately + returns the values NIL and T." + (unless (and (stringp format-string) + (null format-args) + (not (%str-member #\~ (ensure-simple-string format-string)))) + (let ((stream (gensym))) + (setq format-string `#'(lambda (,stream) (format ,stream ,format-string ,@format-args))))) + `(let* ((,temp (%cons-restart ',restart-name + 'simple-restart + ,format-string + nil + nil)) + (,cluster (list ,temp))) + (declare (dynamic-extent ,temp ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + ,@body)))) + +;Like with-simple-restart but takes a pre-consed restart. Not CL. +(defmacro with-restart (restart &body body &aux (cluster (gensym))) + `(let* ((,cluster (list ,restart))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + ,@body)))) + +(defmacro ignore-errors (&rest forms) + "Execute FORMS handling ERROR conditions, returning the result of the last + form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled." + `(handler-case (progn ,@forms) + (error (condition) (values nil condition)))) + +(defmacro def-kernel-restart (&environment env errno name arglist &body body) + (multiple-value-bind (body decls) + (parse-body body env) + `(let* ((fn (nfunction ,name (lambda ,arglist ,@decls (block ,name ,@body)))) + (pair (assq ,errno ccl::*kernel-restarts*))) + (if pair + (rplacd pair fn) + (push (cons ,errno fn) ccl::*kernel-restarts*)) + fn))) + + +;;; Setf. + +; If you change anything here, be sure to make the corresponding change +; in get-setf-method. +(defmacro setf (&rest args &environment env) + "Takes pairs of arguments like SETQ. The first is a place and the second + is the value that is supposed to go into that place. Returns the last + value. The place argument may be any of the access forms for which SETF + knows a corresponding setting form." + (let ((temp (length args)) + (accessor nil)) + (cond ((eq temp 2) + (let* ((form (car args)) + (value (cadr args))) + ;This must match get-setf-method . + (cond ((atom form) + (progn + (unless (symbolp form)(signal-program-error $XNotSym form)) + `(setq ,form ,value))) + ((eq (car form) 'the) + (unless (eql (length form) 3) + (error "Bad THE place form in (SETF ~S ~S)" form value)) + (destructuring-bind (type place) (cdr form) + `(setf ,place (the ,type ,value)))) + (t + (multiple-value-bind (ftype local-p) + (function-information (setq accessor (car form)) ENV) + (if local-p + (if (eq ftype :function) + ;Local function, so don't use global setf definitions. + (default-setf form value env) + `(setf ,(macroexpand-1 form env) ,value)) + (cond + ((setq temp (%setf-method accessor)) + (if (symbolp temp) + `(,temp ,@(cdar args) ,value) + (multiple-value-bind (dummies vals storevars setter #|getter|#) + (funcall temp form env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil)) + ((null d) + (setq let-list (nreverse let-list)) + `(let* ,let-list + (declare (ignorable ,@dummies)) + (multiple-value-bind ,storevars ,value + #|,getter|# + ,setter))) + (push (list (car d) (car v)) let-list))))) + ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env) + (and #-bccl (boundp '%structure-refs%) + (gethash accessor %structure-refs%))))) + (not (refinfo-r/o (if (consp temp) (%cdr temp) temp)))) + (if (consp temp) + ;; strip off type, but add in a require-type + (let ((type (%car temp))) + `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args) env) + (require-type ,value ',type)))) + `(setf ,(defstruct-ref-transform temp (%cdar args) env) + ,value))) + (t + (multiple-value-bind (res win) + (macroexpand-1 form env) + (if win + `(setf ,res ,value) + (default-setf form value env))))))))))) + ((oddp temp) + (signal-program-error "Odd number of args to SETF : ~s." args)) + (t (do* ((a args (cddr a)) (l nil)) + ((null a) `(progn ,@(nreverse l))) + (push `(setf ,(car a) ,(cadr a)) l)))))) + + +(defun default-setf (setter value &optional env) + (let* ((reader (car setter)) + (args (cdr setter)) + (gensyms (mapcar #'(lambda (sym) (declare (ignore sym)) (gensym)) args)) + types declares) + (flet ((form-type (form) + (nx-form-type form env))) + (declare (dynamic-extent #'form-type)) + (setq types (mapcar #'form-type args))) + (dolist (sym gensyms) + (let ((sym-type (pop types))) + (unless (eq sym-type t) + (push `(type ,sym-type ,sym) declares)))) + `(let ,(mapcar #'list gensyms args) + ,@(and declares (list `(declare ,@(nreverse declares)))) + (funcall #'(setf ,reader) ,value ,@gensyms)))) + +;; Establishing these setf-inverses is something that should +;; happen at compile-time +(defsetf elt set-elt) +(defsetf car set-car) +(defsetf %car set-%car) +(defsetf first set-car) +(defsetf cdr set-cdr) +(defsetf %cdr set-%cdr) +(defsetf rest set-cdr) +(defsetf uvref uvset) +(defsetf aref aset) +(defsetf svref svset) +(defsetf %svref %svset) +(defsetf char set-char) +(defsetf schar set-schar) +(defsetf %scharcode %set-scharcode) +(defsetf symbol-value set) +(defsetf symbol-plist set-symbol-plist) +(defsetf fill-pointer set-fill-pointer) + +; This sux; it calls the compiler twice (once to shove the macro in the +; environment, once to dump it into the file.) +(defmacro defmacro (name arglist &body body &environment env) + (unless (symbolp name)(signal-program-error $XNotSym name)) + (unless (listp arglist) (signal-program-error "~S is not a list." arglist)) + (multiple-value-bind (lambda-form doc) + (parse-macro-1 name arglist body env) + (let* ((normalized (normalize-lambda-list arglist t t)) + (body-pos (position '&body normalized)) + (argstring (let ((temp nil)) + (dolist (arg normalized) + (if (eq arg '&aux) + (return) + (push arg temp))) + (format nil "~:a" (nreverse temp))))) + (if (and body-pos (memq '&optional normalized)) (decf body-pos)) + `(progn + (eval-when (:compile-toplevel) + (define-compile-time-macro ',name ',lambda-form ',env)) + (eval-when (:load-toplevel :execute) + (%macro + (nfunction ,name ,lambda-form) + '(,doc ,body-pos . ,argstring)) + ',name))))) + +(defmacro define-symbol-macro (name expansion &environment env) + (unless (symbolp name)(signal-program-error $XNotSym name)) + `(progn + (eval-when (:compile-toplevel) + (define-compile-time-symbol-macro ',name ',expansion ',env)) + (eval-when (:load-toplevel :execute) + (%define-symbol-macro ',name ',expansion)))) + +;; ---- allow inlining setf functions +(defmacro defun (spec args &body body &environment env &aux global-name inline-spec) + "Define a function at top level." + (validate-function-name spec) + (setq args (require-type args 'list)) + (setq body (require-type body 'list)) + (multiple-value-bind (forms decls doc) (parse-body body env t) + (cond ((symbolp spec) + (setq global-name spec) + (setq inline-spec spec) + (setq body `(block ,spec ,@forms))) + ((setf-function-name-p spec) + (setq inline-spec spec) + (setq body `(block ,(cadr spec) ,@forms))) + (t (setq body `(progn ,@forms)))) + (let* ((lambda-expression `(lambda ,args + ,@(if global-name + `((declare (global-function-name ,global-name)))) + ,@decls ,body)) + (info (if (and inline-spec + (or (null env) + (definition-environment env t)) + (nx-declared-inline-p inline-spec env) + (not (and (symbolp inline-spec) + (gethash inline-spec *NX1-ALPHATIZERS*)))) + (cons doc lambda-expression) + doc))) + `(progn + (%defun (nfunction ,spec ,lambda-expression) ',info) + ',spec)))) + +(defmacro %defvar-init (var initform doc) + `(unless (%defvar ',var ,doc) + (set ',var ,initform))) + +(defmacro defvar (&environment env var &optional (value () value-p) doc) + "Define a global variable at top level. Declare the variable + SPECIAL and, optionally, initialize it. If the variable already has a + value, the old value is not clobbered. The third argument is an optional + documentation string for the variable." + (if (and doc (not (stringp doc))) (report-bad-arg doc 'string)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var ,value-p ,env)) + ,(if value-p + `(%defvar-init ,var ,value ,doc) + `(%defvar ',var)) + ',var)) + +(defmacro def-standard-initial-binding (name &optional (form name) (doc nil doc-p) &environment env) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',name t ,env)) + (define-standard-initial-binding ',name #'(lambda () ,form)) + ,@(when doc-p + `((set-documentation ',name 'variable ,doc))) + ',name)) + +(defmacro defparameter (&environment env var value &optional doc) + "Define a parameter that is not normally changed by the program, + but that may be changed without causing an error. Declare the + variable special and sets its value to VAL, overwriting any + previous value. The third argument is an optional documentation + string for the parameter." + (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var t ,env)) + (%defparameter ',var ,value ,doc))) + + +(defmacro defstatic (&environment env var value &optional doc) + "Syntax is like DEFPARAMETER. Proclaims the symbol to be special, +but also asserts that it will never be given a per-thread dynamic +binding. The value of the variable can be changed (via SETQ, etc.), +but since all threads access the same static binding of the variable, +such changes should be made with care." + (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var :global ,env)) + (%defglobal ',var ,value ,doc))) + +(defmacro defstaticvar (&environment env var value &optional doc) + "Syntax is like DEFVAR. Proclaims the symbol to be special, +but also asserts that it will never be given a per-thread dynamic +binding. The value of the variable can be changed (via SETQ, etc.), +but since all threads access the same static binding of the variable, +such changes should be made with care. Like DEFVAR, the initial value +form is not evaluated if the variable is already BOUNDP." + (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var :global ,env)) + (%symbol-bits ',var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits ',var)))) + (%defvar-init ,var ,value ,doc))) + + +(defmacro defglobal (&rest args) + "Synonym for DEFSTATIC." + `(defstatic ,@args)) + + +(defmacro defloadvar (var value &optional doc) + `(progn + (defstaticvar ,var ,nil ,@(if doc `(,doc))) + (def-ccl-pointers ,var () + (setq ,var ,value)) + ',var)) + + + + +(defmacro qlfun (name args &body body) + `(nfunction ,name (lambda ,args ,@body))) + +(defmacro lfun-bits-known-function (f) + (let* ((temp (gensym))) + `(let* ((,temp (function-to-function-vector ,f))) + (%svref ,temp (the fixnum (1- (the fixnum (uvsize ,temp)))))))) + +(defmacro lfunloop (for var in function &body loop-body) + "Loop over immediates in function" + (assert (and (or (equal (symbol-name for) "FOR") (equal (symbol-name for) "AS")) + (equal (symbol-name in) "IN"))) + (let ((fn (gensym)) + (lfv (gensym)) + (i (gensym))) + `(loop with ,fn = ,function + with ,lfv = (function-to-function-vector ,fn) + for ,i from #+ppc-target 1 #+x86-target (%function-code-words ,fn) below (%i- (uvsize ,lfv) 1) + as ,var = (%svref ,lfv ,i) + ,@loop-body))) + +(defmacro cond (&rest args &aux clause) + (when args + (setq clause (car args)) + (if (cdr clause) + `(if ,(car clause) (progn ,@(cdr clause)) (cond ,@(cdr args))) + (if (cdr args) `(or ,(car clause) (cond ,@(cdr args))) + `(values ,(car clause)))))) + +(defmacro and (&rest args) + "And Form* +AND evaluates each form in sequence, from left to right. If any form +returns NIL, AND returns NIL; otherwise, AND returns the values(s) returned +by the last form. If there are no forms, AND returns T." + (if (null args) t + (if (null (cdr args)) (car args) + `(if ,(car args) (and ,@(cdr args)))))) + +(defmacro or (&rest args) + "Or Form* +OR evaluates each Form, in sequence, from left to right. +If any Form but the last returns a non-NIL value, OR returns that +single value (without evaluating any subsequent Forms.) If OR evaluates +the last Form, it returns all values returned by that Form. If there +are no Forms, OR returns NIL." + (if args + (if (cdr args) + (do* ((temp (gensym)) + (handle (list nil)) + (forms `(let ((,temp ,(pop args))) + (if ,temp ,temp ,@handle)))) + ((null (cdr args)) + (%rplaca handle (%car args)) + forms) + (%rplaca handle `(if (setq ,temp ,(%car args)) + ,temp + ,@(setq handle (list nil)))) + (setq args (%cdr args))) + (%car args)))) + +(defmacro case (key &body forms) + "CASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If a singleton key is T then the clause is a default clause." + (let ((key-var (gensym))) + `(let ((,key-var ,key)) + (declare (ignorable ,key-var)) + (cond ,@(case-aux forms key-var nil nil))))) + +(defmacro ccase (keyplace &body forms) + "CCASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then a correctable error is + signalled." + (let* ((key-var (gensym)) + (tag (gensym))) + `(prog (,key-var) + ,tag + (setq ,key-var ,keyplace) + (return (cond ,@(case-aux forms key-var tag keyplace)))))) + +(defmacro ecase (key &body forms) + "ECASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then an error is signalled." + (let* ((key-var (gensym))) + `(let ((,key-var ,key)) + (declare (ignorable ,key-var)) + (cond ,@(case-aux forms key-var 'ecase nil))))) + +(defun case-aux (clauses key-var e-c-p placename &optional (used-keys (list (list '%case-core)))) + (if clauses + (let* ((key-list (caar clauses)) + (stype (if e-c-p (if (eq e-c-p 'ecase) e-c-p 'ccase) 'case)) + (test (cond ((and (not e-c-p) + (or (eq key-list 't) + (eq key-list 'otherwise))) + t) + (key-list + (cons 'or + (case-key-testers key-var used-keys key-list stype))))) + (consequent-list (or (%cdar clauses) '(nil)))) + (if (eq test t) + (progn + (when (%cdr clauses) (warn "~s or ~s clause in the middle of a ~s statement. Subsequent clauses ignored." + 't 'otherwise 'case)) + (cons (cons t consequent-list) nil)) + (cons (cons test consequent-list) + (case-aux (%cdr clauses) key-var e-c-p placename used-keys)))) + (when e-c-p + (setq used-keys `(member ,@(mapcar #'car (cdr used-keys)))) + (if (eq e-c-p 'ecase) + `((t (values (%err-disp #.$XWRONGTYPE ,key-var ',used-keys)))) + `((t (setf ,placename (ensure-value-of-type ,key-var ',used-keys ',placename)) + (go ,e-c-p))))))) + + +;;; We don't want to descend list structure more than once (like this has +;;; been doing for the last 18 years or so.) +(defun case-key-testers (symbol used-keys atom-or-list statement-type &optional recursive) + (if (or recursive (atom atom-or-list)) + (progn + (if (assoc atom-or-list used-keys) + (warn "Duplicate keyform ~s in ~s statement." atom-or-list statement-type) + (setq used-keys (nconc used-keys (list (cons atom-or-list t))))) + `((,(if (typep atom-or-list '(and number (not fixnum))) + 'eql + 'eq) + ,symbol ',atom-or-list))) + (nconc (case-key-testers symbol used-keys (car atom-or-list) statement-type t) + (when (cdr atom-or-list) + (case-key-testers symbol used-keys (%cdr atom-or-list) statement-type nil))))) + + +; generate the COND body of a {C,E}TYPECASE form +(defun typecase-aux (key-var clauses &optional e-c-p keyform) + (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase)) + (types ()) + (body ()) + otherwise-seen-p) + (flet ((bad-clause (c) + (signal-program-error "Invalid clause ~S in ~S form." c construct))) + (dolist (clause clauses) + (if (atom clause) + (bad-clause clause)) + (if otherwise-seen-p + (signal-program-error "OTHERWISE must be final clause in ~S form." construct)) + (destructuring-bind (typespec &body consequents) clause + (when (eq construct 'typecase) + (if (eq typespec 'otherwise) + (progn (setq typespec t) + (setq otherwise-seen-p t)))) + (unless + (dolist (already types nil) + (when (subtypep typespec already) + (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses)) + (return t))) + (push typespec types) + (setq typespec `(typep ,key-var ',typespec)) + (push `(,typespec nil ,@consequents) body)))) + (when e-c-p + (setq types `(or ,@(nreverse types))) + (if (eq construct 'etypecase) + (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body) + (push `(t (setf ,keyform (ensure-value-of-type ,key-var ',types ',keyform)) + (go ,e-c-p)) body)))) + `(cond ,@(nreverse body)))) + +(defmacro typecase (keyform &body clauses) + "TYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true." + (let ((key-var (gensym))) + `(let ((,key-var ,keyform)) + (declare (ignorable ,key-var)) + ,(typecase-aux key-var clauses)))) + +(defmacro etypecase (keyform &body clauses) + "ETYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then an error is signalled." + (let ((key-var (gensym))) + `(let ((,key-var ,keyform)) + (declare (ignorable ,key-var)) + ,(typecase-aux key-var clauses 'etypecase)))) + +(defmacro ctypecase (keyplace &body clauses) + "CTYPECASE Key {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then a correctable error is signalled." + (let ((key-var (gensym)) + (tag (gensym))) + `(prog (,key-var) + ,tag + (setq ,key-var ,keyplace) + (return ,(typecase-aux key-var clauses tag keyplace))))) + +(defmacro destructuring-bind (lambda-list expression &body body) + "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." + (multiple-value-bind (bindings decls) + (%destructure-lambda-list lambda-list expression nil nil) + `(let* ,(nreverse bindings) + ,@(when decls `((declare ,@decls))) + ,@body))) + +(defmacro make-destructure-state (tail whole lambda) + `(%istruct 'destructure-state ,tail ,whole ,lambda)) + + +; This is supposedly ANSI CL. +(defmacro lambda (&whole lambda-expression (&rest paramlist) &body body) + (declare (ignore paramlist body)) + (unless (lambda-expression-p lambda-expression) + (warn "Invalid lambda expression: ~s" lambda-expression)) + `(function ,lambda-expression)) + +; This isn't +(defmacro nlambda (name (&rest arglist) &body body) + `(nfunction ,name (lambda ,arglist ,@body))) + +(defmacro when (test &body body) + "If the first argument is true, the rest of the forms are + evaluated as a PROGN." + `(if ,test + (progn ,@body))) + +(defmacro unless (test &body body) + "If the first argument is not true, the rest of the forms are + evaluated as a PROGN." + `(if (not ,test) + (progn ,@body))) + +(defmacro return (&optional (form nil form-p)) + `(return-from nil ,@(if form-p `(,form)))) + +; since they use tagbody, while & until BOTH return NIL +(defmacro while (test &body body) + (let ((testlab (gensym)) + (toplab (gensym))) + `(tagbody + (go ,testlab) + ,toplab + (progn ,@body) + ,testlab + (when ,test (go ,toplab))))) + +(defmacro until (test &body body) + (let ((testlab (gensym)) + (toplab (gensym))) + `(tagbody + (go ,testlab) + ,toplab + (progn ,@body) + ,testlab + (if (not ,test) + (go ,toplab))))) + +(defmacro psetq (&whole call &body pairs &environment env) + "PSETQ {var value}* + Set the variables to the values, like SETQ, except that assignments + happen in parallel, i.e. no assignments take place until all the + forms have been evaluated." + (when pairs + (if (evenp (length pairs)) + (do* ((l pairs (%cddr l)) + (sym (%car l) (%car l))) + ((null l) (%pset pairs)) + (unless (symbolp sym) (report-bad-arg sym 'symbol)) + (when (nth-value 1 (macroexpand-1 sym env)) + (return `(psetf ,@pairs)))) + (signal-program-error "Uneven number of args in the call ~S" call)))) + +; generates body for psetq. +; "pairs" is a proper list whose length is not odd. +(defun %pset (pairs) + (when pairs + (let (vars vals gensyms let-list var val sets) + (loop + (setq var (pop pairs) + val (pop pairs)) + (if (null pairs) (return)) + (push var vars) + (push val vals) + (push (gensym) gensyms)) + (dolist (g gensyms) + (push g sets) + (push (pop vars) sets) + (push (list g (pop vals)) let-list)) + (push val sets) + (push var sets) + `(progn + (let ,let-list + (setq ,@sets)) + nil)))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun do-loop (binder setter env var-init-steps end-test result body) + (let ((toptag (gensym)) + (testtag (gensym))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(block nil + (,binder ,(do-let-vars var-init-steps) + ,@decls + (tagbody ; crocks-r-us. + (go ,testtag) + ,toptag + (tagbody + ,@forms) + (,setter ,@(do-step-vars var-init-steps)) + ,testtag + (unless ,end-test + (go ,toptag))) + ,@result))))) +) + +(defmacro do (&environment env var-init-steps (&optional end-test &rest result) &body body) + "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Iteration construct. Each Var is initialized in parallel to the value of the + specified Init form. On subsequent iterations, the Vars are assigned the + value of the Step form (if any) in parallel. The Test is evaluated before + each evaluation of the body Forms. When the Test is true, the Exit-Forms + are evaluated as a PROGN, with the result being the value of the DO. A block + named NIL is established around the entire expansion, allowing RETURN to be + used as an alternate exit mechanism." + (do-loop 'let 'psetq env var-init-steps end-test result body)) + +(defmacro do* (&environment env var-init-steps (&optional end-test &rest result) &body body) + "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Iteration construct. Each Var is initialized sequentially (like LET*) to the + value of the specified Init form. On subsequent iterations, the Vars are + sequentially assigned the value of the Step form (if any). The Test is + evaluated before each evaluation of the body Forms. When the Test is true, + the Exit-Forms are evaluated as a PROGN, with the result being the value + of the DO. A block named NIL is established around the entire expansion, + allowing RETURN to be used as an laternate exit mechanism." + (do-loop 'let* 'setq env var-init-steps end-test result body)) + + +(defun do-let-vars (var-init-steps) + (if var-init-steps + (cons (list (do-let-vars-var (car var-init-steps)) + (do-let-vars-init (car var-init-steps))) + (do-let-vars (cdr var-init-steps))))) + +(defun do-let-vars-var (var-init-step) + (if (consp var-init-step) + (car var-init-step) + var-init-step)) + +(defun do-let-vars-init (var-init-step) + (if (consp var-init-step) + (cadr var-init-step) + nil)) + +(defun do-step-vars (var-init-steps) + (if var-init-steps + (if (do-step-vars-step? (car var-init-steps)) + (append (list (do-let-vars-var (car var-init-steps)) + (do-step-vars-step (car var-init-steps))) + (do-step-vars (cdr var-init-steps))) + (do-step-vars (cdr var-init-steps))))) + +(defun do-step-vars-step? (var-init-step) + (if (consp var-init-step) + (cddr var-init-step))) + +(defun do-step-vars-step (var-init-step) + (if (consp var-init-step) + (caddr var-init-step))) + + +(defmacro dotimes ((i n &optional result) &body body &environment env) + (multiple-value-bind (forms decls) + (parse-body body env) + (if (not (symbolp i))(signal-program-error $Xnotsym i)) + (let* ((toptag (gensym)) + (limit (gensym))) + `(block nil + (let ((,limit ,n) (,i 0)) + ,@decls + (declare (unsettable ,i)) + (if (int>0-p ,limit) + (tagbody + ,toptag + ,@forms + (locally + (declare (settable ,i)) + (setq ,i (1+ ,i))) + (unless (eql ,i ,limit) (go ,toptag)))) + ,result))))) + +(defun do-syms-result (var resultform) + (unless (eq var resultform) + (if (and (consp resultform) (not (quoted-form-p resultform))) + `(progn (setq ,var nil) ,resultform) + resultform))) + +(defun expand-package-iteration-macro (iteration-function var pkg-spec resultform body env) + (multiple-value-bind (body decls) (parse-body body env nil) + (let* ((ftemp (gensym)) + (vtemp (gensym)) + (ptemp (gensym)) + (result (do-syms-result var resultform))) + `(block nil + (let* ((,var nil) + (,ptemp ,pkg-spec)) + ,@decls + (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body))) + (declare (dynamic-extent #',ftemp)) + (,iteration-function ,ptemp #',ftemp)) + ,@(when result `(,result))))))) + +(defmacro do-symbols ((var &optional pkg result) &body body &environment env) + "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}* + Executes the FORMs at least once for each symbol accessible in the given + PACKAGE with VAR bound to the current symbol." + (expand-package-iteration-macro 'iterate-over-accessable-symbols var pkg result body env)) + +(defmacro do-present-symbols ((var &optional pkg result) &body body &environment env) + (expand-package-iteration-macro 'iterate-over-present-symbols var pkg result body env)) + +(defmacro do-external-symbols ((var &optional pkg result) &body body &environment env) + "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}* + Executes the FORMs once for each external symbol in the given PACKAGE with + VAR bound to the current symbol." + (expand-package-iteration-macro 'iterate-over-external-symbols var pkg result body env)) + +(defmacro do-all-symbols ((var &optional resultform) + &body body &environment env) + "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}* + Executes the FORMs once for each symbol in every package with VAR bound + to the current symbol." + (multiple-value-bind (body decls) (parse-body body env nil) + (let* ((ftemp (gensym)) + (vtemp (gensym)) + (result (do-syms-result var resultform))) + `(block nil + (let* ((,var nil)) + ,@decls + (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body))) + (declare (dynamic-extent #',ftemp)) + (iterate-over-all-symbols #',ftemp)) + ,@(when result `(,result))))))) + +(defmacro multiple-value-list (form) + `(multiple-value-call #'list ,form)) + + + + +(defmacro %i> (x y) + `(> (the fixnum ,x) (the fixnum ,y))) + +(defmacro %i< (x y) + `(< (the fixnum ,x) (the fixnum ,y))) + +(defmacro %i<= (x y) + `(not (%i> ,x ,y))) + +(defmacro %i>= (x y) + `(not (%i< ,x ,y))) + +(defmacro bitset (bit number) + `(logior (ash 1 ,bit) ,number)) + +(defmacro bitclr (bit number) + `(logand (lognot (ash 1 ,bit)) ,number)) + +(defmacro bitopf ((op bit place) &environment env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + (let* ((constant-bit-p (constantp bit)) + (bitvar (if constant-bit-p bit (gensym)))) + `(let ,(unless constant-bit-p `((,bitvar ,bit))) ; compiler isn't smart enough + (let* ,(mapcar #'list `(,@vars ,@stores) `(,@vals (,op ,bitvar ,access-form))) + ,store-form))))) + +(defmacro bitsetf (bit place) + `(bitopf (bitset ,bit ,place))) + +(defmacro bitclrf (bit place) + `(bitopf (bitclr ,bit ,place))) + +(defmacro %svref (v i) + (let* ((vtemp (make-symbol "VECTOR")) + (itemp (make-symbol "INDEX"))) + `(let* ((,vtemp ,v) + (,itemp ,i)) + (locally (declare (optimize (speed 3) (safety 0))) + (svref ,vtemp ,itemp))))) + +(defmacro %svset (v i new) + (let* ((vtemp (make-symbol "VECTOR")) + (itemp (make-symbol "INDEX")) + (ntemp (make-symbol "NEW"))) + `(let* ((,vtemp ,v) + (,itemp ,i) + (,ntemp ,new)) + (locally (declare (optimize (speed 3) (safety 0))) + (setf (svref ,vtemp ,itemp) ,ntemp))))) + + +(defmacro %schar (v i) + (let* ((vtemp (make-symbol "STRING")) + (itemp (make-symbol "INDEX"))) + `(let* ((,vtemp ,v) + (,itemp ,i)) + (locally (declare (optimize (speed 3) (safety 0))) + (schar ,vtemp ,itemp))))) + +(defmacro %set-schar (v i new) + (let* ((vtemp (make-symbol "STRING")) + (itemp (make-symbol "INDEX")) + (ntemp (make-symbol "NEW"))) + `(let* ((,vtemp ,v) + (,itemp ,i) + (,ntemp ,new)) + (locally (declare (optimize (speed 3) (safety 0))) + (setf (schar ,vtemp ,itemp) ,ntemp))))) + + + +(defmacro %char-code (c) `(char-code (the character ,c))) +(defmacro %code-char (i) `(code-char (the (mod 256) ,i))) + +(defmacro %izerop (x) `(eq ,x 0)) +(defmacro %iminusp (x) `(< (the fixnum ,x) 0)) +(defmacro %i+ (&rest (&optional (n0 0) &rest others)) + (if others + `(the fixnum (+ (the fixnum ,n0) (%i+ ,@others))) + `(the fixnum ,n0))) +(defmacro %i- (x y &rest others) + (if (not others) + `(the fixnum (- (the fixnum ,x) (the fixnum ,y))) + `(the fixnum (- (the fixnum ,x) (the fixnum (%i+ ,y ,@others)))))) + + +(defmacro %i* (x y) `(the fixnum (* (the fixnum ,x) (the fixnum ,y)))) + +(defmacro %ilogbitp (b i) + (target-word-size-case + (32 + `(logbitp (the (integer 0 29) ,b) (the fixnum ,i))) + (64 + `(logbitp (the (integer 0 60) ,b) (the fixnum ,i))))) + +;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence. + +(defmacro seq-dispatch (sequence list-form array-form) + `(if (sequence-type ,sequence) + ,list-form + ,array-form)) + + +(defsetf %get-byte %set-byte) +(defsetf %get-unsigned-byte %set-unsigned-byte) +(defsetf %get-signed-byte %set-byte) +(defsetf %get-word %set-word) +(defsetf %get-signed-word %set-word) +(defsetf %get-unsigned-word %set-unsigned-word) +(defsetf %get-long %set-long) +(defsetf %get-signed-long %set-long) +(defsetf %get-unsigned-long %set-unsigned-long) +(defsetf %get-full-long %set-long) +(defsetf %get-point %set-long) +(defsetf %get-ptr %set-ptr) +(defsetf %get-double-float %set-double-float) +(defsetf %get-single-float %set-single-float) +(defsetf %get-bit %set-bit) +(defsetf %get-unsigned-long-long %set-unsigned-long-long) +(defsetf %%get-unsigned-longlong %%set-unsigned-longlong) +(defsetf %get-signed-long-long %set-signed-long-long) +(defsetf %%get-signed-longlong %%set-signed-longlong) +(defsetf %get-bitfield %set-bitfield) + +(defmacro %ilognot (int) `(%i- -1 ,int)) + +(defmacro %ilogior2 (x y) + `(logior (the fixnum ,x) (the fixnum ,y))) + +(defmacro %ilogior (body &rest args) + (while args + (setq body (list '%ilogior2 body (pop args)))) + body) + +(defmacro %ilogand2 (x y) + `(logand (the fixnum ,x) (the fixnum ,y))) + +(defmacro %ilogand (body &body args) + (while args + (setq body (list '%ilogand2 body (pop args)))) + body) + +(defmacro %ilogxor2 (x y) + `(logxor (the fixnum ,x) (the fixnum ,y))) + +(defmacro %ilogxor (body &body args) + (while args + (setq body (list '%ilogxor2 body (pop args)))) + body) + +(defmacro with-macptrs (varlist &rest body &environment env) + (multiple-value-bind (body other-decls) (parse-body body env) + (collect ((temp-bindings) + (temp-decls) + (bindings) + (our-decls) + (inits)) + (dolist (var varlist) + (let* ((temp (gensym))) + (temp-decls temp) + (if (consp var) + (progn + (our-decls (car var)) + (temp-bindings `(,temp (%null-ptr))) + (bindings `(,(car var) ,temp)) + (if (cdr var) + (inits `(%setf-macptr ,temp ,@(cdr var))))) + (progn + (our-decls var) + (temp-bindings `(,temp (%null-ptr))) + (bindings `(,var ,temp)))))) + `(let* ,(temp-bindings) + (declare (dynamic-extent ,@(temp-decls))) + (declare (type macptr ,@(temp-decls))) + ,@(inits) + (let* ,(bindings) + (declare (type macptr ,@(our-decls))) + ,@other-decls + ,@body))))) + + +(defmacro with-loading-file (filename &rest body) + `(let ((*loading-files* (cons ,filename (locally (declare (special *loading-files*)) + *loading-files*)))) + (declare (special *loading-files*)) + ,@body)) + +(defmacro with-input-from-string ((var string &key index start end) &body forms &environment env) + "Create an input string stream, provide an opportunity to perform +operations on the stream (returning zero or more values), and then close +the string stream. + +STRING is evaluated first, and VAR is bound to a character input string +stream that supplies characters from the subsequence of the resulting +string bounded by start and end. BODY is executed as an implicit progn." + (multiple-value-bind (forms decls) (parse-body forms env nil) + `(let ((,var + ,(cond ((null end) + `(make-string-input-stream ,string ,(or start 0))) + ((symbolp end) + `(if ,end + (make-string-input-stream ,string ,(or start 0) ,end) + (make-string-input-stream ,string ,(or start 0)))) + (t + `(make-string-input-stream ,string ,(or start 0) ,end))))) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + ,@(if index `((setf ,index (string-input-stream-index ,var))))) + (close ,var))))) + +(defmacro with-input-from-vector ((var vector &key index (start 0) end external-format) &body forms &environment env) + (multiple-value-bind (forms decls) (parse-body forms env nil) + `(let ((,var (%make-vector-input-stream ,vector ,start ,end ,external-format))) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + ,@(if index `((setf ,index (vector-input-stream-index ,var))))) + (close ,var))))) + +(defmacro with-output-to-string ((var &optional string &key (element-type 'base-char element-type-p)) + &body body + &environment env) + "Create a character output stream, perform a series of operations that +may send results to this stream, and then close the stream. BODY is +executed as an implicit progn with VAR bound to an output string stream. +All output to that string stream is saved in a string." + (let* ((string-p (not (null string)))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,var ,@(if string-p + `(,@(if element-type-p + `((progn + ,element-type + (%make-string-output-stream ,string))) + `((%make-string-output-stream ,string)))) + `(,@(if element-type-p + `((make-string-output-stream :element-type ,element-type)) + `((make-string-output-stream))))))) + ,@decls + (unwind-protect + (progn + ,@forms + ,@(if string-p () `((get-output-stream-string ,var)))) + (close ,var)))))) + +(defmacro with-output-to-vector ((var &optional vector &key external-format) + &body body + &environment env) + (let* ((vector-p (not (null vector)))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,var ,@(if vector-p + `((%make-vector-output-stream ,vector ,external-format)) + `((make-vector-output-stream :external-format ,external-format))))) + ,@decls + (unwind-protect + (progn + ,@forms + ,@(if vector-p () `((get-output-stream-vector ,var)))) + (close ,var)))))) + +(defmacro with-output-to-truncating-string-stream ((var len) &body body + &environment env) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,var (make-truncating-string-stream ,len))) + ,@decls + (unwind-protect + (progn + ,@forms + (values (get-output-stream-string ,var) + (slot-value ,var 'truncated))) + (close ,var))))) + +(defmacro with-open-file ((var filename . args) &body body &aux (stream (gensym))(done (gensym))) + "Use open to create a file stream to file named by filename. Filename is +the name of the file to be opened. Options are used as keyword arguments +to open." + `(let (,stream ,done) + (unwind-protect + (multiple-value-prog1 + (let ((,var (setq ,stream (open ,filename ,@args)))) + ,@body) + (setq ,done t)) + (when ,stream (close ,stream :abort (null ,done)))))) + +(defmacro with-compilation-unit ((&key override) &body body) + "WITH-COMPILATION-UNIT ({Key Value}*) Form* + This form affects compilations that take place within its dynamic extent. It + is intended to be wrapped around the compilation of all files in the same + system. These keywords are defined: + :OVERRIDE Boolean-Form + One of the effects of this form is to delay undefined warnings + until the end of the form, instead of giving them at the end of each + compilation. If OVERRIDE is NIL (the default), then the outermost + WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying + OVERRIDE true causes that form to grab any enclosed warnings, even if + it is enclosed by another WITH-COMPILATION-UNIT." + `(flet ((with-compilation-unit-body () + ,@body)) + (declare (dynamic-extent #'with-compilation-unit-body)) + (call-with-compilation-unit #'with-compilation-unit-body :override ,override))) + +; Yow! Another Done Fun. +(defmacro with-standard-io-syntax (&body body &environment env) + "Bind the reader and printer control variables to values that enable READ + to reliably read the results of PRINT. These values are: + *PACKAGE* the COMMON-LISP-USER package + *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-LINES* NIL + *PRINT-MISER-WIDTH* NIL + *PRINT-PRETTY* NIL + *PRINT-RADIX* NIL + *PRINT-READABLY* T + *PRINT-RIGHT-MARGIN* NIL + *READ-BASE* 10 + *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT + *READ-EVAL* T + *READ-SUPPRESS* NIL + *READTABLE* the standard readtable" + (multiple-value-bind (decls body) (parse-body body env) + `(let ((*package* (pkg-arg "COMMON-LISP-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-lines* nil) ; This doesn't exist as of 5/15/90 - does now + (*print-miser-width* nil) + (*print-pprint-dispatch* nil) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10.) + (*read-default-float-format* 'single-float) + (*read-eval* t) ; Also MIA as of 5/15/90 + (*read-suppress* nil) + (*readtable* %standard-readtable%) + ; ccl extensions (see l1-io.lisp) + (*print-abbreviate-quote* t) + (*print-structure* t) + (*print-simple-vector* nil) + (*print-simple-bit-vector* nil) + (*print-string-length* nil)) + ,@decls + ,@body))) + +(defmacro with-self-bound-io-control-vars (&body body) + `(let ( + (*print-array* *print-array*) + (*print-base* *print-base*) + (*print-case* *print-case*) + (*print-circle* *print-circle*) + (*print-escape* *print-escape*) + (*print-gensym* *print-gensym*) + (*print-length* *print-length*) + (*print-level* *print-level*) + (*print-lines* *print-lines*) + (*print-miser-width* *print-miser-width*) + (*print-pprint-dispatch* *print-pprint-dispatch*) + (*print-pretty* *print-pretty*) + (*print-radix* *print-radix*) + (*print-readably* *print-readably*) + (*print-right-margin* *print-right-margin*) + (*read-base* *read-base*) + (*read-default-float-format* *read-default-float-format*) + (*read-eval* *read-eval*) + (*read-suppress* *read-suppress*) + (*readtable* *readtable*)) + ,@body)) + +(defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms) + "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally + with object-type prefix and object-identity suffix, and executing the + code in BODY to provide possible further output." + (multiple-value-bind (body decls) (parse-body forms env) + (if body + (let ((thunk (gensym))) + `(let ((,thunk #'(lambda () ,@decls ,@body))) + (declare (dynamic-extent ,thunk)) + (%print-unreadable-object ,object ,stream ,type ,identity ,thunk))) + `(%print-unreadable-object ,object ,stream ,type ,identity nil)))) +;; Pointers and Handles + +;;Add function to lisp system pointer functions, and run it if it's not already +;; there. +(defmacro def-ccl-pointers (name arglist &body body &aux (old (gensym))) + `(flet ((,name ,arglist ,@body)) + (let ((,old (member ',name *lisp-system-pointer-functions* :key #'function-name))) + (if ,old + (rplaca ,old #',name) + (progn + (push #',name *lisp-system-pointer-functions*) + (,name)))))) + +(defmacro def-load-pointers (name arglist &body body &aux (old (gensym))) + `(flet ((,name ,arglist ,@body)) + (let ((,old (member ',name *lisp-user-pointer-functions* :key #'function-name))) + (if ,old + (rplaca ,old #',name) + (progn + (push #',name *lisp-user-pointer-functions*) + (,name)))))) + +;Queue up some code to run after ccl all loaded up, or, if ccl is already +;loaded up, just run it right now. +(defmacro queue-fixup (&rest body &aux (fn (gensym))) + `(let ((,fn #'(lambda () ,@body))) + (if (eq %lisp-system-fixups% T) + (funcall ,fn) + (push (cons ,fn (or *loading-toplevel-location* *loading-file-source-file*)) %lisp-system-fixups%)))) + +(defmacro %incf-ptr (p &optional (by 1)) + (if (symbolp p) ;once-only + `(%setf-macptr (the macptr ,p) (%inc-ptr ,p ,by)) + (let ((var (gensym))) + `(let ((,var ,p)) (%setf-macptr (the macptr ,var) (%inc-ptr ,var ,by)))))) + +(defmacro with-string-from-cstring ((s ptr) &body body) + (let* ((len (gensym)) + (p (gensym))) + `(let* ((,p ,ptr) + (,len (%cstrlen ,p)) + (,s (make-string ,len))) + (declare (fixnum ,len)) + (%copy-ptr-to-ivector ,p 0 ,s 0 ,len) + (locally + ,@body)))) + + +(defmacro with-cstr ((sym str &optional start end) &rest body &environment env) + (multiple-value-bind (body decls) (parse-body body env nil) + (if (and (base-string-p str) (null start) (null end)) + (let ((strlen (%i+ (length str) 1))) + `(%stack-block ((,sym ,strlen)) + ,@decls + (%cstr-pointer ,str ,sym) + ,@body)) + (let ((strname (gensym)) + (start-name (gensym)) + (end-name (gensym))) + `(let ((,strname ,str) + ,@(if (or start end) + `((,start-name ,(or start 0)) + (,end-name ,(or end `(length ,strname)))))) + (%vstack-block (,sym + (the fixnum + (1+ + (the fixnum + ,(if (or start end) + `(byte-length + ,strname ,start-name ,end-name) + `(length ,strname)))))) + ,@decls + ,(if (or start end) + `(%cstr-segment-pointer ,strname ,sym ,start-name ,end-name) + `(%cstr-pointer ,strname ,sym)) + ,@body)))))) + +(defmacro with-utf-8-cstr ((sym str) &body body) + (let* ((data (gensym)) + (offset (gensym)) + (string (gensym)) + (len (gensym)) + (noctets (gensym)) + (end (gensym))) + `(let* ((,string ,str) + (,len (length ,string))) + (multiple-value-bind (,data ,offset) (array-data-and-offset ,string) + (let* ((,end (+ ,offset ,len)) + (,noctets (utf-8-octets-in-string ,data ,offset ,end))) + (%stack-block ((,sym (1+ ,noctets))) + (utf-8-memory-encode ,data ,sym 0 ,offset ,end) + (setf (%get-unsigned-byte ,sym ,noctets) 0) + ,@body)))))) + + + +(defmacro with-native-utf-16-cstr ((sym str) &body body) + (let* ((data (gensym)) + (offset (gensym)) + (string (gensym)) + (len (gensym)) + (noctets (gensym)) + (end (gensym))) + `(let* ((,string ,str) + (,len (length ,string))) + (multiple-value-bind (,data ,offset) (array-data-and-offset ,string) + (let* ((,end (+ ,offset ,len)) + (,noctets (utf-16-octets-in-string ,data ,offset ,end))) + (%stack-block ((,sym (1+ ,noctets))) + (native-utf-16-memory-encode ,data ,sym 0 ,offset ,end) + (setf (%get-unsigned-word ,sym ,noctets) 0) + ,@body)))))) + +(defmacro with-pointers (speclist &body body) + (with-specs-aux 'with-pointer speclist body)) + + + +(defmacro with-cstrs (speclist &body body) + (with-specs-aux 'with-cstr speclist body)) + +(defmacro with-utf-8-cstrs (speclist &body body) + (with-specs-aux 'with-utf-8-cstr speclist body)) + +(defmacro with-native-utf-16-cstrs (speclist &body body) + (with-specs-aux 'with-native-utf-16-cstr speclist body)) + +(defmacro with-encoded-cstr ((encoding-name (sym string &optional start end)) + &rest body &environment env) + (let* ((encoding (gensym)) + (str (gensym))) + (multiple-value-bind (body decls) (parse-body body env nil) + `(let* ((,str ,string) + (,encoding (get-character-encoding ,encoding-name))) + (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end) :clear t)) + ,@decls + (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end) + ,@body))))) + +(defmacro with-encoded-cstrs (encoding-name bindings &body body) + (with-specs-aux 'with-encoded-cstr (mapcar #'(lambda (b) + `(,encoding-name ,b)) + bindings) body)) + +(defmacro with-filename-cstrs (&rest rest) + (case (target-os-name) + (:darwin `(with-utf-8-cstrs ,@rest)) + (:windows `(with-native-utf-16-cstrs ,@rest)) + (t `(with-encoded-cstrs (pathname-encoding-name) ,@rest)))) + + +(defun with-specs-aux (name spec-list original-body) + (multiple-value-bind (body decls) (parse-body original-body nil) + (when decls (signal-program-error "declarations not allowed in ~s" original-body)) + (setq body (cons 'progn body)) + (dolist (spec (reverse spec-list)) + (setq body (list name spec body))) + body)) + + +(defmacro type-predicate (type) + `(get-type-predicate ,type)) + +(defsetf type-predicate set-type-predicate) + +(defun adjust-defmethod-lambda-list (ll) + ;; If the lambda list contains &key, ensure that it also contains + ;; &allow-other-keys + (if (or (not (memq '&key ll)) + (memq '&allow-other-keys ll)) + ll + (if (memq '&aux ll) + (let* ((ll (copy-list ll)) + (aux (memq '&aux ll))) + (setf (car aux) '&allow-other-keys + (cdr aux) (cons '&aux (cdr aux))) + ll) + (append ll '(&allow-other-keys))))) + +(defmacro defmethod (name &rest args &environment env) + (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers) + (parse-defmethod name args env) + `(progn + (eval-when (:compile-toplevel) + (record-function-info ',(maybe-setf-function-name name) + ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t) + (unless bits ;; verify failed + (signal-program-error "Invalid lambda list ~s" + (find-if #'listp args))) + (%cons-def-info 'defmethod bits keyvect nil specializers qualifiers)) + ,env)) + (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers))) + (ensure-method ',name ,specializers-form + :function ,function-form + :qualifiers ',qualifiers + :lambda-list ',lambda-list + ,@(if documentation `(:documentation ,documentation))))))) + + +(defun seperate-defmethod-decls (decls) + (let (outer inner) + (dolist (decl decls) + (if (neq (car decl) 'declare) + (push decl outer) + (let (outer-list inner-list) + (dolist (d (cdr decl)) + (if (and (listp d) (eq (car d) 'dynamic-extent)) + (let (in out) + (dolist (fspec (cdr d)) + (if (and (listp fspec) + (eq (car fspec) 'function) + (listp (cdr fspec)) + (null (cddr fspec)) + (memq (cadr fspec) '(call-next-method next-method-p))) + (push fspec in) + (push fspec out))) + (when out + (push `(dynamic-extent ,@(nreverse out)) outer-list)) + (when in + (push `(dynamic-extent ,@(nreverse in)) inner-list))) + (push d outer-list))) + (when outer-list + (push `(declare ,@(nreverse outer-list)) outer)) + (when inner-list + (push `(declare ,@(nreverse inner-list)) inner))))) + (values (nreverse outer) (nreverse inner)))) + + +(defvar *warn-about-unreferenced-required-args-in-methods* #+ccl-0711 nil #-ccl-0711 T) + +(defun parse-defmethod (name args env) + (validate-function-name name) + (let (qualifiers lambda-list parameters specializers specializers-form refs types temp) + (until (listp (car args)) + (push (pop args) qualifiers)) + (setq lambda-list (pop args)) + (while (and lambda-list (not (memq (car lambda-list) lambda-list-keywords))) + (let ((p (pop lambda-list))) + (cond ((consp p) + (unless (and (consp (%cdr p)) (null (%cddr p))) + (signal-program-error "Illegal arg ~S" p)) + (push (%car p) parameters) + (push (%car p) refs) + (setq p (%cadr p)) + (cond ((and (consp p) (eq (%car p) 'eql) + (consp (%cdr p)) (null (%cddr p))) + (push `(list 'eql ,(%cadr p)) specializers-form) + (push p specializers)) + ((or (setq temp (non-nil-symbol-p p)) + (specializer-p p)) + (push `',p specializers-form) + (push p specializers) + (unless (or (eq p t) (not temp)) + ;Should be `(guaranteed-type ...). + (push `(type ,p ,(%car parameters)) types))) + (t (signal-program-error "Illegal arg ~S" p)))) + (t + (push p parameters) + (unless *warn-about-unreferenced-required-args-in-methods* + (push p refs)) + (push t specializers-form) + (push t specializers))))) + (setq lambda-list (nreconc parameters lambda-list)) + (multiple-value-bind (body decls doc) (parse-body args env t) + (multiple-value-bind (outer-decls inner-decls) + (seperate-defmethod-decls decls) + (let* ((methvar (make-symbol "NEXT-METHOD-CONTEXT")) + (cnm-args (gensym)) + (lambda-form `(lambda ,(list* '&method methvar lambda-list) + (declare ;,@types + (ignorable ,@refs)) + ,@outer-decls + (block ,(if (consp name) (cadr name) name) + (flet ((call-next-method (&rest ,cnm-args) + (declare (dynamic-extent ,cnm-args)) + (if ,cnm-args + (apply #'%call-next-method-with-args ,methvar ,cnm-args) + (%call-next-method ,methvar))) + (next-method-p () (%next-method-p ,methvar))) + (declare (inline call-next-method next-method-p)) + ,@inner-decls + ,@body))))) + (values + (if name `(nfunction ,name ,lambda-form) `(function ,lambda-form)) + `(list ,@(nreverse specializers-form)) + (nreverse qualifiers) + lambda-list + doc + (nreverse specializers))))))) + +(defmacro anonymous-method (name &rest args &environment env) + (multiple-value-bind (function-form specializers-form qualifiers method-class documentation) + (parse-defmethod name args env) + + `(%anonymous-method + ,function-form + ,specializers-form + ',qualifiers + ,@(if (or method-class documentation) `(',method-class)) + ,@(if documentation `(,documentation))))) + + + +(defmacro defclass (class-name superclasses slots &rest class-options &environment env) + (flet ((duplicate-options (where) (signal-program-error "Duplicate options in ~S" where)) + (illegal-option (option) (signal-program-error "Illegal option ~s" option)) + (make-initfunction (form) + (cond ((or (eq form 't) + (equal form ''t)) + '(function true)) + ((or (eq form 'nil) + (equal form ''nil)) + '(function false)) + (t + `(function (lambda () ,form)))))) + (setq class-name (require-type class-name '(and symbol (not null)))) + (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses)) + (let* ((options-seen ()) + (signatures ()) + (slot-names ()) + (slot-initargs ())) + (flet ((canonicalize-defclass-option (option) + (let* ((option-name (car option))) + (if (member option-name options-seen :test #'eq) + (duplicate-options class-options) + (push option-name options-seen)) + (case option-name + (:default-initargs + (let ((canonical ()) + (initargs-seen ())) + (let (key val (tail (cdr option))) + (loop (when (null tail) (return nil)) + (setq key (pop tail) + val (pop tail)) + (when (memq key initargs-seen) + (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name)) + (push key initargs-seen) + (push ``(,',key ,',val ,,(make-initfunction val)) canonical)) + `(':direct-default-initargs (list ,@(nreverse canonical)))))) + (:metaclass + (unless (and (cadr option) + (typep (cadr option) 'symbol)) + (illegal-option option)) + `(:metaclass ',(cadr option))) + (:documentation + `(:documentation ',(cadr option))) + (t + (list `',option-name `',(cdr option)))))) + (canonicalize-slot-spec (slot) + (if (null slot) (signal-program-error "Illegal slot NIL")) + (if (not (listp slot)) (setq slot (list slot))) + (let* ((slot-name (require-type (car slot) 'symbol)) + (initargs nil) + (other-options ()) + (initform nil) + (initform-p nil) + (initfunction nil) + (type nil) + (type-p nil) + (allocation nil) + (allocation-p nil) + (documentation nil) + (documentation-p nil) + (readers nil) + (writers nil) + (reader-info (%cons-def-info 'defmethod (dpb 1 $lfbits-numreq 0) nil nil (list class-name))) + (writer-info (%cons-def-info 'defmethod (dpb 2 $lfbits-numreq 0) nil nil (list t class-name)))) + (when (memq slot-name slot-names) + (signal-program-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name)) + (push slot-name slot-names) + (do ((options (cdr slot) (cddr options)) + name) + ((null options)) + (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot)) + (case (car options) + (:reader + (setq name (cadr options)) + (unless (memq name readers) + (push (cons name reader-info) signatures) + (push name readers))) + (:writer + (setq name (cadr options)) + (unless (member name writers :test 'equal) + (push (cons name writer-info) signatures) + (push name writers))) + (:accessor + (setq name (cadr options)) + (unless (memq name readers) + (push (cons name reader-info) signatures) + (push name readers)) + (let ((setf-name `(setf ,name))) + (unless (member setf-name writers :test 'equal) + (push (cons (setf-function-name name) writer-info) signatures) + (push setf-name writers)))) + (:initarg + (let* ((initarg (require-type (cadr options) 'symbol)) + (other (position initarg slot-initargs :test #'memq))) + (when other + (warn "Initarg ~s occurs in both ~s and ~s slots" + initarg (nth (1+ other) slot-names) slot-name)) + (push initarg initargs))) + (:type + (if type-p + (duplicate-options slot) + (setq type-p t)) + (setq type (cadr options)) + ;; complain about illegal typespecs and continue + (handler-case (specifier-type type env) + (program-error () + (warn "Invalid type ~s in ~s slot definition ~s" type class-name slot)))) + (:initform + (if initform-p + (duplicate-options slot) + (setq initform-p t)) + (let ((option (cadr options))) + (setq initform `',option + initfunction + (if (constantp option) + `(constantly ,option) + `#'(lambda () ,option))))) + (:allocation + (if allocation-p + (duplicate-options slot) + (setq allocation-p t)) + (setq allocation (cadr options))) + (:documentation + (if documentation-p + (duplicate-options slot) + (setq documentation-p t)) + (setq documentation (cadr options))) + (t + (let* ((pair (or (assq (car options) other-options) + (car (push (list (car options)) other-options))))) + (push (cadr options) (cdr pair)))))) + (push initargs slot-initargs) + `(list :name ',slot-name + ,@(when allocation `(:allocation ',allocation)) + ,@(when initform-p `(:initform ,initform + :initfunction ,initfunction)) + ,@(when initargs `(:initargs ',initargs)) + ,@(when readers `(:readers ',readers)) + ,@(when writers `(:writers ',writers)) + ,@(when type-p `(:type ',type)) + ,@(when documentation-p `(:documentation ,documentation)) + ,@(mapcan #'(lambda (opt) + `(',(car opt) ',(if (null (cddr opt)) + (cadr opt) + (cdr opt)))) other-options))))) + (let* ((direct-superclasses superclasses) + (direct-slot-specs (mapcar #'canonicalize-slot-spec slots)) + (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))) + (keyvect (class-keyvect class-name other-options))) + (when (vectorp keyvect) + (let ((illegal (loop for arg in other-options by #'cddr + as key = (if (quoted-form-p arg) (%cadr arg) arg) + unless (or (eq key :metaclass) (find key keyvect)) collect key))) + (when illegal + (signal-program-error "Class option~p~{ ~s~} is not one of ~s" + (length illegal) illegal keyvect)))) + `(progn + (when (memq ',class-name *nx-known-declarations*) + (check-declaration-redefinition ',class-name 'defclass)) + (eval-when (:compile-toplevel) + (%compile-time-defclass ',class-name ,env) + (progn + ,@(mapcar #'(lambda (sig) `(record-function-info ',(car sig) ',(cdr sig) ,env)) + signatures))) + (ensure-class-for-defclass ',class-name + :direct-superclasses ',direct-superclasses + :direct-slots ,`(list ,@direct-slot-specs) + ,@other-options))))))) + +(defmacro define-method-combination (name &rest rest &environment env) + (setq name (require-type name 'symbol)) + (cond ((or (null rest) (and (car rest) (symbolp (car rest)))) + `(short-form-define-method-combination ',name ',rest)) + ((listp (car rest)) + (destructuring-bind (lambda-list method-group-specifiers . forms) rest + (long-form-define-method-combination + name lambda-list method-group-specifiers forms env))) + (t (%badarg (car rest) '(or (and null symbol) list))))) + +(defmacro defgeneric (function-name lambda-list &rest options-and-methods &environment env) + (fboundp function-name) ; type-check + (multiple-value-bind (method-combination generic-function-class options methods) + (parse-defgeneric function-name t lambda-list options-and-methods) + (let ((gf (gensym))) + `(progn + (eval-when (:compile-toplevel) + (record-function-info ',(maybe-setf-function-name function-name) + ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t) + (%cons-def-info 'defgeneric bits keyvect)) + ,env)) + (let ((,gf (%defgeneric + ',function-name ',lambda-list ',method-combination ',generic-function-class + ',(apply #'append options)))) + (%set-defgeneric-methods ,gf ,@methods) + ,gf))))) + + + +(defun parse-defgeneric (function-name global-p lambda-list options-and-methods) + (check-generic-function-lambda-list lambda-list) + (let ((method-combination '(standard)) + (generic-function-class 'standard-generic-function) + options declarations methods option-keywords method-class) + (flet ((bad-option (o) + (signal-program-error "Bad option: ~s to ~s." o 'defgeneric))) + (dolist (o options-and-methods) + (let ((keyword (car o)) + (defmethod (if global-p 'defmethod 'anonymous-method))) + (if (eq keyword :method) + (let ((defn `(,defmethod ,function-name ,@(%cdr o)))) + (note-source-transformation o defn) + (push defn methods)) + (cond ((and (not (eq keyword 'declare)) + (memq keyword (prog1 option-keywords (push keyword option-keywords)))) + (signal-program-error "Duplicate option: ~s to ~s" keyword 'defgeneric)) + ((eq keyword :method-combination) + (unless (symbolp (cadr o)) + (bad-option o)) + (setq method-combination (cdr o))) + ((eq keyword :generic-function-class) + (unless (and (cdr o) (symbolp (cadr o)) (null (%cddr o))) + (bad-option o)) + (setq generic-function-class (%cadr o))) + ((eq keyword 'declare) + (push (cadr o) declarations)) + ((eq keyword :argument-precedence-order) + (dolist (arg (cdr o)) + (unless (and (symbolp arg) (memq arg lambda-list)) + (bad-option o))) + (push (list keyword (cdr o)) options)) + ((eq keyword :method-class) + (push o options) + (when (or (cddr o) (not (symbolp (setq method-class (%cadr o))))) + (bad-option o))) + ((eq keyword :documentation) + (push o options) + (when (or (cddr o) (not (stringp (%cadr o)))) + (bad-option o))) + (t (bad-option o))))))) + (when method-class + (dolist (m methods) + (push `(:method-class ,method-class) (cddr m)))) + (when declarations + (setq options `((:declarations ,declarations) ,@options))) + (values method-combination generic-function-class options methods))) + + +(defmacro def-aux-init-functions (class &rest functions) + `(set-aux-init-functions ',class (list ,@functions))) + + + + + + +;;; A powerful way of defining REPORT-CONDITION... +;;; Do they really expect that each condition type has a unique method on PRINT-OBJECT +;;; which tests *print-escape* ? Scary if so ... + +(defmacro define-condition (name (&rest supers) (&rest slots) &body options) + "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option* + Define NAME as a condition type. This new type inherits slots and its + report function from the specified PARENT-TYPEs. A slot spec is a list of: + (slot-name :reader :initarg {Option Value}* + + The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION + and :TYPE and the overall options :DEFAULT-INITARGS and + [type] :DOCUMENTATION are also allowed. + + The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either + a string or a two-argument lambda or function name. If a function, the + function is called with the condition and stream to report the condition. + If a string, the string is printed. + + Condition types are classes, but (as allowed by ANSI and not as described in + CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and + SLOT-VALUE may not be used on condition objects." + ; If we could tell what environment we're being expanded in, we'd + ; probably want to check to ensure that all supers name conditions + ; in that environment. + (let ((classopts nil) + (duplicate nil) + (docp nil) + (default-initargs-p nil) + (reporter nil)) + (dolist (option options) + (unless (and (consp option) + (consp (%cdr option))) + (signal-program-error "Invalid option ~s ." option)) + (ecase (%car option) + (:default-initargs + (unless (plistp (cdr option)) + (signal-program-error "~S is not a plist." (%cdr option))) + (if default-initargs-p + (setq duplicate t) + (push (setq default-initargs-p option) classopts))) + (:documentation + (unless (null (%cddr option)) + (signal-program-error "Invalid option ~s ." option)) + (if docp + (setq duplicate t) + (push (setq docp option) classopts))) + (:report + (unless (null (%cddr option)) + (signal-program-error "Invalid option ~s ." option)) + (if reporter + (setq duplicate t) + (progn + (if (or (lambda-expression-p (setq reporter (%cadr option))) + (symbolp reporter)) + (setq reporter `(function ,reporter)) + (if (stringp reporter) + (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s)))) + (signal-program-error "~a expression is not a string, symbol, or lambda expression ." (%car option)))) + (setq reporter `((defmethod report-condition ((c ,name) s) + (funcall ,reporter c s)))))))) + (if duplicate (signal-program-error "Duplicate option ~s ." option))) + `(progn + (defclass ,name ,(or supers '(condition)) ,slots ,@classopts) + ,@reporter + ',name))) + +(defmacro with-condition-restarts (&environment env condition restarts &body body) + "Evaluates the BODY in a dynamic environment where the restarts in the list + RESTARTS-FORM are associated with the condition returned by CONDITION-FORM. + This allows FIND-RESTART, etc., to recognize restarts that are not related + to the error currently being debugged. See also RESTART-CASE." + (multiple-value-bind (body decls) + (parse-body body env) + (let ((cond (gensym)) + (r (gensym))) + `(let* ((*condition-restarts* *condition-restarts*)) + ,@decls + (let ((,cond ,condition)) + (dolist (,r ,restarts) (push (cons ,r ,cond) *condition-restarts*)) + ,@body))))) + +(defmacro setf-find-class (name arg1 &optional (arg2 () 2-p) (arg3 () 3-p)) + (cond (3-p ;might want to pass env (arg2) to find-class someday? + `(set-find-class ,name (progn ,arg1 ,arg2 ,arg3))) + (2-p + `(set-find-class ,name (progn ,arg1 ,arg2))) + (t `(set-find-class ,name ,arg1)))) + +(defsetf find-class setf-find-class) + +(defmacro restoring-interrupt-level (var &body body) + `(unwind-protect + (progn ,@body) + (restore-interrupt-level ,var) + (%interrupt-poll))) + +(defmacro without-interrupts (&body body) + "Evaluate its body in an environment in which process-interrupt +requests are deferred." + `(let* ((*interrupt-level* -1)) + ,@body)) + +(defmacro with-interrupts-enabled (&body body) + "Evaluate its body in an environment in which process-interrupt +has immediate effect." + `(let* ((*interrupt-level* 0)) + ,@body)) + +;;; undoes the effect of one enclosing without-interrupts during execution of body. +(defmacro ignoring-without-interrupts (&body body) + `(let* ((*interrupt-level* 0)) + ,@body)) + + + +(defmacro error-ignoring-without-interrupts (format-string &rest format-args) + `(ignoring-without-interrupts + (error ,format-string ,@format-args))) + + +;init-list-default: if there is no init pair for , +; add a pair to init-list +(defmacro init-list-default (the-init-list &rest args) + (let ((result) + (init-list-sym (gensym))) + (do ((args args (cddr args))) + ((not args)) + (setq result + (cons `(if (eq '%novalue (getf ,init-list-sym ,(car args) + '%novalue)) + (setq ,init-list-sym (cons ,(car args) + (cons ,(cadr args) + ,init-list-sym)))) + result))) + `(let ((,init-list-sym ,the-init-list)) + (progn ,@result) + ,init-list-sym) + )) + +; This can only be partially backward-compatible: even if only +; the "name" arg is supplied, the old function would create the +; package if it didn't exist. +; Should see how well this works & maybe flush the whole idea. + +(defmacro in-package (name) + (let ((form nil)) + (when (quoted-form-p name) + (warn "Unquoting argument ~S to ~S." name 'in-package ) + (setq name (cadr name))) + (setq form `(set-package ,(string name))) + `(eval-when (:execute :load-toplevel :compile-toplevel) + ,form))) + +(defmacro defpackage (name &rest options) + "Defines a new package called PACKAGE. Each of OPTIONS should be one of the + following: + (NICKNAMES {package-name}*) + + (SIZE ) + (SHADOW {symbol-name}*) + (SHADOWING-IMPORT-FROM {symbol-name}*) + (USE {package-name}*) + (IMPORT-FROM {symbol-name}*) + (INTERN {symbol-name}*) + (EXPORT {symbol-name}*) + (IMPLEMENT {package-name}*) + (LOCK boolean) + (DOCUMENTATION doc-string) + All options except SIZE, LOCK, and :DOCUMENTATION can be used multiple + times." + (let* ((size nil) + (all-names-size 0) + (intern-export-size 0) + (shadow-etc-size 0) + (documentation nil) + (all-names-hash (let ((all-options-alist nil)) + (dolist (option options) + (let ((option-name (car option))) + (when (memq option-name + '(:nicknames :shadow :shadowing-import-from + :use :import-from :intern :export)) + (let ((option-size (length (cdr option))) + (cell (assq option-name all-options-alist))) + (declare (fixnum option-size)) + (if cell + (incf (cdr cell) option-size) + (push (cons option-name option-size) all-options-alist)) + (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern)) + (incf shadow-etc-size option-size)) + (when (memq option-name '(:export :intern)) + (incf intern-export-size option-size)))))) + (dolist (cell all-options-alist) + (let ((option-size (cdr cell))) + (when (> option-size all-names-size) + (setq all-names-size option-size)))) + (when (> all-names-size 0) + (make-hash-table :test 'equal :size all-names-size)))) + (intern-export-hash (when (> intern-export-size 0) + (make-hash-table :test 'equal :size intern-export-size))) + (shadow-etc-hash (when (> shadow-etc-size 0) + (make-hash-table :test 'equal :size shadow-etc-size))) + (external-size nil) + (nicknames nil) + (shadow nil) + (shadowing-import-from-specs nil) + (use :default) + (import-from-specs nil) + (intern nil) + (export nil)) + (declare (fixnum all-names-size intern-export-size shadow-etc-size)) + (labels ((string-or-name (s) (string s)) + (duplicate-option (o) + (signal-program-error "Duplicate ~S option in ~S ." o options)) + (duplicate-name (name option-name) + (signal-program-error "Name ~s, used in ~s option, is already used in a conflicting option ." name option-name)) + (all-names (option-name tail already) + (when (eq already :default) (setq already nil)) + (when all-names-hash + (clrhash all-names-hash)) + (dolist (name already) + (setf (gethash (string-or-name name) all-names-hash) t)) + (dolist (name tail already) + (setq name (string-or-name name)) + (unless (gethash name all-names-hash) ; Ok to repeat name in same option. + (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern)) + (if (gethash name shadow-etc-hash) + (duplicate-name name option-name)) + (setf (gethash name shadow-etc-hash) t)) + (when (memq option-name '(:export :intern)) + (if (gethash name intern-export-hash) + (duplicate-name name option-name)) + (setf (gethash name intern-export-hash) t)) + (setf (gethash name all-names-hash) t) + (push name already))))) + (dolist (option options) + (let ((args (cdr option))) + (ecase (%car option) + (:size + (if size + (duplicate-option :size) + (setq size (car args)))) + (:external-size + (if external-size + (duplicate-option :external-size) + (setq external-size (car args)))) + (:nicknames (setq nicknames (all-names nil args nicknames))) + (:shadow (setq shadow (all-names :shadow args shadow))) + (:shadowing-import-from + (destructuring-bind (from &rest shadowing-imports) args + (push (cons (string-or-name from) + (all-names :shadowing-import-from shadowing-imports nil)) + shadowing-import-from-specs))) + (:use (setq use (all-names nil args use))) + (:import-from + (destructuring-bind (from &rest imports) args + (push (cons (string-or-name from) + (all-names :import-from imports nil)) + import-from-specs))) + (:intern (setq intern (all-names :intern args intern))) + (:export (setq export (all-names :export args export))) + (:documentation + (if documentation + (duplicate-option :documentation) + (setq documentation (cadr option))))))) + `(eval-when (:execute :compile-toplevel :load-toplevel) + (%define-package ',(string-or-name name) + ',size + ',external-size + ',nicknames + ',shadow + ',shadowing-import-from-specs + ',use + ',import-from-specs + ',intern + ',export + ',documentation))))) + + + +(defmacro with-package-iterator ((mname package-list first-type &rest other-types) + &body body) + "Within the lexical scope of the body forms, MNAME is defined via macrolet + such that successive invocations of (MNAME) will return the symbols, + one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be + any of :INHERITED :EXTERNAL :INTERNAL." + (setq mname (require-type mname 'symbol)) + (let ((state (make-symbol "WITH-PACKAGE-ITERATOR_STATE"))) + (dolist (type (push first-type other-types)) + (ecase type + ((:external :internal :inherited)))) + `(let ((,state (%setup-pkg-iter-state ,package-list ',other-types))) + (macrolet ((,mname () `(%pkg-iter-next ,',state))) + ,@body)))) + +; Does NOT evaluate the constructor, but DOES evaluate the destructor & initializer +(defmacro defresource (name &key constructor destructor initializer) + `(defparameter ,name (make-resource #'(lambda () ,constructor) + ,@(when destructor + `(:destructor ,destructor)) + ,@(when initializer + `(:initializer ,initializer))))) + +(defmacro using-resource ((var resource) &body body) + (let ((resource-var (gensym))) + `(let ((,resource-var ,resource) + ,var) + (unwind-protect + (progn + (setq ,var (allocate-resource ,resource-var)) + ,@body) + (when ,var + (free-resource ,resource-var ,var)))))) + +;;; Bind per-thread specials which help with lock accounting. +(defmacro with-lock-context (&body body) + `(progn ,@body)) + +(defmacro with-lock-grabbed ((lock &optional + (whostate "Lock")) + &body body) + "Wait until a given lock can be obtained, then evaluate its body with +the lock held." + (declare (ignore whostate)) + (let* ((locked (gensym)) + (l (gensym))) + ` (with-lock-context + (let ((,locked (make-lock-acquisition)) + (,l ,lock)) + (declare (dynamic-extent ,locked)) + (unwind-protect + (progn + (%lock-recursive-lock-object ,l ,locked ) + ,@body) + (when (lock-acquisition.status ,locked) (%unlock-recursive-lock-object ,l))))))) + +(defmacro with-lock-grabbed-maybe ((lock &optional + (whostate "Lock")) + &body body) + (declare (ignore whostate)) + (let* ((l (gensym))) + `(with-lock-context + (let* ((,l ,lock)) + (when (%try-recursive-lock-object ,l) + (unwind-protect + (progn ,@body) + (%unlock-recursive-lock-object ,l))))))) + +(defmacro with-standard-abort-handling (abort-message &body body) + (let ((stream (gensym))) + `(restart-case + (catch :abort + (catch-cancel + ,@body)) + (abort () ,@(when abort-message + `(:report (lambda (,stream) + (write-string ,abort-message ,stream))))) + (abort-break ())))) + + + + +(defmacro %lexpr-count (l) + `(%lisp-word-ref ,l 0)) + +(defmacro %lexpr-ref (lexpr count i) + `(%lisp-word-ref ,lexpr (%i- ,count ,i))) + +;;; args will be list if old style clos +(defmacro apply-with-method-context (magic function args) + (let ((m (gensym)) + (f (gensym)) + (as (gensym))) + `((lambda (,m ,f ,as) + (if (listp ,as) + (%apply-with-method-context ,m ,f ,as) + (%apply-lexpr-with-method-context ,m ,f ,as))) ,magic ,function ,args))) + +(defmacro defcallback (name arglist &body body &environment env) + "Proclaim name to be a special variable; sets its value to a MACPTR which, +when called by foreign code, calls a lisp function which expects foreign +arguments of the specified types and which returns a foreign value of the +specified result type. Any argument variables which correspond to foreign +arguments of type :ADDRESS are bound to stack-allocated MACPTRs. + +If name is already a callback function pointer, its value is not changed; +instead, it's arranged that an updated version of the lisp callback function +will be called. This feature allows for callback functions to be redefined +incrementally, just like Lisp functions are. + +defcallback returns the callback pointer, e.g., the value of name." + (define-callback name arglist body env)) + +(declare-arch-specific-macro %get-single-float-from-double-ptr) + +(declare-arch-specific-macro lfun-vector) +(declare-arch-specific-macro lfun-vector-lfun) + +(declare-arch-specific-macro symptr->symvector) +(declare-arch-specific-macro symvector->symptr) + +(declare-arch-specific-macro function-to-function-vector) +(declare-arch-specific-macro function-vector-to-function) + +(declare-arch-specific-macro with-ffcall-results) + +(defvar *trace-print-functions* nil) +(defun %trace-print-arg (stream arg val type) + (format stream " ") + (let ((fn (assoc type *trace-print-functions*))) + (if fn + (funcall (cdr fn) stream arg val) + (progn + (when arg + (format stream "~A = " arg)) + (if (and type (not (eq type :void))) + (format stream "[:~A] ~A~%" type val) + (format stream ":VOID~%")))))) + +(defun def-trace-print-function (type fn) + (push (cons type fn) *trace-print-functions*)) + +(defun define-callback (name args body env) + (let* ((stack-word (gensym)) + (stack-ptr (gensym)) + (fp-args-ptr (gensym)) + (result-type-spec :void) + (args args) + (discard-stack-args nil) ;only meaningful on win32 + (discard-hidden-arg nil) ;only meaningful on x8632 + (info nil) + (woi nil) + (need-struct-arg) + (struct-return-arg-name) + (error-return nil)) + (collect ((arg-names) + (arg-specs)) + (let* ((spec (car (last args))) + (rtype (ignore-errors (parse-foreign-type spec)))) + (setq need-struct-arg (typep rtype 'foreign-record-type)) + (when need-struct-arg + (setq discard-hidden-arg + (funcall (ftd-ff-call-struct-return-by-implicit-arg-function + *target-ftd*) rtype))) + (if rtype + (setq result-type-spec spec args (butlast args)))) + (loop + (when (null args) (return)) + (if (eq (car args) :without-interrupts) + (setq woi (cadr args) args (cddr args)) + (if (eq (car args) :discard-stack-args) + (setq discard-stack-args (eq (backend-target-os *target-backend*) :win32) args (cdr args)) + (if (eq (car args) :error-return) + (setq error-return + (cadr args) + args (cddr args)) + (if need-struct-arg + (setq struct-return-arg-name (pop args) need-struct-arg nil) + (progn + (arg-specs (pop args)) + (arg-names (pop args)))))))) + (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type fp-args-form error-return-offset num-arg-bytes) + (funcall (ftd-callback-bindings-function *target-ftd*) + stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name) + ;; x8632 hair + (when discard-hidden-arg + (if discard-stack-args + ;; We already have to discard some number of args, so just + ;; discard the extra hidden arg while we're at it. + (incf num-arg-bytes 4) + ;; Otherwise, indicate that we'll need to discard the + ;; hidden arg. + (setq info (ash 1 23)))) + (when discard-stack-args + (setq info 0) + ;; put number of words to discard in high-order byte + (setf (ldb (byte 8 24) info) + (ash num-arg-bytes (- target::word-shift)))) + (multiple-value-bind (body decls doc) (parse-body body env t) + `(progn + (declaim (special ,name)) + (define-callback-function + (nfunction ,name + (lambda (,stack-word) + (declare (ignorable ,stack-word)) + (block ,name + (with-macptrs ((,stack-ptr)) + (%setf-macptr-to-object ,stack-ptr ,stack-word) + (with-macptrs (,@(when fp-args-form + `((,fp-args-ptr ,fp-args-form)))) + ,(defcallback-body stack-ptr + fp-args-ptr + lets + rlets + inits + `(declare (dynamic-extent ,@dynamic-extent-names)) + decls + body + foreign-return-type + struct-return-arg-name + error-return + error-return-offset + )))))) + ,doc + ,woi + ,info))))))) + + +(defun defcallback-body (&rest args) + (declare (dynamic-extent args)) + (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args + (declare (ignorable dynamic-extent-decls)) + (let* ((condition-name (if (atom error-return) 'error (car error-return))) + (error-return-function (if (atom error-return) error-return (cadr error-return))) + (result (if struct-return-arg (gensym))) + (body + `(rlet ,rlets + (let ,lets + ,dynamic-extent-decls + ,@other-decls + ,@inits + ,(if result + `(let* ((,result ,@body)) + (declare (dynamic-extent ,result) + (ignorable ,result)) + ,(funcall (ftd-callback-return-value-function *target-ftd*) + stack-ptr + fp-args-ptr + result + return-type + struct-return-arg)) + (if (eq return-type *void-foreign-type*) + `(progn ,@body) + (funcall (ftd-callback-return-value-function *target-ftd*) + stack-ptr + fp-args-ptr + `(progn ,@body) + return-type + struct-return-arg))) + nil)))) + (if error-return + (let* ((cond (gensym)) + (block (gensym)) + (handler (gensym))) + `(block ,block + (let* ((,handler (lambda (,cond) + (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)) + (return-from ,block + nil)))) + (declare (dynamic-extent ,handler)) + (handler-bind ((,condition-name ,handler)) + (values ,body))))) + body)))) + + +(defmacro define-toplevel-command (group-name name arglist &body body &environment env) + (let* ((key (make-keyword name))) + (multiple-value-bind (body decls doc) (parse-body body env) + `(%define-toplevel-command ',group-name ,key ',name + (nfunction ,name (lambda ,arglist + ,@decls + (block ,name + ,@body))) + ,doc + ',(mapcar #'symbol-name arglist))))) + +(defmacro with-toplevel-commands (group-name &body body) + `(let* ((*active-toplevel-commands* *active-toplevel-commands*)) + (progn + (%use-toplevel-commands ',group-name) + ,@body))) + +(defmacro assert (test-form &optional (places ()) string &rest args) + "ASSERT Test-Form [(Place*) [String Arg*]] + If the Test-Form is not true, then signal a correctable error. If Places + are specified, then new values are prompted for when the error is proceeded. + String and Args are the format string and args to the error call." + (let* ((TOP (gensym)) + (setf-places-p (not (null places)))) + `(without-compiling-code-coverage + (tagbody + ,TOP + (unless ,test-form + (%assertion-failure ,setf-places-p ',test-form ,string ,@args) + ,@(if places + `((write-line "Type expressions to set places to, or nothing to leave them alone." + *query-io*) + ,@(mapcar #'(lambda (place &aux (new-val (gensym)) + (set-p (gensym))) + `(multiple-value-bind + (,new-val ,set-p) + (assertion-value-prompt ',place) + (when ,set-p (setf ,place (values-list ,new-val))))) + places))) + (go ,TOP)))))) + + +(defmacro check-type (place typespec &optional string) + "CHECK-TYPE Place Typespec [String] + Signal a restartable error of type TYPE-ERROR if the value of PLACE is + not of the specified type. If an error is signalled and the restart is + used to return, this can only return if the STORE-VALUE restart is + invoked. In that case it will store into PLACE and start over." + (let* ((val (gensym))) + `(without-compiling-code-coverage + (do* ((,val ,place ,place)) + ((typep ,val ',typespec)) + (setf ,place (%check-type ,val ',typespec ',place ,string)))))) + + + + +(defmacro with-hash-table-iterator ((mname hash-table) &body body) + "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body) + provides a method of manually looping over the elements of a hash-table. + FUNCTION is bound to a generator-macro that, within the scope of the + invocation, returns one or three values. The first value tells whether + any objects remain in the hash table. When the first value is non-NIL, + the second and third values are the key and the value of the next object." + (let* ((hash (gensym)) + (keys (gensym)) + (values (gensym)) + (count (gensym)) + (state (gensym))) + `(let* ((,hash ,hash-table) + (,count (hash-table-count ,hash)) + (,keys (make-array ,count)) + (,values (make-array ,count)) + (,state (vector ,hash 0 ,keys ,values (enumerate-hash-keys-and-values ,hash ,keys ,values)))) + (declare (dynamic-extent ,keys ,state) + (fixnum ,count)) + (macrolet ((,mname () `(next-hash-table-iteration-1 ,',state))) + ,@body)))) + + +(eval-when (compile load eval) +(defmacro pprint-logical-block ((stream-symbol list + &key (prefix "" prefixp) + (per-line-prefix "" per-line-prefix-p) + (suffix "" suffixp)) + &body body) + (cond ((eq stream-symbol nil) (setq stream-symbol '*standard-output*)) + ((eq stream-symbol T) (setq stream-symbol '*terminal-io*))) + (when (not (symbolp stream-symbol)) + (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol" + stream-symbol) + (setq stream-symbol '*standard-output*)) + (when (and prefixp per-line-prefix-p) + (warn "prefix ~S and per-line-prefix ~S cannot both be specified ~ + in PPRINT-LOGICAL-BLOCK" prefix per-line-prefix) + (setq per-line-prefix nil)) + `(let ((*logical-block-p* t)) + (maybe-initiate-xp-printing + #'(lambda (,stream-symbol) + (let ((+l ,list) + (+p (or (and ,prefixp + (require-type ,prefix 'string)) + (and ,per-line-prefix-p + (require-type ,per-line-prefix 'string)))) + (+s (require-type ,suffix 'string))) + (pprint-logical-block+ + (,stream-symbol +l +p +s ,per-line-prefix-p T nil) + ,@ body nil))) + (decode-stream-arg ,stream-symbol)))) + + +;Assumes var and args must be variables. Other arguments must be literals or variables. + +(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?) + &body body) + "Group some output into a logical block. STREAM-SYMBOL should be either a + stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer + control variable *PRINT-LEVEL* is automatically handled." + (when (and circle-check? atsign?) + (setq circle-check? 'not-first-p)) + `(let ((*current-level* (1+ *current-level*)) + (*current-length* -1) + ;(*parents* *parents*) + ,@(if (and circle-check? atsign?) `((not-first-p (plusp *current-length*))))) + (unless (check-block-abbreviation ,var ,args ,circle-check?) + (start-block ,var ,prefix ,per-line? ,suffix) + (when + (catch 'line-limit-abbreviation-exit + (block logical-block + (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var)) + (pprint-exit-if-list-exhausted () + `(if (null ,',args) (return-from logical-block nil)))) + ,@ body)) + (end-block ,var ,suffix) + nil) + (end-block ,var ,suffix) + (throw 'line-limit-abbreviation-exit T))))) +) ; eval-when + +(defmacro %old-class-local-shared-slotds (class &optional default) + (if default ; so setf works + `(%class-get ,class '%old-class-local-shared-slotds ,default) + `(%class-get ,class '%old-class-local-shared-slotds))) + +(defmacro with-slot-values (slot-entries instance-form &body body) +; Simplified form of with-slots. Expands into a let instead of a symbol-macrolet +; Thus, you can access the slot values, but you can't setq them. + (let ((instance (gensym)) var slot-name bindings) + (dolist (slot-entry slot-entries) + (cond ((symbolp slot-entry) + (setq var slot-entry slot-name slot-entry)) + ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry)) + (symbolp (car slot-entry)) (symbolp (cadr slot-entry))) + (setq var (car slot-entry) slot-name (cadr slot-entry))) + (t (signal-program-error "Malformed slot-entry: ~a to with-slot-values.~@ + Should be a symbol or a list of two symbols." + slot-entry))) + (push `(,var (slot-value ,instance ',slot-name)) bindings)) + `(let ((,instance ,instance-form)) + (let ,(nreverse bindings) + ,@body)))) + +(defmacro with-slots (slot-entries instance-form &body body) + "Establish a lexical environment for referring to the slots in the +instance named by the given slot-names as though they were variables. +Within such a context the value of the slot can be specified by using +its slot name, as if it were a lexically bound variable. Both setf and +setq can be used to set the value of the slot." + (let ((instance (gensym)) var slot-name bindings) + (dolist (slot-entry slot-entries) + (cond ((symbolp slot-entry) + (setq var slot-entry slot-name slot-entry)) + ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry)) + (symbolp (car slot-entry)) (symbolp (cadr slot-entry))) + (setq var (car slot-entry) slot-name (cadr slot-entry))) + (t (signal-program-error "Malformed slot-entry: ~a to with-slots.~@ + Should be a symbol or a list of two symbols." + slot-entry))) + (push `(,var (slot-value ,instance ',slot-name)) bindings)) + `(let ((,instance ,instance-form)) + ,@(if bindings + (list `(declare (ignorable ,instance))) + (list `(declare (ignore ,instance)))) + (symbol-macrolet ,(nreverse bindings) + ,@body)))) + +(defmacro with-accessors (slot-entries instance-form &body body) + "Create a lexical environment in which the slots specified by slot-entry +are lexically available through their accessors as if they were variables. +The appropriate accessors are invoked to access the slots specified by +slot-entry. Both setf and setq can be used to set the value of the slot." + (let ((instance (gensym)) var reader bindings) + (dolist (slot-entry slot-entries) + (cond ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry)) + (symbolp (car slot-entry)) (symbolp (cadr slot-entry))) + (setq var (car slot-entry) reader (cadr slot-entry))) + (t (signal-program-error "Malformed slot-entry: ~a to with-accessors.~@ + Should be a list of two symbols." + slot-entry))) + (push `(,var (,reader ,instance)) bindings)) + `(let ((,instance ,instance-form)) + ,@(if bindings + (list `(declare (ignorable ,instance))) + (list `(declare (ignore ,instance)))) + (symbol-macrolet ,(nreverse bindings) + ,@body)))) + +; I wanted to call this ":method" +(defmacro reference-method (gf &rest qualifiers-and-specializers) + (let ((qualifiers (butlast qualifiers-and-specializers)) + (specializers (car (last qualifiers-and-specializers)))) + (if (null specializers) (report-bad-arg qualifiers-and-specializers '(not null))) + `(find-method #',gf ',qualifiers (mapcar #'find-specializer ',specializers)))) + +(defmacro time (form) + "Execute FORM and print timing information on *TRACE-OUTPUT*." + `(report-time ',form #'(lambda () (progn ,form)))) + +(defmacro with-error-reentry-detection (&body body) + (let ((thunk (gensym))) + `(let ((,thunk #'(lambda () ,@body))) + (declare (dynamic-extent ,thunk)) + (funcall-with-error-reentry-detection ,thunk)))) + +(defmacro without-duplicate-definition-warnings (&body body) + `(compiler-let ((*compiler-warn-on-duplicate-definitions* nil)) + ,@body)) + + +#+ppc-target +(defmacro scan-for-instr (mask opcode fn pc-index &optional (tries *trap-lookup-tries*)) + `(%scan-for-instr ,mask ,opcode ,fn ,pc-index ,tries)) + + +(declare-arch-specific-macro codevec-header-p) + +#+ppc-target +(defmacro match-instr (instr mask bits-to-match) + `(eql (logand ,instr ,mask) ,bits-to-match)) + +(defmacro with-xp-stack-frames ((xp trap-function &optional stack-frame) &body body) + (let ((thunk (gensym)) + (sf (or stack-frame (gensym)))) + `(let ((,thunk #'(lambda (&optional ,sf) + ,@(unless stack-frame `((declare (ignore ,sf)))) + ,@body))) + (declare (dynamic-extent ,thunk)) + (funcall-with-xp-stack-frames ,xp ,trap-function ,thunk)))) + +(defmacro signal-eof-error (stream) + `(error 'end-of-file :stream ,stream)) + +(defmacro check-eof (valform stream eof-error-p eof-value) + (let* ((val (gensym))) + `(let ((,val ,valform)) + (if (eq ,val :eof) + (if ,eof-error-p + (signal-eof-error ,stream) + ,eof-value) + ,val)))) + +(defmacro designated-input-stream (input-stream) + `(if ,input-stream + (if (eq t ,input-stream) + *terminal-io* + ,input-stream) + *standard-input*)) + +(defmacro pref (pointer accessor) + "Reference an instance of a foreign type (or a component of a foreign +type) accessible via ptr. + +Expand into code which references the indicated scalar type or component, +or returns a pointer to a composite type." + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + (destructuring-bind (type-name &rest accessors) (decompose-record-accessor accessor) + (%foreign-access-form pointer (%foreign-type-or-record type-name) 0 accessors)))) + +(defmacro paref (pointer type-name index) + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + (%foreign-array-access-form pointer (%foreign-type-or-record type-name) index))) + +(defmacro rref (pointer accessor &key (storage :pointer storage-p)) + (when storage-p + (warn "Use of :storage option ignored: ~a" storage)) + `(pref ,pointer ,accessor)) + +(defmacro rlet (spec &body body) + "Execute body in an environment in which each var is bound to a MACPTR +encapsulating the address of a stack-allocated foreign memory block, +allocated and initialized from typespec and initforms as per make-record. +Return whatever value(s) body returns." + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + `(%stack-block ,(rlet-sizes spec) + ,@(rlet-inits spec) + ,@body))) + +(defmacro rletz (spec &body body) + "Execute body in an environment in which each var is bound to a MACPTR +encapuslating the address of a stack-allocated foreign memory block, +allocated and initialized from typespec and initforms as per make-record. +Return whatever value(s) body returns. + +Unlike rlet, record fields that aren't explicitly initialized are set +to binary 0." + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + `(%stack-block ,(rlet-sizes spec t) + ,@(rlet-inits spec) + ,@body))) + +(defun rlet-sizes (inits &optional clear-p &aux result) + (dolist (item inits (nreverse result)) + (push `(,(car item) + ,(%foreign-type-or-record-size (cadr item) :bytes) + ,@(if clear-p '(:clear t))) + result))) + +(defun rlet-inits (inits &aux result) + (dolist (item inits result) + (let* ((name (car item)) + (record-name (cadr item)) + (inits (cddr item)) + (ftype (%foreign-type-or-record record-name)) + (ordinal (foreign-type-ordinal ftype)) + (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal) + ordinal + `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name)))))) + (when (eq *host-backend* *target-backend*) + (setq result (nconc result `((%set-macptr-type ,name ,ordinal-form))))) + (if (typep ftype 'foreign-record-type) + (setq result + (nconc result (%foreign-record-field-forms name ftype record-name inits))) + (progn + (when inits + (if (and ftype (null (cdr inits))) + (setq result + (nconc result + `((setf ,(%foreign-access-form name ftype 0 nil) + ,(car inits))))) + (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s" + inits record-name)))))))) + +(defun %foreign-record-field-forms (ptr record-type record-name inits) + (unless (evenp (length inits)) + (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s" + inits record-name)) + (let* ((result ())) + (do* () + ((null inits) + `((progn + ;(%assert-macptr-ftype ,ptr ,record-type) + ,@(nreverse result)))) + (let* ((accessor (decompose-record-accessor (pop inits))) + (valform (pop inits))) + (push `(setf ,(%foreign-access-form ptr record-type 0 accessor) ,valform) + result))))) + +(defmacro get-field-offset (accessor) + (destructuring-bind (type-name field-name) (decompose-record-accessor accessor) + (let* ((record-type (require-type (%foreign-type-or-record type-name) 'foreign-record-type)) + (field (%find-foreign-record-type-field record-type field-name)) + (bit-offset (foreign-record-field-offset field))) + `(values ,(floor bit-offset 8) ,(foreign-record-field-type field) ,bit-offset)))) + +(defmacro record-length (recname) + (%foreign-type-or-record-size recname :bytes)) + +(defun make-record-form (record-name allocator &rest initforms) + (let* ((ftype (%foreign-type-or-record record-name)) + (ordinal (foreign-type-ordinal ftype)) + (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal) + ordinal + `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name))))) + (bits (ensure-foreign-type-bits ftype)) + (bytes (if bits + (ceiling bits 8) + (signal-program-error "Unknown size for foreign type ~S." + (unparse-foreign-type ftype)))) + (p (gensym)) + (memset (read-from-string "#_memset"))) + `(let* ((,p (,allocator ,bytes))) + ,@(when (eq *host-backend* *target-backend*) + `((%set-macptr-type ,p ,ordinal-form))) + (,memset ,p 0 ,bytes) + ,@(%foreign-record-field-forms p ftype record-name initforms) + ,p))) + +(defmacro make-record (record-name &rest initforms) + "Expand into code which allocates and initalizes an instance of the type +denoted by typespec, on the foreign heap. The record is allocated using the +C function malloc, and the user of make-record must explicitly call the C +function free to deallocate the record, when it is no longer needed." + (apply 'make-record-form record-name 'malloc initforms)) + +(defmacro make-gcable-record (record-name &rest initforms) + "Like MAKE-RECORD, only advises the GC that the foreign memory can + be deallocated if the returned pointer becomes garbage." + (apply 'make-record-form record-name '%new-gcable-ptr initforms)) + +(defmacro copy-record (type source dest) + (let* ((size (* (%foreign-type-or-record-size type :words) #+64-bit-target 1 #+32-bit-target 2)) + (src (gensym "SRC")) + (dst (gensym "DST")) + (accessor #+64-bit-target '%get-unsigned-long #+32-bit-target '%get-unsigned-word) + (i (gensym "I")) + (j (gensym "J"))) + `(with-macptrs ((,src ,source) + (,dst ,dest)) + (do* ((,i 0 (+ ,i #+64-bit-target 4 #+32-bit-target 2)) + (,j 0 (+ ,j 1))) + ((= ,j ,size)) + (declare (fixnum ,i)) + (setf (,accessor ,dst ,i) (,accessor ,src ,i)))))) + +(defmacro assert-pointer-type (pointer type) + "Assert that the pointer points to an instance of the specified foreign type. +Return the pointer." + (let* ((ptr (gensym))) + `(let* ((,ptr ,pointer)) + (%set-macptr-type ,ptr (foreign-type-ordinal (load-time-value (parse-foreign-type ',type)))) + ,ptr))) + + + +(defmacro with-terminal-input (&body body) + "Execute body in an environment with exclusive read access to the terminal." + (let* ((got-it (gensym))) + `(let* ((,got-it (%request-terminal-input))) + (unwind-protect + (progn ,@body) + (%restore-terminal-input ,got-it))))) + + +(defmacro with-process-whostate ((whostate) &body body) + `(let* ((*whostate* ,whostate)) + ,@body)) + + + + + +(defmacro with-read-lock ((lock) &body body) + "Wait until a given lock is available for read-only access, then evaluate +its body with the lock held." + (let* ((p (gensym))) + `(with-lock-context + (let* ((,p ,lock)) + (unwind-protect + (progn + (read-lock-rwlock ,p) + ,@body) + (unlock-rwlock ,p)))))) + + +(defmacro with-write-lock ((lock) &body body) + "Wait until the given lock is available for write access, then execute +its body with the lock held." + (let* ((p (gensym))) + `(with-lock-context + (let* ((,p ,lock)) + (unwind-protect + (progn + (write-lock-rwlock ,p) + ,@body) + (unlock-rwlock ,p)))))) + + + +(defmacro without-gcing (&body body) + `(unwind-protect + (progn + (%lock-gc-lock) + ,@body) + (%unlock-gc-lock))) + +(defmacro with-deferred-gc (&body body) + "Execute BODY without responding to the signal used to suspend +threads for GC. BODY must be very careful not to do anything which +could cause an exception (note that attempting to allocate lisp memory +may cause an exception.)" + `(let* ((*interrupt-level* -2)) + ,@body)) + +(defmacro allowing-deferred-gc (&body body) + "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC." + `(let* ((*interrupt-level* -1)) + (%check-deferred-gc) + ,@body)) + +(defmacro defer-gc () + `(setq *interrupt-level* -2)) + + +(defmacro with-pointer-to-ivector ((ptr ivector) &body body) + "Executes BODY with PTR bound to a pointer to the first byte of data +in IVECTOR. The GC is disabled during execution of BODY; PTR has +has dynamic-extent (and the address it references may become invalid +after the BODY exits.) IVECTOR should be a (SIMPLE-ARRAY (*)) whose +element-type is numeric." + (let* ((v (gensym))) + `(let* ((,v ,ivector)) + (unless (typep ,v 'ivector) (report-bad-arg ,v 'ivector)) + (without-gcing + (with-macptrs ((,ptr)) + (%vect-data-to-macptr ,v ,ptr) + ,@body))))) + + + +(defmacro with-other-threads-suspended (&body body) + `(unwind-protect + (progn + (%suspend-other-threads) + ,@body) + (%resume-other-threads))) + +(defmacro with-package-read-lock ((p) &body body) + `(with-read-lock ((pkg.lock ,p)) ,@body)) + +(defmacro with-package-write-lock ((p) &body body) + `(with-write-lock ((pkg.lock ,p)) ,@body)) + +(defmacro with-package-lock ((p) &body body) + `(with-package-write-lock (,p) ,@body)) + +;;; Lock %all-packages-lock%, for shared read access to %all-packages% + +(defmacro with-package-list-read-lock (&body body) + `(with-read-lock (%all-packages-lock%) ,@body)) + +;;; Lock %all-packages-lock%, to allow modification to %all-packages% +(defmacro with-package-list-write-lock (&body body) + `(with-write-lock (%all-packages-lock%) ,@body)) + +(defmacro atomic-incf-decf (place delta &environment env) + (setq place (macroexpand place env)) + (if (consp place) + (let* ((sym (car place)) + (struct-transform (or (environment-structref-info sym env) + (gethash sym %structure-refs%)))) + (if struct-transform + (setq place (defstruct-ref-transform struct-transform (cdr place) env) + sym (car place))) + (ecase sym + (the `(the ,(cadr place) (atomic-incf-decf ,(caddr place) ,delta))) + ;; Needed so can handle %svref (which macroexpands into a LET*) + ((let let*) (multiple-value-bind (body decls) (parse-body (cddr place) env t) + (unless (eql (length body) 1) + (error "~S is not a valid atomic-incf/decf place" place)) + `(,sym ,(cadr place) ,@decls (atomic-incf-decf ,@body ,delta)))) + ;; Ditto + (locally (multiple-value-bind (body decls) (parse-body (cdr place) env t) + (unless (eql (length body) 1) + (error "~S is not a valid atomic-incf/decf place" place)) + `(,sym ,@decls (atomic-incf-decf ,@body ,delta)))) + (car `(%atomic-incf-car ,(cadr place) ,delta)) + (cdr `(%atomic-incf-cdr ,(cadr place) ,delta)) + (svref `(%atomic-incf-gvector ,@(cdr place) ,delta)))) + (if (and (symbolp place) (eq :special (variable-information place env))) + (let* ((base (gensym)) + (offset (gensym))) + `(multiple-value-bind (,base ,offset) + (%symbol-binding-address ',place) + (%atomic-incf-node ,delta ,base ,offset))) + (signal-program-error "~S is not a special variable" place)))) + +(defmacro atomic-incf (place) + `(atomic-incf-decf ,place 1)) + +(defmacro atomic-decf (place) + `(atomic-incf-decf ,place -1)) + +; Some of these macros were stolen from CMUCL. Sort of ... + +(defmacro iterate (name binds &body body) + "Iterate Name ({(Var Initial-Value)}*) Declaration* Form* + This is syntactic sugar for Labels. It creates a local function Name with + the specified Vars as its arguments and the Declarations and Forms as its + body. This function is then called with the Initial-Values, and the result + of the call is return from the macro." + (dolist (x binds) + (unless (and (listp x) + (= (length x) 2)) + (signal-program-error "Malformed iterate variable spec: ~S." x))) + + `(labels ((,name ,(mapcar #'first binds) ,@body)) + (,name ,@(mapcar #'second binds)))) + +;;;; The Collect macro: + +;;; Collect-Normal-Expander -- Internal +;;; +;;; This function does the real work of macroexpansion for normal collection +;;; macros. N-Value is the name of the variable which holds the current +;;; value. Fun is the function which does collection. Forms is the list of +;;; forms whose values we are supposed to collect. +;;; +(eval-when (:compile-toplevel :load-toplevel :execute) + + +(defun collect-normal-expander (n-value fun forms) + `(progn + ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) + ,n-value)) + + +) + +(defmacro once-only (specs &body body) + "Once-Only ({(Var Value-Expression)}*) Form* + Create a Let* which evaluates each Value-Expression, binding a temporary + variable to the result, and wrapping the Let* around the result of the + evaluation of Body. Within the body, each Var is bound to the corresponding + temporary variable." + (iterate frob + ((specs specs) + (body body)) + (if (null specs) + `(progn ,@body) + (let ((spec (first specs))) + (when (/= (length spec) 2) + (signal-program-error "Malformed ~s binding spec: ~S." 'once-only spec)) + (let ((name (first spec)) + (exp-temp (gensym))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun form-symbol (first &rest others) + (intern (apply #'concatenate 'simple-base-string (string first) (mapcar #'string others)))) +) + + +;;; Collect-List-Expander -- Internal +;;; +;;; This function deals with the list collection case. N-Tail is the pointer +;;; to the current tail of the list, which is NIL if the list is empty. +;;; +(defun collect-list-expander (n-value n-tail forms) + (let ((n-res (gensym))) + `(progn + ,@(mapcar #'(lambda (form) + `(let ((,n-res (cons ,form nil))) + (cond (,n-tail + (setf (cdr ,n-tail) ,n-res) + (setq ,n-tail ,n-res)) + (t + (setq ,n-tail ,n-res ,n-value ,n-res))))) + forms) + ,n-value))) + +;;; +;;; The ultimate collection macro... +;;; + +(defmacro collect (collections &body body) + "Collect ({(Name [Initial-Value] [Function])}*) {Form}* + Collect some values somehow. Each of the collections specifies a bunch of + things which collected during the evaluation of the body of the form. The + name of the collection is used to define a local macro, a la MACROLET. + Within the body, this macro will evaluate each of its arguments and collect + the result, returning the current value after the collection is done. The + body is evaluated as a PROGN; to get the final values when you are done, just + call the collection macro with no arguments. + + Initial-Value is the value that the collection starts out with, which + defaults to NIL. Function is the function which does the collection. It is + a function which will accept two arguments: the value to be collected and the + current collection. The result of the function is made the new value for the + collection. As a totally magical special-case, the Function may be Collect, + which tells us to build a list in forward order; this is the default. If an + Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the + end. Note that Function may be anything that can appear in the functional + position, including macros and lambdas." + + + (let ((macros ()) + (binds ())) + (dolist (spec collections) + (unless (<= 1 (length spec) 3) + (signal-program-error "Malformed collection specifier: ~S." spec)) + (let ((n-value (gensym)) + (name (first spec)) + (default (second spec)) + (kind (or (third spec) 'collect))) + + (push `(,n-value ,default) binds) + (if (eq kind 'collect) + (let ((n-tail (gensym))) + (if default + (push `(,n-tail (last ,n-value)) binds) + (push n-tail binds)) + (push `(,name (&rest args) + (collect-list-expander ',n-value ',n-tail args)) + macros)) + (push `(,name (&rest args) + (collect-normal-expander ',n-value ',kind args)) + macros)))) + `(macrolet ,macros (let* ,(nreverse binds) (declare (ignorable ,@binds)) ,@body)))) + + +;;; DEFENUM -- Internal Interface. +;;; +(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) + &rest identifiers) + (let ((results nil) + (index 0) + (start (eval start)) + (step (eval step))) + (dolist (id identifiers) + (multiple-value-bind + (root docs) + (if (consp id) + (values (car id) (cdr id)) + (values id nil)) + (push `(defconstant ,(intern (concatenate 'simple-base-string + (string prefix) + (string root) + (string suffix))) + ,(+ start (* step index)) + ,@docs) + results)) + (incf index)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(nreverse results)))) + + +;;; This does something like special binding, but the "bindings" established +;;; aren't thread-specific. + +(defmacro let-globally ((&rest vars) &body body &environment env) + (multiple-value-bind (body decls) (parse-body body env) + (let* ((initforms nil) + (psetform nil) + (specvars nil) + (restoreform nil)) + (flet ((pair-name-value (p) + (if (atom p) + (values (require-global-symbol p env) nil) + (if (and (consp (%cdr p)) (null (%cddr p))) + (values (require-global-symbol (%car p) env) (%cadr p)) + (signal-program-error "Invalid variable initialization form : ~s"))))) + (declare (inline pair-name-value)) + (dolist (v vars) + (let* ((oldval (gensym)) + (newval (gensym))) + (multiple-value-bind (var valueform) (pair-name-value v) + (push var specvars) + (push var restoreform) + (push oldval restoreform) + (push `(,oldval (uvref (symptr->symvector ',var) #.target::symbol.vcell-cell)) initforms) + (push `(,newval ,valueform) initforms) + (push var psetform) + (push newval psetform)))) + `(let ,(nreverse initforms) + ,@decls + (locally (declare (special ,@(nreverse specvars))) + (unwind-protect + (progn (psetq ,@(nreverse psetform)) ,@body) + (psetq ,@(nreverse restoreform))))))))) +;;; From CLX. + +;;; The good news is that this uses an interlocked load/store sequence +;;; and is fairly efficient. +;;; The bad news is that it only handles a few types of "place" forms. +;;; The good news is that CLX only uses a few types of "place" forms. + +(defmacro conditional-store (place old-value new-value &environment env) + (setq place (macroexpand place env)) + (if (atom place) + ;; CLX uses special variables' value cells as place forms. + (if (and (symbolp place) + (eq :special (ccl::variable-information place env))) + (let* ((base (gensym)) + (offset (gensym))) + `(multiple-value-bind (,base ,offset) + (ccl::%symbol-binding-address ',place) + (ccl::%store-node-conditional ,offset ,base ,old-value ,new-value))) + (signal-program-error "~s is not a special variable ." place)) + (let* ((sym (car place)) + (struct-transform (or (ccl::environment-structref-info sym env) + (gethash sym ccl::%structure-refs%)))) + (if struct-transform + (setq place (defstruct-ref-transform struct-transform (cdr place) env) + sym (car place))) + (if (member sym '(svref ccl::%svref ccl::struct-ref)) + (let* ((v (gensym))) + `(let* ((,v ,(cadr place))) + (ccl::store-gvector-conditional ,(caddr place) + ,v ,old-value ,new-value))) + (signal-program-error "Don't know how to do conditional store to ~s" place))))) + +(defmacro step (form) + "The form is evaluated with single stepping enabled. Function calls +outside the lexical scope of the form can be stepped into only if the +functions in question have been compiled with sufficient DEBUG policy +to be at least partially steppable." + form) + +(defmacro target-arch-case (&rest clauses) + `(case (backend-target-arch-name *target-backend*) + ,@clauses)) + +(defmacro target-os-case (&rest clauses) + `(ecase (backend-target-os *target-backend*) + ,@clauses)) + +(defmacro target-word-size-case (&rest clauses) + `(ecase (arch::target-nbits-in-word (backend-target-arch *target-backend*)) + ,@clauses)) + +(defmacro %get-natural (&body body) + "A free copy of the next OpenMCL release to anyone who remembers Flakey Foont" + (target-word-size-case + (32 `(%get-unsigned-long ,@body)) + (64 `(%%get-unsigned-longlong ,@body)))) + +(defmacro %get-signed-natural (&body body) + "And that's my final offer." + (target-word-size-case + (32 `(%get-signed-long ,@body)) + (64 `(%%get-signed-longlong ,@body)))) + +(declare-arch-specific-macro %target-kernel-global) + +;;; This behaves like a function, but looks up the kernel global +;;; at compile time if possible. Probably should be done as a function +;;; and a compiler macro, but we can't define compiler macros yet, +;;; and I don't want to add it to "ccl:compiler;optimizers.lisp" +(declare-arch-specific-macro %get-kernel-global) + +(declare-arch-specific-macro %get-kernel-global-ptr) + +(declare-arch-specific-macro area-code) + +(declare-arch-specific-macro nth-immediate) + +(declare-arch-specific-macro set-nth-immediate) + +(defsetf nth-immediate set-nth-immediate) + +(defmacro do-consing-areas ((area) &body body) + (let ((code (gensym))) + `(do-gc-areas (,area) + (let ((,code (%fixnum-ref ,area (area-code)))) + (when (or (eql ,code area-readonly) + (eql ,code area-watched) + (eql ,code area-managed-static) + (eql ,code area-static) + (eql ,code area-dynamic)) + ,@body))))) + +(declare-arch-specific-macro area-succ) + + +(defmacro do-gc-areas ((area) &body body) + (let ((initial-area (gensym))) + `(let* ((,initial-area (%get-kernel-global 'all-areas)) + (,area ,initial-area)) + (declare (fixnum ,initial-area ,area)) + (loop + (setq ,area (%fixnum-ref ,area (area-succ))) + (when (eql ,area ,initial-area) + (return)) + ,@body)))) + +(defmacro with-ioblock-input-lock-grabbed ((ioblock) &body body) + (let* ((i (gensym))) + `(let* ((,i ,ioblock)) + (with-lock-grabbed ((ioblock-inbuf-lock ,i)) + (cond ((ioblock-device ,i) + ,@body) + (t (stream-is-closed (ioblock-stream ,i)))))))) + +(defmacro with-ioblock-output-lock-grabbed ((ioblock) &body body) + (let* ((i (gensym))) + `(let* ((,i ,ioblock)) + (with-lock-grabbed ((ioblock-outbuf-lock ,i)) + (cond ((ioblock-device ,i) + ,@body) + (t (stream-is-closed (ioblock-stream ,i)))))))) + + +(defmacro with-stream-ioblock-input ((ioblock stream &key + speedy) + &body body) + `(let ((,ioblock (stream-ioblock ,stream t))) + ,@(when speedy `((declare (optimize (speed 3) (safety 0))))) + (with-ioblock-input-locked (,ioblock) ,@body))) + +(defmacro with-stream-ioblock-output ((ioblock stream &key + speedy) + &body body) + `(let ((,ioblock (stream-ioblock ,stream t))) + ,@(when speedy `((declare (optimize (speed 3) (safety 0))))) + (with-ioblock-output-locked (,ioblock) ,@body))) + +(defmacro with-stream-ioblock-output-maybe ((ioblock stream &key + speedy) + &body body) + `(let ((,ioblock (stream-ioblock ,stream t))) + ,@(when speedy `((declare (optimize (speed 3) (safety 0))))) + (with-ioblock-output-locked-maybe (,ioblock) ,@body))) + +(defmacro with-ioblock-input-locked ((ioblock) &body body) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-inbuf-lock ,ioblock)))) + (if ,lock + (with-lock-grabbed (,lock) + (cond ((ioblock-device ,ioblock) + ,@body) + (t (stream-is-closed (ioblock-stream ,ioblock))))) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) + +(defmacro with-ioblock-output-locked ((ioblock) &body body) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-outbuf-lock ,ioblock)))) + (if ,lock + (with-lock-grabbed (,lock) + (cond ((ioblock-device ,ioblock) + ,@body) + (t (stream-is-closed (ioblock-stream ,ioblock))))) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) + + + +(defmacro with-ioblock-output-locked-maybe ((ioblock) &body body) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-outbuf-lock ,ioblock)))) + (if ,lock + (with-lock-grabbed (,lock) + (cond ((ioblock-device ,ioblock) + ,@body) + (t (stream-is-closed (ioblock-stream ,ioblock))))) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) + +;;; Use this when it's possible that the fd might be in +;;; a non-blocking state. Body must return a negative of +;;; the os error number on failure. +;;; The use of READ-FROM-STRING below is certainly ugly, but macros +;;; that expand into reader-macros don't generally trigger the reader-macro's +;;; side-effects. (Besides, the reader-macro might return a different +;;; value when the macro function is expanded than it did when the macro +;;; function was defined; this can happen during cross-compilation.) +(defmacro with-eagain (fd direction &body body) + (let* ((res (gensym)) + (eagain (symbol-value (read-from-string "#$EAGAIN")))) + `(loop + (let ((,res (progn ,@body))) + (if (eql ,res (- ,eagain)) + (progn + (setq ,res + (,(ecase direction + (:input 'process-input-would-block) + (:output 'process-output-would-block)) + ,fd)) + (unless (eq ,res t) (return ,res))) + (return ,res)))))) + +(defmacro ignoring-eintr (&body body) + (let* ((res (gensym)) + (eintr (symbol-value (read-from-string "#$EINTR")))) + `(loop + (let* ((,res (progn ,@body))) + (unless (eql ,res (- ,eintr)) + (return ,res)))))) + +(defmacro ff-call-ignoring-eintr (&body body) + (let* ((res (gensym)) + (eintr (symbol-value (read-from-string "#$EINTR")))) + `(loop + (let* ((,res (progn ,@body))) + (declare (fixnum ,res)) + (when (< ,res 0) + (setq ,res (%get-errno))) + (unless (eql ,res (- ,eintr)) + (return ,res)))))) + +(defmacro basic-stream-ioblock (s) + `(or (basic-stream.state ,s) + (stream-is-closed ,s))) + +(defsetf interrupt-level set-interrupt-level) + +(defmacro %swap-u16 (val) + (let* ((arg (gensym))) + `(let* ((,arg ,val)) + (declare (type (unsigned-byte 16) ,arg)) + (logand #xffff (the fixnum (logior (the fixnum (ash ,arg -8)) + (the fixnum (ash ,arg 8)))))))) + +(defmacro %swap-u32 (val) + (let* ((arg (gensym))) + `(let ((,arg ,val)) + (declare (type (unsigned-byte 32) ,arg)) + (the (unsigned-byte 32) (logior (the (unsigned-byte 32) + (ash (logand #xff ,arg) 24)) + (the (unsigned-byte 24) + (logior + (the (unsigned-byte 24) (ash (logand #xff00 ,arg) 8)) + (the (unsigned-byte 16) + (logior + (the (unsigned-byte 16) (ash (logand #xff0000 ,arg) -8)) + (the (unsigned-byte 8) (ash ,arg -24))))))))))) + + +(defmacro multiple-value-bind (varlist values-form &body body &environment env) + (multiple-value-bind (body decls) + (parse-body body env) + (let ((ignore (make-symbol "IGNORE"))) + `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore) + (declare (ignore ,ignore)) + ,@decls + ,@body) + ,values-form)))) + +(defmacro multiple-value-setq (vars val) + (if vars + `(values (setf (values ,@(mapcar #'(lambda (s) (require-type s 'symbol)) vars)) ,val)) + `(prog1 ,val))) + +(defmacro nth-value (n form) + "Evaluate FORM and return the Nth value (zero based). This involves no + consing when N is a trivial constant integer." + `(car (nthcdr ,n (multiple-value-list ,form)))) + + + +(defmacro with-input-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body) + "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's +stream-input-timeout set to TIMEOUT." + (let* ((old-input-timeout (gensym)) + (stream (gensym))) + `(let* ((,stream ,stream-form) + (,stream-var ,stream) + (,old-input-timeout (stream-input-timeout ,stream))) + (unwind-protect + (progn + (setf (stream-input-timeout ,stream) ,timeout) + ,@body) + (setf (stream-input-timeout ,stream) ,old-input-timeout))))) + +(defmacro with-output-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body) + "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's +stream-output-timeout set to TIMEOUT." + (let* ((old-output-timeout (gensym)) + (stream (gensym))) + `(let* ((,stream ,stream-form) + (,stream-var ,stream) + (,old-output-timeout (stream-output-timeout ,stream))) + (unwind-protect + (progn + (setf (stream-output-timeout ,stream) ,timeout) + ,@body) + (setf (stream-output-timeout ,stream) ,old-output-timeout))))) + +;;; FORM returns a signed integer. If it's non-negative, return that +;;; value, otherwise, return the (negative) errnor value returned by +;;; %GET-ERRNO +(defmacro int-errno-call (form) + (let* ((value (gensym))) + `(let* ((,value ,form)) + (if (< ,value 0) + (%get-errno) + ,value)))) + +(defmacro int-errno-ffcall (entry &rest args) + `(int-errno-call (ff-call ,entry ,@args))) Index: /branches/qres/ccl/lib/mcl-compat.lisp =================================================================== --- /branches/qres/ccl/lib/mcl-compat.lisp (revision 13564) +++ /branches/qres/ccl/lib/mcl-compat.lisp (revision 13564) @@ -0,0 +1,48 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; mcl-compat.lisp - (some) backwards-compatibility with traditional MCL +;;; (CLtL2/ANSI, etc.) + +;;; Gratuitous name changes, for the most part: + +(deftype base-character () 'base-char) +(deftype extended-character () 'extended-char) + +(defmacro define-setf-method (access-fn lambda-list &body body) + `(define-setf-expander ,access-fn ,lambda-list ,@body)) + +(defun get-setf-method (form &optional environment) + (get-setf-expansion-aux form environment nil)) + +(defun get-setf-method-multiple-value (form &optional environment) + "Like Get-Setf-Method, but may return multiple new-value variables." + (get-setf-expansion-aux form environment t)) + +;;; Traditional MCL I/O primitives: + +(defun tyi (stream) + (let* ((ch (stream-read-char stream))) + (unless (eq ch :eof) ch))) + +(defun untyi (ch &optional stream) + (stream-unread-char (designated-input-stream stream) ch)) + +(defun tyo (ch &optional stream) + (stream-write-char (real-print-stream stream) ch)) Index: /branches/qres/ccl/lib/method-combination.lisp =================================================================== --- /branches/qres/ccl/lib/method-combination.lisp (revision 13564) +++ /branches/qres/ccl/lib/method-combination.lisp (revision 13564) @@ -0,0 +1,784 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;;;;;;;;;;;;;; +;; +;; define-method-combination.lisp +;; Copyright 1990-1994, Apple Computer, Inc. +;; Copyright 1995-1996 Digitool, Inc. + +;; + +;;;;;;;;;;;;;;; +; +; Change History +; +; 05/31/96 bill list method combination is not :identity-with-one-argument +; ------------- MCL-PPC 3.9 +; 12/01/93 bill specifier-match-p uses EQUAL instead of EQ +; ------------- 3.0d13 +; 04/30/93 bill no-applicable-primary-method -> make-no-applicable-method-function +; ------------ 2.0 +; 11/05/91 gb experiment with INLINE. +; 09/26/91 bill %badarg had the wrong number of args in with-call-method-context. +; Mix in Flavors Technology's optimization. +; 07/21/91 gb Use DYNAMIC-EXTENT vice DOWNWARD-FUNCTION. +; 06/26/91 bill method-combination's direct-superclass is metaobject +;-------------- 2.0b2 +; 02/13/91 bill New File. +;------------ 2.0b1 +; + +; MOP functions pertaining to method-combination: +; +; COMPUTE-DISCRIMINATING-FUNCTION generic-function (not implemented) +; COMPUTE-EFFECTIVE-METHOD generic-function method-combination methods +; FIND-METHOD-COMBINATION generic-function method-combination-type method-combination-options +; Readers for method-combination objects +; METHOD-COMBINATION-NAME +; METHOD-COMBINATION-OPTIONS +; METHOD-COMBINATION-ORDER +; METHOD-COMBINATION-OPERATOR +; METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT + +(in-package "CCL") + +(defclass method-combination (metaobject) + ((name :reader method-combination-name :initarg :name) + (options :reader method-combination-options :initarg :options :initform nil))) + +(defclass short-method-combination (method-combination) + ((operator :reader method-combination-operator :initarg :operator :initform nil) + (identity-with-one-argument :reader method-combination-identity-with-one-argument + :initarg :identity-with-one-argument + :initform nil)) + (:documentation "Generated by the simple form of define-method-combination")) + +(defclass long-method-combination (method-combination) + ((expander :reader method-combination-expander :initarg :expander + :documentation "The expander is called by compute-effective-method with args: gf mc options methods args") + ) + (:documentation "Generated by the long form of define-method-combination")) + +(defmethod print-object ((object method-combination) stream) + (print-unreadable-object (object stream :type t) + (let* ((name (method-combination-name object)) + (options (method-combination-options object))) + (declare (dynamic-extent options)) + (prin1 name stream) + (dolist (option options) + (pp-space stream) + (prin1 option stream))))) + +; Hash a method-combination name to a method-combination-info vector +(defvar *method-combination-info* (make-hash-table :test 'eq)) + +(defmacro method-combination-info (method-combination-type) + `(gethash ,method-combination-type *method-combination-info*)) + +;;; Need to special case (find-method-combination #'find-method-combination ...) +(without-duplicate-definition-warnings ;; override version in l1-clos-boot.lisp + (defmethod find-method-combination ((generic-function standard-generic-function) + method-combination-type + method-combination-options) + (%find-method-combination + generic-function method-combination-type method-combination-options))) + +(defun %find-method-combination (gf type options) + (declare (ignore gf)) + (if (eq type 'standard) + (progn + (unless (null options) + (error "STANDARD method-combination accepts no options.")) + *standard-method-combination*) + (let ((mci (method-combination-info type))) + (unless mci + (error "~s is not a method-combination type" type)) + (labels ((same-options-p (o1 o2) + (cond ((null o1) (null o2)) + ((null o2) nil) + ((or (atom o1) (atom o2)) nil) + ((eq (car o1) (car o2)) + (same-options-p (cdr o1) (cdr o2))) + (t nil)))) + (dolist (mc (population-data (mci.instances mci))) + (when (same-options-p options (method-combination-options mc)) + (return-from %find-method-combination mc)))) + (let ((new-mc + (case (mci.class mci) + (short-method-combination + (unless (or (null options) + (and (listp options) + (null (cdr options)) + (memq (car options) + '(:most-specific-first :most-specific-last)))) + (error "Illegal method-combination options: ~s" options)) + (destructuring-bind (&key identity-with-one-argument + (operator type) + &allow-other-keys) + (mci.options mci) + (make-instance 'short-method-combination + :name type + :identity-with-one-argument identity-with-one-argument + :operator operator + :options options))) + (long-method-combination + (make-instance 'long-method-combination + :name type + :options options + :expander (mci.options mci))) + (t (error "Don't understand ~s method-combination" type))))) + (push new-mc (population-data (mci.instances mci))) + new-mc)))) + +; Push GF on the MCI.GFS population of its method-combination type. +(defun register-gf-method-combination (gf &optional (mc (%gf-method-combination gf))) + (unless (eq mc *standard-method-combination*) + (let* ((name (method-combination-name mc)) + (mci (or (method-combination-info name) + (error "~s not a known method-combination type" name))) + (gfs (mci.gfs mci))) + (pushnew gf (population-data gfs))) + mc)) + +(defun unregister-gf-method-combination (gf &optional (mc (%gf-method-combination gf))) + (unless (eq mc *standard-method-combination*) + (let* ((name (method-combination-name mc)) + (mci (or (method-combination-info name) + (error "~s not a known method-combination type" name))) + (gfs (mci.gfs mci))) + (setf (population-data gfs) (delq gf (population-data gfs)))) + mc)) + + +;;; Need to special case (compute-effective-method #'compute-effective-method ...) +(defmethod compute-effective-method ((generic-function standard-generic-function) + (method-combination standard-method-combination) + methods) + (%compute-standard-effective-method generic-function method-combination methods)) + +(defun %compute-standard-effective-method (generic-function method-combination methods) + (declare (ignore method-combination)) + (make-standard-combined-method methods nil generic-function t)) + +(defvar *method-combination-evaluators* (make-hash-table :test 'eq)) + +(defmacro get-method-combination-evaluator (key) + `(gethash ,key *method-combination-evaluators*)) + +(defmacro define-method-combination-evaluator (name arglist &body body) + (setq name (require-type name 'symbol)) + (unless (and arglist (listp arglist) (eq (length arglist) 2)) + (error "A method-combination-evaluator must take two args.")) + `(%define-method-combination-evaluator ',name #'(lambda ,arglist ,@body))) + +(defun %define-method-combination-evaluator (operator function) + (setq operator (require-type operator 'symbol)) + (setq function (require-type function 'function)) + (record-source-file operator 'method-combination-evaluator) + (setf (get-method-combination-evaluator operator) function) + (maphash #'(lambda (name mci) + (when (eq operator (or (and (eq (mci.class mci) 'short-method-combination) (getf (mci.options mci) :operator)) name))) + (clear-method-combination-caches name mci)) + *method-combination-info*) + function) + +(defmethod compute-effective-method ((generic-function standard-generic-function) + (method-combination short-method-combination) + methods) + (or (get-combined-method methods generic-function) + (put-combined-method + methods + (let* ((arounds nil) + (primaries nil) + (iwoa (method-combination-identity-with-one-argument method-combination)) + (reverse-p (eq (car (method-combination-options method-combination)) + :most-specific-last)) + (operator (method-combination-operator method-combination)) + (name (method-combination-name method-combination)) + qualifiers + q) + (dolist (m methods) + (setq qualifiers (method-qualifiers m)) + (unless (and qualifiers (null (cdr qualifiers)) + (cond ((eq (setq q (car qualifiers)) name) + (push m primaries)) + ((eq q :around) + (push m arounds)) + (t nil))) + (%invalid-method-error m "invalid method qualifiers: ~s" qualifiers))) + (when (null primaries) + (return-from compute-effective-method + (make-no-applicable-method-function generic-function))) + (setq arounds (nreverse arounds)) + (unless reverse-p (setq primaries (nreverse primaries))) + (or (optimized-short-effective-method generic-function operator iwoa arounds primaries) + (let ((code (if (and iwoa (null (cdr primaries))) + `(call-method ,(car primaries) nil) + `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m nil)) primaries))))) + (make-effective-method + generic-function + (if arounds + `(call-method ,(car arounds) + (,@(cdr arounds) (make-method ,code))) + code))))) + generic-function))) + +(defun optimized-short-effective-method (gf operator iwoa arounds primaries) + (let* ((functionp (functionp (fboundp operator))) + (evaluator (unless functionp (get-method-combination-evaluator operator)))) + (when (or functionp evaluator) + (let ((code (if (and iwoa (null (cdr primaries))) + (let ((method (car primaries))) + (if (call-next-method-p method) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (%%call-method* method nil args)) + (method-function method))) + (if functionp + (let ((length (length primaries)) + (primaries primaries)) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (let* ((results (make-list length)) + (results-tail results)) + (declare (cons results-tail)) + (declare (dynamic-extent results)) + (dolist (method primaries) + (setf (car results-tail) + (%%call-method* method nil args)) + (pop results-tail)) + (apply operator results)))) + (let ((primaries primaries)) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (funcall evaluator primaries args))))))) + (if arounds + (let* ((code-method (make-instance 'standard-method + :function code + :generic-function gf + :name (function-name gf))) + (first-around (car arounds)) + (rest-arounds (nconc (cdr arounds) (list code-method)))) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (%%call-method* first-around rest-arounds args))) + code))))) + +(defmethod compute-effective-method ((generic-function standard-generic-function) + (method-combination long-method-combination) + methods) + (or (get-combined-method methods generic-function) + (destructuring-bind ((args-var . gf-name) . expander) + (method-combination-expander method-combination) + (let* ((user-form (funcall expander + generic-function + methods + (method-combination-options method-combination))) + (effective-method + (if (functionp user-form) + user-form + (make-effective-method generic-function user-form args-var gf-name)))) + (put-combined-method methods effective-method generic-function))))) + +(defmacro with-call-method-context (args-var &body body) + (labels ((bad-call-method-method (method) + (error "~s is neither a method nor a ~s form." method 'make-method)) + (call-method-aux (method next-methods args-var) + (unless (typep method 'standard-method) + (if (and (listp method) (eq (car method) 'make-method)) + (setq method (%make-method method)) + (bad-call-method-method method))) + (let ((real-next-methods nil)) + (dolist (m next-methods) + (cond ((typep m 'standard-method) + (push m real-next-methods)) + ((and (listp m) (eq (car m) 'make-method)) + (push (%make-method m) real-next-methods)) + (t (bad-call-method-method m)))) + `(%%call-method* ,method + ',(nreverse real-next-methods) + ,args-var)))) + `(macrolet ((call-method (method &optional next-methods) + (funcall ',#'call-method-aux method next-methods ',args-var))) + ,@body))) + +(defun %make-method (make-method-form &optional + args-var + generic-function + (method-class 'standard-method)) + (setq args-var (require-type args-var 'symbol)) + (unless (and (cdr make-method-form) (null (cddr make-method-form))) + (%method-combination-error "MAKE-METHOD requires exactly one argument.")) + (let ((form (cadr make-method-form))) + (make-instance + method-class + :generic-function generic-function + :name (and (functionp generic-function) (function-name generic-function)) + :function (%make-function + nil + `(lambda (&rest ,(setq args-var (or args-var (make-symbol "ARGS")))) + (declare (ignore-if-unused ,args-var) + (dynamic-extent ,args-var)) + (with-call-method-context ,args-var + ,form)) + nil)))) + +(defmethod call-next-method-p ((method standard-method)) + (call-next-method-p (%method-function method))) + +(defmethod call-next-method-p ((function function)) + (let (lfbits) + (and (logbitp $lfbits-method-bit + (setq lfbits (lfun-bits function))) + (logbitp $lfbits-nextmeth-bit lfbits)))) + +(defun make-effective-method (gf form &optional (args-sym (make-symbol "ARGS")) (gf-name (make-symbol "GF"))) + (setq args-sym (require-type args-sym 'symbol)) + (let (m mf) + (if (and (listp form) + (eq (car form) 'call-method) + (listp (cdr form)) + (typep (setq m (cadr form)) 'standard-method) + (listp (cddr form)) + (null (cdddr form)) + (not (call-next-method-p (setq mf (%method-function m))))) + mf + (%make-function + nil + `(lambda (&rest ,args-sym) + (declare (dynamic-extent ,args-sym)) + (let* ((,gf-name ,gf)) + (declare (ignorable ,gf-name)) + (with-call-method-context ,args-sym + ,form))) + nil)))) + +;;;;;;; +;; +;; Expansions of the DEFINE-METHOD-COMBINATION macro +;; + +;; +;; Short form +;; +(defun short-form-define-method-combination (name options) + (destructuring-bind (&key documentation identity-with-one-argument + (operator name)) options + (setq name (require-type name 'symbol) + operator (require-type operator 'symbol) + documentation (unless (null documentation) + (require-type documentation 'string))) + (let* ((mci (method-combination-info name)) + (was-short? (and mci (eq (mci.class mci) 'short-method-combination)))) + (when (and mci (not was-short?)) + (check-long-to-short-method-combination name mci)) + (if mci + (let ((old-options (mci.options mci))) + (setf (mci.class mci) 'short-method-combination + (mci.options mci) options) + (unless (and was-short? + (destructuring-bind (&key ((:identity-with-one-argument id)) + ((:operator op) name) + &allow-other-keys) + old-options + (and (eq id identity-with-one-argument) + (eq op operator)))) + (update-redefined-short-method-combinations name mci))) + (setf (method-combination-info name) + (setq mci (%cons-mci 'short-method-combination options))))) + (set-documentation name 'method-combination documentation)) + (record-source-file name 'method-combination) + name) + +(defun check-long-to-short-method-combination (name mci) + (dolist (gf (population-data (mci.gfs mci))) + (let ((options (method-combination-options (%gf-method-combination gf)))) + (unless (or (null options) + (and (listp options) + (null (cdr options)) + (memq (car options) '(:most-specific-first :most-specific-last)))) + (error "Redefining ~s method-combination disagrees with the~ + method-combination arguments to ~s" name gf))))) + +(defun update-redefined-short-method-combinations (name mci) + (destructuring-bind (&key identity-with-one-argument (operator name) documentation) + (mci.options mci) + (declare (ignore documentation)) + (dolist (mc (population-data (mci.instances mci))) + (when (typep mc 'long-method-combination) + (change-class mc 'short-method-combination)) + (if (typep mc 'short-method-combination) + (setf (slot-value mc 'identity-with-one-argument) identity-with-one-argument + (slot-value mc 'operator) operator) + (error "Bad method-combination-type: ~s" mc)))) + (clear-method-combination-caches name mci)) + +(defun clear-method-combination-caches (name mci) + (dolist (gf (population-data (mci.gfs mci))) + (clear-gf-cache gf)) + (when *effective-method-gfs* ; startup glitch + (let ((temp #'(lambda (mc gf) + (when (eq name (method-combination-name (%gf-method-combination gf))) + (remhash mc *effective-method-gfs*) + (remhash mc *combined-methods*))))) + (declare (dynamic-extent temp)) + (maphash temp *effective-method-gfs*)))) + +;;; Support el-bizarro arglist partitioning for the long form of +;;; DEFINE-METHOD-COMBINATION. +(defun nth-required-gf-arg (gf argvals i) + (declare (fixnum i)) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits))) + (declare (fixnum bits numreq)) + (if (< i numreq) + (nth i argvals)))) + +(defun nth-opt-gf-arg-present-p (gf argvals i) + (declare (fixnum i)) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (numopt (ldb $lfbits-numopt bits))) + (declare (fixnum bits numreq numopt)) + (and (< i numopt) + (< (the fixnum (+ i numreq)) (length argvals))))) + +;;; This assumes that we've checked for argument presence. +(defun nth-opt-gf-arg (gf argvals i) + (declare (fixnum i)) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits))) + (declare (fixnum bits numreq )) + (nth (the fixnum (+ i numreq)) argvals))) + +(defun gf-arguments-tail (gf argvals) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (numopt (ldb $lfbits-numopt bits))) + (declare (fixnum bits numreq numopt)) + (nthcdr (the fixnum (+ numreq numopt)) argvals))) + +(defun gf-key-present-p (gf argvals key) + (let* ((tail (gf-arguments-tail gf argvals)) + (missing (cons nil nil))) + (declare (dynamic-extent missing)) + (not (eq missing (getf tail key missing))))) + +;; Again, this should only be called if GF-KEY-PRESENT-P returns true. +(defun gf-key-value (gf argvals key) + (let* ((tail (gf-arguments-tail gf argvals))) + (getf tail key))) + + +(defun lfmc-bindings (gf-form args-form lambda-list) + (let* ((req-idx 0) + (opt-idx 0) + (state :required)) + (collect ((names) + (vals)) + (dolist (arg lambda-list) + (case arg + ((&whole &optional &rest &key &allow-other-keys &aux) + (setq state arg)) + (t + (case state + (:required + (names arg) + (vals (list 'quote `(nth-required-gf-arg ,gf-form ,args-form ,req-idx))) + (incf req-idx)) + (&whole + (names arg) + (vals `,args-form) + (setq state :required)) + (&optional + (let* ((var arg) + (val nil) + (spvar nil)) + (when (listp arg) + (setq var (pop arg) + val (pop arg) + spvar (car arg))) + (names var) + (vals (list 'quote + `(if (nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx) + (nth-opt-gf-arg ,gf-form ,args-form ,opt-idx) + ,val))) + (when spvar + (names spvar) + (vals (list 'quote + `(nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx)))) + (incf opt-idx))) + (&rest + (names arg) + (vals (list 'quote + `(gf-arguments-tail ,gf-form ,args-form)))) + (&key + (let* ((var arg) + (keyword nil) + (val nil) + (spvar nil)) + (if (atom arg) + (setq keyword (make-symbol (symbol-name arg))) + (progn + (setq var (car arg)) + (if (atom var) + (setq keyword (make-symbol (symbol-name var))) + (setq keyword (car var) var (cadr var))) + (setq val (cadr arg) spvar (caddr arg)))) + (names var) + (vals (list 'quote `(if (gf-key-present-p ,gf-form ,args-form ',keyword) + (gf-key-value ,gf-form ,args-form ',keyword) + ,val))) + (when spvar + (names spvar) + (vals (list 'quote `(gf-key-present-p ,gf-form ,args-form ',keyword)))))) + (&allow-other-keys) + (&aux + (cond ((atom arg) + (names arg) + (vals nil)) + (t + (names (car arg)) + (vals (list 'quote (cadr arg)))))))))) + (values (names) (vals))))) +;; +;; Long form +;; +(defun long-form-define-method-combination (name lambda-list method-group-specifiers + forms env) + (let (arguments args-specified? generic-fn-symbol gf-symbol-specified?) + (unless (verify-lambda-list lambda-list) + (error "~s is not a proper lambda-list" lambda-list)) + (loop + (unless (and forms (consp (car forms))) (return)) + (case (caar forms) + (:arguments + (when args-specified? (error ":ARGUMENTS specified twice")) + (setq arguments (cdr (pop forms)) + args-specified? t) + (do ((args arguments (cdr args))) + ((null args)) + (setf (car args) (require-type (car args) 'symbol)))) + (:generic-function + (when gf-symbol-specified? (error ":GENERIC-FUNCTION specified twice")) + (setq generic-fn-symbol + (require-type (cadr (pop forms)) '(and symbol (not null))) + gf-symbol-specified? t)) + (t (return)))) + (multiple-value-bind (body decls doc) (parse-body forms env) + (unless generic-fn-symbol (setq generic-fn-symbol (make-symbol "GF"))) + (multiple-value-bind (specs order-forms required-flags descriptions) + (parse-method-group-specifiers method-group-specifiers) + (let* ((methods-sym (make-symbol "METHODS")) + (args-sym (make-symbol "ARGS")) + (options-sym (make-symbol "OPTIONS")) + (arg-vars ()) + (arg-vals ()) + (code `(lambda (,generic-fn-symbol ,methods-sym ,options-sym) + ,@(unless gf-symbol-specified? + `((declare (ignore-if-unused ,generic-fn-symbol)))) + (let* (,@(progn + (multiple-value-setq (arg-vars arg-vals) + (lfmc-bindings generic-fn-symbol + args-sym + arguments)) + (mapcar #'list arg-vars arg-vals))) + (declare (ignorable ,@arg-vars)) + ,@decls + (destructuring-bind ,lambda-list ,options-sym + (destructuring-bind + ,(mapcar #'car method-group-specifiers) + (seperate-method-groups + ,methods-sym ',specs + (list ,@order-forms) + ',required-flags + ',descriptions) + ,@body)))))) + `(%long-form-define-method-combination + ',name (cons (cons ',args-sym ',generic-fn-symbol) #',code) ',doc)))))) + +(defun %long-form-define-method-combination (name args-var.expander documentation) + (setq name (require-type name 'symbol)) + (let* ((mci (method-combination-info name))) + (if mci + (progn + (setf (mci.class mci) 'long-method-combination + (mci.options mci) args-var.expander) + (update-redefined-long-method-combinations name mci)) + (setf (method-combination-info name) + (setq mci (%cons-mci 'long-method-combination args-var.expander))))) + (set-documentation name 'method-combination documentation) + (record-source-file name 'method-combination) + name) + +(defun update-redefined-long-method-combinations (name mci) + (let ((args-var.expander (mci.options mci))) + (dolist (mc (population-data (mci.instances mci))) + (when (typep mc 'short-method-combination) + (change-class mc 'long-method-combination)) + (if (typep mc 'long-method-combination) + (setf (slot-value mc 'expander) args-var.expander) + (error "Bad method-combination-type: ~s" mc)))) + (clear-method-combination-caches name mci)) + +; Returns four values: +; method-group specifiers with :order, :required, & :description parsed out +; Values for the :order args +; Values for the :required args +; values for the :description args +(defun parse-method-group-specifiers (mgs) + (let (specs orders requireds descriptions) + (dolist (mg mgs) + (push nil specs) + (push :most-specific-first orders) + (push nil requireds) + (push nil descriptions) + (push (pop mg) (car specs)) ; name + (loop + (when (null mg) (return)) + (when (memq (car mg) '(:order :required :description)) + (destructuring-bind (&key (order :most-specific-first) required description) + mg + (setf (car orders) order) + (setf (car requireds) required) + (setf (car descriptions) description)) + (return)) + (push (pop mg) (car specs))) + (setf (car specs) (nreverse (car specs)))) + (values (nreverse specs) + (nreverse orders) + (nreverse requireds) + (nreverse descriptions)))) + +(defun seperate-method-groups (methods specs orders requireds descriptions) + (declare (ignore descriptions)) + (let ((res (make-list (length specs)))) + (dolist (m methods) + (let ((res-tail res)) + (dolist (s specs (%invalid-method-error + m "Does not match any of the method group specifiers")) + (when (specifier-match-p (method-qualifiers m) s) + (push m (car res-tail)) + (return)) + (pop res-tail)))) + (do ((res-tail res (cdr res-tail)) + (o-tail orders (cdr o-tail)) + (r-tail requireds (cdr r-tail))) + ((null res-tail)) + (case (car o-tail) + (:most-specific-last) + (:most-specific-first (setf (car res-tail) (nreverse (car res-tail)))) + (t (error "~s is neither ~s nor ~s" (car o-tail) :most-specific-first :most-specific-last))) + (when (car r-tail) + (unless (car res-tail) + ; should use DESCRIPTIONS here + (error "A required method-group matched no method group specifiers")))) + res)) + +(defun specifier-match-p (qualifiers spec) + (flet ((match (qs s) + (cond ((or (listp s) (eq s '*)) + (do ((qs-tail qs (cdr qs-tail)) + (s-tail s (cdr s-tail))) + ((or (null qs-tail) (atom s-tail)) + (or (eq s-tail '*) + (and (null qs-tail) (null s-tail)))) + (unless (or (eq (car s-tail) '*) + (equal (car qs-tail) (car s-tail))) + (return nil)))) + ((atom s) (funcall s qs)) + (t (error "Malformed method group specifier: ~s" spec))))) + (declare (inline match)) + (dolist (s (cdr spec)) + (when (match qualifiers s) + (return t))))) + +;;;;;;; +; +; The user visible error functions +; We don't add any contextual information yet. +; Maybe we never will. +(setf (symbol-function 'method-combination-error) #'%method-combination-error) +(setf (symbol-function 'invalid-method-error) #'%invalid-method-error) + +;;;;;;; +; +; The predefined method-combination types +; +(define-method-combination + :identity-with-one-argument t) +(define-method-combination and :identity-with-one-argument t) +(define-method-combination append :identity-with-one-argument t) +(define-method-combination list :identity-with-one-argument nil) +(define-method-combination max :identity-with-one-argument t) +(define-method-combination min :identity-with-one-argument t) +(define-method-combination nconc :identity-with-one-argument t) +(define-method-combination or :identity-with-one-argument t) +(define-method-combination progn :identity-with-one-argument t) + +; And evaluators for the non-functions +(define-method-combination-evaluator and (methods args) + (when methods + (loop + (if (null (cdr methods)) + (return (%%call-method* (car methods) nil args))) + (unless (%%call-method* (pop methods) nil args) + (return nil))))) + +(define-method-combination-evaluator or (methods args) + (when methods + (loop + (if (null (cdr methods)) + (return (%%call-method* (car methods) nil args))) + (let ((res (%%call-method* (pop methods) nil args))) + (when res (return res)))))) + +(define-method-combination-evaluator progn (methods args) + (when methods + (loop + (if (null (cdr methods)) + (return (%%call-method* (car methods) nil args))) + (%%call-method* (pop methods) nil args)))) + +#| + +;(define-method-combination and :identity-with-one-argument t) +(defgeneric func (x) (:method-combination and)) +(defmethod func and ((x window)) (print 3)) +(defmethod func and ((x fred-window)) (print 2)) +(func (front-window)) + +(define-method-combination example ()((methods positive-integer-qualifier-p)) + `(progn ,@(mapcar #'(lambda (method) + `(call-method ,method ())) + (sort methods #'< :key #'(lambda (method) + (first (method-qualifiers method))))))) + +(defun positive-integer-qualifier-p (method-qualifiers) + (and (= (length method-qualifiers) 1) + (typep (first method-qualifiers)'(integer 0 *)))) + +(defgeneric zork (x)(:method-combination example)) + +(defmethod zork 1 ((x window)) (print 1)) +(defmethod zork 2 ((x fred-window)) (print 2)) +(zork (front-window)) + + +|# + Index: /branches/qres/ccl/lib/misc.lisp =================================================================== --- /branches/qres/ccl/lib/misc.lisp (revision 13564) +++ /branches/qres/ccl/lib/misc.lisp (revision 13564) @@ -0,0 +1,1442 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (eval compile) + (require 'defstruct-macros)) + +(defun short-site-name () + "Return a string with the abbreviated site name, or NIL if not known." + (or *short-site-name* "unspecified")) + +(defun long-site-name () + "Return a string with the long form of the site name, or NIL if not known." + (or *long-site-name* "unspecified")) + +(defun machine-instance () + "Return a string giving the name of the local machine." + #-windows-target (%uname 1) + #+windows-target + (rlet ((nsize #>DWORD 0)) + (if (eql 0 (#_GetComputerNameExW #$ComputerNameDnsFullyQualified + (%null-ptr) + nsize)) + (%stack-block ((buf (* 2 (pref nsize #>DWORD)))) + (#_GetComputerNameExW #$ComputerNameDnsFullyQualified + buf + nsize) + (%get-native-utf-16-cstring buf)) + "localhost")) + ) + + +(defun machine-type () + "Returns a string describing the type of the local machine." + #-windows-target (%uname 4) + #+windows-target + (rlet ((info #>SYSTEM_INFO)) + (#_GetSystemInfo info) + (case (pref info #>SYSTEM_INFO.nil.nil.wProcessorArchitecture) + (#.#$PROCESSOR_ARCHITECTURE_AMD64 "x64") + (#.#$PROCESSOR_ARCHITECTURE_INTEL "x86") + (t "unknown"))) + ) + + + +(defloadvar *machine-version* nil) + +(defun machine-version () + "Return a string describing the version of the computer hardware we +are running on, or NIL if we can't find any useful information." + (or *machine-version* + (setq *machine-version* + #+darwin-target + (block darwin-machine-version + (%stack-block ((mib 8)) + (setf (%get-long mib 0) #$CTL_HW + (%get-long mib 4) #$HW_MODEL) + (%stack-block ((res 256) + (reslen target::node-size)) + (setf (%get-byte res 0) 0 + (%get-natural reslen 0) 256) + (if (zerop (#_sysctl mib 2 res reslen (%null-ptr) 0)) + (return-from darwin-machine-version (%get-cstring res)))))) + #+linux-target + (with-open-file (f "/proc/cpuinfo" :if-does-not-exist nil) + (when f + (flet ((cpu-info-match (target line) + (let* ((targetlen (length target)) + (linelen (length line))) + (if (and (> linelen targetlen) + (string= target line + :end2 targetlen)) + (let* ((colonpos (position #\: line))) + (when colonpos + (string-trim " " + (subseq line (1+ colonpos))))))))) + (do* ((line (read-line f nil nil) + (read-line f nil nil)) + (target #+ppc-target "machine" + #+x86-target "model name")) + ((null line)) + (let* ((matched (cpu-info-match target line))) + (when matched (return matched))))))) + #+freebsd-target + (%stack-block ((ret 512) + (mib (* (record-length :uint)))) + (setf (%get-unsigned-long mib 0) + #$CTL_HW + (%get-unsigned-long mib (record-length :uint)) + #$HW_MODEL) + (rlet ((oldsize :uint 512)) + (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0)) + (%get-cstring ret) + 1))) + #+solaris-target + (rlet ((info :processor_info_t)) + (do* ((i 0 (1+ i))) + ((and (= 0 (#_processor_info i info)) + (= (pref info :processor_info_t.pi_state) + #$P_ONLINE)) + (%get-cstring (pref info :processor_info_t.pi_processor_type))))) + #+windows-target + (getenv "PROCESSOR_IDENTIFIER") + ))) + + +(defun software-type () + "Return a string describing the supporting software." + #-windows-target (%uname 0) + #+windows-target "Microsoft Windows") + + +(defun software-version () + "Return a string describing version of the supporting software, or NIL + if not available." + #-windows-target (%uname 2) + #+windows-target + (rletZ ((info #>OSVERSIONINFOEX)) + (setf (pref info #>OSVERSIONINFOEX.dwOSVersionInfoSize) + (record-length #>OSVERSIONINFOEX)) + (#_GetVersionExA info) + (format nil "~d.~d Build ~d (~a)" + (pref info #>OSVERSIONINFOEX.dwMajorVersion) + (pref info #>OSVERSIONINFOEX.dwMinorVersion) + (pref info #>OSVERSIONINFOEX.dwBuildNumber) + (if (eql (pref info #>OSVERSIONINFOEX.wProductType) + #$VER_NT_WORKSTATION) + "Workstation" + "Server"))) + ) + + + + + + + +;;; Yawn. + + + +(defmethod documentation (thing doc-id) + (%get-documentation thing doc-id)) + +(defmethod (setf documentation) (new thing doc-id) + (%put-documentation thing doc-id new)) + + +(defmethod documentation ((symbol symbol) (doc-type (eql 'function))) + (let* ((def (fboundp symbol))) ; FBOUNDP returns info about definition + (when def + (%get-documentation def t)))) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'function))) + (let* ((def (fboundp symbol))) ; FBOUNDP returns info about definition + (when def + (%put-documentation def + t + new)) + new)) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'setf))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'setf))) + (call-next-method)) + + +(defmethod documentation ((symbol symbol) (doc-type (eql 'variable))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'variable))) + (call-next-method)) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'compiler-macro))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'compiler-macro))) + (call-next-method)) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'type))) + (let* ((class (find-class symbol nil))) + (if class + (documentation class doc-type) + (call-next-method)))) + +(defmethod (setf documentation) (new (symbol symbol) (doc-type (eql 'type))) + (let* ((class (find-class symbol nil))) + (if class + (setf (documentation class doc-type) new) + (call-next-method)))) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'method-combination))) + (let* ((mci (method-combination-info symbol))) + (if mci + (documentation mci doc-type)))) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'method-combination))) + (let* ((mci (method-combination-info symbol))) + (if mci + (setf (documentation mci doc-type) new)))) + + +(defmethod documentation ((symbol symbol) (doc-type (eql 'structure))) + (let* ((class (find-class symbol nil))) + (if (typep class 'structure-class) + (documentation class 'type) + (call-next-method)))) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'structure))) + (let* ((class (find-class symbol nil))) + (if (typep class 'structure-class) + (setf (documentation class 'type) new) + (call-next-method)))) + +(defmethod documentation ((p package) (doc-type (eql 't))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) (p package) (doc-type (eql 't))) + (call-next-method)) + +(defmethod documentation ((f function) (doc-type (eql 't))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) (f function) (doc-type (eql 't))) + (call-next-method)) + +(defmethod documentation ((f function) (doc-type (eql 'function))) + (documentation f t)) + +(defmethod (setf documentation) ((new t) + (f function) + (doc-type (eql 'function))) + (setf (documentation f t) new)) + +(defmethod documentation ((l cons) (doc-type (eql 'function))) + (let* ((name (setf-function-spec-name l))) + (if name + (documentation name doc-type) + (%get-documentation l doc-type)))) + +(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'function))) + (let* ((name (setf-function-spec-name l))) + (if name + (setf (documentation name doc-type) new) + (%put-documentation l doc-type new)))) + + +(defmethod documentation ((l cons) (doc-type (eql 'compiler-macro))) + (let* ((name (setf-function-spec-name l))) + (if name + (documentation name doc-type) + (%get-documentation l doc-type)))) + +(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'compiler-macr0))) + (let* ((name (setf-function-spec-name l))) + (if name + (setf (documentation name doc-type) new) + (%put-documentation l doc-type new)))) + + +(defmethod documentation ((m method-combination) + (doc-type (eql 'method-combination))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (m method-combination) + (doc-type (eql 'method-combination))) + (call-next-method)) + +(defmethod documentation ((m method-combination) + (doc-type (eql t))) + (documentation m 'method-combination)) + +(defmethod (setf documentation) ((new t) + (m method-combination) + (doc-type (eql t))) + (setf (documentation m 'method-combination) new)) + +(defmethod documentation ((m standard-method) + (doc-type (eql t))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (m standard-method) + (doc-type (eql t))) + (call-next-method)) + +(defmethod documentation ((c standard-class) (doc-type (eql 'type))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (c standard-class) + (doc-type (eql 'type))) + (call-next-method)) + +(defmethod documentation ((c standard-class) (doc-type (eql 't))) + (documentation c 'type)) + +(defmethod (setf documentation) ((new t) + (c standard-class) + (doc-type (eql 't))) + (setf (documentation c 'type) new)) + +(defmethod documentation ((c structure-class) (doc-type (eql 'type))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (c structure-class) + (doc-type (eql 'type))) + (call-next-method)) + +(defmethod documentation ((c structure-class) (doc-type (eql 't))) + (documentation c 'type)) + +(defmethod (setf documentation) ((new t) + (c structure-class) + (doc-type (eql 't))) + (setf (documentation c 'type) new)) + +;;; This is now deprecated; things which call it should stop doing so. +(defun set-documentation (symbol doc-type string) + (setf (documentation symbol doc-type) string)) + +(defun set-function-info (symbol info) + (let* ((doc-string (if (consp info) (car info) info))) + (if (and *save-doc-strings* (stringp doc-string)) + (set-documentation symbol 'function doc-string))) + (let* ((cons (assq symbol *nx-globally-inline*)) + (lambda-expression (if (consp info) (cdr info)))) + (if (and (proclaimed-inline-p symbol) + (not (compiler-special-form-p symbol)) + (lambda-expression-p lambda-expression) + (let* ((lambda-list (cadr lambda-expression))) + (and (not (memq '&lap lambda-list)) + (not (memq '&method lambda-list)) + (not (memq '&lexpr lambda-list))))) + (if cons + (%rplacd cons lambda-expression) + (push (cons symbol lambda-expression) *nx-globally-inline*)) + (if cons (setq *nx-globally-inline* (delete cons *nx-globally-inline*))))) + symbol) + + +(setf (documentation 'if 'function) + "If Predicate Then [Else] + If Predicate evaluates to non-null, evaluate Then and returns its values, + otherwise evaluate Else and return its values. Else defaults to NIL.") + +(setf (documentation 'progn 'function) + "progn form* + Evaluates each FORM and returns the value(s) of the last FORM.") + +(defmethod documentation ((thing character-encoding) (doc-type (eql t))) + (character-encoding-documentation thing)) + +(defmethod (setf documentation) (new (thing character-encoding) (doc-type (eql t))) + (check-type new (or null string)) + (setf (character-encoding-documentation thing) new)) + +(defmethod documentation ((thing symbol) (doc-type (eql 'character-encoding))) + (let* ((encoding (lookup-character-encoding (intern (string thing) :keyword)))) + (when encoding + (documentation encoding t)))) + + + + +#| +(setf (documentation 'car 'variable) "Preferred brand of automobile") +(documentation 'car 'variable) +(setf (documentation 'foo 'structure) "the structure is grand.") +(documentation 'foo 'structure) +(setf (documentation 'foo 'variable) "the metasyntactic remarker") +(documentation 'foo 'variable) +(setf (documentation 'foo 'obscure) "no one really knows what it means") +(documentation 'foo 'obscure) +(setf (documentation 'foo 'structure) "the structure is solid") +(documentation 'foo 'function) +||# + +;; + + +(defun %page-fault-info () + #-(or darwin-target windows-target) + (rlet ((usage :rusage)) + (%%rusage usage) + (values (pref usage :rusage.ru_minflt) + (pref usage :rusage.ru_majflt) + (pref usage :rusage.ru_nswap))) + #+darwin-target + (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT) + (info #>task_events_info)) + (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count) + (values (pref info #>task_events_info.cow_faults) + (pref info #>task_events_info.faults) + (pref info #>task_events_info.pageins))) + #+windows-target + ;; Um, don't know how to determine this, or anything like it. + (values 0 0 0)) + + + +(defparameter *report-time-function* nil + "If non-NULL, should be a function which accepts the following + keyword arguments: + :FORM the form that was executed + :RESULTS a list of all values returned by the execution of FORM + :ELAPSED-TIME total elapsed (real) time, in internal-time-units-per-second + :USER-TIME elapsed user time, in internal-time-units-per-second + :SYSTEM-TIME elapsed system time, in internal-time-units-per-second + :GC-TIME total real time spent in the GC, in internal-time-units-per-second + :BYTES-ALLOCATED total bytes allocated + :MINOR-PAGE-FAULTS minor page faults + :MAJOR-PAGE-FAULTS major page faults + :SWAPS swaps") + + +(defun standard-report-time (&key form results elapsed-time user-time + system-time gc-time bytes-allocated + minor-page-faults major-page-faults + swaps) + (let* ((s *trace-output*) + (units + (ecase internal-time-units-per-second + (1000000 "microseconds") + (1000 "milliseconds"))) + (width + (ecase internal-time-units-per-second + (1000000 6) + (1000 3))) + (cpu-count (cpu-count))) + (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P." + form elapsed-time units width (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count) + (format s "~&During that period, ~:D ~a (~,vF seconds) were spent in user mode" user-time units width (/ user-time internal-time-units-per-second)) + (format s "~& ~:D ~a (~,vF seconds) were spent in system mode" system-time units width(/ system-time internal-time-units-per-second)) + (unless (eql gc-time 0) + (format s + "~%~:D ~a (~,vF seconds) was spent in GC." + gc-time units width (/ gc-time internal-time-units-per-second))) + (unless (eql 0 bytes-allocated) + (format s "~% ~:D bytes of memory allocated." bytes-allocated)) + (when (or (> minor-page-faults 0) + (> major-page-faults 0) + (> swaps 0)) + (format s + "~% ~:D minor page faults, ~:D major page faults, ~:D swaps." + minor-page-faults major-page-faults swaps)) + (format s "~&") + (values-list results))) + +(defun report-time (form thunk) + (flet ((integer-size-in-bytes (i) + (if (typep i 'fixnum) + 0 + (* (logand (+ 2 (uvsize i)) (lognot 1)) 4)))) + (multiple-value-bind (user-start system-start) + (%internal-run-time) + (multiple-value-bind (minor-start major-start swaps-start) + (%page-fault-info) + (let* ((initial-real-time (get-internal-real-time)) + (initial-gc-time (gctime)) + (initial-consed (total-bytes-allocated)) + (initial-overhead (integer-size-in-bytes initial-consed))) + (let* ((results (multiple-value-list (funcall thunk)))) + (declare (dynamic-extent results)) + (multiple-value-bind (user-end system-end) + (%internal-run-time) + (multiple-value-bind (minor-end major-end swaps-end) + (%page-fault-info) + (let* ((new-consed (total-bytes-allocated)) + (bytes-consed + (- new-consed (+ initial-overhead initial-consed))) + (elapsed-real-time + (- (get-internal-real-time) initial-real-time)) + (elapsed-gc-time (- (gctime) initial-gc-time)) + (elapsed-user-time + (- user-end user-start)) + (elapsed-system-time + (- system-end system-start)) + (elapsed-minor (- minor-end minor-start)) + (elapsed-major (- major-end major-start)) + (elapsed-swaps (- swaps-end swaps-start))) + (funcall (or *report-time-function* + #'standard-report-time) + :form form + :results results + :elapsed-time elapsed-real-time + :user-time elapsed-user-time + :system-time elapsed-system-time + :gc-time elapsed-gc-time + :bytes-allocated bytes-consed + :minor-page-faults elapsed-minor + :major-page-faults elapsed-major + :swaps elapsed-swaps)))))))))) + + + + +;;; site names and machine-instance is in the init file. + +(defun add-feature (symbol) + "Not CL but should be." + (if (symbolp symbol) + (if (not (memq symbol *features*)) + (setq *features* (cons symbol *features*))))) + +;;; (dotimes (i 5000) (declare (fixnum i)) (add-feature 'junk)) + + + + +;;; Misc string functions + + +(defun string-left-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + left end." + (setq string (string string)) + (setq end (length string)) + (do ((index 0 (%i+ index 1))) + ((or (eq index end) (not (find (aref string index) char-bag))) + (subseq string index end)))) + +(defun string-right-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + right end." + (setq string (string string)) + (setq end (length string)) + (do ((index (%i- end 1) (%i- index 1))) + ((or (%i< index 0) (not (find (aref string index) char-bag))) + (subseq string 0 (%i+ index 1))))) + +(defun string-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns a + copy of the string with the characters in the set removed from both + ends." + (setq string (string string)) + (setq end (length string)) + (let ((left-end) (right-end)) + (do ((index 0 (%i+ index 1))) + ((or (eq index end) (not (find (aref string index) char-bag))) + (setq left-end index))) + (do ((index (%i- end 1) (%i- index 1))) + ((or (%i< index left-end) (not (find (aref string index) char-bag))) + (setq right-end index))) + (subseq string left-end (%i+ right-end 1)))) + + + +(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol def) + "Make and return a new uninterned symbol with the same print name + as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound + nor fbound and has no properties, else it has a copy of SYMBOL's + function, value and property list." + (setq new-symbol (make-symbol (symbol-name symbol))) + (when copy-props + (when (boundp symbol) + (set new-symbol (symbol-value symbol))) + (when (setq def (fboundp symbol)) + ;;;Shouldn't err out on macros/special forms. + (%fhave new-symbol def)) + (set-symbol-plist new-symbol (copy-list (symbol-plist symbol)))) + new-symbol) + + +(defvar %gentemp-counter 0 + "Counter for generating unique GENTEMP symbols.") + +(defun gentemp (&optional (prefix "T") (package *package*)) + "Creates a new symbol interned in package PACKAGE with the given PREFIX." + (loop + (let* ((new-pname (%str-cat (ensure-simple-string prefix) + (%integer-to-string %gentemp-counter))) + (sym (find-symbol new-pname package))) + (if sym + (setq %gentemp-counter (%i+ %gentemp-counter 1)) + (return (values (intern new-pname package))))))) ; 1 value. + + + + +(defun add-gc-hook (hook-function &optional (which-hook :pre-gc)) + (ecase which-hook + (:pre-gc + (pushnew hook-function *pre-gc-hook-list*) + (setq *pre-gc-hook* #'(lambda () + (dolist (hook *pre-gc-hook-list*) + (funcall hook))))) + (:post-gc + (pushnew hook-function *post-gc-hook-list*) + (setq *post-gc-hook* #'(lambda () + (dolist (hook *post-gc-hook-list*) + (funcall hook)))))) + hook-function) + +(defun remove-gc-hook (hook-function &optional (which-hook :pre-gc)) + (ecase which-hook + (:pre-gc + (unless (setq *pre-gc-hook-list* (delq hook-function *pre-gc-hook-list*)) + (setq *pre-gc-hook* nil))) + (:post-gc + (unless (setq *post-gc-hook-list* (delq hook-function *post-gc-hook-list*)) + (setq *post-gc-hook* nil))))) + + + + + + +(defun find-method-by-names (name qualifiers specializers) + (let ((gf (fboundp name))) + (when gf + (if (not (standard-generic-function-p gf)) + (error "~S is not a generic-function." gf) + (let ((methods (%gf-methods gf))) + (when methods + (let* ((spec-len (length (%method-specializers (car methods)))) + (new-specs (make-list spec-len :initial-element (find-class t)))) + (declare (dynamic-extent new-specs)) + (do ((specs specializers (cdr specs)) + (nspecs new-specs (cdr nspecs))) + ((or (null specs) (null nspecs))) + (let ((s (car specs))) + (rplaca nspecs (if (consp s) s (find-class s nil))))) + (find-method gf qualifiers new-specs nil)))))))) + + + + +(defun make-population (&key (type :list) initial-contents) + (let* ((ntype (ecase type + (:list $population_weak-list) + (:alist $population_weak-alist))) + (list (if (eq type :alist) + (map 'list (lambda (c) (cons (car c) (%cdr c))) initial-contents) + (if (listp initial-contents) + (copy-list initial-contents) + (coerce initial-contents 'list))))) + (%cons-population list ntype))) + +(defun population-type (population) + (let ((ntype (population.type (require-type population 'population)))) + (cond ((eq ntype $population_weak-alist) :alist) + ((eq ntype $population_weak-list) :list) + (t nil)))) + +(declaim (inline population-contents (setf population-contents))) + +(defun population-contents (population) + (population.data (require-type population 'population))) + +(defun (setf population-contents) (list population) + (setf (population.data (require-type population 'population)) (require-type list 'list))) + + + + +(defun get-string-from-user (prompt) + (with-terminal-input + (format *query-io* "~&~a " prompt) + (force-output *query-io*) + (clear-input *query-io*) + (values (read-line *query-io*)))) + + +(defun select-item-from-list (list &key (window-title "Select one of the following") + (table-print-function #'prin1) + &allow-other-keys) + (block get-answer + (with-terminal-input + (format *query-io* "~a:~%" window-title) + (loop + (catch :redisplay + (do* ((l list (cdr l)) + (i 0 (1+ i)) + (item (car l) (car l))) + ((null l)) + (declare (fixnum i)) + (format *query-io* "~& ~d: " i) + (funcall table-print-function item *query-io*)) + (loop + (fresh-line *query-io*) + (let* ((string (get-string-from-user "Selection [number,q,r,?]:")) + (value (ignore-errors + (let* ((*package* *keyword-package*)) + (read-from-string string nil))))) + (cond ((eq value :q) (throw :cancel t)) + ((eq value :r) (throw :redisplay t)) + ((eq value :?) + (format *query-io* "~%Enter the number of the selection, ~% r to redisplay, ~% q to cancel or ~% ? to show this message again.")) + ((and (typep value 'unsigned-byte) + (< value (length list))) + (return-from get-answer (list (nth value list)))))))))))) + +(defvar *choose-file-dialog-hook* nil "for GUIs") + +;;; There should ideally be some way to override the UI (such as +;;; it is ...) here. +;;; More generally, this either +;;; a) shouldn't exist, or +;;; b) should do more sanity-checking +(defun choose-file-dialog (&key file-types (prompt "File name:")) + (let* ((hook *choose-file-dialog-hook*)) + (if hook + (funcall hook t prompt file-types) + (%choose-file-dialog t prompt file-types)))) + +(defun choose-new-file-dialog (&key prompt) + (let* ((hook *choose-file-dialog-hook*)) + (if hook + (funcall hook nil prompt nil) + (%choose-file-dialog nil prompt nil)))) + +(defun %choose-file-dialog (must-exist prompt file-types) + (loop + (let* ((namestring (get-string-from-user prompt)) + (pathname (ignore-errors (pathname namestring))) + (exists (and pathname (probe-file pathname)))) + (when (and (if must-exist exists) + (or (null file-types) + (member (pathname-type pathname) + file-types :test #'equal))) + (return pathname)) + (if (not exists) + (format *query-io* "~&~s does not exist." namestring) + (format *query-io* "~&Type of ~s is not one of ~{~a~}" + namestring file-types))))) + +(defparameter *overwrite-dialog-hook* nil) +(defun overwrite-dialog (filename prompt) + (if *overwrite-dialog-hook* + (funcall *overwrite-dialog-hook* filename prompt) + t)) + +;;; Might want to have some other entry for, e.g., the inspector +;;; and to let it get its hands on the list header returned by +;;; disassemble-ppc-function. Maybe disassemble-ppc-function +;;; should take care of "normalizing" the code-vector ? +(defun disassemble (thing) + "Disassemble the compiled code associated with OBJECT, which can be a + function, a lambda expression, or a symbol with a function definition. If + it is not already compiled, the compiler is called to produce something to + disassemble." + (#+ppc-target ppc-xdisassemble + #+x86-target x86-xdisassemble + (require-type (function-for-disassembly thing) 'compiled-function))) + +(defun function-for-disassembly (thing) + (let* ((fun thing)) + ;; CLHS says that DISASSEMBLE should signal a type error if its + ;; argument isn't a function designator. Hard to imagine any + ;; code depending on that ... + ;;(when (typep fun 'standard-method) (setq fun (%method-function fun))) + (when (or (symbolp fun) + (and (consp fun) (neq (%car fun) 'lambda))) + (setq fun (fboundp thing)) + (when (and (symbolp thing) (not (functionp fun))) + (setq fun (macro-function thing)))) + (if (typep fun 'compiled-lexical-closure) + (setq fun (closure-function fun))) + (when (lambda-expression-p fun) + (setq fun (compile-named-function fun))) + fun)) + +(%fhave 'df #'disassemble) + +(defun string-sans-most-whitespace (string &optional (max-length (length string))) + (with-output-to-string (sans-whitespace) + (loop + for count below max-length + for char across string + with just-saw-space = nil + if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed)) + do (if just-saw-space + (decf count) + (write-char #\Space sans-whitespace)) + and do (setf just-saw-space t) + else + do (setf just-saw-space nil) + and do (write-char char sans-whitespace)))) + + +(defparameter *svn-program* "svn") + +(defloadvar *use-cygwin-svn* + #+windows-target (not (null (getenv "CYGWIN"))) + #-windows-target nil) + +(defun svn-info-component (component) + (let* ((component-length (length component))) + (let* ((s (make-string-output-stream))) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program *svn-program* (list "info" (native-translated-namestring "ccl:")) :output s :error :output)) + (when (and (eq :exited status) (zerop exit-code)) + (with-input-from-string (output (get-output-stream-string s)) + (do* ((line (read-line output nil nil) (read-line output nil nil))) + ((null line)) + (when (and (>= (length line) component-length) + (string= component line :end2 component-length)) + (return-from svn-info-component + (string-trim " " (subseq line component-length))))))))) + nil)) + +(defun svn-url () (svn-info-component "URL:")) +(defun svn-repository () (svn-info-component "Repository Root:")) + +;;; Try to say something about what tree (trunk, a branch, a release) +;;; we were built from. If the URL (relative to the repository) +;;; starts with "branches", return the second component of the +;;; relative URL, otherwise return the first component. +(defun svn-tree () + (let* ((repo (svn-repository)) + (url (svn-url))) + (or + (if (and repo url) + (let* ((repo-len (length repo))) + (when (and (> (length url) repo-len) + (string= repo url :end2 repo-len)) + ;; Cheat: do pathname parsing here. + (let* ((path (pathname (ensure-directory-namestring (subseq url repo-len)))) + (dir (cdr (pathname-directory path)))) + (when (string= "ccl" (car (last dir))) + (let* ((base (car dir))) + (unless (or (string= base "release") + (string= base "releases")) + (if (string= base "branches") + (cadr dir) + (car dir)))))))))))) + + +(defun svnversion-program () + (or (ignore-errors + (native-translated-namestring + (merge-pathnames "svnversion" *svn-program*))) + "svnversion")) + + + + +(defun local-svn-revision () + (let* ((s (make-string-output-stream)) + (root (native-translated-namestring "ccl:"))) + (when *use-cygwin-svn* + (setq root (cygpath root))) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program (svnversion-program) (list (native-translated-namestring "ccl:") (or (svn-url) "")) :output s :error :output)) + (when (and (eq :exited status) (zerop exit-code)) + (with-input-from-string (output (get-output-stream-string s)) + (let* ((line (read-line output nil nil))) + (when (and line (parse-integer line :junk-allowed t) ) + (return-from local-svn-revision line)))))) + nil)) + + +;;; Scan the heap, collecting infomation on the primitive object types +;;; found. Report that information. + +(defun heap-utilization (&key (stream *debug-io*) + (gc-first t) + (area nil) + (unit nil) + (sort :size) + (classes nil) + (start nil) + (threshold (and classes 0.00005))) + "Show statistics about types of objects in the heap. + If :GC-FIRST is true (the default), do a full gc before scanning the heap. + If :START is non-nil, it should be an object returned by GET-ALLOCATION-SENTINEL, only + objects at higher address are scanned (i.e. roughly, only objects allocated after it). + :SORT can be one of :COUNT, :LOGICAL-SIZE, or :PHYSICAL-SIZE to sort by count or size. + :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes. + :AREA can be used to restrict the walk to one area or a list of areas. Some possible + values are :DYNAMIC, :STATIC, :MANAGED-STATIC, :READONLY. By default, all areas + (including stacks) are examined. + If :CLASSES is true, classifies by class rather than just typecode" + (let ((data (collect-heap-utilization :gc-first gc-first :start start :area area :classes classes))) + (report-heap-utilization data :stream stream :unit unit :sort sort :threshold threshold))) + +(defun collect-heap-utilization (&key (gc-first t) start area classes) + ;; returns list of (type-name count logical-sizes-total physical-sizes-total) + (when start + (unless (or (null area) + (eq (heap-area-code area) area-dynamic) + (and (consp area) (every (lambda (a) (eq (heap-area-code a) area-dynamic)) area))) + (error "~s ~s and ~s ~s are incompatible" :start start :area area)) + (setq area area-dynamic)) + (if classes + (collect-heap-utilization-by-class gc-first area start) + (collect-heap-utilization-by-typecode gc-first area start))) + +(defun collect-heap-utilization-by-typecode (gc-first area start) + (let* ((nconses 0) + (counts (make-array 257)) + (sizes (make-array 257)) + (physical-sizes (make-array 257)) + (array-size-function (arch::target-array-data-size-function + (backend-target-arch *host-backend*)))) + (declare (type (simple-vector 257) counts sizes physical-sizes) + (fixnum nconses) + (dynamic-extent counts sizes physical-sizes)) + (flet ((collect (thing) + (when (or (null start) + (locally (declare (optimize (speed 3) (safety 0))) ;; lie + (%i< start thing))) + (if (listp thing) + (incf nconses) + (let* ((typecode (typecode thing)) + (logsize (funcall array-size-function typecode (uvsize thing))) + (physize (logandc2 (+ logsize + #+64-bit-target (+ 8 15) + #+32-bit-target (+ 4 7)) + #+64-bit-target 15 + #+32-bit-target 7))) + (incf (aref counts typecode)) + (incf (aref sizes typecode) logsize) + (incf (aref physical-sizes typecode) physize)))))) + (declare (dynamic-extent #'collect)) + (when gc-first (gc)) + (%map-areas #'collect area)) + (setf (aref counts 256) nconses) + (setf (aref sizes 256) (* nconses target::cons.size)) + (setf (aref physical-sizes 256) (aref sizes 256)) + (loop for i from 0 upto 256 + when (plusp (aref counts i)) + collect (list (if (eql i 256) 'cons (aref *heap-utilization-vector-type-names* i)) + (aref counts i) + (aref sizes i) + (aref physical-sizes i))))) + +(defun collect-heap-utilization-by-class (gc-first area start) + (let* ((nconses 0) + (max-classes (+ 100 (hash-table-count %find-classes%))) + (map (make-hash-table :shared nil + :test 'eq + :size max-classes)) + (inst-counts (make-array max-classes :initial-element 0)) + (slotv-counts (make-array max-classes :initial-element 0)) + (inst-sizes (make-array max-classes :initial-element 0)) + (slotv-sizes (make-array max-classes :initial-element 0)) + (inst-psizes (make-array max-classes :initial-element 0)) + (slotv-psizes (make-array max-classes :initial-element 0)) + (overflow nil) + (array-size-function (arch::target-array-data-size-function + (backend-target-arch *host-backend*)))) + (declare (type simple-vector inst-counts slotv-counts inst-sizes slotv-sizes inst-psizes slotv-psizes)) + (flet ((collect (thing) + (when (or (null start) + (locally (declare (optimize (speed 3) (safety 0))) ;; lie + (%i< start thing))) + (if (listp thing) + (incf nconses) + (unless (or (eq thing map) + (eq thing (nhash.vector map)) + (eq thing inst-counts) + (eq thing slotv-counts) + (eq thing inst-sizes) + (eq thing slotv-sizes) + (eq thing inst-psizes) + (eq thing slotv-psizes)) + (let* ((typecode (typecode thing)) + (logsize (funcall array-size-function typecode (uvsize thing))) + (physize (logandc2 (+ logsize + #+64-bit-target (+ 8 15) + #+32-bit-target (+ 4 7)) + #+64-bit-target 15 + #+32-bit-target 7)) + (class (class-of (if (eql typecode target::subtag-slot-vector) + (uvref thing slot-vector.instance) + (if (eql typecode target::subtag-function) + (function-vector-to-function thing) + thing)))) + (index (or (gethash class map) + (let ((count (hash-table-count map))) + (if (eql count max-classes) + (setq overflow t count (1- max-classes)) + (setf (gethash class map) count)))))) + + (if (eql typecode target::subtag-slot-vector) + (progn + (incf (aref slotv-counts index)) + (incf (aref slotv-sizes index) logsize) + (incf (aref slotv-psizes index) physize)) + (progn + (incf (aref inst-counts index)) + (incf (aref inst-sizes index) logsize) + (incf (aref inst-psizes index) physize))))))))) + (declare (dynamic-extent #'collect)) + (when gc-first (gc)) + (%map-areas #'collect area)) + (let ((data ())) + (when (plusp nconses) + (push (list 'cons nconses (* nconses target::cons.size) (* nconses target::cons.size)) data)) + (maphash (lambda (class index) + (let* ((icount (aref inst-counts index)) + (scount (aref slotv-counts index)) + (name (if (and overflow (eql index (1- max-classes))) + "All others" + (or (%class-proper-name class) class)))) + (declare (fixnum icount) (fixnum scount)) + ;; When printing class names, the package matters. report-heap-utilization + ;; uses ~a, so print here. + (when (plusp icount) + (push (list (prin1-to-string name) + icount (aref inst-sizes index) (aref inst-psizes index)) data)) + (when (plusp scount) + (push (list (format nil "~s slot vector" name) + scount (aref slotv-sizes index) (aref slotv-psizes index)) data)))) + map) + data))) + +(defun collect-heap-ivector-utilization-by-typecode () + (let* ((counts (make-array 256 :initial-element 0)) + (sizes (make-array 256 :initial-element 0)) + (physical-sizes (make-array 256 :initial-element 0)) + (array-size-function (arch::target-array-data-size-function + (backend-target-arch *host-backend*))) + (result ())) + (declare (dynamic-extent counts sizes)) + (with-lock-grabbed (*heap-ivector-lock*) + (dolist (vector *heap-ivectors*) + (let* ((typecode (typecode vector)) + (logsize (funcall array-size-function typecode (uvsize vector))) + (physsize (+ logsize + ;; header, delta, round up + #+32-bit-target (+ 4 2 7) + #+64-bit-target (+ 8 2 15)))) + (incf (aref counts typecode)) + (incf (aref sizes typecode) logsize) + (incf (aref physical-sizes typecode) physsize)))) + (dotimes (i 256 result) + (when (plusp (aref counts i)) + (push (list (aref *heap-utilization-vector-type-names* i) + (aref counts i) + (aref sizes i) + (aref physical-sizes i)) + result))))) + +(defun heap-ivector-utilization (&key (stream *debug-io*) + (unit nil) + (sort :size)) + (let* ((data (collect-heap-ivector-utilization-by-typecode))) + (report-heap-utilization data :stream stream :unit unit :sort sort))) + +(defvar *heap-utilization-vector-type-names* + (let* ((a (make-array 256))) + #+x8664-target + (dotimes (i 256) + (let* ((fulltag (logand i x8664::fulltagmask)) + (names-vector + (cond ((= fulltag x8664::fulltag-nodeheader-0) + *nodeheader-0-types*) + ((= fulltag x8664::fulltag-nodeheader-1) + *nodeheader-1-types*) + ((= fulltag x8664::fulltag-immheader-0) + *immheader-0-types*) + ((= fulltag x8664::fulltag-immheader-1) + *immheader-1-types*) + ((= fulltag x8664::fulltag-immheader-2) + *immheader-2-types*))) + (name (if names-vector + (aref names-vector (ash i -4))))) + ;; Special-case a few things ... + (if (eq name 'symbol-vector) + (setq name 'symbol) + (if (eq name 'function-vector) + (setq name 'function))) + (setf (aref a i) name))) + #+ppc64-target + (dotimes (i 256) + (let* ((lowtag (logand i ppc64::lowtagmask))) + (setf (%svref a i) + (cond ((= lowtag ppc64::lowtag-immheader) + (%svref *immheader-types* (ash i -2))) + ((= lowtag ppc64::lowtag-nodeheader) + (%svref *nodeheader-types* (ash i -2))))))) + #+(or ppc32-target x8632-target) + (dotimes (i 256) + (let* ((fulltag (logand i target::fulltagmask))) + (setf (%svref a i) + (cond ((= fulltag target::fulltag-immheader) + (%svref *immheader-types* (ash i -3))) + ((= fulltag target::fulltag-nodeheader) + (%svref *nodeheader-types* (ash i -3))))))) + a)) + + +(defun report-heap-utilization (data &key stream unit sort threshold) + (check-type threshold (or null (real 0 1))) + (let* ((div (ecase unit + ((nil) 1) + (:kb 1024.0d0) + (:mb (* 1024.0d0 1024.0d0)) + (:gb (* 1024.0d0 1024.0d0 1024.0d0)))) + (sort-key (ecase sort + (:count #'cadr) + (:logical-size #'caddr) + ((:physical-size :size) #'cadddr) + ((:name nil) nil))) + (total-count 0) + (total-lsize 0) + (total-psize 0) + (max-name 0) + (others (list "All others" 0 0 0))) + + (when (hash-table-p data) + (setq data + (let ((alist nil)) + (maphash (lambda (type measures) (push (cons type measures) alist)) data) + alist))) + + (flet ((type-string (name) + (if (stringp name) + name + (if (symbolp name) + (symbol-name name) + (princ-to-string name))))) + (loop for (nil count lsize psize) in data + do (incf total-count count) + do (incf total-lsize lsize) + do (incf total-psize psize)) + + (when (and data threshold) + (setq data (sort data #'< :key #'cadddr)) + (loop while (< (/ (cadddr (car data)) total-psize) threshold) + do (destructuring-bind (type count lsize psize) (pop data) + (declare (ignore type)) + (incf (cadr others) count) + (incf (caddr others) lsize) + (incf (cadddr others) psize)))) + + (setq data + (if sort-key + (sort data #'> :key sort-key) + (sort data #'string-lessp :key #'(lambda (s) (type-string (car s)))))) + + (when (> (cadr others) 0) + (setq data (nconc data (list others)))) + + (setq max-name (loop for (name) in data maximize (length (type-string name)))) + + (format stream "~&Object type~vtCount Logical size Physical size % of Heap~%~vt ~a~vt ~2:*~a" + (+ max-name 7) + (+ max-name 15) + (ecase unit + ((nil) " (in bytes)") + (:kb "(in kilobytes)") + (:mb "(in megabytes)") + (:gb "(in gigabytes)")) + (+ max-name 31)) + (loop for (type count logsize physsize) in data + do (if unit + (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%" + (type-string type) + (1+ max-name) + count + (/ logsize div) + (/ physsize div) + (* 100.0 (/ physsize total-psize))) + (format stream "~&~a~vt~11d~16d~16d~11,2f%" + (type-string type) + (1+ max-name) + count + logsize + physsize + (* 100.0 (/ physsize total-psize))))) + (if unit + (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%" + "Total" + (1+ max-name) + total-count + (/ total-lsize div) + (/ total-psize div) + 100.0d0) + (format stream "~&~a~vt~11d~16d~16d~11,2f%" + "Total" + (1+ max-name) + total-count + total-lsize + total-psize + 100.0d0)))) + (values)) + +;; The number of words to allocate for static conses when the user requests +;; one and we don't have any left over +(defparameter *static-cons-chunk* 1048576) + +(defun initialize-static-cons () + "Activates collection of garbage conses in the static-conses + list and allocates initial static conses." + ; There might be a race here when multiple threads call this + ; function. However, the discarded static conses will become + ; garbage and be added right back to the list. No harm here + ; except for additional garbage collections. + (%set-kernel-global 'static-conses nil) + (allocate-static-conses)) + +(defun allocate-static-conses () + "Allocates some memory, freezes it and lets it become garbage. + This will add the memory to the list of free static conses." + (let* ((nfullgc (full-gccount))) + (multiple-value-bind (head tail) + (%allocate-list 0 *static-cons-chunk*) + (if (eql (full-gccount) nfullgc) + (freeze) + (flash-freeze)) + (%augment-static-conses head tail)))) + +(defun static-cons (car-value cdr-value) + "Allocates a cons cell that doesn't move on garbage collection, + and thus doesn't trigger re-hashing when used as a key in a hash + table. Usage is equivalent to regular CONS." + (when (eq (%get-kernel-global 'static-conses) 0) + (initialize-static-cons)) + (let ((cell (%atomic-pop-static-cons))) + (if cell + (progn + (setf (car cell) car-value) + (setf (cdr cell) cdr-value) + cell) + (progn + (allocate-static-conses) + (static-cons car-value cdr-value))))) + + +(defparameter *weak-gc-method-names* + '((:traditional . 0) + (:non-circular . 1))) + + +(defun weak-gc-method () + (or (car (rassoc (%get-kernel-global 'weak-gc-method) + *weak-gc-method-names*)) + :traditional)) + + +(defun (setf weak-gc-method) (name) + (setf (%get-kernel-global 'weak-gc-method) + (or (cdr (assoc name *weak-gc-method-names*)) + 0)) + name) + +(defun %lock-whostate-string (string lock) + (with-standard-io-syntax + (format nil "~a for ~a ~@[~a ~]@ #x~x" + string + (%svref lock target::lock.kind-cell) + (lock-name lock) + (%ptr-to-int (%svref lock target::lock._value-cell))))) + +(defun all-watched-objects () + (let (result) + (with-other-threads-suspended + (%map-areas #'(lambda (x) (push x result)) area-watched)) + result)) + +(defun primitive-watch (thing) + (require-type thing '(or cons (satisfies uvectorp))) + (%watch thing)) + +(defun watch (&optional thing) + (cond ((null thing) + (all-watched-objects)) + ((arrayp thing) + (primitive-watch (array-data-and-offset thing))) + ((hash-table-p thing) + (primitive-watch (nhash.vector thing))) + ((standard-instance-p thing) + (primitive-watch (instance-slots thing))) + (t + (primitive-watch thing)))) + +(defun unwatch (thing) + (with-other-threads-suspended + (%map-areas #'(lambda (x) + (when (eq x thing) + (let ((new (if (uvectorp thing) + (%alloc-misc (uvsize thing) + (typecode thing)) + (cons nil nil)))) + (return-from unwatch (%unwatch thing new))))) + area-watched))) + +(defun %parse-unsigned-integer (vector start end) + (declare ((simple-array (unsigned-byte 8) (*)) vector) + (fixnum start end) + (optimize (speed 3) (safety 0))) + (let* ((count (- end start)) + (msb 0)) + (declare (fixnum count) ((unsigned-byte 8) msb)) + (or + (do* ((i start (1+ i))) + ((>= i end) 0) + (declare (fixnum i)) + (let* ((b (aref vector i))) + (declare ((unsigned-byte 8) b)) + (cond ((zerop b) (incf start) (decf count)) + (t (setq msb b) (return))))) + (cond + ((or (< count #+64-bit-target 8 #+32-bit-target 4) + (and (= count #+64-bit-target 8 #+32-bit-target 4) + (< msb #+64-bit-target 16 #+32-bit-target 32))) + ;; Result will be a fixnum. + (do* ((result 0) + (shift 0 (+ shift 8)) + (i (1- end) (1- i))) + ((< i start) result) + (declare (fixnum result shift i)) + (setq result (logior result (the fixnum (%ilsl shift (aref vector i))))))) + (t + ;; Result will be a bignum. If COUNT is a multiple of 4 + ;; and the most significant bit is set, need to add an + ;; extra word of zero-extension. + (let* ((result (allocate-typed-vector :bignum + (if (and (logbitp 7 msb) + (zerop (the fixnum (logand count 3)))) + (the fixnum (1+ (the fixnum (ash count -2)))) + (the fixnum (ash (the fixnum (+ count 3)) -2)))))) + (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie + (dotimes (i count result) + (decf end) + (setf (aref result + #+little-endian-target i + #+big-endian-target (the fixnum (logxor i 3))) + (aref vector end))))))))) + + +;;; Octets between START and END encode an unsigned integer in big-endian +;;; byte order. +(defun parse-unsigned-integer (vector &optional (start 0) end) + (setq end (check-sequence-bounds vector start end)) + (locally (declare (fixnum start end)) + (unless (typep vector '(simple-array (unsigned-byte 8) (*))) + (multiple-value-bind (data offset) (array-data-and-offset vector) + (declare (fixnum offset)) + (unless (typep data '(simple-array (unsigned-byte 8) (*))) + (report-bad-arg vector '(vector (unsigned-byte 8)))) + (incf start offset) + (incf end offset) + (setq vector data))) + (%parse-unsigned-integer vector start end))) + +(defun %parse-signed-integer (vector start end) + (declare ((simple-array (unsigned-byte 8) (*)) vector) + (fixnum start end) + (optimize (speed 3) (safety 0))) + (let* ((count (- end start))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((sign-byte (aref vector start))) + (declare (fixnum sign-byte)) + (if (< sign-byte 128) + (%parse-unsigned-integer vector start end) + (progn + (decf sign-byte 256) + (or + (do* () + ((= count 1) sign-byte) + (unless (= sign-byte -1) + (return)) + (let* ((next (1+ start)) + (nextb (aref vector next))) + (declare (fixnum next nextb)) + (if (not (logbitp 7 nextb)) + (return)) + (setq sign-byte (- nextb 256) + start next + count (1- count)))) + (cond ((or (< count #+64-bit-target 8 #+32-bit-target 4) + (and (= count #+64-bit-target 8 #+32-bit-target 4) + (>= sign-byte + #+64-bit-target -16 + #+32-bit-target -32))) + ;; Result will be a fixnum + (do* ((result 0) + (shift 0 (+ shift 8)) + (i (1- end) (1- i))) + ((= i start) (logior result (the fixnum (%ilsl shift sign-byte)))) + (declare (fixnum result shift i)) + (setq result (logior result (the fixnum (%ilsl shift (aref vector i))))))) + (t + (let* ((result (allocate-typed-vector :bignum (the fixnum (ash (the fixnum (+ count 3)) -2))))) + (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie + (dotimes (i count (do* ((i count (1+ i))) + ((= 0 (the fixnum (logand i 3))) + result) + (declare (fixnum i)) + (setf (aref result + #+little-endian-target i + #+big-endian-target (the fixnum (logxor i 3))) #xff))) + (decf end) + (setf (aref result + #+little-endian-target i + #+big-endian-target (the fixnum (logxor i 3))) + (aref vector end))))))))))))) + +(defun parse-signed-integer (vector &optional (start 0) end) + (setq end (check-sequence-bounds vector start end)) + (locally (declare (fixnum start end)) + (unless (typep vector '(simple-array (unsigned-byte 8) (*))) + (multiple-value-bind (data offset) (array-data-and-offset vector) + (declare (fixnum offset)) + (unless (typep data '(simple-array (unsigned-byte 8) (*))) + (report-bad-arg vector '(vector (unsigned-byte 8)))) + (incf start offset) + (incf end offset) + (setq vector data))) + (%parse-signed-integer vector start end))) Index: /branches/qres/ccl/lib/nfcomp.lisp =================================================================== --- /branches/qres/ccl/lib/nfcomp.lisp (revision 13564) +++ /branches/qres/ccl/lib/nfcomp.lisp (revision 13564) @@ -0,0 +1,2054 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; :lib:nfcomp.lisp - New fasl compiler. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'level-2)) + +(require 'optimizers) +(require 'hash) + +(eval-when (:compile-toplevel :execute) + +(require 'backquote) +(require 'defstruct-macros) + +(defmacro short-fixnum-p (fixnum) + `(and (fixnump ,fixnum) (< (integer-length ,fixnum) 16))) + +(require "FASLENV" "ccl:xdump;faslenv") + +#+ppc32-target +(require "PPC32-ARCH") +#+ppc64-target +(require "PPC64-ARCH") +#+x8632-target +(require "X8632-ARCH") +#+x8664-target +(require "X8664-ARCH") +) ;eval-when (:compile-toplevel :execute) + + +;File compiler options. Not all of these need to be exported/documented, but +;they should be in the product just in case we need them for patches.... +(defvar *fasl-save-local-symbols* t) +(defvar *fasl-save-doc-strings* t) +(defvar *fasl-save-definitions* nil) + +(defvar *fasl-deferred-warnings* nil) +(defvar *fasl-non-style-warnings-signalled-p* nil) +(defvar *fasl-warnings-signalled-p* nil) + +(defvar *compile-verbose* nil ; Might wind up getting called *compile-FILE-verbose* + "The default for the :VERBOSE argument to COMPILE-FILE.") +(defvar *compile-file-pathname* nil + "The defaulted pathname of the file currently being compiled, or NIL if not + compiling.") ; pathname of src arg to COMPILE-FILE +(defvar *compile-file-truename* nil + "The TRUENAME of the file currently being compiled, or NIL if not + compiling.") ; truename ... +(defvar *fasl-target* (backend-name *host-backend*)) +(defvar *fasl-backend* *host-backend*) +(defvar *fasl-host-big-endian* + (arch::target-big-endian (backend-target-arch *host-backend*))) +(defvar *fasl-target-big-endian* *fasl-host-big-endian*) +(defvar *fcomp-external-format* :default) + +(defvar *fasl-break-on-program-errors* #+ccl-0711 nil #-ccl-0711 :defer + "Controls what happens when the compiler detects PROGRAM-ERROR's during file compilation. + + If T, the compiler signals an error immediately when it detects the program-error. + + If :DEFER, program errors are reported as compiler warnings, and in addition, an error + is signalled at the end of file compilation. This allows all warnings for the file + to be reported, but prevents the creation of a fasl file. + + If NIL, program errors are treated the same as any other error condition detected by + the compiler, i.e. they are reported as compiler warnings and do not cause any + error to be signalled at compile time.") + + +(defvar *compile-print* nil ; Might wind up getting called *compile-FILE-print* + "The default for the :PRINT argument to COMPILE-FILE.") + +;Note: errors need to rebind this to NIL if they do any reading without +; unwinding the stack! +(declaim (special *compiling-file*)) ; defined in l1-init. + +(defvar *fasl-source-file* nil "Name of file currently being read from. +Will differ from *compiling-file* during an INCLUDE") + +(defparameter *fasl-package-qualified-symbols* '(*loading-file-source-file* set-package %define-package) + "These symbols are always fasdumped with full package qualification.") + +(defun setup-target-features (backend features) + (if (eq backend *host-backend*) + features + (let* ((new nil) + (nope (backend-target-specific-features *host-backend*))) + (dolist (f features) + (unless (memq f nope) (pushnew f new))) + (dolist (f (backend-target-specific-features backend) + (progn (pushnew :cross-compiling new) new)) + (pushnew f new))))) + +(defun compile-file-pathname (pathname &rest ignore &key output-file &allow-other-keys) + "Return a pathname describing what file COMPILE-FILE would write to given + these arguments." + (declare (ignore ignore)) + (setq pathname (merge-pathnames pathname)) + (merge-pathnames (if output-file + (merge-pathnames output-file *.fasl-pathname*) + *.fasl-pathname*) + pathname)) + +(defun compile-file (src &key output-file + (verbose *compile-verbose*) + (print *compile-print*) + load + features + (target *fasl-target* target-p) + (save-local-symbols *fasl-save-local-symbols*) + (save-doc-strings *fasl-save-doc-strings*) + (save-definitions *fasl-save-definitions*) + (save-source-locations *save-source-locations*) + (external-format :default) + force + ;; src may be a temp file with a section of the real source, + ;; then this is the real source file name. + compile-file-original-truename + (compile-file-original-buffer-offset 0) + (break-on-program-errors (if compile-file-original-truename + t ;; really SLIME being interactive... + *fasl-break-on-program-errors*))) + "Compile SRC, producing a corresponding fasl file and returning its filename." + (let* ((backend *target-backend*)) + (when (and target-p (not (setq backend (find-backend target)))) + (warn "Unknown :TARGET : ~S. Reverting to ~s ..." target *fasl-target*) + (setq target *fasl-target* backend *target-backend*)) + (multiple-value-bind (output-file truename warnings-p serious-p) + (loop + (restart-case + (return (%compile-file src output-file verbose print features + save-local-symbols save-doc-strings save-definitions + save-source-locations break-on-program-errors + force backend external-format + compile-file-original-truename compile-file-original-buffer-offset)) + (retry-compile-file () + :report (lambda (stream) (format stream "Retry compiling ~s" src)) + nil) + (skip-compile-file () + :report (lambda (stream) + (if load + (format stream "Skip compiling and loading ~s" src) + (format stream "Skip compiling ~s" src))) + (return-from compile-file)))) + (when load (load output-file :verbose (or verbose *load-verbose*))) + (values truename warnings-p serious-p)))) + + +(defvar *fasl-compile-time-env* nil) + +(defun %compile-file (src output-file verbose print features + save-local-symbols save-doc-strings save-definitions + save-source-locations break-on-program-errors + force target-backend external-format + compile-file-original-truename compile-file-original-buffer-offset) + (let* ((orig-src (merge-pathnames src)) + (output-default-type (backend-target-fasl-pathname target-backend)) + (*fasl-non-style-warnings-signalled-p* nil) + (*fasl-warnings-signalled-p* nil)) + (setq src (fcomp-find-file orig-src)) + (let* ((newtype (pathname-type src))) + (when (and newtype (not (pathname-type orig-src))) + (setq orig-src (merge-pathnames orig-src (make-pathname :type newtype :defaults nil))))) + (setq output-file (merge-pathnames + (if output-file ; full-pathname in case output-file is relative + (full-pathname (merge-pathnames output-file output-default-type) :no-error nil) + output-default-type) + orig-src)) + ;; This should not be necessary, but it is. + (setq output-file (namestring output-file)) + (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time + (setq orig-src (back-translate-pathname orig-src '("home" "ccl")))) + (when (and (not force) + (probe-file output-file) + (not (fasl-file-p output-file))) + (cerror "overwrite it anyway" + "Compile destination ~S is not a ~A file!" + output-file (pathname-type + (backend-target-fasl-pathname + *target-backend*)))) + (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*))) + (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ... + (*fasl-save-local-symbols* save-local-symbols) + (*save-source-locations* save-source-locations) + (*fasl-save-doc-strings* save-doc-strings) + (*fasl-save-definitions* save-definitions) + (*fasl-break-on-program-errors* break-on-program-errors) + (*fcomp-warnings-header* nil) + (*compile-file-pathname* orig-src) + (*compile-file-truename* (truename src)) + (*package* *package*) + (*readtable* *readtable*) + (*compile-print* print) + (*compile-verbose* verbose) + (*fasl-target* (backend-name target-backend)) + (*fasl-backend* target-backend) + (*fasl-target-big-endian* (arch::target-big-endian + (backend-target-arch target-backend))) + (*target-ftd* (backend-target-foreign-type-data target-backend)) + (defenv (new-definition-environment)) + (lexenv (new-lexical-environment defenv)) + (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment))) + (*fcomp-external-format* external-format) + (forms nil)) + (let ((current *outstanding-deferred-warnings*) last) + (when (and current + (setq last (deferred-warnings.last-file current)) + (equalp *compile-file-pathname* (cdr last))) + ;; Discard previous deferred warnings when recompiling exactly the same file again, + ;; since most likely this is due to an interactive "retry compilation" request and + ;; we want to avoid duplicate warnings. + (setf (deferred-warnings.last-file current) nil))) + + (let* ((*outstanding-deferred-warnings* (%defer-warnings nil))) + (rplacd (defenv.type defenv) *outstanding-deferred-warnings*) + (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*)) + + (setq forms (fcomp-file src + (or compile-file-original-truename (namestring orig-src)) + compile-file-original-buffer-offset + lexenv)) + + (setf (deferred-warnings.warnings *outstanding-deferred-warnings*) + (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*))) + (when *compile-verbose* (fresh-line)) + (multiple-value-bind (any harsh) (report-deferred-warnings *compile-file-pathname*) + (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any) + *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very + (or *fasl-non-style-warnings-signalled-p* harsh))))) + (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very)) + (cerror "create the output file despite the errors" + "Serious errors encountered during compilation of ~s" + src)) + (fasl-scan-forms-and-dump-file forms output-file lexenv) + (values output-file + (truename (pathname output-file)) + *fasl-warnings-signalled-p* + (and *fasl-non-style-warnings-signalled-p* t))))) + +(defvar *fcomp-locked-hash-tables*) +(defvar *fcomp-load-forms-environment* nil) + +; This is separated out so that dump-forms-to-file can use it +(defun fasl-scan-forms-and-dump-file (forms output-file &optional env) + (let ((*fcomp-locked-hash-tables* nil) + (*fcomp-load-forms-environment* env)) + (unwind-protect + (multiple-value-bind (hash gnames goffsets) (fasl-scan forms) + (fasl-dump-file gnames goffsets forms hash output-file)) + (fasl-unlock-hash-tables)))) + +#-bccl +(defun nfcomp (src &optional dest &rest keys) + (when (keywordp dest) (setq keys (cons dest keys) dest nil)) + (apply #'compile-file src :output-file dest keys)) + +#-bccl +(%fhave 'fcomp #'nfcomp) + +(defparameter *default-file-compilation-policy* (new-compiler-policy)) + +(defun current-file-compiler-policy () + *default-file-compilation-policy*) + +(defun set-current-file-compiler-policy (&optional new-policy) + (setq *default-file-compilation-policy* + (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy)))) + +(defparameter *compile-time-evaluation-policy* + (new-compiler-policy :force-boundp-checks t)) + +(defun %compile-time-eval (form env) + (declare (ignore env)) + (let* ((*target-backend* *host-backend*) + (*loading-toplevel-location* (or (fcomp-source-note form) + *loading-toplevel-location*)) + (lambda `(lambda () ,form))) + (fcomp-note-source-transformation form lambda) + ;; The HANDLER-BIND here is supposed to note WARNINGs that're + ;; signaled during (eval-when (:compile-toplevel) processing; this + ;; in turn is supposed to satisfy a pedantic interpretation of the + ;; spec's requirement that COMPILE-FILE's second and third return + ;; values reflect (all) conditions "detected by the compiler." + ;; (It's kind of sad that CL language design is influenced so + ;; strongly by the views of pedants these days.) + (handler-bind ((warning (lambda (c) + (setq *fasl-warnings-signalled-p* t) + (unless (typep c 'style-warning) + (setq *fasl-non-style-warnings-signalled-p* t)) + (signal c)))) + (funcall (compile-named-function + lambda + :source-notes *fcomp-source-note-map* + :env *fasl-compile-time-env* + :policy *compile-time-evaluation-policy*))))) + + +;;; No methods by default, not even for structures. This really sux. +(defgeneric make-load-form (object &optional environment)) + +;;; Well, no usable methods by default. How this is better than +;;; getting a NO-APPLICABLE-METHOD error frankly escapes me, +(defun no-make-load-form-for (object) + (error "No ~S method is defined for ~s" 'make-load-form object)) + +(defmethod make-load-form ((s standard-object) &optional environment) + (declare (ignore environment)) + (no-make-load-form-for s)) + +(defmethod make-load-form ((s structure-object) &optional environment) + (declare (ignore environment)) + (no-make-load-form-for s)) + +(defmethod make-load-form ((c condition) &optional environment) + (declare (ignore environment)) + (no-make-load-form-for c)) + +(defmethod make-load-form ((c class) &optional environment) + (let* ((name (class-name c)) + (found (if name (find-class name nil environment)))) + (if (eq found c) + `(find-class ',name) + (error "Class ~s does not have a proper name." c)))) + + +;;;; FCOMP-FILE - read & compile file +;;;; Produces a list of (opcode . args) to run on loading, intermixed +;;;; with read packages. + +(defparameter *fasl-eof-forms* nil) + +(defparameter cfasl-load-time-eval-sym (make-symbol "LOAD-TIME-EVAL")) +(%macro-have cfasl-load-time-eval-sym + #'(lambda (call env) (declare (ignore env)) (list 'eval (list 'quote call)))) +;Make it a constant so compiler will barf if try to bind it, e.g. (LET #,foo ...) +(define-constant cfasl-load-time-eval-sym cfasl-load-time-eval-sym) + + +(defparameter *reading-for-cfasl* nil "Used by the reader for #,") + + + +(declaim (special *nx-compile-time-types* +;The following are the global proclaimed values. Since compile-file binds +;them, this means you can't ever globally proclaim these things from within a +;file compile (e.g. from within eval-when compile, or loading a file) - the +;proclamations get lost when compile-file exits. This is sort of intentional +;(or at least the set of things which fall in this category as opposed to +;having a separate compile-time variable is sort of intentional). + *nx-proclaimed-inline* ; inline and notinline + *nx-proclaimed-ignore* ; ignore and unignore + *nx-known-declarations* ; declaration + *nx-speed* ; optimize speed + *nx-space* ; optimize space + *nx-safety* ; optimize safety + *nx-cspeed*)) ; optimize compiler-speed + +(defvar *fcomp-load-time*) +(defvar *fcomp-inside-eval-always* nil) +(defvar *fcomp-eval-always-functions* nil) ; used by the LISP package +(defvar *fcomp-output-list*) +(defvar *fcomp-toplevel-forms*) +(defvar *fcomp-source-note-map* nil) +(defvar *fcomp-loading-toplevel-location*) +(defvar *fcomp-warnings-header*) +(defvar *fcomp-stream-position* nil) +(defvar *fcomp-previous-position* nil) +(defvar *fcomp-indentation*) +(defvar *fcomp-print-handler-plist* nil) +(defvar *fcomp-last-compile-print* + '(INCLUDE (NIL . T) + DEFSTRUCT ("Defstruct" . T) + DEFCONSTANT "Defconstant" + DEFSETF "Defsetf" + DEFTYPE "Deftype" + DEFCLASS "Defclass" + DEFGENERIC "Defgeneric" + DEFMETHOD "Defmethod" + DEFMACRO "Defmacro" + DEFPARAMETER "Defparameter" + DEFVAR "Defvar" + DEFUN "")) + +(setf (getf *fcomp-print-handler-plist* 'defun) "" + (getf *fcomp-print-handler-plist* 'defvar) "Defvar" + (getf *fcomp-print-handler-plist* 'defparameter) "Defparameter" + (getf *fcomp-print-handler-plist* 'defmacro) "Defmacro" + (getf *fcomp-print-handler-plist* 'defmethod) "Defmethod" ; really want more than name (use the function option) + (getf *fcomp-print-handler-plist* 'defgeneric) "Defgeneric" + (getf *fcomp-print-handler-plist* 'defclass) "Defclass" + (getf *fcomp-print-handler-plist* 'deftype) "Deftype" + (getf *fcomp-print-handler-plist* 'defsetf) "Defsetf" + (getf *fcomp-print-handler-plist* 'defconstant) "Defconstant" + (getf *fcomp-print-handler-plist* 'defstruct) '("Defstruct" . t) + (getf *fcomp-print-handler-plist* 'include) '(nil . t)) + + +(defun fcomp-file (filename orig-file orig-offset env) ; orig-file is back-translated + (let* ((*package* *package*) + (*compiling-file* filename) + (*nx-compile-time-types* *nx-compile-time-types*) + (*nx-proclaimed-inline* *nx-proclaimed-inline*) + (*nx-known-declarations* *nx-known-declarations*) + (*nx-proclaimed-ignore* *nx-proclaimed-ignore*) + (*nx-speed* *nx-speed*) + (*nx-space* *nx-space*) + (*nx-debug* *nx-debug*) + (*nx-safety* *nx-safety*) + (*nx-cspeed* *nx-cspeed*) + (*fcomp-load-time* t) + (*fcomp-output-list* nil) + (*fcomp-indentation* 0) + (*fcomp-last-compile-print* (cons nil (cons nil nil)))) + (push (list $fasl-platform (backend-target-platform *fasl-backend*)) *fcomp-output-list*) + (fcomp-read-loop filename orig-file orig-offset env :not-compile-time) + (nreverse *fcomp-output-list*))) + +(defun fcomp-find-file (file &aux path) + (unless (or (setq path (probe-file file)) + (setq path (probe-file (merge-pathnames file *.lisp-pathname*)))) + (error 'file-error :pathname file :error-type "File ~S not found")) + (namestring path)) + +;;; orig-file is back-translated when from fcomp-file +;;; when from fcomp-include it's included filename merged with *compiling-file* +;;; which is not back translated +(defun fcomp-read-loop (filename orig-file orig-offset env processing-mode) + (when *compile-verbose* + (format t "~&;~A ~S..." + (if (eq filename *compiling-file*) "Compiling" " Including") + filename)) + (with-open-file (stream filename + :element-type 'base-char + :external-format *fcomp-external-format*) + (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*)) + (*fasl-source-file* (or orig-file filename)) + (*fcomp-toplevel-forms* nil) + (*fasl-eof-forms* nil) + (*loading-file-source-file* orig-file) + (*fcomp-source-note-map* (and (or *save-source-locations* *compile-code-coverage*) + (make-hash-table :test #'eq :shared nil))) + (*loading-toplevel-location* nil) + (*fcomp-loading-toplevel-location* nil) + (eofval (cons nil nil)) + (read-package nil) + form) + + (fcomp-output-form $fasl-src env *loading-file-source-file*) + (let* ((*fcomp-previous-position* nil)) + (loop + (let* ((*fcomp-stream-position* (file-position stream)) + (*nx-warnings* nil)) ;; catch any warnings from :compile-toplevel forms + (when (and *fcomp-stream-position* orig-offset) + (incf *fcomp-stream-position* orig-offset)) + (unless (eq read-package *package*) + (fcomp-compile-toplevel-forms env) + (setq read-package *package*)) + (let ((*reading-for-cfasl* + (and *fcomp-load-time* cfasl-load-time-eval-sym))) + (declare (special *reading-for-cfasl*)) + (let ((pos (file-position stream))) + (handler-bind + ((error #'(lambda (c) ; we should distinguish read errors from others? + (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename) + (signal c)))) + (multiple-value-setq (form *loading-toplevel-location*) + (read-recording-source stream + :eofval eofval + :file-name *loading-file-source-file* + :start-offset orig-offset + :map *fcomp-source-note-map* + :save-source-text (neq *save-source-locations* :no-text)))))) + (when (eq eofval form) + (require-type *loading-toplevel-location* 'null) + (return)) + (fcomp-form form env processing-mode) + (fcomp-signal-or-defer-warnings *nx-warnings* env) + (setq *fcomp-previous-position* *fcomp-stream-position*)))) + (when *compile-code-coverage* + (fcomp-compile-toplevel-forms env) + (let* ((fns (fcomp-code-covered-functions)) + (v (nreverse (coerce fns 'vector)))) + (map nil #'fcomp-digest-code-notes v) + (fcomp-random-toplevel-form `(register-code-covered-functions ',v) env))) + (while (setq form *fasl-eof-forms*) + (setq *fasl-eof-forms* nil) + (fcomp-form-list form env processing-mode)) + (when old-file + (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*))) + (fcomp-compile-toplevel-forms env)))) + +(defun fcomp-code-covered-functions () + (loop for op in *fcomp-output-list* + when (consp op) + nconc (if (eq (car op) $fasl-lfuncall) + ;; Don't collect the toplevel lfun itself, it leads to spurious markings. + ;; Instead, descend one level and collect any referenced fns. + (destructuring-bind (fn) (cdr op) + (lfunloop for imm in fn when (functionp imm) collect imm)) + (loop for arg in (cdr op) when (functionp arg) collect arg)))) + + +(defun fcomp-form (form env processing-mode + &aux print-stuff + (load-time (and processing-mode (neq processing-mode :compile-time))) + (compile-time-too (or (eq processing-mode :compile-time) + (eq processing-mode :compile-time-too)))) + (let* ((*fcomp-indentation* *fcomp-indentation*) + (*compile-print* *compile-print*)) + (when *compile-print* + (cond ((and (consp form) (setq print-stuff (getf *fcomp-print-handler-plist* (car form)))) + (rplaca (rplacd (cdr *fcomp-last-compile-print*) nil) nil) + (rplaca *fcomp-last-compile-print* nil) + (let ((print-recurse nil)) + (when (consp print-stuff) + (setq print-recurse (cdr print-stuff) print-stuff (car print-stuff))) + (cond ((stringp print-stuff) + (if (equal print-stuff "") + (format t "~&~vT~S~%" *fcomp-indentation* (second form)) + (format t "~&~vT~S [~A]~%" *fcomp-indentation* (second form) print-stuff))) + ((not (null print-stuff)) + (format t "~&~vT" *fcomp-indentation*) + (funcall print-stuff form *standard-output*) + (terpri *standard-output*))) + (if print-recurse + (setq *fcomp-indentation* (+ *fcomp-indentation* 4)) + (setq *compile-print* nil)))) + (t (unless (and (eq load-time (car *fcomp-last-compile-print*)) + (eq compile-time-too (cadr *fcomp-last-compile-print*)) + (eq *fcomp-indentation* (cddr *fcomp-last-compile-print*))) + (rplaca *fcomp-last-compile-print* load-time) + (rplaca (rplacd (cdr *fcomp-last-compile-print*) compile-time-too) *fcomp-indentation*) + (format t "~&~vTToplevel Forms...~A~%" + *fcomp-indentation* + (if load-time + (if compile-time-too + " (Compiletime, Loadtime)" + "") + (if compile-time-too + " (Compiletime)" + ""))))))) + (fcomp-form-1 form env processing-mode))) + +(defun fcomp-form-1 (form env processing-mode &aux sym body) + (if (consp form) (setq sym (%car form) body (%cdr form))) + (case sym + (progn (fcomp-form-list body env processing-mode)) + (eval-when (fcomp-eval-when form env processing-mode)) + (compiler-let (fcomp-compiler-let form env processing-mode)) + (locally (fcomp-locally form env processing-mode)) + (macrolet (fcomp-macrolet form env processing-mode)) + (symbol-macrolet (fcomp-symbol-macrolet form env processing-mode)) + ((%include include) (fcomp-include form env processing-mode)) + (t + ;;Need to macroexpand to see if get more progn's/eval-when's and so should + ;;stay at toplevel. But don't expand if either the evaluator or the + ;;compiler might not - better safe than sorry... + ;; Good advice, but the hard part is knowing which is which. + (cond + ((and (non-nil-symbol-p sym) + (macro-function sym env) + (not (compiler-macro-function sym env)) + (not (eq sym '%defvar-init)) ; a macro that we want to special-case + (multiple-value-bind (new win) (fcomp-macroexpand-1 form env) + (if win (setq form new)) + win)) + (fcomp-form form env processing-mode)) + ((and (not *fcomp-inside-eval-always*) + (memq sym *fcomp-eval-always-functions*)) + (let* ((*fcomp-inside-eval-always* t) + (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form))) + (fcomp-form-1 new env processing-mode))) + (t + (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too)) + (%compile-time-eval form env)) + (when (and processing-mode (neq processing-mode :compile-time)) + (case sym + ((%defconstant) (fcomp-load-%defconstant form env)) + ((%defparameter) (fcomp-load-%defparameter form env)) + ((%defvar %defvar-init) (fcomp-load-defvar form env)) + ((%defun) (fcomp-load-%defun form env)) + ((set-package %define-package) + (fcomp-random-toplevel-form form env) + (fcomp-compile-toplevel-forms env)) + ((%macro) (fcomp-load-%macro form env)) + ;; ((%deftype) (fcomp-load-%deftype form)) + ;; ((define-setf-method) (fcomp-load-define-setf-method form)) + (t (fcomp-random-toplevel-form form env))))))))) + +(defun fcomp-form-list (forms env processing-mode) + (let* ((outer *loading-toplevel-location*)) + (dolist (form forms) + (setq *loading-toplevel-location* (or (fcomp-source-note form) outer)) + (fcomp-form form env processing-mode)) + (setq *loading-toplevel-location* outer))) + +(defun fcomp-compiler-let (form env processing-mode &aux vars varinits (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (dolist (pair (car body)) + (push (nx-pair-name pair) vars) + (push (%compile-time-eval (nx-pair-initform pair) env) varinits)) + (progv (nreverse vars) (nreverse varinits) + (fcomp-form-list (cdr body) env processing-mode) + (fcomp-compile-toplevel-forms env))) + +(defun fcomp-locally (form env processing-mode &aux (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (multiple-value-bind (body decls) (parse-body body env) + (let* ((decl-specs (decl-specs-from-declarations decls)) + (env (augment-environment env :declare decl-specs)) + (*fasl-compile-time-env* (augment-environment *fasl-compile-time-env* + :declare decl-specs))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env)))) + +(defun fcomp-macrolet (form env processing-mode &aux (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (flet ((augment-with-macros (e defs) + (augment-environment e + :macro + (mapcar #'(lambda (m) + (destructuring-bind (name arglist &body body) m + (list name (enclose (parse-macro name arglist body env) + e)))) + defs)))) + + (let* ((macros (car body)) + (outer-env (augment-with-macros env macros))) + (multiple-value-bind (body decls) (parse-body (cdr body) outer-env) + (let* ((decl-specs (decl-specs-from-declarations decls)) + (env (augment-environment + outer-env + :declare decl-specs)) + (*fasl-compile-time-env* (augment-environment + (augment-with-macros + *fasl-compile-time-env* + macros) + :declare decl-specs))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env)))))) + +(defun fcomp-symbol-macrolet (form env processing-mode &aux (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (let* ((defs (car body)) + (outer-env (augment-environment env :symbol-macro defs))) + (multiple-value-bind (body decls) (parse-body (cdr body) env) + (let* ((decl-specs (decl-specs-from-declarations decls)) + (env (augment-environment outer-env + :declare decl-specs)) + (*fasl-compile-time-env* (augment-environment *fasl-compile-time-env* + :symbol-macro defs + :declare decl-specs))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env))))) + +(defun fcomp-eval-when (form env processing-mode &aux (body (%cdr form)) (eval-times (pop body))) + (let* ((compile-time-too (eq processing-mode :compile-time-too)) + (compile-time-only (eq processing-mode :compile-time)) + (at-compile-time nil) + (at-load-time nil) + (at-eval-time nil)) + (dolist (when eval-times) + (if (or (eq when 'compile) (eq when :compile-toplevel)) + (setq at-compile-time t) + (if (or (eq when 'eval) (eq when :execute)) + (setq at-eval-time t) + (if (or (eq when 'load) (eq when :load-toplevel)) + (setq at-load-time t) + (warn "Unknown EVAL-WHEN time ~s in ~S while compiling ~S." + when eval-times *fasl-source-file*))))) + (fcomp-compile-toplevel-forms env) ; always flush the suckers + (cond (compile-time-only + (if at-eval-time (fcomp-form-list body env :compile-time))) + (at-load-time + (fcomp-form-list body env (if (or at-compile-time (and at-eval-time compile-time-too)) + :compile-time-too + :not-compile-time))) + ((or at-compile-time (and at-eval-time compile-time-too)) + (fcomp-form-list body env :compile-time)))) + (fcomp-compile-toplevel-forms env)) + +(defun fcomp-include (form env processing-mode &aux file) + (fcomp-compile-toplevel-forms env) + (verify-arg-count form 1 1) + (setq file (nx-transform (%cadr form) env)) + (unless (constantp file) (report-bad-arg file '(or string pathname))) + (let ((actual (merge-pathnames (eval-constant file) + (directory-namestring *compiling-file*)))) + (when *compile-print* (format t "~&~vTIncluding file ~A~%" *fcomp-indentation* actual)) + (let ((*fcomp-indentation* (+ 4 *fcomp-indentation*)) + (*package* *package*)) + (fcomp-read-loop (fcomp-find-file actual) actual 0 env processing-mode) + (fcomp-output-form $fasl-src env *loading-file-source-file*)) + (when *compile-print* (format t "~&~vTFinished included file ~A~%" *fcomp-indentation* actual)))) + +(defun define-compile-time-constant (symbol initform env) + (note-variable-info symbol t env) + (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*)) + (definition-env (definition-environment env))) + (when (or compile-time-defenv definition-env) + (multiple-value-bind (value error) + (ignore-errors (values (%compile-time-eval initform env) nil)) + (when error + (warn "Compile-time evaluation of DEFCONSTANT initial value form for ~S while ~ + compiling ~S signalled the error: ~&~A" symbol *fasl-source-file* error)) + (let ((cell (cons symbol (if error (%unbound-marker-8) value)))) + (when definition-env + (push cell (defenv.constants definition-env))) + (when compile-time-defenv + (push cell (defenv.constants compile-time-defenv)))))) + symbol)) + +(defun fcomp-load-%defconstant (form env) + (destructuring-bind (sym valform &optional doc) (cdr form) + (unless *fasl-save-doc-strings* + (setq doc nil)) + (if (quoted-form-p sym) + (setq sym (%cadr sym))) + (if (and (typep sym 'symbol) (or (quoted-form-p valform) (self-evaluating-p valform))) + (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc)) + (fcomp-random-toplevel-form form env)))) + +(defun fcomp-load-%defparameter (form env) + (destructuring-bind (sym valform &optional doc) (cdr form) + (unless *fasl-save-doc-strings* + (setq doc nil)) + (if (quoted-form-p sym) + (setq sym (%cadr sym))) + (let* ((sym-p (typep sym 'symbol)) + (fn (and sym-p (fcomp-function-arg valform env)))) + (if (and sym-p (or fn (constantp valform))) + (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc)) + (fcomp-random-toplevel-form form env))))) + +; Both the simple %DEFVAR and the initial-value case (%DEFVAR-INIT) come here. +; Only try to dump this as a special fasl operator if the initform is missing +; or is "harmless" to evaluate whether needed or not (constant or function.) +; Hairier initforms could be handled by another fasl operator that takes a thunk +; and conditionally calls it. +(defun fcomp-load-defvar (form env) + (destructuring-bind (sym &optional (valform nil val-p) doc) (cdr form) + (unless *fasl-save-doc-strings* + (setq doc nil)) + (if (quoted-form-p sym) ; %defvar quotes its arg, %defvar-init doesn't. + (setq sym (%cadr sym))) + (let* ((sym-p (typep sym 'symbol))) + (if (and sym-p (not val-p)) + (fcomp-output-form $fasl-defvar env sym) + (let* ((fn (if sym-p (fcomp-function-arg valform env)))) + (if (and sym-p (or fn (constantp valform))) + (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc)) + (fcomp-random-toplevel-form form env))))))) + +(defun define-compile-time-macro (name lambda-expression env) + (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*)) + (definition-env (definition-environment env))) + (when (or definition-env compile-time-defenv) + (let ((cell (list* name + 'macro + (compile-named-function lambda-expression :name name :env env)))) + (when compile-time-defenv + (push cell (defenv.functions compile-time-defenv))) + (when definition-env + (push cell (defenv.functions definition-env)))) + (record-function-info name (%cons-def-info 'defmacro) env)) + name)) + +(defun define-compile-time-symbol-macro (name expansion env) + (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*)) + (definition-env (definition-environment env))) + (let* ((info (variable-information name env))) + (when (or (eq info :special) + (eq info :constant)) + (signal-program-error "Can't define ~s as a symbol-macro; already defined as a ~a." name (string-downcase info)))) + (when (or definition-env compile-time-defenv) + (let ((cell (cons name expansion))) + (when compile-time-defenv + (push cell (defenv.symbol-macros compile-time-defenv))) + (when definition-env + (push cell (defenv.symbol-macros definition-env))))) + name)) + + +(defun fcomp-proclaim-type (type syms env) + (if (every #'symbolp syms) + (progn + (specifier-type-if-known type env :whine t) + (dolist (sym syms) + (push (cons sym type) *nx-compile-time-types*))) + (nx-bad-decls `(,type ,@syms)))) + +(defun compile-time-proclamation (specs env &aux sym (defenv (definition-environment env))) + (when defenv + (dolist (spec specs) + (setq sym (pop spec)) + (case sym + (type + (fcomp-proclaim-type (car spec) (cdr spec) env)) + (special + (if (every #'symbolp spec) + (dolist (sym spec) + (push (cons sym nil) (defenv.specials defenv))) + (nx-bad-decls `(,sym ,@spec)))) + (notspecial + (if (every #'symbolp spec) + (let ((specials (defenv.specials defenv))) + (dolist (sym spec (setf (defenv.specials defenv) specials)) + (let ((pair (assq sym specials))) + (when pair (setq specials (nremove pair specials)))))) + (nx-bad-decls `(,sym ,@spec)))) + (optimize + (handler-case (%proclaim-optimize spec) + (program-error () (nx-bad-decls `(,sym ,@spec))))) + (inline + (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec) + (dolist (sym spec) + (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv))) + (nx-bad-decls `(,sym ,@spec)))) + (notinline + (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec) + (dolist (sym spec) + (unless (compiler-special-form-p sym) + (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv)))) + (nx-bad-decls `(,sym ,@spec)))) + (declaration + (if (every #'symbolp spec) + (dolist (sym spec) + (pushnew sym *nx-known-declarations*)) + (nx-bad-decls `(,sym ,@spec)))) + (ignore + (if (every #'symbolp spec) + (dolist (sym spec) + (push (cons sym t) *nx-proclaimed-ignore*)) + (nx-bad-decls `(,sym ,@spec)))) + (unignore + (if (every #'symbolp spec) + (dolist (sym spec) + (push (cons sym nil) *nx-proclaimed-ignore*)) + (nx-bad-decls `(,sym ,@spec)))) + (ftype + (let ((ftype (car spec)) + (fnames (cdr spec))) + (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) fnames) + (when (specifier-type-if-known ftype env :whine t) + ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done + (if (and (consp ftype) + (consp fnames) + (eq (%car ftype) 'function)) + (dolist (fname fnames) + (note-function-info fname nil env))) + (dolist (fname fnames) + (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))) + (nx-bad-decls `(ftype ,@spec))))) + (otherwise + (unless (memq sym *nx-known-declarations*) + ;; Any type name is now (ANSI CL) a valid declaration. + (if (specifier-type-if-known sym env) + (fcomp-proclaim-type sym spec env) + (nx-bad-decls `(,sym ,@spec))))))))) + +(defun fcomp-load-%defun (form env) + (destructuring-bind (fn &optional doc) (cdr form) + (unless *fasl-save-doc-strings* + (if (consp doc) + (if (and (eq (car doc) 'quote) (consp (cadr doc))) + (setf (car (cadr doc)) nil)) + (setq doc nil))) + (when (and (consp fn) (eq (%car fn) 'nfunction)) + (note-function-info (cadr fn) (caddr fn) env)) + (if (and (constantp doc) + (setq fn (fcomp-function-arg fn env))) + (progn + (setq doc (eval-constant doc)) + (fcomp-output-form $fasl-defun env fn doc)) + (fcomp-random-toplevel-form form env)))) + +(defun fcomp-load-%macro (form env &aux fn doc) + (verify-arg-count form 1 2) + (if (and (constantp (setq doc (caddr form))) + (setq fn (fcomp-function-arg (cadr form) env))) + (progn + (setq doc (eval-constant doc)) + (fcomp-output-form $fasl-macro env fn doc)) + (fcomp-random-toplevel-form form env))) + +(defun define-compile-time-structure (sd refnames predicate env) + (let ((defenv (definition-environment env))) + (when defenv + (when (and (non-nil-symbolp (sd-name sd)) + (not (sd-type sd))) + (note-type-info (sd-name sd) 'class env) + (push (make-instance 'compile-time-class :name (sd-name sd)) + (defenv.classes defenv))) + (setf (defenv.structures defenv) (alist-adjoin (sd-name sd) sd (defenv.structures defenv))) + (let* ((structrefs (defenv.structrefs defenv))) + (when (and (null (sd-type sd)) + predicate) + (setq structrefs (alist-adjoin predicate (sd-name sd) structrefs))) + (dolist (slot (sd-slots sd)) + (unless (fixnump (ssd-name slot)) + (setq structrefs + (alist-adjoin (if refnames (pop refnames) (ssd-name slot)) + (ssd-type-and-refinfo slot) + structrefs)))) + (setf (defenv.structrefs defenv) structrefs))))) + +(defun fcomp-source-note (form &aux (notes *fcomp-source-note-map*)) + (and notes (gethash form notes))) + +(defun fcomp-note-source-transformation (original new) + (let* ((*nx-source-note-map* *fcomp-source-note-map*)) + (nx-note-source-transformation original new))) + +(defun fcomp-macroexpand-1 (form env) + (handler-bind ((warning (lambda (c) + (nx1-whine :program-error c) + (muffle-warning c))) + (program-error (lambda (c) + (if *fasl-break-on-program-errors* + (cerror "continue compilation ignoring this form" c) + (progn + (when (typep c 'compile-time-program-error) + (setq c (make-condition 'simple-program-error + :format-control (simple-condition-format-control c) + :format-arguments (simple-condition-format-arguments c)))) + (nx1-whine :program-error c))) + (return-from fcomp-macroexpand-1 (values nil t))))) + (let* ((*nx-source-note-map* *fcomp-source-note-map*)) + (multiple-value-bind (new win) + (macroexpand-1 form env) + (when win + (nx-note-source-transformation form new)) + (values new win))))) + +(defun fcomp-transform (form env) + (let* ((*nx-source-note-map* *fcomp-source-note-map*)) + (nx-transform form env))) + + +(defun fcomp-random-toplevel-form (form env) + (unless (constantp form) + (unless (or (atom form) + (compiler-special-form-p (%car form))) + ;;Pre-compile any lfun args. This is an efficiency hack, since compiler + ;;reentering itself for inner lambdas tends to be more expensive than + ;;top-level compiles. + ;;This assumes the form has been macroexpanded, or at least none of the + ;;non-evaluated macro arguments could look like functions. + (let ((new-form (make-list (length form)))) + (declare (dynamic-extent new-form)) + (loop for arg in (%cdr form) for newptr on (%cdr new-form) + do (setf (%car newptr) + (multiple-value-bind (new win) (fcomp-transform arg env) + (let ((lfun (fcomp-function-arg new env))) + (when lfun + (setq new `',lfun win t) + (fcomp-note-source-transformation arg new))) + (if win new arg)))) + (unless (every #'eq (%cdr form) (%cdr new-form)) + (setf (%car new-form) (%car form)) + (fcomp-note-source-transformation form (setq form (copy-list new-form)))))) + ;; At some point we will dump the toplevel forms, make sure that when that happens, + ;;; the loading location for this form is stored in *fcomp-loading-toplevel-location*, + ;; because *loading-toplevel-location* will be long gone by then. + (fcomp-ensure-source env) + (push form *fcomp-toplevel-forms*))) + +(defun fcomp-function-arg (expr env) + (when (consp expr) + (multiple-value-bind (lambda-expr name win) + (cond ((and (eq (%car expr) 'nfunction) + (lambda-expression-p (cadr (%cdr expr)))) + (values (%caddr expr) (%cadr expr) t)) + ((and (eq (%car expr) 'function) + (lambda-expression-p (car (%cdr expr)))) + (values (%cadr expr) nil t))) + (when win + (fcomp-named-function lambda-expr name env + (or (fcomp-source-note expr) + (fcomp-source-note lambda-expr) + *loading-toplevel-location*)))))) + +(defun fcomp-compile-toplevel-forms (env) + (when *fcomp-toplevel-forms* + (let* ((forms (nreverse *fcomp-toplevel-forms*)) + (*fcomp-stream-position* *fcomp-previous-position*) + (*loading-toplevel-location* *fcomp-loading-toplevel-location*) + (lambda (if T ;; (null (cdr forms)) + `(lambda () ,@forms) + `(lambda () + (macrolet ((load-time-value (value) + (declare (ignore value)) + (compiler-function-overflow))) + ,@forms))))) + (setq *fcomp-toplevel-forms* nil) + ;(format t "~& Random toplevel form: ~s" lambda) + (handler-case (fcomp-output-form + $fasl-lfuncall + env + (fcomp-named-function lambda nil env *loading-toplevel-location*)) + (compiler-function-overflow () + (if (null (cdr forms)) + (error "Form ~s cannot be compiled - size exceeds compiler limitation" + (%car forms)) + ; else compile each half : + (progn + (dotimes (i (floor (length forms) 2)) + (declare (fixnum i)) + (push (pop forms) *fcomp-toplevel-forms*)) + (fcomp-compile-toplevel-forms env) + (setq *fcomp-toplevel-forms* (nreverse forms)) + (fcomp-compile-toplevel-forms env)))))))) + +(defun fcomp-ensure-source (env) + ;; if source location saving is off, both values are NIL, so this will do nothing, + ;; don't need to check explicitly. + (unless (eq *fcomp-loading-toplevel-location* *loading-toplevel-location*) + (setq *fcomp-loading-toplevel-location* *loading-toplevel-location*) + (fcomp-output-form $fasl-toplevel-location env *loading-toplevel-location*))) + +(defun fcomp-output-form (opcode env &rest args) + (fcomp-ensure-source env) + (when *fcomp-toplevel-forms* (fcomp-compile-toplevel-forms env)) + (push (cons opcode args) *fcomp-output-list*)) + + +;;; Compile a lambda expression for the sole purpose of putting it in a fasl +;;; file. The result will not be funcalled. This really shouldn't bother +;;; making an lfun, but it's simpler this way... +(defun fcomp-named-function (def name env &optional source-note) + (let* ((env (new-lexical-environment env)) + (*nx-break-on-program-errors* (not (memq *fasl-break-on-program-errors* '(nil :defer))))) + (multiple-value-bind (lfun warnings) + (compile-named-function def + :name name + :env env + :function-note source-note + :keep-lambda *fasl-save-definitions* + :keep-symbols *fasl-save-local-symbols* + :policy *default-file-compilation-policy* + :source-notes *fcomp-source-note-map* + :load-time-eval-token cfasl-load-time-eval-sym + :target *fasl-target*) + (fcomp-signal-or-defer-warnings warnings env) + lfun))) + + +;; Convert parent-notes to immediate indices. The reason this is necessary is to avoid hitting +;; the fasdumper's 64K limit on multiply-referenced objects. This removes the reference +;; from parent slots, making notes less likely to be multiply-referenced. +(defun fcomp-digest-code-notes (lfun &optional refs) + (unless (memq lfun refs) + (let* ((lfv (function-to-function-vector lfun)) + (start #+ppc-target 0 #+x86-target (%function-code-words lfun)) + (refs (cons lfun refs))) + (declare (dynamic-extent refs)) + (loop for i from start below (uvsize lfv) as imm = (uvref lfv i) + do (typecase imm + (code-note + (let* ((parent (code-note-parent-note imm)) + (pos (when (code-note-p parent) + (loop for j from start below i + do (when (eq parent (uvref lfv j)) (return j)))))) + (when pos + (setf (code-note-parent-note imm) pos)))) + (function + (fcomp-digest-code-notes imm refs))))))) + +; For now, defer only UNDEFINED-REFERENCEs, signal all others via WARN. +; Well, maybe not WARN, exactly. +(defun fcomp-signal-or-defer-warnings (warnings env) + (let ((init (null *fcomp-warnings-header*)) + (some *fasl-warnings-signalled-p*) + (harsh *fasl-non-style-warnings-signalled-p*)) + (dolist (w warnings) + (unless (compiler-warning-source-note w) + (setf (compiler-warning-source-note w) + (make-source-note :source nil + :filename *fasl-source-file* + :start-pos *fcomp-stream-position* + :end-pos *fcomp-stream-position*))) + (if (and (typep w 'undefined-reference) + (eq w (setq w (macro-too-late-p w env)))) + (push w *fasl-deferred-warnings*) + (progn + (multiple-value-setq (harsh some *fcomp-warnings-header*) + (signal-compiler-warning w init *fcomp-warnings-header* harsh some)) + (setq init nil)))) + (setq *fasl-warnings-signalled-p* some + *fasl-non-style-warnings-signalled-p* harsh))) + +; If W is an UNDEFINED-FUNCTION-REFERENCE which refers to a macro (either at compile-time in ENV +; or globally), cons up a MACRO-USED-BEFORE-DEFINITION warning and return it; else return W. + +(defun macro-too-late-p (w env) + (let* ((args (compiler-warning-args w)) + (name (car args))) + (if (typep w 'undefined-function-reference) + (if (or (macro-function name) + (let* ((defenv (definition-environment env)) + (info (if defenv (assq name (defenv.functions defenv))))) + (and (consp (cdr info)) + (eq 'macro (cadr info))))) + (make-instance 'macro-used-before-definition + :source-note (compiler-warning-source-note w) + :function-name (compiler-warning-function-name w) + :warning-type ':macro-used-before-definition + :args args) + w) + w))) + + + +;;;; fasl-scan - dumping reference counting +;;;; +;;;; +;These should be constants, but it's too much trouble when need to change 'em. +(defparameter FASL-FILE-ID #xFF00) ;Overall file format, shouldn't change much +(defparameter FASL-VERSION #xFF5b) ;Fasl block format. ($fasl-vers) + +(defvar *fasdump-hash*) +(defvar *fasdump-read-package*) +(defvar *fasdump-global-offsets*) +(defvar *make-load-form-hash*) + +;;;Return a hash table containing subexp's which are referenced more than once. +(defun fasl-scan (forms) + (let* ((*fasdump-hash* (make-hash-table :size (length forms) ; Crude estimate + :rehash-threshold 0.9 + :test 'eq + :shared nil)) + (*make-load-form-hash* (make-hash-table :test 'eq :shared nil)) + (*fasdump-read-package* nil) + (*fasdump-global-offsets* nil) + (gsymbols nil)) + (dolist (op forms) + (if (packagep op) ; old magic treatment of *package* + (setq *fasdump-read-package* op) + (dolist (arg (cdr op)) (fasl-scan-form arg)))) + + #-bccl (when (eq *compile-verbose* :debug) + (format t "~&~S forms, ~S entries -> " + (length forms) + (hash-table-count *fasdump-hash*))) + (maphash #'(lambda (key val) + (when (%izerop val) (remhash key *fasdump-hash*))) + *fasdump-hash*) + #-bccl (when (eq *compile-verbose* :debug) + (format t "~S." (hash-table-count *fasdump-hash*))) + (values *fasdump-hash* + gsymbols + *fasdump-global-offsets*))) + +;;; During scanning, *fasdump-hash* values are one of the following: +;;; nil - form hasn't been referenced yet. +;;; 0 - form has been referenced exactly once +;;; T - form has been referenced more than once +;;; (load-form scanning-p referenced-p initform) +;;; form should be replaced by load-form +;;; scanning-p is true while we're scanning load-form +;;; referenced-p is nil if unreferenced, +;;; T if referenced but not dumped yet, +;;; 0 if dumped already (fasl-dump-form uses this) +;;; initform is a compiled version of the user's initform +(defun fasl-scan-form (form) + (when form + (let ((info (gethash form *fasdump-hash*))) + (cond ((null info) + (fasl-scan-dispatch form)) + ((eql info 0) + (puthash form *fasdump-hash* t)) + ((listp info) ; a make-load-form form + (when (cadr info) + (error "Circularity in ~S for ~S" 'make-load-form form)) + (let ((referenced-cell (cddr info))) + (setf (car referenced-cell) t) ; referenced-p + (setf (gethash (car info) *fasdump-hash*) t))))))) + + + + +(defun fasl-scan-dispatch (exp) + (when exp + (let ((type-code (typecode exp))) + (declare (fixnum type-code)) + (case type-code + (#.target::tag-fixnum + (fasl-scan-fixnum exp)) + (#.target::fulltag-cons (fasl-scan-list exp)) + #+ppc32-target + (#.ppc32::tag-imm) + #+ppc64-target + ((#.ppc64::fulltag-imm-0 + #.ppc64::fulltag-imm-1 + #.ppc64::fulltag-imm-2 + #.ppc64::fulltag-imm-3)) + #+x8632-target + (#.x8632::tag-imm) + #+x8664-target + ((#.x8664::fulltag-imm-0 + #.x8664::fulltag-imm-1)) + (t + (if + #+ppc32-target + (= (the fixnum (logand type-code ppc32::full-tag-mask)) ppc32::fulltag-immheader) + #+ppc64-target + (= (the fixnum (logand type-code ppc64::lowtagmask)) ppc64::lowtag-immheader) + #+x8632-target + (= (the fixnum (logand type-code x8632::fulltagmask)) x8632::fulltag-immheader) + #+x8664-target + (and (= (the fixnum (lisptag exp)) x8664::tag-misc) + (logbitp (the (unsigned-byte 16) (logand type-code x8664::fulltagmask)) + (logior (ash 1 x8664::fulltag-immheader-0) + (ash 1 x8664::fulltag-immheader-1) + (ash 1 x8664::fulltag-immheader-2)))) + (case type-code + (#.target::subtag-dead-macptr (fasl-unknown exp)) + (#.target::subtag-macptr + ;; Treat untyped pointers to the high/low 64K of the address + ;; space as constants. Refuse to dump other pointers. + (unless (and (zerop (%macptr-type exp)) + (<= (%macptr-domain exp) 1)) + (error "Can't dump typed pointer ~s" exp)) + (let* ((addr (%ptr-to-int exp))) + (unless (or (< addr #x10000) + (>= addr (- (ash 1 target::nbits-in-word) + #x10000))) + (error "Can't dump pointer ~s : address is not in the low or high 64K of the address space." exp)))) + (t (fasl-scan-ref exp))) + (case type-code + ((#.target::subtag-pool #.target::subtag-weak #.target::subtag-lock) (fasl-unknown exp)) + (#+ppc-target #.target::subtag-symbol + #+x8632-target #.target::subtag-symbol + #+x8664-target #.target::tag-symbol (fasl-scan-symbol exp)) + ((#.target::subtag-instance #.target::subtag-struct) + (fasl-scan-user-form exp)) + (#.target::subtag-package (fasl-scan-ref exp)) + (#.target::subtag-istruct + (if (memq (istruct-type-name exp) *istruct-make-load-form-types*) + (progn + (if (hash-table-p exp) + (fasl-lock-hash-table exp)) + (fasl-scan-user-form exp)) + (fasl-scan-gvector exp))) + #+x8632-target + (#.target::subtag-function (fasl-scan-clfun exp)) + #+x8664-target + (#.target::tag-function (fasl-scan-clfun exp)) + (t (fasl-scan-gvector exp))))))))) + + +(defun fasl-scan-ref (form) + (puthash form *fasdump-hash* 0)) + +(defun fasl-scan-fixnum (fixnum) + (unless (short-fixnum-p fixnum) (fasl-scan-ref fixnum))) + +(defparameter *istruct-make-load-form-types* + '(lexical-environment shared-library-descriptor shared-library-entry-point + external-entry-point foreign-variable + ctype unknown-ctype class-ctype foreign-ctype union-ctype member-ctype + array-ctype numeric-ctype hairy-ctype named-ctype constant-ctype args-ctype + hash-table package-ref type-cell class-cell slot-id)) + + + + +(defun fasl-scan-gvector (vec) + (fasl-scan-ref vec) + (dotimes (i (uvsize vec)) + (declare (fixnum i)) + (fasl-scan-form (%svref vec i)))) + +#+x86-target +(defun fasl-scan-clfun (f) + (let* ((fv (function-to-function-vector f)) + (size (uvsize fv)) + (ncode-words (%function-code-words f))) + (fasl-scan-ref f) + (do* ((k ncode-words (1+ k))) + ((= k size)) + (fasl-scan-form (uvref fv k))))) + +(defun funcall-lfun-p (form) + (and (listp form) + (eq (%car form) 'funcall) + (listp (%cdr form)) + (or (functionp (%cadr form)) + (eql (typecode (%cadr form)) target::subtag-xfunction)) + (null (%cddr form)))) + +;;; We currently represent istruct-cells as conses. That's not +;;; incredibly efficient (among other things, we have to do this +;;; check when scanning/dumping any list), but it's probably not +;;; worth burning a tag on them. There are currently about 50 +;;; entries on the *istruct-cells* list. +(defun istruct-cell-p (x) + (and (consp x) + (typep (%car x) 'symbol) + (atom (%cdr x)) + (not (null (memq x *istruct-cells*))))) + +(defun fasl-scan-list (list) + (cond ((eq (%car list) cfasl-load-time-eval-sym) + (let ((form (car (%cdr list)))) + (fasl-scan-form (if (funcall-lfun-p form) + (%cadr form) + form)))) + ((istruct-cell-p list) + (fasl-scan-form (%car list))) + (t (when list + (fasl-scan-ref list) + (fasl-scan-form (%car list)) + (fasl-scan-form (%cdr list)))))) + +(defun fasl-scan-user-form (form) + (when (or (source-note-p form) + (code-note-p form)) + (return-from fasl-scan-user-form (fasl-scan-gvector form))) + (multiple-value-bind (load-form init-form) (make-load-form form *fcomp-load-forms-environment*) + (labels ((simple-load-form (form) + (or (atom form) + (let ((function (car form))) + (or (eq function 'quote) + (and (symbolp function) + ;; using fboundp instead of symbol-function + ;; see comments in symbol-function + (or (functionp (fboundp function)) + (eq function 'progn)) + ;; (every #'simple-load-form (cdr form)) + (dolist (arg (cdr form) t) + (unless (simple-load-form arg) + (return nil)))))))) + (load-time-eval-form (load-form form type) + (cond ((quoted-form-p load-form) + (%cadr load-form)) + ((self-evaluating-p load-form) + load-form) + ((simple-load-form load-form) + `(,cfasl-load-time-eval-sym ,load-form)) + (t (multiple-value-bind (lfun warnings) + (or + (gethash load-form *make-load-form-hash*) + (fcomp-named-function `(lambda () ,load-form) nil nil)) + (when warnings + (cerror "Ignore the warnings" + "Compiling the ~s ~a form for~%~s~%produced warnings." + 'make-load-form type form)) + (setf (gethash load-form *make-load-form-hash*) lfun) + `(,cfasl-load-time-eval-sym (funcall ,lfun))))))) + (declare (dynamic-extent #'simple-load-form #'load-time-eval-form)) + (let* ((compiled-initform + (and init-form (load-time-eval-form init-form form "initialization"))) + (info (list (load-time-eval-form load-form form "creation") + T ; scanning-p + nil ; referenced-p + compiled-initform ;initform-info + ))) + (puthash form *fasdump-hash* info) + (fasl-scan-form (%car info)) + (setf (cadr info) nil) ; no longer scanning load-form + (when init-form + (fasl-scan-form compiled-initform)))))) + +(defun fasl-scan-symbol (form) + (fasl-scan-ref form) + (fasl-scan-form (symbol-package form))) + + + +;;;; Pass 3 - dumping +;;;; +;;;; +(defvar *fasdump-epush*) +(defvar *fasdump-stream*) +(defvar *fasdump-eref*) + +(defun fasl-dump-file (gnames goffsets forms hash filename) + (let ((opened? nil) + (finished? nil)) + (unwind-protect + (with-open-file (*fasdump-stream* filename :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede + :if-does-not-exist :create) + (setq opened? t) + (fasl-set-filepos 0) + (fasl-out-word 0) ;Will become the ID word + (fasl-out-word 1) ;One block in the file + (fasl-out-long 12) ;Block starts at file pos 12 + (fasl-out-long 0) ;Length will go here + (fasl-dump-block gnames goffsets forms hash) ;Write the block + (let ((pos (fasl-filepos))) + (fasl-set-filepos 8) ;Back to length longword + (fasl-out-long (- pos 12))) ;Write length + (fasl-set-filepos 0) ;Seem to have won, make us legal + (fasl-out-word FASL-FILE-ID) + (setq finished? t) + filename) + (when (and opened? (not finished?)) + (delete-file filename))))) + +(defun fasl-dump-block (gnames goffsets forms hash) + (let ((etab-size (hash-table-count hash))) + (when (> etab-size 65535) + (error "Too many multiply-referenced objects in fasl file.~%Limit is ~d. Were ~d." 65535 etab-size)) + (fasl-out-word FASL-VERSION) ; Word 0 + (fasl-out-long 0) + (fasl-out-byte $fasl-vetab-alloc) + (fasl-out-count etab-size) + (fasl-dump gnames goffsets forms hash) + (fasl-out-byte $fasl-end))) + +(defun fasl-dump (gnames goffsets forms hash) + (let* ((*fasdump-hash* hash) + (*fasdump-read-package* nil) + (*fasdump-epush* nil) + (*fasdump-eref* -1) + (*fasdump-global-offsets* goffsets)) + (when gnames + (fasl-out-byte $fasl-globals) + (fasl-dump-form gnames)) + (dolist (op forms) + (if (packagep op) + (setq *fasdump-read-package* op) + (progn + (fasl-out-byte (car op)) + (dolist (arg (cdr op)) (fasl-dump-form arg))))))) + +;;;During dumping, *fasdump-hash* values are one of the following: +;;; nil - form has no load form, is referenced at most once. +;;; fixnum - form has already been dumped, fixnum is the etab index. +;;; T - form hasn't been dumped yet, is referenced more than once. +;;; (load-form . nil) - form should be replaced by load-form. +(defun fasl-dump-form (form) + (let ((info (gethash form *fasdump-hash*))) + (cond ((fixnump info) + (fasl-out-byte $fasl-veref) + (fasl-out-count info)) + ((consp info) + (fasl-dump-user-form form info)) + (t + (setq *fasdump-epush* info) + (fasl-dump-dispatch form))))) + +(defun fasl-dump-user-form (form info) + (let* ((load-form (car info)) + (referenced-p (caddr info)) + (initform (cadddr info))) + (when referenced-p + (unless (gethash load-form *fasdump-hash*) + (error "~s was not in ~s. This shouldn't happen." 'load-form '*fasdump-hash*))) + (when initform + (fasl-out-byte $fasl-prog1)) ; ignore the initform + (fasl-dump-form load-form) + (when referenced-p + (setf (gethash form *fasdump-hash*) (gethash load-form *fasdump-hash*))) + (when initform + (fasl-dump-form initform)))) + +(defun fasl-out-opcode (opcode form) + (if *fasdump-epush* + (progn + (setq *fasdump-epush* nil) + (fasl-out-byte (fasl-epush-op opcode)) + (fasl-dump-epush form)) + (fasl-out-byte opcode))) + +(defun fasl-dump-epush (form) + #-bccl (when (fixnump (gethash form *fasdump-hash*)) + (error "Bug! Duplicate epush for ~S" form)) + (puthash form *fasdump-hash* (setq *fasdump-eref* (1+ *fasdump-eref*)))) + + +(defun fasl-dump-dispatch (exp) + (etypecase exp + ((signed-byte 16) (fasl-dump-s16 exp)) + ((signed-byte 32) (fasl-dump-s32 exp)) + ((signed-byte 64) (fasl-dump-s64 exp)) + (bignum (fasl-dump-32-bit-ivector exp $fasl-bignum32)) + (character (fasl-dump-char exp)) + (list (fasl-dump-list exp)) + (immediate (fasl-dump-t_imm exp)) + (double-float (fasl-dump-dfloat exp)) + (single-float (fasl-dump-sfloat exp)) + (simple-string (let* ((n (length exp))) + (fasl-out-opcode $fasl-nvstr exp) + (fasl-out-count n) + (fasl-out-simple-string exp 0 n))) + (simple-bit-vector (fasl-dump-bit-vector exp)) + ((simple-array (unsigned-byte 8) (*)) + (fasl-dump-8-bit-ivector exp $fasl-u8-vector)) + ((simple-array (signed-byte 8) (*)) + (fasl-dump-8-bit-ivector exp $fasl-s8-vector)) + ((simple-array (unsigned-byte 16) (*)) + (fasl-dump-16-bit-ivector exp $fasl-u16-vector)) + ((simple-array (signed-byte 16) (*)) + (fasl-dump-16-bit-ivector exp $fasl-s16-vector)) + ((simple-array (unsigned-byte 32) (*)) + (fasl-dump-32-bit-ivector exp $fasl-u32-vector)) + ((simple-array (signed-byte 32) (*)) + (fasl-dump-32-bit-ivector exp $fasl-s32-vector)) + ((simple-array single-float (*)) + (fasl-dump-32-bit-ivector exp $fasl-single-float-vector)) + ((simple-array double-float (*)) + (fasl-dump-double-float-vector exp)) + (symbol (fasl-dump-symbol exp)) + (package (fasl-dump-package exp)) + (function (fasl-dump-function exp)) + (xfunction (fasl-dump-function exp)) + (code-vector (fasl-dump-codevector exp)) + (xcode-vector (fasl-dump-codevector exp)) + (simple-vector (fasl-dump-gvector exp $fasl-t-vector)) + (ratio (fasl-dump-ratio exp)) + (complex (fasl-dump-complex exp)) + #+(and 64-bit-target (not cross-compiling)) + ((simple-array (unsigned-byte 64) (*)) + (fasl-dump-64-bit-ivector exp $fasl-u64-vector)) + #+(and 64-bit-target (not cross-compiling)) + ((simple-array (signed-byte 64) (*)) + (fasl-dump-64-bit-ivector exp $fasl-s64-vector)) + (ivector + (unless (eq (backend-target-arch-name *target-backend*) + (backend-target-arch-name *host-backend*)) + (error "can't cross-compile constant reference to ~s" exp)) + (let* ((typecode (typecode exp)) + (n (uvsize exp)) + (nb (subtag-bytes typecode n))) + (declare (fixnum n nb typecode)) + (fasl-out-opcode $fasl-vivec exp) + (fasl-out-byte typecode) + (fasl-out-count n) + (fasl-out-ivect exp 0 nb))) + (vector (fasl-dump-gvector exp $fasl-vector-header)) + (array (fasl-dump-gvector exp $fasl-array-header)) + + (gvector + (if (= (typecode exp) target::subtag-istruct) + (fasl-dump-gvector exp $fasl-istruct) + (progn + (unless (eq (backend-target-arch-name *target-backend*) + (backend-target-arch-name *host-backend*)) + (error "can't cross-compile constant reference to ~s" exp)) + (let* ((typecode (typecode exp)) + (n (uvsize exp))) + (declare (fixnum n typecode)) + (fasl-out-opcode $fasl-vgvec exp) + (fasl-out-byte typecode) + (fasl-out-count n) + (dotimes (i n) + (fasl-dump-form (%svref exp i))))))))) + +(defun fasl-dump-gvector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (dotimes (i n) + (fasl-dump-form (%svref v i))))) + +(defun fasl-dump-ratio (v) + (fasl-out-opcode $fasl-ratio v) + (fasl-dump-form (%svref v target::ratio.numer-cell)) + (fasl-dump-form (%svref v target::ratio.denom-cell))) + +(defun fasl-dump-complex (v) + (fasl-out-opcode $fasl-complex v) + (fasl-dump-form (%svref v target::complex.realpart-cell)) + (fasl-dump-form (%svref v target::complex.imagpart-cell))) + +(defun fasl-dump-bit-vector (v) + (let* ((n (uvsize v))) + (fasl-out-opcode $fasl-bit-vector v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash (+ n 7) -3))) + (fasl-out-ivect v 0 nb)) + (compiler-bug "need to byte-swap ~a" v)))) + +(defun fasl-dump-8-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (let* ((nb n)) + (fasl-out-ivect v 0 nb)))) + +(defun fasl-dump-16-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 1))) + (fasl-out-ivect v 0 nb)) + (dotimes (i n) + (let* ((k (uvref v i))) + (fasl-out-byte (ldb (byte 8 0) k)) + (fasl-out-byte (ldb (byte 8 8) k))))))) + +(defun fasl-dump-32-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 2))) + (fasl-out-ivect v 0 nb)) + (dotimes (i n) + (let* ((k (uvref v i))) + (fasl-out-byte (ldb (byte 8 0) k)) + (fasl-out-byte (ldb (byte 8 8) k)) + (fasl-out-byte (ldb (byte 8 16) k)) + (fasl-out-byte (ldb (byte 8 24) k))))))) + + +(defun fasl-dump-64-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 3))) + (fasl-out-ivect v 0 nb)) + (compiler-bug "need to byte-swap ~a" v)))) + +(defun fasl-dump-double-float-vector (v) + (let* ((n (uvsize v))) + (fasl-out-opcode $fasl-double-float-vector v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 3))) + (fasl-out-ivect v (- target::misc-dfloat-offset + target::misc-data-offset) nb)) + (compiler-bug "need to byte-swap ~a" v)))) + +;;; This is used to dump functions and "xfunctions". +;;; If we're cross-compiling, we shouldn't reference any +;;; (host) functions as constants; try to detect that +;;; case. +#-x86-target +(defun fasl-dump-function (f) + (if (and (not (eq *fasl-backend* *host-backend*)) + (typep f 'function)) + (compiler-bug "Dumping a native function constant ~s during cross-compilation." f)) + (if (and (= (typecode f) target::subtag-xfunction) + (= (typecode (uvref f 0)) target::subtag-u8-vector)) + (fasl-xdump-clfun f) + (let* ((n (uvsize f))) + (fasl-out-opcode $fasl-function f) + (fasl-out-count n) + (dotimes (i n) + (fasl-dump-form (%svref f i)))))) + +#+x86-target +(defun fasl-dump-function (f) + (if (and (not (eq *fasl-backend* *host-backend*)) + (typep f 'function)) + (compiler-bug "Dumping a native function constant ~s during cross-compilation." f)) + (if (and (= (typecode f) target::subtag-xfunction) + (= (typecode (uvref f 0)) target::subtag-u8-vector)) + (fasl-xdump-clfun f) + (let* ((code-size (%function-code-words f)) + (function-vector (function-to-function-vector f)) + (function-size (uvsize function-vector))) + (fasl-out-opcode $fasl-clfun f) + (fasl-out-count function-size) + (fasl-out-count code-size) + (fasl-out-ivect function-vector 0 (ash code-size target::word-shift)) + (do* ((k code-size (1+ k))) + ((= k function-size)) + (declare (fixnum k)) + (fasl-dump-form (uvref function-vector k)))))) + + + + +;;; Write a "concatenated function". +(defun fasl-xdump-clfun (f) + (target-arch-case + (:x8632 + (let* ((code (uvref f 0)) + (function-size (ash (uvsize code) -2)) + (imm-words (dpb (uvref code 1) (byte 8 8) (uvref code 0))) + (imm-bytes (ash imm-words 2)) + (other-words (- function-size imm-words))) + (assert (= other-words (1- (uvsize f)))) + (fasl-out-opcode $fasl-clfun f) + (fasl-out-count function-size) + (fasl-out-count imm-words) + (fasl-out-ivect code 0 imm-bytes) + (do ((i 1 (1+ i)) + (n (uvsize f))) + ((= i n)) + (declare (fixnum i n)) + (fasl-dump-form (%svref f i))))) + (:x8664 + (let* ((code (uvref f 0)) + (code-size (dpb (uvref code 3) + (byte 8 24) + (dpb (uvref code 2) + (byte 8 16) + (dpb (uvref code 1) + (byte 8 8) + (uvref code 0))))) + (function-size (ash (uvsize code) -3))) + (assert (= (- function-size code-size) (1- (uvsize f)))) + (fasl-out-opcode $fasl-clfun f) + (fasl-out-count function-size) + (fasl-out-count code-size) + (fasl-out-ivect code 0 (ash code-size 3)) + (do* ((i 1 (1+ i)) + (n (uvsize f))) + ((= i n)) + (declare (fixnum i n)) + (fasl-dump-form (%svref f i))))))) + +(defun fasl-dump-codevector (c) + (if (and (not (eq *fasl-backend* *host-backend*)) + (typep c 'code-vector)) + (compiler-bug "Dumping a native code-vector constant ~s during cross-compilation." c)) + (let* ((n (uvsize c))) + (fasl-out-opcode $fasl-code-vector c) + (fasl-out-count n) + (fasl-out-ivect c))) + +(defun fasl-dump-t_imm (imm) + (fasl-out-opcode $fasl-timm imm) + (fasl-out-long (%address-of imm))) + +(defun fasl-dump-char (char) ; << maybe not + (let ((code (%char-code char))) + (fasl-out-opcode $fasl-char char) + (fasl-out-count code))) + +;;; Always write big-endian. +(defun fasl-dump-s16 (s16) + (fasl-out-opcode $fasl-word-fixnum s16) + (fasl-out-word s16)) + +;;; Always write big-endian +(defun fasl-dump-s32 (s32) + (fasl-out-opcode $fasl-s32 s32) + (fasl-out-word (ldb (byte 16 16) s32)) + (fasl-out-word (ldb (byte 16 0) s32))) + +;;; Always write big-endian +(defun fasl-dump-s64 (s64) + (fasl-out-opcode $fasl-s64 s64) + (fasl-out-word (ldb (byte 16 48) s64)) + (fasl-out-word (ldb (byte 16 32) s64)) + (fasl-out-word (ldb (byte 16 16) s64)) + (fasl-out-word (ldb (byte 16 0) s64))) + + + +(defun fasl-dump-dfloat (float) + (fasl-out-opcode $fasl-dfloat float) + (multiple-value-bind (high low) (double-float-bits float) + (fasl-out-long high) + (fasl-out-long low))) + +(defun fasl-dump-sfloat (float) + (fasl-out-opcode $fasl-sfloat float) + (fasl-out-long (single-float-bits float))) + + +(defun fasl-dump-package (pkg) + (let ((name (package-name pkg))) + (fasl-out-opcode $fasl-nvpkg pkg) + (fasl-out-nvstring name))) + + + +(defun fasl-dump-list (list) + (cond ((null list) (fasl-out-opcode $fasl-nil list)) + ((eq (%car list) cfasl-load-time-eval-sym) + (let* ((form (car (%cdr list))) + (opcode $fasl-eval)) + (when (funcall-lfun-p form) + (setq opcode $fasl-lfuncall + form (%cadr form))) + (if *fasdump-epush* + (progn + (fasl-out-byte (fasl-epush-op opcode)) + (fasl-dump-form form) + (fasl-dump-epush list)) + (progn + (fasl-out-byte opcode) + (fasl-dump-form form))))) + ((istruct-cell-p list) + (fasl-out-opcode $fasl-istruct-cell (car list)) + (fasl-dump-symbol (car list))) + (t (fasl-dump-cons list)))) + +(defun fasl-dump-cons (cons &aux (end cons) (cdr-len 0)) + (declare (fixnum cdr-len)) + (while (and (consp (setq end (%cdr end))) + (null (gethash end *fasdump-hash*))) + (incf cdr-len)) + (if (eql 0 cdr-len) + (fasl-out-opcode $fasl-cons cons) + (progn + (fasl-out-opcode (if end $fasl-vlist* $fasl-vlist) cons) + (fasl-out-count cdr-len))) + (dotimes (i (the fixnum (1+ cdr-len))) + (fasl-dump-form (%car cons)) + (setq cons (%cdr cons))) + (when (or (eql 0 cdr-len) end) ;cons or list* + (fasl-dump-form end))) + + + +(defun fasl-dump-symbol (sym) + (let* ((pkg (symbol-package sym)) + (name (symbol-name sym)) + (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell))) + (declare (fixnum i)) + (unless (zerop i) i)))) + (cond ((null pkg) + (progn + (fasl-out-opcode (if idx $fasl-nvmksym-special $fasl-nvmksym) sym) + (fasl-out-nvstring name))) + (*fasdump-epush* + (progn + (fasl-out-byte (fasl-epush-op (if idx + $fasl-nvpkg-intern-special + $fasl-nvpkg-intern))) + (fasl-dump-form pkg) + (fasl-dump-epush sym) + (fasl-out-nvstring name))) + (t + (progn + (fasl-out-byte (if idx + $fasl-nvpkg-intern-special + $fasl-nvpkg-intern)) + (fasl-dump-form pkg) + (fasl-out-nvstring name)))))) + + +(defun fasl-unknown (exp) + (error "Can't dump ~S - unknown type" exp)) + +(defun fasl-out-simple-string (str start end) + (declare (simple-string str) (fixnum start end)) + (do* ((k start (1+ k))) + ((= k end)) + (declare (fixnum k)) + (fasl-out-count (char-code (schar str k))))) + +(defun fasl-out-nvstring (str) + (fasl-out-count (length str)) + (fasl-out-simple-string str 0 (length str))) + +(defun fasl-out-ivect (iv &optional + (start 0) + (nb + (subtag-bytes (typecode iv) (uvsize iv)))) + (stream-write-ivector *fasdump-stream* iv start nb)) + + +(defun fasl-out-long (long) + (fasl-out-word (ash long -16)) + (fasl-out-word (logand long #xFFFF))) + +(defun fasl-out-word (word) + (fasl-out-byte (ash word -8)) + (fasl-out-byte word)) + +(defun fasl-out-byte (byte) + (write-byte (%ilogand2 byte #xFF) *fasdump-stream*)) + +;;; Write an unsigned integer in 7-bit chunks. +(defun fasl-out-count (val) + (do* ((b (ldb (byte 7 0) val) (ldb (byte 7 0) val)) + (done nil)) + (done) + (when (zerop (setq val (ash val -7))) + (setq b (logior #x80 b) done t)) + (fasl-out-byte b))) + +(defun fasl-filepos () + (file-position *fasdump-stream*)) + +(defun fasl-set-filepos (pos) + (file-position *fasdump-stream* pos) + #-bccl (unless (eq (file-position *fasdump-stream*) pos) + (error "Unable to set file position to ~S" pos))) + +;;; Concatenate fasl files. + +;;; Format of a fasl file as expected by the fasloader. +;;; +;;; #xFF00 2 bytes - File version +;;; Block Count 2 bytes - Number of blocks in the file +;;; addr[0] 4 bytes - address of 0th block +;;; length[0] 4 bytes - length of 0th block +;;; addr[1] 4 bytes - address of 1st block +;;; length[1] 4 bytes - length of 1st block +;;; ... +;;; addr[n-1] 4 bytes +;;; length[n-1] 4 bytes +;;; length[0] + length[1] + ... + length [n-1] bytes of data + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; (fasl-concatenate out-file fasl-files &key :if-exists) +;; +;; out-file name of file in which to store the concatenation +;; fasl-files list of names of fasl files to concatenate +;; if-exists as for OPEN, defaults to :error +;; +;; function result: pathname to the output file. +;; It works to use the output of one invocation of fasl-concatenate +;; as an input of another invocation. +;; +(defun fasl-concatenate (out-file fasl-files &key (if-exists :error)) + (%fasl-concatenate out-file fasl-files if-exists (pathname-type *.fasl-pathname*))) + +(defun %fasl-concatenate (out-file fasl-files if-exists file-ext) + (let ((count 0) + (created? nil) + (finished? nil) + (ext-pathname (make-pathname :type file-ext))) + (declare (fixnum count)) + (flet ((fasl-read-halfword (f) + (dpb (read-byte f) (byte 8 8) (read-byte f))) + (fasl-write-halfword (h f) + (write-byte (ldb (byte 8 8) h) f) + (write-byte (ldb (byte 8 0) h) f) + h)) + (flet ((fasl-read-fullword (f) + (dpb (fasl-read-halfword f) (byte 16 16) (fasl-read-halfword f))) + (fasl-write-fullword (w f) + (fasl-write-halfword (ldb (byte 16 16) w) f) + (fasl-write-halfword (ldb (byte 16 0) w) f) + w)) + (dolist (file fasl-files) + (setq file (merge-pathnames file ext-pathname)) + (unless (equal (pathname-type file) file-ext) + (error "Not a ~A file: ~s" file-ext file)) + (with-open-file (instream file :element-type '(unsigned-byte 8)) + (unless (eql fasl-file-id (fasl-read-halfword instream)) + (error "Bad ~A file ID in ~s" file-ext file)) + (incf count (fasl-read-halfword instream)))) + (unwind-protect + (with-open-file (outstream + (setq out-file (merge-pathnames out-file ext-pathname)) + :element-type '(unsigned-byte 8) + :direction :output + :if-does-not-exist :create + :if-exists if-exists) + (setq created? t) + (let ((addr-address 4) + (data-address (+ 4 (* count 8)))) + (fasl-write-halfword 0 outstream) ; will be $fasl-id + (fasl-write-halfword count outstream) + (dotimes (i (* 2 count)) + (fasl-write-fullword 0 outstream)) ; for addresses/lengths + (dolist (file fasl-files) + (with-open-file (instream (merge-pathnames file ext-pathname) + :element-type '(unsigned-byte 8)) + (fasl-read-halfword instream) ; skip ID + (let* ((fasl-count (fasl-read-halfword instream)) + (addrs (make-array fasl-count)) + (sizes (make-array fasl-count)) + addr0) + (declare (fixnum fasl-count) + (dynamic-extent addrs sizes)) + (dotimes (i fasl-count) + (setf (svref addrs i) (fasl-read-fullword instream) + (svref sizes i) (fasl-read-fullword instream))) + (setq addr0 (svref addrs 0)) + (file-position outstream addr-address) + (dotimes (i fasl-count) + (fasl-write-fullword + (+ data-address (- (svref addrs i) addr0)) + outstream) + (fasl-write-fullword (svref sizes i) outstream) + (incf addr-address 8)) + (file-position outstream data-address) + (dotimes (i fasl-count) + (file-position instream (svref addrs i)) + (let ((fasl-length (svref sizes i))) + (dotimes (j fasl-length) + (write-byte (read-byte instream) outstream)) + (incf data-address fasl-length)))))) + (stream-length outstream data-address) + (file-position outstream 0) + (fasl-write-halfword fasl-file-id outstream) + (setq finished? t))) + (when (and created? (not finished?)) + (delete-file out-file)))) + out-file))) + +;;; Cross-compilation environment stuff. Some of this involves +;;; setting up the TARGET and OS packages. +(defun ensure-package-nickname (name package) + (let* ((old (find-package name))) + (unless (eq old package) + (rename-package old (package-name old) (delete name (package-nicknames old) :test #'string=)) + (rename-package package (package-name package) (cons name (package-nicknames package))) + old))) + +(defmacro with-cross-compilation-package ((name target) &body body) + (let* ((old-package (gensym)) + (name-var (gensym)) + (target-var (gensym))) + `(let* ((,name-var ,name) + (,target-var ,target) + (,old-package (ensure-package-nickname ,name-var ,target-var))) + (unwind-protect + (progn ,@body) + (when ,old-package (ensure-package-nickname ,name-var + ,old-package)))))) + +(defun %with-cross-compilation-target (target thunk) + (let* ((backend (find-backend target))) + (if (null backend) + (error "No known compilation target named ~s." target) + (let* ((arch (backend-target-arch backend)) + (arch-package-name (arch::target-package-name arch)) + (ftd (backend-target-foreign-type-data backend)) + (ftd-package-name (ftd-interface-package-name ftd))) + (or (find-package arch-package-name) + (make-package arch-package-name)) + (or (find-package ftd-package-name) + (make-package ftd-package-name :use "COMMON-LISP")) + (with-cross-compilation-package ("OS" ftd-package-name) + (with-cross-compilation-package ("TARGET" arch-package-name) + (let* ((*target-ftd* ftd)) + (funcall thunk)))))))) + +(defmacro with-cross-compilation-target ((target) &body body) + `(%with-cross-compilation-target ,target #'(lambda () ,@body))) + + + + +(provide 'nfcomp) + Index: /branches/qres/ccl/lib/number-case-macro.lisp =================================================================== --- /branches/qres/ccl/lib/number-case-macro.lisp (revision 13564) +++ /branches/qres/ccl/lib/number-case-macro.lisp (revision 13564) @@ -0,0 +1,109 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;;;;;;;; +;; support fns and vars for number-case + +(defun type-name-to-code (name) + (funcall (arch::target-numeric-type-name-to-typecode-function + (backend-target-arch *target-backend*)) + name)) + +(defvar nd-onions `((integer fixnum bignum) (rational fixnum bignum ratio) + (float double-float short-float) + (real fixnum bignum ratio double-float short-float) + (number fixnum bignum ratio double-float short-float complex))) + +(defun nd-diff (x y) ; things in x that are not in y + (let ((res)) + (dolist (e x) + (when (not (memq e y))(push e res))) + res)) + +(defun nd-type-compose (selectors) + ;; this could do better but probably not worth the trouble - only + ;; for require-type error + (or (dolist (union nd-onions) + (if (when (eq (length selectors)(length (cdr union))) + (dolist (e selectors t)(if (not (memq e (cdr union)))(return)))) + (return (car union)))) + (cons 'or selectors))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Simpler number dispatch. Syntax is just like case. +;; +;; (number-case x => (case (typecode x) +;; (fixnum (print 4)) (target::tag-fixnum (print 4)) ; actually tag value +;; ((bignum ratio)(print 5))) ((target::tag-bignum target::tag-ratio)(print 5)) +;; (t (require-type x 'rational)))) +;; + +(defmacro number-case (var &rest cases) + (let ((selectors-so-far) + (t-case nil) + (tag (gensym)) + (block (gensym))) + (flet ((maybe-compound (selector) + (let ((compound (cdr (assq selector nd-onions)))) + (when compound + (setq compound (nd-diff compound selectors-so-far)) + (when (not compound)(error "Unreachable case ~s" selector)) + (setq selectors-so-far + (append compound selectors-so-far)) + compound)))) + (declare (dynamic-extent #'maybe-compound)) + `(block ,block + (tagbody + ,tag + (return-from ,block + (case (typecode ,var) + ,@(mapcar + #'(lambda (case) + (let ((selector (car case))) + (if (atom selector) + (cond ((eq selector t)(setq t-case t)) + ((memq selector selectors-so-far)(error "Unreachable case ~s" selector)) + ((let ((compound (maybe-compound selector))) + (when compound + (setq selector compound)))) + (t (push selector selectors-so-far))) + (progn + (setq selector + (mapcan #'(lambda (item) + (cond ((memq item selectors-so-far)) + ((let ((compound (maybe-compound item))) + (when compound + (setq item compound)))) + (t (push item selectors-so-far))) + (if (listp item) item (list item))) + selector)))) + (setq selector (if (listp selector) + (mapcar #'type-name-to-code selector) + (if (eq selector t) t + (type-name-to-code selector)))) + `(,selector ,@(cdr case)))) + cases) + ,@(if (not t-case) + `((t (setq ,var (%kernel-restart $xwrongtype ,var ',(nd-type-compose selectors-so-far))) + (go ,tag))))))))))) + +(provide "NUMBER-CASE-MACRO") Index: /branches/qres/ccl/lib/number-macros.lisp =================================================================== --- /branches/qres/ccl/lib/number-macros.lisp (revision 13564) +++ /branches/qres/ccl/lib/number-macros.lisp (revision 13564) @@ -0,0 +1,141 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "LISPEQU") + ) + +(declare-arch-specific-macro %make-sfloat) + +(declare-arch-specific-macro %make-dfloat) + +(defmacro require-null-or-double-float-sym (sym) + (setq sym (require-type sym 'symbol)) + `(when (and ,sym (not (double-float-p ,sym))) + (setq ,sym (require-type ,sym 'double-float)))) + + +(declare-arch-specific-macro %numerator) + +(declare-arch-specific-macro %denominator) + +(declare-arch-specific-macro %realpart) + +(declare-arch-specific-macro %imagpart) + + +(defmacro with-stack-double-floats (specs &body body) + (collect ((binds) + (inits) + (names)) + (dolist (spec specs) + (let ((name (first spec))) + (binds `(,name (%make-dfloat))) + (names name) + (let ((init (second spec))) + (when init + (inits `(%double-float ,init ,name)))))) + `(let* ,(binds) + (declare (dynamic-extent ,@(names)) + (double-float ,@(names))) + ,@(inits) + ,@body))) + + + + + + + ;;; WITH-BIGNUM-BUFFERS -- Internal. + ;;; + ;;; Could do freelisting someday. NAH + ;;; +(defmacro with-bignum-buffers (specs &body body) ; << + "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*" + (collect ((binds) + (inits) + (names)) + (dolist (spec specs) + (let ((name (first spec)) + (size (second spec))) + (binds `(,name (allocate-typed-vector :bignum ,size))) + (names name) + (let ((init (third spec))) + (when init + (inits `(bignum-replace ,name ,init)))))) + `(let* ,(binds) + (declare (dynamic-extent ,@(names))) + ,@(inits) + ,@body))) + +;;; call fn on possibly stack allocated negative of a and/or b +;;; args better be vars - we dont bother with once-only +(defmacro with-negated-bignum-buffers (a b fn) + `(let* ((len-a (%bignum-length ,a)) + (len-b (%bignum-length ,b)) + (a-plusp (bignum-plusp ,a)) + (b-plusp (bignum-plusp ,b))) + (declare (type bignum-index len-a len-b)) + (if (and a-plusp b-plusp) + (,fn ,a ,b ) + (if (not a-plusp) + (with-bignum-buffers ((a1 (1+ len-a))) + (negate-bignum ,a nil a1) + (if b-plusp + (,fn a1 ,b) + (with-bignum-buffers ((b1 (1+ len-b))) + (negate-bignum ,b nil b1) + (,fn a1 b1)))) + (with-bignum-buffers ((b1 (1+ len-b))) + (negate-bignum ,b nil b1) + (,fn ,a b1)))))) + +(defmacro with-one-negated-bignum-buffer (a fn) + `(if (bignum-plusp ,a) + (,fn ,a) + (with-bignum-buffers ((a1 (1+ (%bignum-length ,a)))) + (negate-bignum ,a nil a1) + (,fn a1)))) + + +(defmacro fixnum-to-bignum-set (big fix) + `(%fixnum-to-bignum-set ,big ,fix)) + +(defmacro with-small-bignum-buffers (specs &body body) + (collect ((binds) + (inits) + (names)) + (dolist (spec specs) + (let ((name (first spec))) + (binds `(,name (allocate-typed-vector :bignum + ,(target-word-size-case (32 1) + (64 2))))) + + (names name) + (let ((init (second spec))) + (when init + (inits `(fixnum-to-bignum-set ,name ,init)))))) + `(let* ,(binds) + (declare (dynamic-extent ,@(names))) + ,@(inits) + ,@body))) + +(provide "NUMBER-MACROS") + +;;; end of number-macros.lisp Index: /branches/qres/ccl/lib/numbers.lisp =================================================================== --- /branches/qres/ccl/lib/numbers.lisp (revision 13564) +++ /branches/qres/ccl/lib/numbers.lisp (revision 13564) @@ -0,0 +1,803 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Lib;numbers.lisp - Lisp arithmetic code. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require :number-macros) + (require :number-case-macro) + #+(and cross-compiling 64-bit-target) + (declaim (ftype function %single-float-atanh %single-float-acosh + %single-float-asinh %single-float-tanh + %single-float-cosh %single-float-sinh))) + + + +(defconstant double-float-positive-infinity + #.(let* ((division-by-zero (get-fpu-mode :division-by-zero))) + (declare (notinline /)) + (unwind-protect + (progn + (ccl:set-fpu-mode :division-by-zero nil) + (/ 0d0)) + (ccl:set-fpu-mode :division-by-zero division-by-zero)))) + +(defconstant double-float-negative-infinity + #.(let* ((division-by-zero (get-fpu-mode :division-by-zero))) + (declare (notinline /)) + (unwind-protect + (progn + (ccl:set-fpu-mode :division-by-zero nil) + (/ -0d0)) + (ccl:set-fpu-mode :division-by-zero division-by-zero)))) + +(defconstant double-float-nan + #.(let ((invalid (get-fpu-mode :invalid))) + (unwind-protect + (progn + (set-fpu-mode :invalid nil) + (+ double-float-positive-infinity double-float-negative-infinity)) + (set-fpu-mode :invalid invalid)))) + +(defun parse-float (str len off) + ; we cant assume this really is a float but dont call with eg s1 or e1 + (let ((integer 0)(expt 0)(sign 0)(done 0)(digits 0) point-pos type) + (setq integer + (do ((n off (1+ n)) + (first t nil) + (maxn (+ off len))) + ((>= n maxn) integer) + (declare (fixnum n maxn)) + (let ((c (%schar str n))) + (cond ((eq c #\.) + (setq point-pos digits)) + ((and first (eq c #\+))) + ((and first (eq c #\-)) + (setq sign -1)) + ((memq c '(#\s #\f #\S #\F)) + (setq type 'short-float) + (return integer)) + ((memq c '(#\d #\l #\D #\L)) + (setq type 'double-float) + (return integer)) + ((memq c '(#\e #\E)) + (return integer)) + ((setq c (digit-char-p c)) + (setq digits (1+ digits)) + (setq integer (+ c (* 10 integer)))) + (t (return-from parse-float nil))) + (setq done (1+ done))))) + (when point-pos + (setq expt (%i- point-pos digits))) + (when (null type) + (setq type *read-default-float-format*)) + (when (> len done) + (let ((eexp nil) (inf nil) (nan nil) (esign 1) c (xsign-n -1)) + (do ((n (%i+ off done 1) (1+ n)) + (first t nil)) + ((>= n (+ off len))) + (declare (fixnum n)) + (setq c (%schar str n)) + (cond ((and first (or (eq c #\+)(eq c #\-))) + (when (eq c #\-)(setq esign -1)) + (setq xsign-n (1+ n))) + ((and (= n xsign-n) + (or (eq c #\+)(eq c #\-))) + (if (eq c #\-) + (setq nan t) + (setq inf t))) + ((setq c (digit-char-p c)) + (setq eexp (+ c (* (or eexp 0) 10)))) + (t (return-from parse-float nil)))) + (when (not eexp)(return-from parse-float nil)) + (cond + (inf + (return-from parse-float + (coerce (if (minusp sign) + double-float-negative-infinity + double-float-positive-infinity) + type))) + (nan + (return-from parse-float + (coerce double-float-nan type))) + (expt (setq expt (%i+ expt (* esign eexp)))) + (t (return-from parse-float nil))))) + (fide sign integer expt (subtypep type 'short-float)))) + + +;; an interesting test case: 1.448997445238699 +;; The correct result is 6525704354437805 x 2^-52 +;; Incorrect is 6525704354437806 x 2^-52 +;; (from Will Clinger, "How to Read Floating Point Numbers Accurately", +;; ACM SIGPLAN'90 Conference on Programming Language Design and Implementation") +;; Doug Curries numbers 214748.3646, 1073741823/5000 + + +;; Sane read losers +;; 15871904747836473438871.0e-8 +;; 3123927307537977993905.0-13 +;; 17209940865514936528.0e-6 +;; "13.60447536e132" => adds some gratuitous drech +;; "94824331561426550.889e182" +;; "1166694.64175277e-150" => 1.1666946417527701E-144 +;; "3109973217844.55680988601e-173" +;; "817332.e-184" => 8.173320000000001E-179 +;; "2695.13e-180" => 2.6951300000000002E-177 +;; "89.85345789e-183" => 8.985345789000001E-182 +;; "0864813880.29e140" => 8.648138802899999E+148 +;; "5221.e-193" => 5.2209999999999995E-190 +;; "7.15628e-175" => 7.156280000000001E-175 + +(defparameter float-powers-of-5 nil) +(defparameter integer-powers-of-5 nil) + +(defun 5-to-e (e) + (declare (fixnum e)(optimize (speed 3)(safety 0))) + (if (> e 335) + (* (5-to-e 335)(5-to-e (- e 335))) ; for the dude who types 200 digits and e-500 + (if (< e 12) + (svref integer-powers-of-5 e) + (multiple-value-bind (q r) (truncate e 12) ; was floor + (declare (fixnum q r)) + (if (eql r 0) + (svref integer-powers-of-5 (%i+ q 11)) + (* (svref integer-powers-of-5 r) + (svref integer-powers-of-5 (%i+ q 11)))))))) + +(defun float-5-to-e (e) + (if (> e 22) ; shouldnt happen + (expt 5.0d0 e) + (svref float-powers-of-5 e))) + +(defparameter a-short-float nil) + +(eval-when (:compile-toplevel :execute) + ; number of bits for mantissa before rounding + (defconstant *short-float-extended-precision* 28) + (defconstant *double-float-extended-precision* 60) + ; number of mantissa bits including hidden bit + (defconstant *double-float-precision* (1+ IEEE-double-float-mantissa-width)) + (defconstant *short-float-precision* (1+ IEEE-single-float-mantissa-width)) + (defconstant *double-float-bias* IEEE-double-float-bias) + (defconstant *double-float-max-exponent* (1+ IEEE-double-float-normal-exponent-max)) + (defconstant *double-float-max-exact-power-of-5* 23) + ;(defconstant *short-float-max-exact-integer-length* 24) + (defconstant *double-float-max-exact-integer-length* 53) +) + + + + +(eval-when (:compile-toplevel :execute) + (defconstant *short-float-max-exact-power-of-5* 10) + (defconstant *short-float-bias* IEEE-single-float-bias) + (defconstant *short-float-max-exact-integer-length* 24) + (defconstant *short-float-max-exponent* (1+ IEEE-single-float-normal-exponent-max)) +) + + +;; this stuff could be in a shared file + +(defun fide #|float-integer-with-decimal-exponent|# (sign integer power-of-10 &optional short) + ;; take care of the zero case + (when (zerop integer) + (return-from fide ;float-integer-with-decimal-exponent + (if short + (if (minusp sign) -0.0s0 0.0s0) + (if (minusp sign) -0.0d0 0.0d0)))) + (let ((abs-power (abs power-of-10)) + (integer-length (integer-length integer))) + ;; this doesn't work for the above example, so arithmetic must be done wrong + ;; This does work if set FPCR precision to double + ;; now see if the conversion can be done simply: + ;; if both the integer and the power of 10 can be floated exactly, then + ;; correct rounding can be done by the multiply or divide + (when (or;short + (and (<= integer-length + ;; was (if short 17 53) why 17? see above + (if short *short-float-max-exact-integer-length* *double-float-max-exact-integer-length*)) + ;; (integer-length (expt 5 23)) => 54 + ;; was (if short 5 23) + (< abs-power (if short + *short-float-max-exact-power-of-5* + *double-float-max-exact-power-of-5*)))) ; we mean < 23 not <= + ;; if you care about consing, this could be done in assembly language or whatever, + ;; since all integers fit in 53 bits + (return-from fide ;float-integer-with-decimal-exponent + (let* ((signed-integer (prog1 (if (minusp sign) (- integer) integer))) + (float (float signed-integer (if short 0.0s0 0.0d0))) + (10-to-power (scale-float (float-5-to-e abs-power) abs-power))) + ;; coerce to short-float does not whine about undeflow, but does re overflow + (when short (setq 10-to-power (coerce 10-to-power 'short-float))) + (if (zerop abs-power) + float + (if (minusp power-of-10) + (/ float 10-to-power) + (* float 10-to-power)))))) + (try-harder sign integer power-of-10 short))) + + +(defun try-harder (sign integer power-of-10 short) + (flet ((ovf (&optional under) + (if under + (if (get-fpu-mode :underflow) + (error 'floating-point-underflow + :operation 'scale + :operands (list sign integer power-of-10))) + (if (get-fpu-mode :overflow) + (error 'floating-point-overflow + :operation 'scale + :operands (list sign integer power-of-10)))) + (return-from try-harder + (if under + (if short + (if (minusp sign) -0.0s0 0.0s0) + (if (minusp sign) 0.0d0 0.0d0)) + (if short + (if (minusp sign) most-negative-short-float most-positive-short-float) + (if (minusp sign) most-negative-double-float most-positive-double-float)))))) + (let* ((integer-length (integer-length integer)) new-int power-of-2) + (if (minusp power-of-10) + (progn + ;; avoid creating enormous integers with 5-to-e only to error later + (when (< power-of-10 -335) + (let ((poo (+ (round integer-length 3.2) power-of-10))) + ;; overestimate digits in integer + (when (< poo -335) (ovf t)) + ;; this case occurs if 600+ digits + (when (> poo 335) (ovf)))) + (let* ((divisor (5-to-e (- power-of-10))) + ;; make sure we will have enough bits in the quotient + ;; (and a couple extra for rounding) + (shift-factor (+ (- (integer-length divisor) integer-length) + (if short *short-float-extended-precision* *double-float-extended-precision*))) + (scaled-integer integer)) + (if (plusp shift-factor) + (setq scaled-integer (ash integer shift-factor)) + (setq divisor (ash divisor (- shift-factor)))) + (multiple-value-bind (quotient remainder)(floor scaled-integer divisor) + (unless (zerop remainder) ; whats this - tells us there's junk below + (setq quotient (logior quotient 1))) + (setq new-int quotient) + (setq power-of-2 (- power-of-10 shift-factor))))) + (progn + (when (> power-of-10 335)(ovf)) + (setq new-int (* integer (5-to-e power-of-10))) + (setq power-of-2 power-of-10))) + (float-and-scale-and-round sign new-int power-of-2 short)))) + + +(defun float-and-scale-and-round (sign integer power-of-2 short &optional result) + (let* ((length (integer-length integer)) + (lowbits 0) + (prec (if short *short-float-precision* *double-float-precision*)) + (ep (if short *short-float-extended-precision* *double-float-extended-precision*))) + (when (<= length prec) + ;; float can be done exactly, so do it the easy way + (return-from float-and-scale-and-round + (scale-float (float (if (minusp sign) (- integer) integer) (if short a-short-float)) + power-of-2))) + (let* ((exponent (+ length power-of-2)) + (biased-exponent (+ exponent (if short *short-float-bias* *double-float-bias*))) + (sticky-residue nil)) + (cond + ((<= biased-exponent 0) + ;; denormalize the number + (setf sticky-residue (not (zerop (ldb integer (byte (- 1 biased-exponent) 0))))) + (setf integer (ash integer (- biased-exponent 1))) + (setf biased-exponent 0))) + (let ((lowest (min ep length))) + (when (and (> length ep)(not (zerop (ldb (byte (- length ep) 0) integer)))) + (setq integer (logior integer (ash 1 (- length ep))))) + ; somewhere between 1 and (- ep prec) bits + (setq lowbits (ash (ldb (byte (- lowest prec) (- length lowest)) integer) (- ep lowest)))) + (let* ((significand (ldb (byte (1- prec) (- length prec)) integer))) + (when (and (not (zerop (ldb (byte 1 (- length (1+ prec))) integer))) ; round bit + (or sticky-residue (oddp significand) + (not (zerop (ldb (byte (- ep prec 1) 0) lowbits))))) + ;; round up + (setf significand (ldb (byte (1- prec) 0) (+ significand 1))) + (when (zerop significand) + (incf biased-exponent))) + (cond ((and (zerop biased-exponent) + (zerop significand) + (get-fpu-mode :underflow)) + (error 'floating-point-underflow + :operation 'scale + :operands (list sign integer power-of-2))) + ((>= biased-exponent (if short *short-float-max-exponent* *double-float-max-exponent*)) + (cond + (t + (if (get-fpu-mode :overflow) + (error 'floating-point-overflow + :operation 'scale + :operands (list sign integer power-of-2))) + (setf significand 0) + (setq biased-exponent (if short *short-float-max-exponent* *double-float-max-exponent*)))))) + (values + (if short + (make-short-float-from-fixnums (ldb (byte 23 0) significand) + biased-exponent + sign #-64-bit-target result) + (make-float-from-fixnums (ldb (byte 24 28) significand) + (ldb (byte 28 0) significand) + biased-exponent + sign result)) + lowbits))))) + + + + +(defparameter a-short-float 1.0s0) + +(defmethod print-object ((rs random-state) stream) + (let* ((s1 (random.mrg31k3p-state rs))) + (format stream "#.(~s~{ ~s~})" ;>> #.GAG!!! + 'ccl::initialize-mrg31k3p-state + (coerce s1 'list)))) + +(defun float-radix (float) + "Return (as an integer) the radix b of its floating-point argument." + (require-type float 'float) + 2) + +(defun float-digits (float) + (if (typep (require-type float 'float) 'short-float) + IEEE-single-float-digits + IEEE-double-float-digits)) + +(defun number-arg (arg) + (if (numberp arg) arg (%badarg arg 'number))) + + + + + +;==> Needs a transform... +(defun logandc2 (integer1 integer2) + "Bitwise AND INTEGER1 with (LOGNOT INTEGER2)." + (logandc1 integer2 integer1)) + +(defun logorc2 (integer1 integer2) + "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)." + (logorc1 integer2 integer1)) + + + +; Figure that the common (2-arg) case is caught by a compiler transform anyway. +(defun gcd (&lexpr numbers) + "Return the greatest common divisor of the arguments, which must be + integers. Gcd with no arguments is defined to be 0." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lexpr-ref numbers count 0))) + (if (= count 1) + (%integer-abs n0) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (setq n0 (gcd-2 n0 (%lexpr-ref numbers count i))))))))) + +(defun lcm-2 (n0 n1) + (or (typep n0 'integer) (report-bad-arg n0 'integer)) + (or (typep n1 'integer) (report-bad-arg n1 'integer)) + (locally (declare (integer n0 n1)) + (if (zerop n0) + 0 + (if (zerop n1) + 0 + (let* ((small (if (< n0 n1) n0 n1)) + (large (if (eq small n0) n1 n0))) + (values (truncate (abs (* n0 n1)) (gcd large small)))))))) + +(defun lcm (&lexpr numbers) + "Return the least common multiple of one or more integers. LCM of no + arguments is defined to be 1." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 1 + (let* ((n0 (%lexpr-ref numbers count 0))) + (if (= count 1) + (%integer-abs n0) + (if (= count 2) + (lcm-2 n0 (%lexpr-ref numbers count 1)) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (setq n0 (lcm-2 n0 (%lexpr-ref numbers count i)))))))))) + + +#| +(defun rationalize (x) + (etypecase x + (rational x) + (real + (cond ((minusp x) (- (rationalize (- x)))) + ((zerop x) 0) + (t + (let ((eps (etypecase x + (single-float single-float-epsilon) + (double-float double-float-epsilon))) + (y ()) + (a ())) + (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x))))) + (num (setq a (truncate x)) + (+ (* (setq a (truncate y)) num) onum)) + (den 1 (+ (* a den) oden)) + (onum 1 num) + (oden 0 den)) + ((and (not (zerop den)) + (not (> (abs (/ (- x (/ (float num x) + (float den x))) + x)) + eps))) + (integer-/-integer num den))))))))) +|# + +(defun rationalize (number) + "Converts any REAL to a RATIONAL. Floats are converted to a simple rational + representation exploiting the assumption that floats are only accurate to + their precision. RATIONALIZE (and also RATIONAL) preserve the invariant: + (= x (float (rationalize x) x))" + (if (floatp number) + (labels ((simpler-rational (less-predicate lonum loden hinum hiden + &aux (trunc (if (eql less-predicate #'<=) + #'ceiling + #'(lambda (n d) (1+ (floor n d))))) + (term (funcall trunc lonum loden))) + ;(pprint (list lonum loden hinum hiden)) + (if (funcall less-predicate (* term hiden) hinum) + (values term 1) + (multiple-value-bind + (num den) + (simpler-rational less-predicate hiden (- hinum (* (1- term) hiden)) + loden (- lonum (* (1- term) loden))) + (values (+ den (* (1- term) num)) num))))) + (multiple-value-bind (fraction exponent sign) (integer-decode-float number) + ;; the first 2 tests may be unnecessary - I think the check + ;; for denormalized is compensating for a bug in 3.0 re + ;; floating a rational (in order to pass tests in + ;; ppc-test-arith). + (if (or (and (typep number 'double-float) ; is it denormalized + (eq exponent #.(nth-value 1 (integer-decode-float least-positive-double-float)))) ; aka -1074)) + (eq exponent #.(nth-value 1 (integer-decode-float least-positive-short-float))) ; aka -149)) + (zerop (logand fraction (1- fraction)))) ; or a power of two + (rational number) + (if (minusp exponent) + ;;less than 1 + (let ((num (ash fraction 2)) + (den (ash 1 (- 2 exponent)))) + (multiple-value-bind + (n d) + (simpler-rational (if (evenp fraction) #'<= #'<) + (- num 2) ;(if (zerop (logand fraction (1- fraction))) 1 2)) + den (+ num 2) den) + (when (minusp sign) + (setq n (- n))) + (/ n d))) + ;;greater than 1 + (ash (if (minusp number) (- fraction) fraction) exponent))))) + (rational number))) +#| +(defun testrat (&optional (n 1000)) + (dotimes (i n) + (let* (( numerator (random (ash 1 63))) + (denominator (random (ash 1 63))) + (sign (if (zerop (random 2)) 1 -1)) + (trial (float (/ (* sign numerator) denominator))) + (rat (rationalize trial))) + (when (not (= (float rat) trial)) + (error "Rationalize failed. Input ~s Rational ~s Float ~s" trial rat (float rat)))))) + +; smallest fails in 3.0 - powers of 2 - works here but we cheat a bit +(defun testrat2 () + (let ((f least-positive-double-float)) + (dotimes (i 100) + (when (not (= (float (rationalize f)) f)) + (cerror "a" "rat failed ~s ~s" f i)) + (setq f (* f 2))))) + +; fails a lot in 3.0 - not powers of 2 - works here +(defun testrat3 () + (let ((f least-positive-double-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i))))) + (let ((f least-negative-double-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i)))))) + +(defun testrat31 () + (let ((f least-positive-short-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i))))) + (let ((f least-negative-short-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i)))))) + +; works in 3.0 - and here +(defun testrat4 () + (let ((f least-positive-normalized-double-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i))))) + (let ((f least-negative-normalized-double-float)) + (dotimes (i 100) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i)))))) + + +|# + +#| now in l1-numbers.lisp +(defun logeqv (&lexpr numbers) + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + -1 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logeqv-2 (%lexpr-ref numbers count i) n0)))))))) +|# + + +(defparameter *boole-ops* + (vector + #'(lambda (i1 i2) (declare (ignore i1 i2)) 0) + #'(lambda (i1 i2) (declare (ignore i1 i2)) -1) + #'(lambda (i1 i2) (declare (ignore i2)) i1) + #'(lambda (i1 i2) (declare (ignore i1)) i2) + #'(lambda (i1 i2) (declare (ignore i2)) (lognot i1)) + #'(lambda (i1 i2) (declare (ignore i1)) (lognot i2)) + #'(lambda (i1 i2) (logand i1 i2)) + #'(lambda (i1 i2) (logior i1 i2)) + #'(lambda (i1 i2) (logxor i1 i2)) + #'(lambda (i1 i2) (logeqv i1 i2)) + #'(lambda (i1 i2) (lognand i1 i2)) + #'(lambda (i1 i2) (lognor i1 i2)) + #'(lambda (i1 i2) (logandc1 i1 i2)) + #'(lambda (i1 i2) (logandc2 i1 i2)) + #'(lambda (i1 i2) (logorc1 i1 i2)) + #'(lambda (i1 i2) (logorc2 i1 i2)))) + + + +;===> Change these constants to match maclisp!! +(defun boole (op integer1 integer2) + "Bit-wise boolean function on two integers. Function chosen by OP: + 0 BOOLE-CLR + 1 BOOLE-SET + 2 BOOLE-1 + 3 BOOLE-2 + 4 BOOLE-C1 + 5 BOOLE-C2 + 6 BOOLE-AND + 7 BOOLE-IOR + 8 BOOLE-XOR + 9 BOOLE-EQV + 10 BOOLE-NAND + 11 BOOLE-NOR + 12 BOOLE-ANDC1 + 13 BOOLE-ANDC2 + 14 BOOLE-ORC1 + 15 BOOLE-ORC2" + (unless (and (typep op 'fixnum) + (locally (declare (fixnum op)) + (and (>= op 0) + (<= op 15)))) + (report-bad-arg op '(integer 0 15))) + (funcall (%svref *boole-ops* op) + (require-type integer1 'integer) + (require-type integer2 'integer))) + + +(defun %integer-power (b e) + (declare (type unsigned-byte e)) + (if (zerop e) + (+ 1 (* b 0)) + (if (eql b 2) + (ash 1 e) + (do* ((next (ash e -1) (ash e -1)) + (oddexp (oddp e) (oddp e)) + (total (if oddexp b 1) (if oddexp (* b total) total))) + ((zerop next) total) + (declare (type unsigned-byte next)) + (setq b (* b b) e next))))) + +(defun signum (x) + "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." + (cond ((complexp x) (if (zerop x) x (/ x (abs x)))) + ((rationalp x) (if (plusp x) 1 (if (zerop x) 0 -1))) + ((zerop x) (float 0.0 x)) + (t (float-sign x)))) + + + +; Thanks to d34676@tansei.cc.u-tokyo.ac.jp (Akira KURIHARA) +(defun isqrt (n &aux n-len-quarter n-half n-half-isqrt + init-value iterated-value) + "Return the root of the nearest integer less than n which is a perfect + square. Argument n must be a non-negative integer" + (cond + ((eql n 0) 0) + ; this fails sometimes - do we care? 70851992595801818865024053174 or #x80000000 + ; maybe we do - its used by dotimes + ;((not (int>0-p n)) (report-bad-arg n '(integer 0))) ;'unsigned-byte)) ; Huh? + ((or (not (integerp n))(minusp n))(report-bad-arg n '(integer 0))) + ((> n 24) ; theoretically (> n 7) ,i.e., n-len-quarter > 0 + (setq n-len-quarter (ash (integer-length n) -2)) + (setq n-half (ash n (- (ash n-len-quarter 1)))) + (setq n-half-isqrt (isqrt n-half)) + (setq init-value (ash (1+ n-half-isqrt) n-len-quarter)) + (loop + (setq iterated-value (ash (+ init-value (floor n init-value)) -1)) + (if (not (< iterated-value init-value)) + (return init-value) + (setq init-value iterated-value)))) + ((> n 15) 4) + ((> n 8) 3) + ((> n 3) 2) + (t 1))) + + +(defun sinh (x) + "Return the hyperbolic sine of NUMBER." + (if (complexp x) + (/ (- (exp x) (exp (- x))) 2) + (if (typep x 'double-float) + (%double-float-sinh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-sinh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-sinh (%short-float x))))) + + +(defun cosh (x) + "Return the hyperbolic cosine of NUMBER." + (if (complexp x) + (/ (+ (exp x) (exp (- x))) 2) + (if (typep x 'double-float) + (%double-float-cosh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-cosh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-cosh (%short-float x))))) + +(defun tanh (x) + "Return the hyperbolic tangent of NUMBER." + (if (complexp x) + (/ (sinh x) (cosh x)) + (if (typep x 'double-float) + (%double-float-tanh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-tanh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-tanh (%short-float x))))) + +(defun asinh (x) + "Return the hyperbolic arc sine of NUMBER." + (if (complexp x) + (log (+ x (sqrt (+ 1 (* x x))))) + (if (typep x 'double-float) + (%double-float-asinh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-asinh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-asinh (%short-float x))))) + +(defun acosh (x) + "Return the hyperbolic arc cosine of NUMBER." + (if (and (realp x) (<= 1.0 x)) + (if (typep x 'double-float) + (%double-float-acosh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-acosh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-acosh (%short-float x))) + (* 2 (log (+ (sqrt (/ (1+ x) 2)) (sqrt (/ (1- x) 2))))))) + +(defun atanh (x) + "Return the hyperbolic arc tangent of NUMBER." + (if (and (realp x) (<= -1.0 (setq x (float x)) 1.0)) + (if (typep x 'double-float) + (%double-float-atanh! x (%make-dfloat)) + #+32-bit-target + (%single-float-atanh! x (%make-sfloat)) + #+64-bit-target + (%single-float-atanh x)) + (/ (log (/ (+ 1 x) (- 1 x))) 2))) + + +(defun ffloor (number &optional divisor) + "Same as FLOOR, but returns first value as a float." + (multiple-value-bind (q r) (floor number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun fceiling (number &optional divisor) + "Same as CEILING, but returns first value as a float." + (multiple-value-bind (q r) (ceiling number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun ftruncate (number &optional divisor) + "Same as TRUNCATE, but returns first value as a float." + (multiple-value-bind (q r) (truncate number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun fround (number &optional divisor) + "Same as ROUND, but returns first value as a float." + (multiple-value-bind (q r) (round number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun rational (number) + "RATIONAL produces a rational number for any real numeric argument. This is + more efficient than RATIONALIZE, but it assumes that floating-point is + completely accurate, giving a result that isn't as pretty." + (if (floatp number) + (multiple-value-bind (s e sign) + (number-case number + (short-float + (integer-decode-short-float number)) + (double-float + (integer-decode-double-float number))) + (if (eq sign -1) (setq s (- s))) + (if (%iminusp e) + (/ s (ash 1 (%i- 0 e))) + (ash s e))) + (if (rationalp number) + number + (report-bad-arg number 'real)))) + +; make power tables for floating point reader +(progn + (setq float-powers-of-5 (make-array 23)) + (let ((array float-powers-of-5)) + (dotimes (i 23) + (setf (svref array i) (float (expt 5 i) 0.0d0)))) + (setq integer-powers-of-5 (make-array (+ 12 (floor 324 12)))) + (let ((array integer-powers-of-5)) + (dotimes (i 12) + (setf (svref array i) (expt 5 i))) + (dotimes (i (floor 324 12)) + (setf (svref array (+ i 12)) (expt 5 (* 12 (1+ i))))))) + + +(provide 'numbers) + Index: /branches/qres/ccl/lib/pathnames.lisp =================================================================== --- /branches/qres/ccl/lib/pathnames.lisp (revision 13564) +++ /branches/qres/ccl/lib/pathnames.lisp (revision 13564) @@ -0,0 +1,525 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;pathnames.lisp Pathnames for Coral Common LISP +(in-package "CCL") + +(eval-when (eval compile) + (require 'level-2) + (require 'backquote) +) +;(defconstant $accessDenied -5000) ; put this with other errnos +(defconstant $afpAccessDenied -5000) ; which name to use? + + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;ANSI CL logical pathnames + + +(defvar *pathname-translations-pathname* + (make-pathname :host "ccl" :type "pathname-translations")) + +(defun load-logical-pathname-translations (host) + ;(setq host (verify-logical-host-name host)) + (when (not (%str-assoc host %logical-host-translations%)) + (setf (logical-pathname-translations host) + (with-open-file (file (merge-pathnames (make-pathname :name host :defaults nil) + *pathname-translations-pathname*) + :element-type 'base-char) + (read file))) + T)) + +(defun back-translate-pathname (path &optional hosts) + (let ((newpath (back-translate-pathname-1 path hosts))) + (cond ((equalp path newpath) + ;; (fcomp-standard-source path) + (namestring (pathname path))) + (t newpath)))) + + +(defun back-translate-pathname-1 (path &optional hosts) + (dolist (host %logical-host-translations%) + (when (or (null hosts) (member (car host) hosts :test 'string-equal)) + (dolist (trans (cdr host)) + (when (pathname-match-p path (cadr trans)) + (let* (newpath) + (setq newpath (translate-pathname path (cadr trans) (car trans) :reversible t)) + (return-from back-translate-pathname-1 + (if (equalp path newpath) path (back-translate-pathname-1 newpath hosts)))))))) + path) + + + +; must be after back-translate-pathname +(defun physical-pathname-p (path) + (let* ((path (pathname path)) + (dir (pathname-directory path))) + (and dir + (or (not (logical-pathname-p path)) + (not (null (memq (pathname-host path) '(nil :unspecific)))))))) + + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;File or directory Manipulations + +(defun unix-rename (old-name new-name) + (with-cstrs ((old old-name) + (new new-name)) + #+windows-target + (#__unlink new) + (let* ((res (#_rename old new))) + (declare (fixnum res)) + (if (zerop res) + (values t nil) + (values nil (%get-errno)))))) + +(defun rename-file (file new-name &key (if-exists :error)) + "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a + file, then the associated file is renamed." + (let* ((original (truename file)) + (original-namestring (native-translated-namestring original)) + (new-name (merge-pathnames new-name original)) + (new-namestring (native-translated-namestring new-name))) + (unless new-namestring + (error "~S can't be created." new-name)) + (unless (and (probe-file new-name) + (not (if-exists if-exists new-name))) + (multiple-value-bind (res error) + (unix-rename original-namestring + new-namestring) + (unless res + (error "Failed to rename ~A to ~A: ~A" + original new-name error)) + (when (streamp file) + (setf (stream-filename file) + (namestring (native-to-pathname new-namestring)))) + (values new-name original (truename new-name)))))) + +(defun copy-file (source-path dest-path &key (if-exists :error) (if-does-not-exist :create) + (preserve-attributes nil)) + (let* ((original (truename source-path)) + (new-name (merge-pathnames dest-path original)) + (buffer (make-array 4096 :element-type '(unsigned-byte 8)))) + (with-open-file (in original :direction :input + :element-type '(unsigned-byte 8)) + (with-open-file (out new-name :direction :output + :if-exists if-exists + :if-does-not-exist if-does-not-exist + :element-type '(unsigned-byte 8)) + (loop + as n = (stream-read-vector in buffer 0 4096) until (eql n 0) + do (stream-write-vector out buffer 0 n)))) + (when preserve-attributes + (copy-file-attributes original new-name)) + (values new-name original (truename new-name)))) + +(defun recursive-copy-directory (source-path dest-path &key test (if-exists :error)) + ;; TODO: Support :if-exists :supersede to blow away any files not in source dir + (assert (directoryp source-path)(source-path) + "source-path is not a directory in RECURSIVE-COPY-DIRECTORY") + (setq if-exists (require-type if-exists '(member :overwrite :error))) + (setq dest-path (ensure-directory-pathname dest-path)) + (when (eq if-exists :error) + (when (probe-file dest-path) + (if-exists if-exists dest-path)) + ;; Skip the probe-file in recursive calls, we already know it's ok. + (setq if-exists :overwrite)) + (let* ((source-dir (ensure-directory-pathname source-path)) + (pattern (make-pathname :name :wild :type :wild :defaults source-dir)) + (source-files (directory pattern :test test :directories t :files t))) + (ensure-directories-exist dest-path) + (dolist (f source-files) + (when (or (null test) (funcall test f)) + (if (directory-pathname-p f) + (let ((dest-file (make-pathname :name (first (last (pathname-directory f))) + :defaults dest-path))) + (recursive-copy-directory f dest-file :test test :if-exists if-exists)) + (let* ((dest-file (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path))) + (copy-file f dest-file :if-exists :supersede :preserve-attributes t))))))) + +;;; use with caution! +;;; blows away a directory and all its contents +(defun recursive-delete-directory (path &key (if-does-not-exist :error)) + (setq path (ensure-directory-pathname path)) + (setq if-does-not-exist (require-type if-does-not-exist '(member :error nil))) + (when (eq if-does-not-exist :error) + (unless (probe-file path) + (if-does-not-exist if-does-not-exist path))) + (when (probe-file path) + (if (directoryp path) + ;; it's a directory: blow it away + (let* ((pattern (make-pathname :name :wild :type :wild :defaults path)) + (files (directory pattern :directories nil :files t)) + (subdirs (directory pattern :directories t :files nil)) + (target-pathname (native-translated-namestring path))) + (dolist (f files) + (delete-file f)) + (dolist (d subdirs) + (recursive-delete-directory d :if-does-not-exist if-does-not-exist)) + (%rmdir target-pathname)) + ;; it's not a directory: for safety's sake, signal an error + (error "Pathname '~A' is not a directory" path)))) + +;;; It's not clear that we can support anything stronger than +;;; "advisory" ("you pretend the file's locked & I will too") file +;;; locking under Darwin. + + + + +(defun create-directory (path &key (mode #o777)) + (let* ((pathname (translate-logical-pathname (merge-pathnames path))) + (created-p nil) + (parent-dirs (let* ((pd (pathname-directory pathname))) + (if (eq (car pd) :relative) + (pathname-directory (merge-pathnames + pathname + (mac-default-directory))) + pd))) + (nparents (length parent-dirs))) + (when (wild-pathname-p pathname) + (error 'file-error :error-type "Inappropriate use of wild pathname ~s" + :pathname pathname)) + (do* ((i 1 (1+ i))) + ((> i nparents) (values pathname created-p)) + (declare (fixnum i)) + (let* ((parent (make-pathname + :name :unspecific + :type :unspecific + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (subseq parent-dirs 0 i))) + (parent-name (native-translated-namestring parent)) + (parent-kind (%unix-file-kind parent-name))) + + (if parent-kind + (unless (eq parent-kind :directory) + (error 'simple-file-error + :error-type "Can't create directory ~s, since file ~a exists and is not a directory" + :pathname pathname + :format-arguments (list parent-name))) + (let* ((result (%mkdir parent-name mode))) + (declare (fixnum result)) + (if (< result 0) + (signal-file-error result parent-name) + (setq created-p t)))))))) + + +(defun ensure-directories-exist (pathspec &key verbose (mode #o777)) + "Test whether the directories containing the specified file + actually exist, and attempt to create them if they do not. + The MODE argument is an extension to control the Unix permission + bits. Portable programs should avoid using the :MODE keyword + argument." + (let ((pathname (let ((pathspec (translate-logical-pathname (merge-pathnames pathspec)))) + (make-directory-pathname :device (pathname-device pathspec) + :directory (pathname-directory pathspec)))) + (created-p nil)) + (when (wild-pathname-p pathname) + (error 'file-error + :error-type "Inappropriate use of wild pathname ~s" + :pathname pathname)) + (let ((dir (pathname-directory pathname))) + (if (eq (car dir) :relative) + (setq dir (pathname-directory (merge-pathnames + pathname + (mac-default-directory))))) + (loop for i from 1 upto (length dir) + do (let ((newpath (make-pathname + :name :unspecific + :type :unspecific + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (subseq dir 0 i)))) + (unless (probe-file newpath) + (let ((namestring (native-translated-namestring newpath))) + (when verbose + (format *standard-output* "~&Creating directory: ~A~%" + namestring)) + (%mkdir namestring mode) + (unless (probe-file newpath) + (error 'file-error + :pathname namestring + :error-type "Can't create directory ~S.")) + (setf created-p t))))) + (values pathspec created-p)))) + +(defun dirpath-to-filepath (path) + (setq path (translate-logical-pathname (merge-pathnames path))) + (let* ((dir (pathname-directory path)) + (super (butlast dir)) + (name (car (last dir)))) + (when (eq name :up) + (setq dir (remove-up (copy-list dir))) + (setq super (butlast dir)) + (setq name (car (last dir)))) + (when (null super) + (signal-file-error $xnocreate path)) + (setq path (make-pathname :directory super :name name :defaults nil)))) + +(defun filepath-to-dirpath (path) + (let* ((dir (pathname-directory path)) + (rest (file-namestring path))) + (make-pathname :directory (append dir (list rest)) :defaults nil))) + + + +;Takes a pathname, returns the truename of the directory if the pathname +;names a directory, NIL if it names an ordinary file, error otherwise. +;E.g. (directoryp "ccl;:foo:baz") might return #P"hd:mumble:foo:baz:" if baz +;is a dir. - should we doc this - its exported? +(defun directoryp (path) + (let* ((native (native-translated-namestring path)) + (realpath (%realpath native))) + (if realpath (eq (%unix-file-kind realpath) :directory)))) + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;Wildcards + + + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;Directory Traversing + +(defun %path-cat (device dir subdir) + (if device + (%str-cat device ":" dir subdir) + (%str-cat dir subdir))) + +(defmacro with-open-dir ((dirent device dir) &body body) + `(let ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil))))) + (when ,dirent + (unwind-protect + (progn ,@body) + (close-dir ,dirent))))) + +(defun directory (path &key (directories nil) ;; include subdirectories + (files t) ;; include files + (all t) ;; include Unix dot files (other than dot and dot dot) + (directory-pathnames t) ;; return directories as directory-pathname-p's. + (include-emacs-lockfiles nil) ;; inculde .#foo + test ;; Only return pathnames matching test + (follow-links t)) ;; return truename's of matching files. + "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the + given pathname. Note that the interaction between this ANSI-specified + TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) + means this function can sometimes return files which don't have the same + directory as PATHNAME." + (let* ((keys (list :directories directories ;list defaulted key values + :files files + :all all + :directory-pathnames directory-pathnames + :test test + :include-emacs-lockfiles include-emacs-lockfiles + :follow-links follow-links)) + (path (full-pathname (merge-pathnames path) :no-error nil)) + (dir (directory-namestring path))) + (declare (dynamic-extent keys)) + (if (null (pathname-directory path)) + (setq dir (directory-namestring (setq path + (merge-pathnames path + (mac-default-directory)))))) + (assert (eq (car (pathname-directory path)) :absolute) () + "full-pathname returned relative path ~s??" path) + ;; return sorted in alphabetical order, target-Xload-level-0 depends + ;; on this. + (nreverse + (delete-duplicates (%directory "/" dir path '(:absolute) keys) :test #'equal)))) + +(defun %directory (dir rest path so-far keys) + (multiple-value-bind (sub-dir wild rest) (%split-dir rest) + (%some-specific dir sub-dir wild rest path so-far keys))) + +(defun %some-specific (dir sub-dir wild rest path so-far keys) + (let* ((start 1) + (end (length sub-dir)) + (full-dir (if (eq start end) dir (%str-cat dir (%substr sub-dir start end))))) + (while (neq start end) + (let ((pos (position #\/ sub-dir :start start :end end))) + (push (%path-std-quotes (%substr sub-dir start pos) nil "/:;*") so-far) + (setq start (%i+ 1 pos)))) + (cond ((null wild) + (%files-in-directory full-dir path so-far keys)) + ((string= wild "**") + (%all-directories full-dir rest path so-far keys)) + (t (%one-wild full-dir wild rest path so-far keys))))) + +; for a * or *x*y +(defun %one-wild (dir wild rest path so-far keys) + (let ((result ()) + (device (pathname-device path)) + (all (getf keys :all)) + name) + (with-open-dir (dirent device dir) + (while (setq name (%read-dir dirent)) + (when (and (or all (neq (%schar name 0) #\.)) + (not (string= name ".")) + (not (string= name "..")) + (%path-pstr*= wild name) + (eq (%unix-file-kind (%path-cat device dir name) t) :directory)) + (let ((subdir (%path-cat nil dir name)) + (so-far (cons (%path-std-quotes name nil "/;:*") so-far))) + (declare (dynamic-extent so-far)) + (setq result + (nconc (%directory (%str-cat subdir "/") rest path so-far keys) result)))))) + result)) + +(defun %files-in-directory (dir path so-far keys) + (let ((device (pathname-device path)) + (name (pathname-name path)) + (type (pathname-type path)) + (directories (getf keys :directories)) + (files (getf keys :files)) + (directory-pathnames (getf keys :directory-pathnames)) + (test (getf keys :test)) + (follow-links (getf keys :follow-links)) + (all (getf keys :all)) + (include-emacs-lockfiles (getf keys :include-emacs-lockfiles)) + (result ()) + sub dir-list ans) + (if (not (or name type)) + (let (full-path) + (when (and directories + (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device))) + t) + :directory)) + (setq ans (if directory-pathnames full-path + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device))) + (when (and ans (or (null test) (funcall test ans))) + (setq result (list ans))))) + (with-open-dir (dirent (pathname-device path) dir) + (while (setq sub (%read-dir dirent)) + (when (and (or all (neq (%schar sub 0) #\.)) + (or include-emacs-lockfiles + (< (length sub) 2) + (not (string= sub ".#" :end1 2))) + (not (string= sub ".")) + (not (string= sub "..")) + (%file*= name type sub)) + (setq ans + (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory) + (when directories + (let* ((std-sub (%path-std-quotes sub nil "/;:*"))) + (if directory-pathnames + (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device) + (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil nil device)))) + (when files + (multiple-value-bind (name type) (%std-name-and-type sub) + (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device))))) + (when (and ans (or (null test) (funcall test ans))) + (push (if follow-links (or (probe-file ans) ans) ans) result)))))) + result)) + +(defun %all-directories (dir rest path so-far keys) + (let ((do-files nil) + (do-dirs nil) + (result nil) + (device (pathname-device path)) + (name (pathname-name path)) + (type (pathname-type path)) + (all (getf keys :all)) + (test (getf keys :test)) + (directory-pathnames (getf keys :directory-pathnames)) + (follow-links (getf keys :follow-links)) + sub dir-list ans) + ;; First process the case that the ** stands for 0 components + (multiple-value-bind (next-dir next-wild next-rest) (%split-dir rest) + (while (and next-wild ; Check for **/**/ which is the same as **/ + (string= next-dir "/") + (string= next-wild "**")) + (setq rest next-rest) + (multiple-value-setq (next-dir next-wild next-rest) (%split-dir rest))) + (cond ((not (string= next-dir "/")) + (setq result + (%some-specific dir next-dir next-wild next-rest path so-far keys))) + (next-wild + (setq result + (%one-wild dir next-wild next-rest path so-far keys))) + ((or name type) + (when (getf keys :files) (setq do-files t)) + (when (getf keys :directories) (setq do-dirs t))) + (t (when (getf keys :directories) + (setq sub (if directory-pathnames + (%cons-pathname (setq dir-list (reverse so-far)) nil nil nil device) + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device))) + (when (or (null test) (funcall test sub)) + (setq result (list (if follow-links (truename sub) sub)))))))) + ; now descend doing %all-dirs on dirs and collecting files & dirs if do-x is t + (with-open-dir (dirent device dir) + (while (setq sub (%read-dir dirent)) + (when (and (or all (neq (%schar sub 0) #\.)) + (not (string= sub ".")) + (not (string= sub ".."))) + (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory) + (let* ((subfile (%path-cat nil dir sub)) + (std-sub (%path-std-quotes sub nil "/;:*")) + (so-far (cons std-sub so-far)) + (subdir (%str-cat subfile "/"))) + (declare (dynamic-extent so-far)) + (when (and do-dirs (%file*= name type sub)) + (setq ans (if directory-pathnames + (%cons-pathname (reverse so-far) nil nil nil device) + (%cons-pathname (or dir-list (setq dir-list (reverse (cdr so-far)))) + std-sub nil nil device))) + (when (or (null test) (funcall test ans)) + (push (if follow-links (truename ans) ans) result))) + (setq result (nconc (%all-directories subdir rest path so-far keys) result))) + (when (and do-files (%file*= name type sub)) + (multiple-value-bind (name type) (%std-name-and-type sub) + (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device)) + (when (or (null test) (funcall test ans)) + (push (if follow-links (truename ans) ans) result)))))))) + result)) + +(defun %split-dir (dir &aux pos) ; dir ends in a "/". + ;"/foo/bar/../x*y/baz/../z*t/" -> "/foo/bar/../" "x*y" "/baz/../z*t/" + (if (null (setq pos (%path-mem "*" dir))) + (values dir nil nil) + (let (epos (len (length dir))) + (setq pos (if (setq pos (%path-mem-last "/" dir 0 pos)) (%i+ pos 1) 0) + epos (%path-mem "/" dir pos len)) + (when (%path-mem-last-quoted "/" dir 0 pos) + (signal-file-error $xbadfilenamechar dir #\/)) + (values (unless (%izerop pos) (namestring-unquote (%substr dir 0 pos))) + (%substr dir pos epos) + (%substr dir epos len))))) + +(defun %path-pstr*= (pattern pstr &optional (p-start 0)) + (assert (eq p-start 0)) + (%path-str*= pstr pattern)) + +(defun %file*= (name-pat type-pat pstr) + (if (eq name-pat :wild) (setq name-pat "*")) + (if (eq type-pat :wild) (setq type-pat "*")) + (when (and (null name-pat) (null type-pat)) + (return-from %file*= T)) + (let* ((end (length pstr)) + (pos (position #\. pstr :from-end t)) + (type (and pos (%substr pstr (%i+ pos 1) end))) + (name (unless (eq (or pos end) 0) (if pos (%substr pstr 0 pos) pstr)))) + (and (cond ((or (eq name-pat :unspecific) (null name-pat)) (null name)) + (t (%path-pstr*= name-pat (or name "")))) + (cond ((or (null type-pat) (eq type-pat :unspecific)) (null type)) + (t (%path-pstr*= type-pat (or type ""))))))) + +(provide "PATHNAMES") Index: /branches/qres/ccl/lib/ppc-backtrace.lisp =================================================================== --- /branches/qres/ccl/lib/ppc-backtrace.lisp (revision 13564) +++ /branches/qres/ccl/lib/ppc-backtrace.lisp (revision 13564) @@ -0,0 +1,883 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +(def-accessors (fake-stack-frame) %svref + nil ; 'fake-stack-frame + %fake-stack-frame.sp ; fixnum. The stack pointer where this frame "should" be + %fake-stack-frame.next-sp ; Either sp or another fake-stack-frame + %fake-stack-frame.fn ; The current function + %fake-stack-frame.lr ; fixnum offset from fn (nil if fn is not functionp) + %fake-stack-frame.vsp ; The value stack pointer + %fake-stack-frame.xp ; Exception frame. + %fake-stack-frame.link ; next in *fake-stack-frames* list + ) + +;;; Linked list of fake stack frames. +;;; %frame-backlink looks here +(def-standard-initial-binding *fake-stack-frames* nil) + + +(defun fake-stack-frame-p (x) + (istruct-typep x 'fake-stack-frame)) + +(defun cfp-lfun (p) + (if (fake-stack-frame-p p) + (let* ((fn (%fake-stack-frame.fn p)) + (lr (%fake-stack-frame.lr p))) + (if (and (typep fn 'function) + (typep lr 'fixnum)) + (values fn lr) + (values nil nil))) + (%cfp-lfun p))) + + +(defun %stack< (index1 index2 &optional context) + (cond ((fake-stack-frame-p index1) + (let ((sp1 (%fake-stack-frame.sp index1))) + (declare (fixnum sp1)) + (if (fake-stack-frame-p index2) + (or (%stack< sp1 (%fake-stack-frame.sp index2) context) + (eq index2 (%fake-stack-frame.next-sp index1))) + (%stack< sp1 (%i+ index2 1) context)))) + ((fake-stack-frame-p index2) + (%stack< index1 (%fake-stack-frame.sp index2) context)) + (t (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (cs-area (%fixnum-ref tcr target::tcr.cs-area))) + (and (%ptr-in-area-p index1 cs-area) + (%ptr-in-area-p index2 cs-area) + (< (the fixnum index1) (the fixnum index2))))))) + +;;; Returns two values: +;;; [nil, nil] if it can be reliably determined that function uses no registers at PC +;;; [mask, savevsp] if it can be reliably determined that the registers specified by "mask" +;;; were saved at "savevsp" in the function's stack frame +;;; [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them +;;; (perhaps because the "at-pc" argument wasn't specified. + + +;;; If the last instruction in a code vector is an +;;; LWZ instruction (of the form "(LWZ rx s16 ry)"), +;;; then +;;; this function uses registers RX-R31. Note that this leaves +;;; us 2 extra bits, since we're only encoding 3 bits worth of +;;; register info. +;;; RX is saved nearest the top of the vstack +;;; s16 is the offset from the saved-vsp to the address at which +;;; RX was saved; this is a negative value whose low two bits +;;; are ignored +;;; (logior (ash (logand s16 3) 5) rY) is the pc at which +;;; the registers were saved (a fullword code-vector index). +;;; This scheme lets us encode any "simple" register usage, where +;;; the registers were saved once, saved somewhere within the first +;;; 128 instructions in the code vector, and nothing interesting (to +;;; backtrace) happens after the registers have been restored. +;;; If the compiler ever gets cleverer about this, we'll have to use +;;; some other scheme (perhaps a STW instruction, preceded by branches). +;;; +;;; Note that the "last instruction" really means "last instruction +;;; before any traceback table"; we should be able to truncate the code +;;; vector (probably by copying it) to strip off the traceback table +;;; without losing this information. +;;; Note also that the disassembler would probably ordinarily want to +;;; hide this last instruction ... +;;; + +#+ppc32-target +(defun registers-used-by (lfun &optional at-pc) + (let* ((regs-used nil) + (where-saved nil)) + (multiple-value-bind (op-high op-low) (%code-vector-last-instruction (uvref lfun 0)) + (declare (fixnum op-high op-low)) + (if (eql (ldb (byte 6 (- 26 16)) op-high) 32) ; LWZ + (let* ((nregs (- 32 (ldb (byte 5 (- 21 16)) op-high))) + (pc (dpb (ldb (byte 2 0) op-low) (byte 2 5) (ldb (byte 5 (- 16 16)) op-high))) + (offset (%word-to-int (logand op-low (lognot 3))))) + (declare (fixnum nregs pc offset)) + (setq regs-used (1- (ash 1 nregs))) + (if at-pc + (if (>= at-pc pc) + (setq where-saved (- (ash (- offset) -2) nregs)) + (setq regs-used nil)))))) + (values (and regs-used (bit-reverse-8 regs-used)) where-saved))) + +#+ppc64-target +(defun registers-used-by (lfun &optional at-pc) + (let* ((regs-used nil) + (where-saved nil) + (instr (%code-vector-last-instruction (uvref lfun 0)))) + (if (eql (ldb (byte 6 26) instr) 32) ; LWZ + (let* ((nregs (- 32 (ldb (byte 5 21) instr))) + (pc (dpb (ldb (byte 2 0) instr) (byte 2 5) (ldb (byte 5 16) instr))) + (offset (%word-to-int (logand instr (lognot 7))))) + (declare (fixnum nregs pc offset)) + (setq regs-used (1- (ash 1 nregs))) + (if at-pc + (if (>= at-pc pc) + (setq where-saved (- (ash (- offset) -3) nregs)) + (setq regs-used nil))))) + (values (and regs-used (bit-reverse-8 regs-used)) where-saved))) + + +(defparameter *bit-reverse-8-table* + #.(let ((table (make-array 256 :element-type '(unsigned-byte 8)))) + (dotimes (i 256) + (let ((j 0) + (out-mask (ash 1 7))) + (declare (fixnum j out-mask)) + (dotimes (bit 8) + (when (logbitp bit i) + (setq j (logior j out-mask))) + (setq out-mask (ash out-mask -1))) + (setf (aref table i) j))) + table)) + +(defun bit-reverse-8 (x) + (aref *bit-reverse-8-table* x)) + +(defun %frame-savefn (p) + (if (fake-stack-frame-p p) + (%fake-stack-frame.fn p) + (%%frame-savefn p))) + +(defun %frame-savevsp (p) + (if (fake-stack-frame-p p) + (%fake-stack-frame.vsp p) + (%%frame-savevsp p))) + +(defun frame-vsp (frame) + (%frame-savevsp frame)) + +;;; Return two values: the vsp of p and the vsp of p's "parent" frame. +;;; The "parent" frame vsp might actually be the end of p's segment, +;;; if the real "parent" frame vsp is in another segment. +(defun vsp-limits (p context) + (let* ((vsp (%frame-savevsp p)) + parent) + (when (eql vsp 0) + ; This frame is where the code continues after an unwind-protect cleanup form + (setq vsp (%frame-savevsp (child-frame p context)))) + (flet ((grand-parent (frame) + (let ((parent (parent-frame frame context))) + (when (and parent (eq parent (%frame-backlink frame context))) + (let ((grand-parent (parent-frame parent context))) + (when (and grand-parent (eq grand-parent (%frame-backlink parent context))) + grand-parent)))))) + (declare (dynamic-extent #'grand-parent)) + (let* ((frame p) + grand-parent) + (loop + (setq grand-parent (grand-parent frame)) + (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent)))) + (return)) + (setq frame grand-parent)) + (setq parent (parent-frame frame context))) + (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp)) + (tcr (if context (bt.tcr context) (%current-tcr))) + (vsp-area (%fixnum-ref tcr target::tcr.vs-area))) + (if (eql 0 parent-vsp) + (values vsp vsp) ; p is the kernel frame pushed by an unwind-protect cleanup form + (progn + (unless vsp-area + (error "~s is not a stack frame pointer for context ~s" p tcr)) + (unless (%ptr-in-area-p parent-vsp vsp-area) + (setq parent-vsp (%fixnum-ref vsp-area target::area.high))) + (values vsp parent-vsp))))))) + + +(defun catch-csp-p (p context) + (let ((catch (if context + (bt.top-catch context) + (%catch-top (%current-tcr))))) + (loop + (when (null catch) (return nil)) + (let ((sp (catch-frame-sp catch))) + (when (eql sp p) + (return t))) + (setq catch (next-catch catch))))) + +(defun last-catch-since (sp context) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (catch (%catch-top tcr)) + (last-catch nil)) + (loop + (unless catch (return last-catch)) + (let ((csp (uvref catch target::catch-frame.csp-cell))) + (when (%stack< sp csp context) (return last-catch)) + (setq last-catch catch + catch (next-catch catch)))))) + +(defun register-number->saved-register-index (regno) + (- regno ppc::save7)) + +(defun %find-register-argument-value (context cfp regval bad) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp + (child-frame frame context)) + (first t)) + ((null frame)) + (if (fake-stack-frame-p frame) + (return-from %find-register-argument-value + (xp-gpr-lisp (%fake-stack-frame.xp frame) regval)) + (if first + (setq first nil) + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + (return-from + %find-register-argument-value + (raw-frame-ref frame context where bad))))))))) + (get-register-value nil last-catch index))) + +(defun %set-register-argument-value (context cfp regval new) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp + (child-frame frame context)) + (first t)) + ((null frame)) + (if (fake-stack-frame-p frame) + (return-from %set-register-argument-value + (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new)) + (if first + (setq first nil) + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + (return-from + %set-register-argument-value + (raw-frame-set frame context where new))))))))) + (set-register-value new nil last-catch index))) + +(defun %raw-frame-ref (cfp context idx bad) + (declare (fixnum idx)) + (multiple-value-bind (frame base) + (vsp-limits cfp context) + (let* ((raw-size (- base frame))) + (declare (fixnum frame base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (oldest-binding-frame-value context addr) + (%fixnum-ref addr))))) + bad)))) + +(defun %raw-frame-set (cfp context idx new) + (declare (fixnum idx)) + (multiple-value-bind (frame base) + (vsp-limits cfp context) + (let* ((raw-size (- base frame))) + (declare (fixnum frame base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (setf (oldest-binding-frame-value context addr) new) + (setf (%fixnum-ref addr) new)))) + t))))) + +;;; Used for printing only. +(defun index->address (p) + (when (fake-stack-frame-p p) + (setq p (%fake-stack-frame.sp p))) + (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0) (ash p target::fixnumshift))) + + +(defun match-local-name (cellno info pc) + (when info + (let* ((syms (%car info)) + (ptrs (%cdr info))) + (dotimes (i (length syms)) + (let ((j (%i+ i (%i+ i i )))) + (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77)) + (%i>= pc (uvref ptrs (%i+ j 1))) + (%i< pc (uvref ptrs (%i+ j 2))) + (return (aref syms i)))))))) + +(defun get-register-value (address last-catch index) + (if address + (%fixnum-ref address) + (uvref last-catch (+ index target::catch-frame.save-save7-cell)))) + +;;; Inverse of get-register-value + +(defun set-register-value (value address last-catch index) + (if address + (%fixnum-set address value) + (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell)) + value))) + +;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's +;;; pretty PPC-specific + +;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there. +(defun set-lisp-data (vstack-index data) + (let* ((old (%access-lisp-data vstack-index))) + (if (closed-over-value-p old) + (set-closed-over-value old data) + (%store-lisp-data vstack-index data)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;extensions to let user access and modify values + + + + + +;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace" + + + + + + +(defparameter *saved-register-count+1* + (1+ *saved-register-count*)) + + + +(defparameter *saved-register-numbers* + #+x8664-target #(wrong) + #+ppc-target #(31 30 29 28 27 26 25 24)) + +;;; Don't do unbound checks in compiled code +(declaim (type t *saved-register-count* *saved-register-count+1* + *saved-register-names* *saved-register-numbers*)) + +(defmacro %cons-saved-register-vector () + `(make-array (the fixnum *saved-register-count+1*) :initial-element nil)) + +(defun copy-srv (from-srv &optional to-srv) + (if to-srv + (if (eq from-srv to-srv) + to-srv + (dotimes (i (uvsize from-srv) to-srv) + (setf (uvref to-srv i) (uvref from-srv i)))) + (copy-uvector from-srv))) + +(defmacro srv.unresolved (saved-register-vector) + `(svref ,saved-register-vector 0)) + +(defmacro srv.register-n (saved-register-vector n) + `(svref ,saved-register-vector (1+ ,n))) + +;;; This isn't quite right - has to look at all functions on stack, +;;; not just those that saved VSPs. + + +(defun frame-restartable-p (target &optional context) + (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context) + (when frame + (loop + (when (null frame) + (return-from frame-restartable-p nil)) + (when (eq frame target) (return)) + (multiple-value-setq (frame last-catch srv) + (ccl::parent-frame-saved-vars context frame last-catch srv srv))) + (when (and srv (eql 0 (srv.unresolved srv))) + (setf (srv.unresolved srv) last-catch) + srv)))) + + +;;; get the saved register addresses for this frame +;;; still need to worry about this unresolved business +;;; could share some code with parent-frame-saved-vars +(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector))) + (let ((unresolved 0)) + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (if lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (when mask + (if (not where) + (setq unresolved (%ilogior unresolved mask)) + (let ((vsp (- (frame-vsp frame) where (1- (logcount mask)))) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (when (%ilogbitp (decf j) mask) + (setf (srv.register-n srv-out i) vsp + vsp (1+ vsp) + unresolved (%ilogand unresolved (%ilognot (%ilsl j 1)))))))))) + (setq unresolved (1- (ash 1 *saved-register-count*))))) + (setf (srv.unresolved srv-out) unresolved) + srv-out)) + +(defun parent-frame-saved-vars + (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector))) + (copy-srv srv srv-out) + (let* ((parent (and frame (parent-frame frame context))) + (grand-parent (and parent (parent-frame parent context)))) + (when grand-parent + (loop (let ((next-catch (and last-catch (next-catch last-catch)))) + ;(declare (ignore next-catch)) + (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context)) + (progn + (setf last-catch next-catch + (srv.unresolved srv-out) 0) + (dotimes (i *saved-register-count*) + (setf (srv.register-n srv i) nil))) + (return)))) + (lookup-registers parent context grand-parent srv-out) + (values parent last-catch srv-out)))) + +(defun lookup-registers (parent context grand-parent srv-out) + (unless (or (eql (frame-vsp grand-parent) 0) + (let ((gg-parent (parent-frame grand-parent context))) + (eql (frame-vsp gg-parent) 0))) + (multiple-value-bind (lfun pc) (cfp-lfun parent) + (when lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (when mask + (locally (declare (fixnum mask)) + (if (not where) + (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask)) + (let* ((grand-parent-vsp (frame-vsp grand-parent))) + + (let ((vsp (- grand-parent-vsp where 1)) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (when (%ilogbitp (decf j) mask) + (setf (srv.register-n srv-out i) vsp + vsp (1- vsp) + (srv.unresolved srv-out) + (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1)))))))))))))))) + +;;; initialization for looping on parent-frame-saved-vars +(defun last-catch-since-saved-vars (frame context) + (let* ((parent (parent-frame frame context)) + (last-catch (and parent (last-catch-since parent context)))) + (when last-catch + (let ((frame (catch-frame-sp last-catch)) + (srv (%cons-saved-register-vector))) + (setf (srv.unresolved srv) 0) + (let* ((parent (parent-frame frame context)) + (child (and parent (child-frame parent context)))) + (when child + (lookup-registers child context parent srv)) + (values child last-catch srv)))))) + +;;; Returns 2 values: +;;; mask srv +;;; The mask says which registers are used at PC in LFUN. srv is a +;;; saved-register-vector whose register contents are the register +;;; values registers whose bits are not set in MASK or set in +;;; UNRESOLVED will be returned as NIL. + +(defun saved-register-values + (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector))) + (declare (ignore child)) + (cond ((null srv-out) (setq srv-out (copy-uvector srv))) + ((eq srv-out srv)) + (t (dotimes (i (the fixnum (uvsize srv))) + (setf (uvref srv-out i) (uvref srv i))))) + (let ((mask (or (registers-used-by lfun pc) 0)) + (unresolved (srv.unresolved srv)) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (setf (srv.register-n srv-out i) + (and (%ilogbitp (setq j (%i- j 1)) mask) + (not (%ilogbitp j unresolved)) + (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j))))) + (setf (srv.unresolved srv-out) mask) + (values mask srv-out))) + +; Set the nth saved register to value. +(defun set-saved-register (value n lfun pc child last-catch srv) + (declare (ignore lfun pc child) (dynamic-extent)) + (let ((j (- target::node-size n)) + (unresolved (srv.unresolved srv)) + (addr (srv.register-n srv n))) + (when (logbitp j unresolved) + (error "Can't set register ~S to ~S" n value)) + (set-register-value value addr last-catch j)) + value) + + + + + +(defun return-from-nth-frame (n &rest values) + (apply-in-nth-frame n #'values values)) + +(defun apply-in-nth-frame (n fn arglist) + (let* ((bt-info (car *backtrace-contexts*))) + (and bt-info + (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info))) + (and frame (apply-in-frame frame fn arglist))))) + (format t "Can't return to frame ~d ." n)) + +;;; This method is shadowed by one for the backtrace window. +(defmethod nth-frame (w target n context) + (declare (ignore w)) + (and target (dotimes (i n target) + (declare (fixnum i)) + (unless (setq target (parent-frame target context)) (return nil))))) + +; If this returns at all, it's because the frame wasn't restartable. +(defun apply-in-frame (frame fn arglist &optional context) + (let* ((srv (frame-restartable-p frame context)) + (target-sp (and srv (srv.unresolved srv)))) + (if target-sp + (apply-in-frame-internal context frame fn arglist srv)))) + +(defun apply-in-frame-internal (context frame fn arglist srv) + (let* ((tcr (if context (bt.tcr context) (%current-tcr)))) + (if (eq tcr (%current-tcr)) + (%apply-in-frame frame fn arglist srv) + (let ((process (tcr->process tcr))) + (if process + (process-interrupt + process + #'%apply-in-frame + frame fn arglist srv) + (error "Can't find active process for ~s" tcr)))))) + + +(defun return-from-frame (frame &rest values) + (apply-in-frame frame #'values values nil)) + + +;;; (srv.unresolved srv) is the last catch frame, left there by +;;; frame-restartable-p The registers in srv are locations of +;;; variables saved between frame and that catch frame. +(defun %apply-in-frame (frame fn arglist srv) + (declare (fixnum frame)) + (let* ((catch (srv.unresolved srv)) + (tsp-count 0) + (tcr (%current-tcr)) + (parent (parent-frame frame tcr)) + (vsp (frame-vsp parent)) + (catch-top (%catch-top tcr)) + (db-link (%svref catch target::catch-frame.db-link-cell)) + (catch-count 0)) + (declare (fixnum parent vsp db-link catch-count)) + ;; Figure out how many catch frames to throw through + (loop + (unless catch-top + (error "Didn't find catch frame")) + (incf catch-count) + (when (eq catch-top catch) + (return)) + (setq catch-top (next-catch catch-top))) + ;; Figure out where the db-link should be + (loop + (when (or (eql db-link 0) (>= db-link vsp)) + (return)) + (setq db-link (%fixnum-ref db-link))) + ;; Figure out how many TSP frames to pop after throwing. + (let ((sp (catch-frame-sp catch))) + (loop + (multiple-value-bind (f pc) (cfp-lfun sp) + (when f (incf tsp-count (active-tsp-count f pc)))) + (setq sp (parent-frame sp tcr)) + (when (eql sp parent) (return)) + (unless sp (error "Didn't find frame: ~s" frame)))) + #+debug + (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)" + catch-count srv tsp-count db-link parent fn arglist) + (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist))) + + + + +;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Code to determine how many tsp frames to pop. +;;; This is done by parsing the code. +;;; active-tsp-count is the entry point below. +;;; + +(defstruct (branch-tree (:print-function print-branch-tree)) + first-instruction + last-instruction + branch-target ; a branch-tree or nil + fall-through) ; a branch-tree or nil + +(defun print-branch-tree (tree stream print-level) + (declare (ignore print-level)) + (print-unreadable-object (tree stream :type t :identity t) + (format stream "~s-~s" + (branch-tree-first-pc tree) + (branch-tree-last-pc tree)))) + +(defun branch-tree-first-pc (branch-tree) + (let ((first (branch-tree-first-instruction branch-tree))) + (and first (instruction-element-address first)))) + +(defun branch-tree-last-pc (branch-tree) + (let ((last (branch-tree-last-instruction branch-tree))) + (if last + (instruction-element-address last) + (branch-tree-first-pc branch-tree)))) + +(defun branch-tree-contains-pc-p (branch-tree pc) + (<= (branch-tree-first-pc branch-tree) + pc + (branch-tree-last-pc branch-tree))) + +(defvar *branch-tree-hash* + (make-hash-table :test 'eq :weak :value)) + +(defun get-branch-tree (function) + (or (gethash function *branch-tree-hash*) + (let* ((dll (function-to-dll-header function)) + (tree (dll-to-branch-tree dll))) + (setf (gethash function *branch-tree-hash*) tree)))) + +; Return the number of TSP frames that will be active after throwing out +; of all the active catch frames in function at pc. +; PC is a byte address, a multiple of 4. +(defun active-tsp-count (function pc) + (setq function + (require-type + (if (symbolp function) + (symbol-function function) + function) + 'compiled-function)) + (let* ((tree (get-branch-tree function)) + (visited nil)) + (labels ((find-pc (branch path) + (unless (memq branch visited) + (push branch path) + (if (branch-tree-contains-pc-p branch pc) + path + (let ((target (branch-tree-branch-target branch)) + (fall-through (branch-tree-fall-through branch))) + (push branch visited) + (if fall-through + (or (and target (find-pc target path)) + (find-pc fall-through path)) + (and target (find-pc target path)))))))) + (let* ((path (nreverse (find-pc tree nil))) + (last-tree (car (last path))) + (catch-count 0) + (tsp-count 0)) + (unless path + (error "Can't find path to pc: ~s in ~s" pc function)) + (dolist (tree path) + (let ((next (branch-tree-first-instruction tree)) + (last (branch-tree-last-instruction tree))) + (loop + (when (and (eq tree last-tree) + (eql pc (instruction-element-address next))) + ; If the instruction before the current one is an ff-call, + ; then callback pushed a TSP frame. + #| ; Not any more + (when (ff-call-instruction-p (dll-node-pred next)) + (incf tsp-count)) + |# + (return)) + (multiple-value-bind (type target fall-through count) (categorize-instruction next) + (declare (ignore target fall-through)) + (case type + (:tsp-push + (when (eql catch-count 0) + (incf tsp-count count))) + (:tsp-pop + (when (eql catch-count 0) + (decf tsp-count count))) + ((:catch :unwind-protect) + (incf catch-count)) + (:throw + (decf catch-count count)))) + (when (eq next last) + (return)) + (setq next (dll-node-succ next))))) + tsp-count)))) + + +(defun dll-to-branch-tree (dll) + (let* ((hash (make-hash-table :test 'eql)) ; start-pc -> branch-tree + (res (collect-branch-tree (dll-header-first dll) dll hash)) + (did-something nil)) + (loop + (setq did-something nil) + (let ((mapper #'(lambda (key value) + (declare (ignore key)) + (flet ((maybe-collect (pc) + (when (integerp pc) + (let ((target-tree (gethash pc hash))) + (if target-tree + target-tree + (progn + (collect-branch-tree (dll-pc->instr dll pc) dll hash) + (setq did-something t) + nil)))))) + (declare (dynamic-extent #'maybe-collect)) + (let ((target-tree (maybe-collect (branch-tree-branch-target value)))) + (when target-tree (setf (branch-tree-branch-target value) target-tree))) + (let ((target-tree (maybe-collect (branch-tree-fall-through value)))) + (when target-tree (setf (branch-tree-fall-through value) target-tree))))))) + (declare (dynamic-extent mapper)) + (maphash mapper hash)) + (unless did-something (return))) + ; To be totally correct, we should fix up the trees containing + ; the BLR instruction for unwind-protect cleanups, but none + ; of the users of this code yet care that it appears that the code + ; stops there. + res)) + +(defun collect-branch-tree (instr dll hash) + (unless (eq instr dll) + (let ((tree (make-branch-tree :first-instruction instr)) + (pred nil) + (next instr)) + (setf (gethash (instruction-element-address instr) hash) + tree) + (loop + (when (eq next dll) + (setf (branch-tree-last-instruction tree) pred) + (return)) + (multiple-value-bind (type target fall-through) (categorize-instruction next) + (case type + (:label + (when pred + (setf (branch-tree-last-instruction tree) pred + (branch-tree-fall-through tree) (instruction-element-address next)) + (return))) + ((:branch :catch :unwind-protect) + (setf (branch-tree-last-instruction tree) next + (branch-tree-branch-target tree) target + (branch-tree-fall-through tree) fall-through) + (return)))) + (setq pred next + next (dll-node-succ next))) + tree))) + +;;; Returns 4 values: +;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop +;;; 2) branch target (or catch or unwind-protect cleanup) +;;; 3) branch-fallthrough (or catch or unwind-protect body) +;;; 4) Count for throw, tsp-push, tsp-pop +(defun categorize-instruction (instr) + (etypecase instr + (lap-label :label) + (lap-instruction + (let* ((opcode (lap-instruction-opcode instr)) + (opcode-p (typep opcode 'opcode)) + (name (if opcode-p (opcode-name opcode) opcode)) + (pc (lap-instruction-address instr)) + (operands (lap-instruction-parsed-operands instr))) + (cond ((equalp name "bla") + (let ((subprim (car operands))) + (case subprim + (.SPmkunwind + (values :unwind-protect (+ pc 4) (+ pc 8))) + ((.SPmkcatch1v .SPmkcatchmv) + (values :catch (+ pc 4) (+ pc 8))) + (.SPthrow + (values :branch nil nil)) + ((.SPnthrowvalues .SPnthrow1value) + (let* ((prev-instr (require-type (lap-instruction-pred instr) + 'lap-instruction)) + (prev-name (opcode-name (lap-instruction-opcode prev-instr))) + (prev-operands (lap-instruction-parsed-operands prev-instr))) + ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I + ; can't imagine we'll ever see them + (unless (and (equalp prev-name "li") + (equalp (car prev-operands) "imm0")) + (error "Can't determine throw count for ~s" instr)) + (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift))))) + ((.SPprogvsave + .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg + .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector + .SPstkconslist .SPstkconslist-star + .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init + .SPstkvcell0 .SPstkvcellvsp + .SPsave-values) + (values :tsp-push nil nil 1)) + (.SPrecover-values + (values :tsp-pop nil nil 1)) + (t :regular)))) + ((or (equalp name "lwz") (equalp name "addi")) + (if (equalp (car operands) "tsp") + (values :tsp-pop nil nil 1) + :regular)) + ((equalp name "stwu") + (if (equalp (car operands) "tsp") + (values :tsp-push nil nil 1) + :regular)) + ((member name '("ba" "blr" "bctr") :test 'equalp) + (values :branch nil nil)) + ; It would probably be faster to determine the branch address by adding the PC and the offset. + ((equalp name "b") + (values :branch (branch-label-address instr (car (last operands))) nil)) + ((and opcode-p (eql (opcode-majorop opcode) 16)) + (values :branch (branch-label-address instr (car (last operands))) (+ pc 4))) + (t :regular)))))) + +(defun branch-label-address (instr label-name &aux (next instr)) + (loop + (setq next (dll-node-succ next)) + (when (eq next instr) + (error "Couldn't find label ~s" label-name)) + (when (and (typep next 'lap-label) + (eq (lap-label-name next) label-name)) + (return (instruction-element-address next))))) + +(defun dll-pc->instr (dll pc) + (let ((next (dll-node-succ dll))) + (loop + (when (eq next dll) + (error "Couldn't find pc: ~s in ~s" pc dll)) + (when (eql (instruction-element-address next) pc) + (return next)) + (setq next (dll-node-succ next))))) + +(defun exception-frame-p (frame) + (fake-stack-frame-p frame)) + +(defun arg-check-call-arguments (frame function) + (declare (ignore function)) + (xp-argument-list (%fake-stack-frame.xp frame))) Index: /branches/qres/ccl/lib/ppc-init-ccl.lisp =================================================================== --- /branches/qres/ccl/lib/ppc-init-ccl.lisp (revision 13564) +++ /branches/qres/ccl/lib/ppc-init-ccl.lisp (revision 13564) @@ -0,0 +1,64 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +a;;; Opensourced MCL 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;(setq *save-local-symbols* t) + +#+ppc-target +(progn +(breaker) +(format t "~&Initializing Macintosh Common Lisp ...") +(setq *load-verbose* t) +(setq *warn-if-redefine* nil) +(setq *.fasl-pathname* (pathname ".pfsl")) ; leave it? +(setq *.pfsl-pathname* (pathname ".pfsl")) +(setq *fasl-target* :ppc) +(setq *save-exit-functions* nil) + +(require 'compile-ccl) +(ppc-load-ccl) + +(setq *warn-if-redefine* t) +(setq *load-verbose* nil) +(format t "~&Macintosh Common Lisp Loaded") + +(defun save-mcl-libraries (&optional (suffix "")) + (save-library (concatenate 'string "ccl:ccl;pmcl-compiler" suffix) + "pmcl-compiler" *nx-start* *nx-end*) + ; More here ? + ; Pick up the leftovers ... + (save-library (concatenate 'string "ccl:ccl;pmcl-library" suffix) + "pmcl-library" nil nil)) + +(defun save-it (&optional (suffix "")) + (save-mcl-libraries (and suffix (concatenate 'string "-" suffix))) + (let ((prefix "ccl:ccl;PPCCL")) + (save-application (if suffix + (concatenate 'string prefix " " suffix) + prefix)))) + +;(save-application "ccl;CCL") +) +; End of init-ccl.lisp Index: /branches/qres/ccl/lib/ppcenv.lisp =================================================================== --- /branches/qres/ccl/lib/ppcenv.lisp (revision 13564) +++ /branches/qres/ccl/lib/ppcenv.lisp (revision 13564) @@ -0,0 +1,93 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant $numppcsaveregs 8) +(defconstant $numppcargregs 3) + + +(defconstant ppc-nonvolatile-registers-mask + (logior (ash 1 ppc::save0) + (ash 1 ppc::save1) + (ash 1 ppc::save2) + (ash 1 ppc::save3) + (ash 1 ppc::save4) + (ash 1 ppc::save5) + (ash 1 ppc::save6) + (ash 1 ppc::save7))) + +(defconstant ppc-arg-registers-mask + (logior (ash 1 ppc::arg_z) + (ash 1 ppc::arg_y) + (ash 1 ppc::arg_x))) + +(defconstant ppc-temp-registers-mask + (logior (ash 1 ppc::temp0) + (ash 1 ppc::temp1) + (ash 1 ppc::temp2) + (ash 1 ppc::temp3))) + + +(defconstant ppc-tagged-registers-mask + (logior ppc-temp-registers-mask + ppc-arg-registers-mask + ppc-nonvolatile-registers-mask)) + + + +(defconstant ppc-temp-node-regs + (make-mask ppc::temp0 + ppc::temp1 + ppc::temp2 + ppc::temp3 + ppc::arg_x + ppc::arg_y + ppc::arg_z)) + +(defconstant ppc-nonvolatile-node-regs + (make-mask ppc::save0 + ppc::save1 + ppc::save2 + ppc::save3 + ppc::save4 + ppc::save5 + ppc::save6 + ppc::save7)) + + +(defconstant ppc-node-regs (logior ppc-temp-node-regs ppc-nonvolatile-node-regs)) + +(defconstant ppc-imm-regs (make-mask + ppc::imm0 + ppc::imm1 + ppc::imm2 + ppc::imm3 + ppc::imm4 + ppc::imm5)) + +(defconstant ppc-temp-fp-regs (1- (ash 1 ppc::fp14))) + +(defconstant ppc-cr-fields + (make-mask 0 (ash 4 -2) (ash 8 -2) (ash 12 -2) (ash 16 -2) (ash 20 -2) (ash 24 -2) (ash 28 -2))) + + + +(defconstant $undo-ppc-c-frame 16) + + +(ccl::provide "PPCENV") Index: /branches/qres/ccl/lib/pprint.lisp =================================================================== --- /branches/qres/ccl/lib/pprint.lisp (revision 13564) +++ /branches/qres/ccl/lib/pprint.lisp (revision 13564) @@ -0,0 +1,2035 @@ +;-*-syntax:COMMON-LISP;Package:"CCL"-*- + +;; Change History (most recent first): +;; 2 4/8/97 akh pretty-loop dont loop +;; 3 12/13/95 Alice Hartley no call compiler at load time +;; 3 3/2/95 akh will promote strings to fat strings if needed +;; (do not edit before this line!!) + + +;------------------------------------------------------------------------ + +;Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge, +;Massachusetts. + +;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. + +;------------------------------------------------------------------------ + +;This file "XP.LISP" implements an efficient pretty printer for Common +;Lisp. The functions in this file are documented fully in MIT/AIM-1102a, July +;1989. This report can be obtained by sending $3.25 to + +; Publications +; MIT AI Laboratory +; 545 Tech. Sq. +; Cambridge MA 02139 + +;This file attempts to be as compatible with pure Common Lisp as possible. +;It has been tested on the following Common Lisps to date (7/31/89). +; Symbolics CL version 7 (does not work in version 6), +; LUCID CL version 3.0.2 on a sun. +; Allegro CL version 1.2.1 on a Macintosh. +; CMU CL. + +;The companion file "XPTEST.LISP" contains a set of 600+ tests. You should +;run these tests after the first time you compile this file on a new system. + +;The companion file "XPDOC.TXT" contains brief documentation +; 04/05/97 akh pretty-loop fix for *print-level* exceeded +; 10/26/95 slh %gvector -> %istruct +; 08/26/93 bill indentation +; -------- 3.0d12 +; 06/26/93 alice stream-fresh-line (xp-stream) was producing premature newlines +; 05/24/93 alice *free-xps* and *free-circularity-hash-tables* are global +; 03/04/93 alice set *error-print-circle* to T +; 02/23/93 alice get-printer - look in others table before def.., with.. hack +; 02/15/93 alice don't unwind-protect in pprint-logical-block+ +; 12/21/92 alice lets not print loop as #' +; 06/23/92 alice change set-pprint-dispatch+ and priority-> so '(0) is less than 0 +;--------------- 2.0 +; 02/22/92 (alice from "post 2.0f2c5:pprint-defmethod-patch") fix DEFMETHOD-LIKE. +; -------- 2.0f2c5 +; 01/29/92 gb pretty-structure calls structure-print-function. +; -------- 2.0f2 +; 10/11/91 alice dont print generic-function as #' +; 10/09/91 alice write+ don't deal with structures and arrays - prior fix was brain dead +; p.s. technically we shouldn't special case strings, fixnums and symbols either +; 10/03/91 alice write+ - if print-object method for structure use it. +; 09/25/91 alice fix circularity-process so we can rebind *print-circle* in mid stream +; 09/25/91 alice pretty-structure - no dangling space if no slots +; 09/24/91 alice fix pretty-structure bogus keyword printing +; 09/11/91 alice keep first pass output until first circularity in case no circularities +; 09/09/91 alice fix print circle in case circularity detected after first line (geez) +; dont die if *print-pprint-dispatch* is nil +;--------------- 2.0b3 +; 08/21/91 gb xp-stream-stream +; 07/21/91 gb def-accessors vice defstruct. +; 07/09/91 alice allow write+ to tail call +; 07/01/91 bind level and length as (f *print-readably*) +; 07/01/91 generic-function & reinstate some MLY hacks for "def.." "with-.." etc. +; 06/24/91 added pretty-structure +; 05/22/91 Modified for MCL 2.0b +;;;;;;;;;;;;;; +;;; lisp: => cl: +;;; string-char => character (or base-character?) +;;; #-ccl-2 compiled format and format and much else +;;; put the xp-stream in the xp-structure +;;; write-char => write-char+ in pretty-loop +;;; nuke *last-abbreviated-printing* +;;; Teach it about fred-special-indent-alist +;;; in fred-alist 2 means defun-like, 0 is progn-like +;;; 3 is defsetf-print , 1 is block-like +;;; Put circularity table & number in the structure? - didn't do it +;;; Nuke the xp package +;;; Added progn-print +;;; MAYBELAB take xp-stream or xp-structure +;;; Gave up on #+/#-ccl-2 +;;; Could save a few hundred bytes by (funcall (formatter ...)) to (format ... )) - maybe not +;;; The dispatch table could use some compacting: done! +;;; an entry contains test: 0 - must be some predicate if not of the other form +;;; fn: ok +;;; full-spec: '((0)(cons (member defvar))) +;;; Nuke *print-shared* and *parents* +;;; This version has a new special *xp-current-object* but doesnt gratuitously cons. +;;; Fixed circle doing it twice when it needn't (what does this break?) +;;; member => memq +;;; Apply optimizations as Mly did in prior conversion, i.e. liberal doses +;;; of %i+, (declare (fixnum ...)), dont fetch a stucture field 15 times +;;; when once will suffice, no char=, fewer position & find +;;; Now about same speed as old one. (actually 10% slower) & it conses less +;;; In pprint-dispatch just store the function if (cons (member blah)) & (0) or 0. +;;; nuke some entries in pprint-dispatch where same info is in fred-special-indent-alist +;;; Size is down from 23K larger to 18K larger. +;;; maybe-print-fast iff readtable-case is :upcase +;;; add defmethod-like for guess what +;;; nuke *abbreviation-happened* + + + +(in-package "CCL") + +(defvar *ipd* nil ;see initialization at end of file. + "initial print dispatch table.") + +(eval-when (:compile-toplevel :execute) + (declaim (inline xp-structure-p))) + +(defun xp-structure-p (x) + (istruct-typep x 'xp-structure)) + + +(defun entry-p (x) + (istruct-typep x 'entry)) + + + +;default (bad) definitions for the non-portable functions + +(eval-when (:execute :load-toplevel :compile-toplevel) +(defun structure-type-p (x) (structurep x)) +(defun output-width (&optional (s *standard-output*)) + (when (streamp s)(line-length s))) +(defun output-position (&optional (s *standard-output*)) + (when (streamp s)(column s))) +) + +(defvar *logical-block-p* nil + "True if currently inside a logical block.") + +(defvar *locating-circularities* nil + "Integer if making a first pass over things to identify circularities. + Integer used as counter for #n= syntax.") + +(def-standard-initial-binding *free-circularity-hash-tables* nil) + +(defun get-circularity-hash-table () + (let ((table (pop *free-circularity-hash-tables*))) + (if table table (make-hash-table :test 'eq)))) + +;If you call this, then the table gets efficiently recycled. +(defun free-circularity-hash-table (table) + (clrhash table) + (pushnew table *free-circularity-hash-tables*)) + + + +; ---- DISPATCHING ---- + +(cl:defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil)) + (conses-with-cars (make-hash-table :test #'eq) :type hash-table) + (structures (make-hash-table :test #'eq) :type (or null hash-table)) + (others nil :type list)) + +;The list and the hash-tables contain entries of the +;following form. When stored in the hash tables, the test entry is +;the number of entries in the OTHERS list that have a higher priority. + +(defun make-entry (&key test fn full-spec) + (%istruct 'entry test fn full-spec)) + +(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) + (let* ((table (if (null table) + *IPD* + (require-type table '(or nil pprint-dispatch-table)))) + (new-conses-with-cars + (make-hash-table :test #'eq + :size (max (hash-table-count (conses-with-cars table)) 32))) + (new-structures NIL)) + (maphash #'(lambda (key value) + (setf (gethash key new-conses-with-cars) + (if (istruct-typep value 'entry)(copy-uvector value) value))) + (conses-with-cars table)) + (make-pprint-dispatch-table + :conses-with-cars new-conses-with-cars + :structures new-structures + :others (copy-list (others table))))) + + +(defun set-pprint-dispatch (type-specifier function + &optional (priority 0) (table *print-pprint-dispatch*)) + (when (or (not (numberp priority)) (complexp priority)) + (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority)) + (set-pprint-dispatch+ type-specifier function priority table)) + +(defun set-pprint-dispatch+ (type-specifier function priority table) + (let* ((category (specifier-category type-specifier)) + (pred + (if (not (eq category 'other)) nil + (let ((pred (specifier-fn type-specifier))) + (if (symbolp pred) + (symbol-function pred) + ; checking for (lambda (x) (foo x)) => #'foo + (if (and (consp (caddr pred)) + (symbolp (caaddr pred)) + (equal (cdaddr pred) '(x))) + (symbol-function (caaddr pred)) + ; calling the compiler at load time is an indictable offense + (compile nil pred)))))) + (entry (if function (make-entry :test pred + :fn function + :full-spec (list priority type-specifier))))) + (case category + (cons-with-car + (let ((key (cadadr type-specifier)) ;(cons (member FOO)) + (cons-tbl (conses-with-cars table))) + (cond ((null function) (remhash key cons-tbl)) + (T (let ((num + (count-if #'(lambda (e) + (priority-> e priority)) + (others table)))) + (cond ((and (or ;(eq priority 0) + (and (consp priority)(eq (%car priority) 0))) + (eq num 0)) + (setq entry function)) + (t (setf (entry-test entry) num))) + (setf (gethash key cons-tbl) entry)))))) + (T ;other + (let ((old (car (member type-specifier (others table) :test #'equal + :key #'(lambda (e) (cadr (entry-full-spec e))))))) + (when old + (setf (others table) (delete old (others table))) + (adjust-counts table (car (entry-full-spec old)) -1))) + (when entry + (let ((others (cons nil (others table)))) + (do ((l others (cdr l))) + ((null (cdr l)) (rplacd l (list entry))) + (when (priority-> priority (car (entry-full-spec (cadr l)))) + (rplacd l (cons entry (cdr l))) + (return nil))) + (setf (others table) (cdr others))) + (adjust-counts table priority 1))))) + nil) + +(defun priority-> (entry-x entry-y) + (flet ((foo (e) + (cond ((istruct-typep e 'entry)(car (entry-full-spec e))) + ((or (numberp e)(consp e)) e) + (t '(0))))) + (let ((x (foo entry-x)) + (y (foo entry-y))) + (if (consp x) + (if (consp y) (> (car x) (car y)) nil) + (if (consp y) T (> x y)))))) + + + +(defun adjust-counts (table priority delta) + (maphash #'(lambda (key value) + (when (priority-> priority value) + (when (not (istruct-typep value 'entry)) + (setf (gethash key (conses-with-cars table)) + (setq value (make-entry :fn value :test 0 :full-spec '(0))))) + (incf (entry-test value) delta))) + (conses-with-cars table))) + +(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) + (flet ((non-pretty-print (s object) + (write-not-pretty s object + (if (get-*print-frob* '*print-level*) + (- *print-level* *current-level*)) + nil nil))) + (when (null table) (setq table *IPD*)) + (let ((fn (get-printer object table))) + (values (or fn #'non-pretty-print) (not (null fn)))))) + +(defun get-printer (object table) + (when (null table)(setq table *IPD*)) + (let* (entry) + (cond ((consp object) + (setq entry (gethash (%car object) (conses-with-cars table))) + (when (not entry) + (setq entry (find object (others table) :test #'fits)) + (if entry + (setq entry (entry-fn entry))))) + (nil (setq entry (gethash (type-of object) (structures table))))) + (if (not entry) + (setq entry (find object (others table) :test #'fits)) + (if (istruct-typep entry 'entry) + (let ((test (entry-test entry))) + (when (numberp test) + (do ((i test (1- i)) + (l (others table) (cdr l))) + ((zerop i)) + (when (fits object (car l)) (setq entry (car l)) (return nil))))))) + (when entry + (if (istruct-typep entry 'entry)(entry-fn entry) entry)))) + +(defun fits (obj entry) + (funcall (entry-test entry) obj)) + +(defun specifier-category (spec) + (cond ((and (consp spec) + (eq (car spec) 'cons) + (consp (cdr spec)) + (null (cddr spec)) + (consp (cadr spec)) + (eq (caadr spec) 'member) + (consp (cdadr spec)) + (null (cddadr spec))) + 'cons-with-car) + (T 'other))) + + +; lets make fewer things fns that compile at load time, esp anything +; we do - really none should +(defun specifier-fn (spec) + (if (and (consp spec)(eq (car spec) 'satisfies)(symbolp (cadr spec))) + (cadr spec) + (if (and (symbolp spec)(type-predicate spec)) ; ccl specific + (type-predicate spec) + `(lambda (x) ,(convert-body spec))))) + +(defun convert-body (spec) + (cond ((atom spec) `(typep x ',spec)) + ((member (car spec) '(and or not)) + (cons (car spec) (mapcar #'convert-body (cdr spec)))) + ((eq (car spec) 'member) + `(member x ',(copy-list (cdr spec)))) + ((eq (car spec) 'cons) + `(and (consp x) + ,@(if (cdr spec) `((let ((x (car x))) + ,(convert-body (cadr spec))))) + ,@(if (cddr spec) `((let ((x (cdr x))) + ,(convert-body (caddr spec))))))) + ((eq (car spec) 'satisfies) + `(funcall (function ,(cadr spec)) x)) + (T `(typep x ',spec)))) + + +; ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ---- + +(eval-when (:execute :compile-toplevel) ;not used at run time. + (defvar block-stack-entry-size 1) + (defvar prefix-stack-entry-size 5) + (defvar queue-entry-size 7) + (defvar buffer-entry-size 1) + (defvar prefix-entry-size 1) + (defvar suffix-entry-size 1)) + +(eval-when (:execute :load-toplevel :compile-toplevel) ;used at run time + (defvar block-stack-min-size #.(* 35. block-stack-entry-size)) + (defvar prefix-stack-min-size #.(* 30. prefix-stack-entry-size)) + (defvar queue-min-size #.(* 75. queue-entry-size)) + (defvar buffer-min-size 256.) + (defvar prefix-min-size 256.) + (defvar suffix-min-size 256.)) + +(progn + (setf (symbol-function 'xp-stream-stream) #'(lambda (s) (xp-stream s))) + + (defmethod streamp ((x xp-structure)) t) + (defmethod streamp ((x xp-stream)) t) + + (defmethod output-stream-p ((x xp-structure)) t) + (defmethod output-stream-p ((x xp-stream)) t) + + (defun make-xp-structure () + (%istruct + 'xp-structure + nil ; xp-base-stream + nil ; xp-linel + nil ; xp-line-limit + nil ; xp-line-no + nil ; xp-char-mode + nil ; xp-char-mode-counter + nil ; xp-depth-in-blocks + (make-array #.block-stack-min-size) ; xp-block-stack + nil ; xp-block-stack-ptr + (make-array #.buffer-min-size :element-type 'base-char) + ; use make-string and let it default? + ; xp-buffer + nil ; xp-charpos + nil ; xp-buffer-ptr + nil ; xp-buffer-offset + (make-array #.queue-min-size) ; xp-queue + 0 ; xp-qleft + 0 ; xp-qright + (make-array #.buffer-min-size :element-type 'base-char) + ; xp-prefix + (make-array #.prefix-stack-min-size) ; xp-prefix-stack + nil ; xp-prefix-stack-ptr + (make-array #.buffer-min-size :element-type 'base-char) + ; xp-suffix + nil ; xp-stream + nil ; xp-string-stream + )) ; XP-STRUCTURE is a built-in class. + + (defmethod write-internal-1 ((xp-struc xp-structure) object level list-kludge) + (write-internal-1 (xp-stream xp-struc) object level list-kludge)) + + + + (defun get-xp-stream (pp) + (xp-stream pp)) + ) + + + +(eval-when (:compile-toplevel :execute) +(defmacro LP<-BP (xp &optional (ptr nil)) + (if (null ptr) (setq ptr `(xp-buffer-ptr ,xp))) + `(the fixnum (%i+ ,ptr (xp-charpos ,xp)))) +(defmacro TP<-BP (xp) + `(the fixnum (%i+ (xp-buffer-ptr ,xp) (xp-buffer-offset ,xp)))) +(defmacro BP<-LP (xp ptr) + `(the fixnum (%i- ,ptr (xp-charpos ,xp)))) +(defmacro BP<-TP (xp ptr) + `(the fixnum (%i- ,ptr (xp-buffer-offset ,xp)))) +;This does not tell you the line position you were at when the TP +;was set, unless there have been no newlines or indentation output +;between ptr and the current output point. +(defmacro LP<-TP (xp ptr) + `(LP<-BP ,xp (BP<-TP ,xp ,ptr))) + +;We don't use adjustable vectors or any of that, because we seldom have +;to actually extend and non-adjustable vectors are a lot faster in +;many Common Lisps. + +(defmacro xp-check-size (FORM ptr min-size entry-size + &optional (type '(simple-array * (*)))) + `(let ((.old. ,form) + (.ptr. ,ptr)) + (declare (type ,type .old.) (type fixnum .ptr.)) + (if (and (ccl::%i> .ptr. ,(- min-size entry-size)) ;seldom haxpens + (ccl::%i> .ptr. (- (length (the ,type .old.)) ,entry-size))) + (let ((.new. ,(let ((l `(ccl::%i+ .ptr. ,(if (= entry-size 1) + 50 + (* 10 entry-size))))) + `(make-array ,l :element-type (array-element-type .old.))))) + ;;>> + (replace .new. .old.) + (setf ,form .new.)) + .old.))) + +(defmacro section-start (xp) `(svref (xp-block-stack ,xp) (xp-block-stack-ptr ,xp))) +) ; eval-when + +; ---- CCL specific METHODS -------- +(progn +(defmethod stream-write-char ((stream xp-stream) char) + (write-char+ char (slot-value stream 'xp-structure)) + char) + +(defmethod stream-write-char ((stream xp-structure) char) + (write-char+ char stream) + char) + +(defmethod stream-write-string ((stream xp-stream) string &optional (start 0) end) + (setq end (check-sequence-bounds string start end)) + (write-string+ string (slot-value stream 'xp-structure) start end) + string) + +(defmethod stream-write-string ((stream xp-structure) string &optional (start 0) end) + (setq end (check-sequence-bounds string start end)) + (write-string+ string stream start end) + string) + +; If we really don't care about the value returned then just +; plain (pprint-newline+ :fresh xp) is fine. +(defmethod stream-fresh-line ((stream xp-stream)) + (let ((xp (slot-value stream 'xp-structure))) + (attempt-to-output xp nil nil) ; was (attempt-to-output xp T T) + (prog1 (not (zerop (LP<-BP xp))) + (pprint-newline+ :fresh xp)))) + + +(defmethod stream-finish-output ((stream xp-stream)) + (attempt-to-output (slot-value stream 'xp-structure) t t)) + +(defmethod stream-force-output ((stream xp-stream)) + (attempt-to-output (slot-value stream 'xp-structure) t t) + nil) + +(defmethod stream-clear-output ((stream xp-stream)) + (let ((*locating-circularities* 1)) ;hack to prevent visible output + (attempt-to-output (slot-value stream 'xp-structure) T T)) + nil) + +(defmethod stream-line-column ((stream xp-stream)) + (LP<-BP (slot-value stream 'xp-structure))) + +(defmethod stream-line-length ((stream xp-stream)) + (xp-linel (slot-value stream 'xp-structure))) + +) + + +(defun push-block-stack (xp) + (let ((ptr (%i+ (xp-block-stack-ptr xp) #.block-stack-entry-size))) + (setf (xp-block-stack-ptr xp) ptr) + (xp-check-size (xp-block-stack xp) ptr + #.block-stack-min-size #.block-stack-entry-size))) + +(eval-when (:compile-toplevel :execute) +(defmacro prefix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (xp-prefix-stack-ptr ,xp))) +(defmacro suffix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 1))) +(defmacro non-blank-prefix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 2))) +(defmacro initial-prefix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 3))) +(defmacro section-start-line (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 4))) + +(defmacro stk-prefix-ptr (stk ptr) + `(svref ,stk ,ptr)) +(defmacro stk-suffix-ptr (stk ptr) + `(svref ,stk (%i+ ,ptr 1))) +(defmacro stk-non-blank-prefix-ptr (stk ptr) + `(svref ,stk (%i+ ,ptr 2))) +) ; EVAL-when + + + +; saves 100 bytes and a microsecond or 2 +(defun push-prefix-stack (xp) + (let ((old-prefix 0) + (old-suffix 0) + (old-non-blank 0) + (stack (xp-prefix-stack xp)) + (ptr (xp-prefix-stack-ptr xp))) + (declare (fixnum ptr)) + (when (>= ptr 0) + (setq old-prefix (stk-prefix-ptr stack ptr) + old-suffix (stk-suffix-ptr stack ptr) + old-non-blank (stk-non-blank-prefix-ptr stack ptr))) + (setq ptr (%i+ ptr #.prefix-stack-entry-size)) + (setf (xp-prefix-stack-ptr xp) ptr) + (setq stack + (xp-check-size (xp-prefix-stack xp) ptr + #.prefix-stack-min-size #.prefix-stack-entry-size)) + (setf (stk-prefix-ptr stack ptr) old-prefix) + (setf (stk-suffix-ptr stack ptr) old-suffix) + (setf (stk-non-blank-prefix-ptr stack ptr) old-non-blank))) + + + +(eval-when (:compile-toplevel :execute) +(defmacro Qtype (xp index) `(svref (xp-queue ,xp) ,index)) +(defmacro Qkind (xp index) `(svref (xp-queue ,xp) (1+ ,index))) +(defmacro Qpos (xp index) `(svref (xp-queue ,xp) (+ ,index 2))) +(defmacro Qdepth (xp index) `(svref (xp-queue ,xp) (+ ,index 3))) +(defmacro Qend (xp index) `(svref (xp-queue ,xp) (+ ,index 4))) +(defmacro Qoffset (xp index) `(svref (xp-queue ,xp) (+ ,index 5))) +(defmacro Qarg (xp index) `(svref (xp-queue ,xp) (+ ,index 6))) +(defmacro xpq-type (queue index) + `(svref ,queue ,index)) +(defmacro xpq-kind (queue index) + `(svref ,queue (ccl::%i+ ,index 1))) +(defmacro xpq-pos (queue index) + `(svref ,queue (ccl::%i+ ,index 2))) +(defmacro xpq-depth (queue index) + `(svref ,queue (ccl::%i+ ,index 3))) +(defmacro xpq-end (queue index) + `(svref ,queue (ccl::%i+ ,index 4))) +(defmacro xpq-offset (queue index) + `(svref ,queue (ccl::%i+ ,index 5))) +(defmacro xpq-arg (queue index) + `(svref ,queue (ccl::%i+ ,index 6))) +) ; eval-when + +;we shift the queue over rather than using a circular queue because +;that works out to be a lot faster in practice. Note, short printout +;does not ever cause a shift, and even in long printout, the queue is +;shifted left for free every time it happens to empty out. + +(defun enqueue (xp type kind &optional arg) + (let ((queue (xp-queue xp)) + (qright (ccl::%i+ (xp-qright xp) #.queue-entry-size)) + (qleft (xp-qleft xp))) + (declare (type fixnum qright qleft) (type simple-vector queue)) + (when (ccl::%i> qright #.(- queue-min-size queue-entry-size)) + ;;>> generic + (replace queue queue :start2 qleft :end2 qright) + (setf (xp-qleft xp) 0 + qright (ccl::%i- qright qleft))) + (setq queue (xp-check-size (xp-queue xp) qright + #.queue-min-size #.queue-entry-size)) + (setf (xp-qright xp) qright + (xpq-type queue qright) type + (xpq-kind queue qright) kind + (xpq-pos queue qright) (TP<-BP xp) + (xpq-depth queue qright) (xp-depth-in-blocks xp) + (xpq-end queue qright) nil + (xpq-offset queue qright) nil + (xpq-arg queue qright) arg))) + +(defmacro Qnext (index) `(%i+ ,index #.queue-entry-size)) + + + +;This maintains a list of XP structures. We save them +;so that we don't have to create new ones all of the time. +;We have separate objects so that many can be in use at once. + +;(Note should really be doing some locking here, but CL does not have the +;primitives for it. There is a tiny probability here that two different +;processes could end up trying to use the same xp-stream) + +(def-standard-initial-binding *free-xps* nil) ;free list of XP stream objects + +(defun get-pretty-print-stream (stream) + (let ((xp (without-interrupts (pop *free-xps*)))) + (when (not xp)(setq xp (make-xp-structure))) + (initialize-xp xp stream) + (let ((the-xp-stream (make-instance 'xp-stream))) + (setf (slot-value the-xp-stream 'xp-structure) xp) + (setf (xp-stream xp) the-xp-stream) ; lets be circular + the-xp-stream))) + +;If you call this, the xp-stream gets efficiently recycled. + +(defun free-pretty-print-stream (xp) + (setf (xp-base-stream xp) nil) + (pushnew xp *free-xps*)) + +;This is called to initialize things when you start pretty printing. + +(defun initialize-xp (xp stream) + (setf (xp-base-stream xp) stream) + (setf (xp-linel xp) (max 0 (cond (*print-right-margin*) + ((output-width stream)) + (T *default-right-margin*)))) + (setf (xp-line-limit xp) *print-lines*) + (setf (xp-line-no xp) 1) + (setf (xp-char-mode xp) nil) + (setf (xp-char-mode-counter xp) 0) + (setf (xp-depth-in-blocks xp) 0) + (setf (xp-block-stack-ptr xp) 0) + (setf (xp-charpos xp) (cond ((output-position stream)) (T 0))) + (setf (section-start xp) 0) + (setf (xp-buffer-ptr xp) 0) + (setf (xp-buffer-offset xp) (xp-charpos xp)) + (setf (xp-qleft xp) 0) + (setf (xp-qright xp) #.(- queue-entry-size)) + (setf (xp-prefix-stack-ptr xp) #.(- prefix-stack-entry-size)) + (let ((s (xp-string-stream xp))) + (when s (stream-position s 0))) + xp) + + +;The char-mode stuff is a bit tricky. +;one can be in one of the following modes: +;NIL no changes to characters output. +;:UP CHAR-UPCASE used. +;:DOWN CHAR-DOWNCASE used. +;:CAP0 capitalize next alphanumeric letter then switch to :DOWN. +;:CAP1 capitalize next alphanumeric letter then switch to :CAPW +;:CAPW downcase letters. When a word break letter found, switch to :CAP1. +;It is possible for ~(~) to be nested in a format string, but note that +;each mode specifies what should happen to every letter. Therefore, inner +;nested modes never have any effect. You can just ignore them. + +(defun push-char-mode (xp new-mode) + (if (zerop (xp-char-mode-counter xp)) + (setf (xp-char-mode xp) new-mode)) + (incf (xp-char-mode-counter xp))) + +(defun pop-char-mode (xp) + (decf (xp-char-mode-counter xp)) + (if (zerop (xp-char-mode-counter xp)) + (setf (xp-char-mode xp) nil))) + +;Assumes is only called when char-mode is non-nil +(defun handle-char-mode (xp char) + (case (xp-char-mode xp) + (:CAP0 (cond ((not (alphanumericp char)) char) + (T (setf (xp-char-mode xp) :DOWN) (char-upcase char)))) + (:CAP1 (cond ((not (alphanumericp char)) char) + (T (setf (xp-char-mode xp) :CAPW) (char-upcase char)))) + (:CAPW (cond ((alphanumericp char) (char-downcase char)) + (T (setf (xp-char-mode xp) :CAP1) char))) + (:UP (char-upcase char)) + (T (char-downcase char)))) ;:DOWN + +;All characters output are passed through the handler above. However, it must +;be noted that on-each-line prefixes are only processed in the context of the +;first place they appear. They stay the same later no matter what. Also +;non-literal newlines do not count as word breaks. + + +;This handles the basic outputting of characters. note + suffix means that +;the stream is known to be an XP stream, all inputs are mandatory, and no +;error checking has to be done. Suffix ++ additionally means that the +;output is guaranteed not to contain a newline char. + +(defun write-char+ (char xp) + (if (eql char #\newline) (pprint-newline+ :unconditional xp) + (write-char++ char xp))) + +(defun write-string+ (string xp start end) + (let ((sub-end nil) next-newline) + (loop (setq next-newline + (if (typep string 'simple-string) + (%str-member #\newline string start end) + (position #\newline string :start start :end end :test #'eq ))) + (setq sub-end (if next-newline next-newline end)) + (write-string++ string xp start sub-end) + (when (null next-newline) (return nil)) + (pprint-newline+ :unconditional xp) + (setq start (%i+ 1 sub-end))))) + + + + +;note this checks (> BUFFER-PTR LINEL) instead of (> (LP<-BP) LINEL) +;this is important so that when things are longer than a line they +;end up getting printed in chunks of size LINEL. + +(defun write-char++ (char xp) + (when (> (xp-buffer-ptr xp) (xp-linel xp)) + (force-some-output xp)) + (let ((new-buffer-end (%i+ 1 (xp-buffer-ptr xp)))) + (xp-check-size (xp-buffer xp) new-buffer-end #.buffer-min-size #.buffer-entry-size) + (if (xp-char-mode xp) (setq char (handle-char-mode xp char))) + (setf (schar (xp-buffer xp) (xp-buffer-ptr xp)) char) + (setf (xp-buffer-ptr xp) new-buffer-end))) + + +(defun force-some-output (xp) + (attempt-to-output xp nil nil) + (when (> (xp-buffer-ptr xp) (xp-linel xp)) ;only if printing off end of line + (attempt-to-output xp T T))) + +(defun write-string++ (string xp start end) + (when (> (xp-buffer-ptr xp) (xp-linel xp)) + (force-some-output xp)) + (write-string+++ string xp start end)) + +;never forces output; therefore safe to call from within output-line. + +(defun write-string+++ (string xp start end) + (declare (fixnum start end)) + (let ((new-buffer-end (%i+ (xp-buffer-ptr xp) (- end start)))) + (xp-check-size (xp-buffer xp) new-buffer-end #.buffer-min-size #.buffer-entry-size) + (do ((buffer (xp-buffer xp)) + (i (xp-buffer-ptr xp) (1+ i)) + (j start (1+ j))) + ((= j end)) + (declare (fixnum i j)) + (let ((char (char string j))) + (if (xp-char-mode xp) (setq char (handle-char-mode xp char))) + (setf (schar buffer i) char))) + (setf (xp-buffer-ptr xp) new-buffer-end))) + +(defun pprint-tab+ (kind colnum colinc xp) + (let ((indented? nil) (relative? nil)) + (declare (fixnum colnum colinc)) + (case kind + (:section (setq indented? T)) + (:line-relative (setq relative? T)) + (:section-relative (setq indented? T relative? T))) + (when (or (not indented?) + (and *print-pretty* *logical-block-p*)) + (let* ((current + (if (not indented?) (LP<-BP xp) + (%i- (TP<-BP xp) (section-start xp)))) + (new + (if (zerop colinc) + (if relative? (+ current colnum) (max colnum current)) + (cond (relative? + (* colinc (floor (+ current colnum colinc -1) colinc))) + ((> colnum current) colnum) + (T (+ colnum + (* colinc + (floor (+ current (- colnum) colinc) colinc))))))) + (length (- new current))) + (declare (fixnum current new length)) + (when (plusp length) + (if (xp-char-mode xp) (handle-char-mode xp #\space)) + (let ((end (%i+ (xp-buffer-ptr xp) length))) + (xp-check-size (xp-buffer xp) end #.buffer-min-size #.buffer-entry-size) + (fill (xp-buffer xp) #\space :start (xp-buffer-ptr xp) :end end) + (setf (xp-buffer-ptr xp) end))))))) + +;note following is smallest number >= x that is a multiple of colinc +; (* colinc (floor (+ x (1- colinc)) colinc)) + + +(defun pprint-newline+ (kind xp) + (enqueue xp :newline kind) + (let ((queue (xp-queue xp)) + (qright (xp-qright xp))) + (declare (fixnum qright)) + (do ((ptr (xp-qleft xp) (Qnext ptr))) ;find sections we are ending + ((not (< ptr qright))) ;all but last + (declare (fixnum ptr)) + (when (and (null (xpq-end queue ptr)) + (not (%i> (xp-depth-in-blocks xp) (xpq-depth queue ptr))) + (memq (xpq-type queue ptr) '(:newline :start-block))) + (setf (xpq-end queue ptr) (- qright ptr)))) + (setf (section-start xp) (TP<-BP xp)) + (when (and (memq kind '(:fresh :unconditional)) (xp-char-mode xp)) + (handle-char-mode xp #\newline)) + (when (memq kind '(:fresh :unconditional :mandatory)) + (attempt-to-output xp T nil)))) + +(defun start-block (xp prefix-string on-each-line? suffix-string) + (macrolet ((push-block-stack (xp) + `(let ((ptr (%i+ (xp-block-stack-ptr ,xp) #.block-stack-entry-size))) + (setf (xp-block-stack-ptr ,xp) ptr) + (xp-check-size (xp-block-stack ,xp) ptr + #.block-stack-min-size #.block-stack-entry-size)))) + (let ((length (if prefix-string (length (the string prefix-string)) 0))) + (declare (fixnum length)) + (when prefix-string (write-string++ prefix-string xp 0 length)) + (if (and (xp-char-mode xp) on-each-line?) + (let ((ptr (xp-buffer-ptr xp))) + (declare (fixnum ptr)) + (setq prefix-string + (%substr (xp-buffer xp) (- ptr length) ptr)))) + (push-block-stack xp) + (enqueue xp :start-block nil + (if on-each-line? (cons suffix-string prefix-string) suffix-string)) + (setf (xp-depth-in-blocks xp)(%i+ 1 (xp-depth-in-blocks xp))) ;must be after enqueue + (setf (section-start xp) (TP<-BP xp))))) + +(defun end-block (xp suffix) + (macrolet ((pop-block-stack (xp) + `(decf (the fixnum (xp-block-stack-ptr ,xp)) #.block-stack-entry-size))) + ;(unless (eq *abbreviation-happened* '*print-lines*) + (when suffix (write-string+ suffix xp 0 (length suffix))) + (decf (xp-depth-in-blocks xp)) + (enqueue xp :end-block nil suffix) + (let ((queue (xp-queue xp)) + (qright (xp-qright xp))) + (declare (fixnum qright)) + (do ((ptr (xp-qleft xp) (Qnext ptr))) ;looking for start of block we are ending + ((not (< ptr qright))) ;all but last + (declare (fixnum ptr)) + (when (and (= (the fixnum (xp-depth-in-blocks xp)) (the fixnum (xpq-depth queue ptr))) + (eq (xpq-type queue ptr) :start-block) + (null (xpq-offset queue ptr))) + (setf (xpq-offset queue ptr) (- qright ptr)) + (return nil))) ;can only be 1 + (pop-block-stack xp)))) ;) + +(defun pprint-indent+ (kind n xp) + (when (and *print-pretty* *logical-block-p*) + (enqueue xp :ind kind n))) + + +; The next function scans the queue looking for things it can do. +;it keeps outputting things until the queue is empty, or it finds +;a place where it cannot make a decision yet. + +(eval-when (:compile-toplevel :execute) +(defmacro maybe-too-large (xp Qentry queue linel) + `(let ((.limit. ,linel) + (.qend. (xpq-end ,queue ,qentry))) + (declare (fixnum .limit.)) + (when (eql (xp-line-limit ,xp) (xp-line-no ,xp)) ;prevents suffix overflow + (decf .limit. 2) ;3 for " .." minus 1 for space (heuristic) + (when (not (minusp (xp-prefix-stack-ptr ,xp))) + (decf .limit. (suffix-ptr ,xp)))) + (cond (.qend. + (%i> (LP<-TP ,xp (xpq-pos ,queue (%i+ ,Qentry .qend.))) .limit.)) + ((or force-newlines? (%i> (LP<-BP ,xp) .limit.)) T) + (T (return nil))))) ;wait until later to decide. + +(defmacro misering? (xp left) + `(<= ,left + (the fixnum (initial-prefix-ptr ,xp)))) +) ; eval-when + +;If flush-out? is T and force-newlines? is NIL then the buffer, +;prefix-stack, and queue will be in an inconsistent state after the call. +;You better not call it this way except as the last act of outputting. + + +(defun attempt-to-output (xp force-newlines? flush-out?) + (macrolet ((pop-prefix-stack (xp) + `(decf (the fixnum (xp-prefix-stack-ptr ,xp)) + #.prefix-stack-entry-size))) + (let* ((width *print-miser-width*) + (linel (xp-linel xp)) + (left (if width (- linel width) most-positive-fixnum))) + (declare (fixnum linel left)) + (do ((qleft (xp-qleft xp)) + (queue (xp-queue xp)(xp-queue xp))) + ((%i> qleft (xp-qright xp)) + (setf (xp-qleft xp) 0) + (setf (xp-qright xp) #.(- queue-entry-size))) ;saves shifting + ; initial-prefix-ptr cant be referenced initially - prefix-stack-ptr is negative + (case (xpq-type queue qleft) + (:ind + (unless (misering? xp left) + (set-indentation-prefix xp + (case (xpq-kind queue qleft) + (:block (%i+ (initial-prefix-ptr xp) (xpq-arg queue qleft))) + (T ; :current + (%i+ (LP<-TP xp (xpq-pos queue qleft)) + (xpq-arg queue qleft)))))) ) + (:start-block + (cond ((maybe-too-large xp qleft queue linel) + (push-prefix-stack xp) + (setf (initial-prefix-ptr xp) (prefix-ptr xp)) + (set-indentation-prefix xp (LP<-TP xp (xpq-pos queue qleft))) + (let ((arg (xpq-arg queue qleft))) + (when (consp arg) (set-prefix xp (cdr arg))) + (setf (initial-prefix-ptr xp) (prefix-ptr xp)) + (cond ((not (listp arg)) (set-suffix xp arg)) + ((car arg) (set-suffix xp (car arg))))) + (setf (section-start-line xp) (xp-line-no xp))) + (T (setq qleft (%i+ qleft (xpq-offset queue qleft))))) ) + (:end-block (pop-prefix-stack xp)) + (T ; :newline + (when (case (xpq-kind queue qleft) + (:fresh (not (%izerop (LP<-BP xp)))) + (:miser (misering? xp left)) + (:fill (or (misering? xp left) + (%i> (xp-line-no xp) (section-start-line xp)) + (maybe-too-large xp qleft queue linel))) + (T T)) ;(:linear :unconditional :mandatory) + (output-line xp qleft) + (setup-for-next-line xp qleft)))) + (setf (xp-qleft xp) (setq qleft (qnext qleft)))) + (when flush-out? (flush xp))))) + + + +(defun flush (xp) + (let ((ostream (xp-out-stream xp))) + (when ostream + (write-string (xp-buffer xp) ostream :start 0 :end (xp-buffer-ptr xp))) + (incf (xp-buffer-offset xp) (xp-buffer-ptr xp)) + (incf (xp-charpos xp) (xp-buffer-ptr xp)) + (setf (xp-buffer-ptr xp) 0))) + + +(defun xp-out-stream (xp) + (let ((lc *locating-circularities*)) + (cond + ((null lc) + (xp-base-stream xp)) + ((= lc 0) + (if (null (xp-string-stream xp)) + (setf (xp-string-stream xp) (make-string-output-stream)) + (xp-string-stream xp)))))) + + +;This prints out a line of stuff. + +(defun output-line (xp Qentry) + (flet ((find-not-char-reverse (buffer out-point) + (declare (type simple-base-string buffer) (type fixnum out-point)) + (do ((i (%i- out-point 1) (%i- i 1))) + ((%i< i 0) nil) + (when (or (neq (schar buffer i) #\Space) + ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be + ;; quoted; don't bother checking for that, no big harm leaving the space even if + ;; not totally necessary). + (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\))) + (return i))))) + (let* ((queue (xp-queue xp)) + (out-point (BP<-TP xp (xpq-pos queue Qentry))) + (last-non-blank (find-not-char-reverse (xp-buffer xp) out-point)) + (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point) + (last-non-blank (%i+ 1 last-non-blank)) + (T 0))) + (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp)))))) + (when line-limit-exit + (setf (xp-buffer-ptr xp) end) ;truncate pending output. + (write-string+++ " .." xp 0 3) + (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp)) + (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp)) + (setf (xp-qleft xp) (qnext (xp-qright xp))) + ;(setq *abbreviation-happened* '*print-lines*) + (throw 'line-limit-abbreviation-exit T)) + (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp))) + (let ((bstream (xp-out-stream xp))) + (when bstream + (write-string (xp-buffer xp) bstream :start 0 :end end) + (stream-write-char bstream #\newline)))))) + +(defun setup-for-next-line (xp Qentry) + (let* ((queue (xp-queue xp)) + (out-point (BP<-TP xp (xpq-pos queue Qentry))) + (prefix-end + (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh)) + (non-blank-prefix-ptr xp)) + (T (prefix-ptr xp)))) + (change (- prefix-end out-point))) + (declare (fixnum out-point prefix-end change)) + (setf (xp-charpos xp) 0) + (when (plusp change) ;almost never happens + (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change) + #.buffer-min-size #.buffer-entry-size)) + (let ((buffer (xp-buffer xp))) + (replace buffer buffer :start1 prefix-end + :start2 out-point :end2 (xp-buffer-ptr xp)) + (replace buffer (xp-prefix xp) :end2 prefix-end) + (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change)) + (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change)) + (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh))) + (setf (section-start-line xp) (xp-line-no xp)))))) + +(defun set-indentation-prefix (xp new-position) + (let ((new-ind (max (non-blank-prefix-ptr xp) new-position))) + (declare (fixnum new-ind)) + (setf (prefix-ptr xp) (initial-prefix-ptr xp)) + (xp-check-size (xp-prefix xp) new-ind #.prefix-min-size #.prefix-entry-size) + (when (%i> new-ind (prefix-ptr xp)) + (fill (xp-prefix xp) #\space :start (prefix-ptr xp) :end new-ind)) + (setf (prefix-ptr xp) new-ind))) + +(defun set-prefix (xp prefix-string) + (declare (string prefix-string)) + (replace (xp-prefix xp) prefix-string + :start1 (%i- (prefix-ptr xp) (length prefix-string))) + (setf (non-blank-prefix-ptr xp) (prefix-ptr xp))) + +(defun set-suffix (xp suffix-string) + (declare (string suffix-string)) + (let* ((end (length suffix-string)) + (new-end (%i+ (suffix-ptr xp) end))) + (declare (fixnum end new-end)) + (xp-check-size (xp-suffix xp) new-end #.suffix-min-size #.suffix-entry-size) + (do ((i (1- new-end) (1- i)) (j 0 (1+ j))) ((= j end)) + (declare (fixnum i j)) + (setf (char (xp-suffix xp) i) (char suffix-string j))) + (setf (suffix-ptr xp) new-end))) + +(defun reverse-string-in-place (string start end) + (declare (fixnum start end)) + (do ((i start (1+ i)) (j (1- end) (1- j))) ((not (< i j)) string) + (declare (fixnum i j)) + (let ((c (schar string i))) + (setf (schar string i) (schar string j)) + (setf (schar string j) c)))) + + +; ---- BASIC INTERFACE FUNCTIONS ---- + +;The internal functions in this file, and the (formatter "...") expansions +;use the '+' forms of these functions directly (which is faster) because, +;they do not need error checking of fancy stream coercion. The '++' forms +;additionally assume the thing being output does not contain a newline. + +(defun maybe-initiate-xp-printing (fn stream &rest args) + (if (xp-structure-p stream) (apply fn stream args) + (if (typep stream 'xp-stream) + (apply fn (slot-value stream 'xp-structure) args) + (let ((*locating-circularities* (if *print-circle* 0 nil)) + (*circularity-hash-table* + (if *print-circle* (get-circularity-hash-table) nil))) + (prog1 (xp-print fn (decode-stream-arg stream) args) + (if *circularity-hash-table* + (free-circularity-hash-table *circularity-hash-table*))))))) + +(defun xp-print (fn stream args) + (flet ((do-it (fn stream args) + (prog1 (do-xp-printing fn stream args) + (when *locating-circularities* + (setq *locating-circularities* nil) + (do-xp-printing fn stream args))))) + (cond (*print-readably* + (let* ((*print-level* nil) + (*print-length* nil) + (*print-lines* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-array* nil)) + (do-it fn stream args))) + (t (do-it fn stream args))))) + + +(defun decode-stream-arg (stream) + (cond ((eq stream T) *terminal-io*) + ((null stream) *standard-output*) + (T stream))) + +(defun do-xp-printing (fn stream args) + (let ((xp (slot-value (get-pretty-print-stream stream) 'xp-structure)) + (*current-level* 0) + (*xp-current-object* nil) + (result nil)) + (declare (special *foo-string*)) + (catch 'line-limit-abbreviation-exit + (start-block xp nil nil nil) + (setq result (apply fn xp args)) + (end-block xp nil)) + (when (and *locating-circularities* + (zerop *locating-circularities*) ;No circularities. + ;(= (xp-line-no xp) 1) ;Didn't suppress line. + ;(zerop (xp-buffer-offset xp)) + ) ;Didn't suppress partial line. + (setq *locating-circularities* nil) + (let ((s (xp-string-stream xp))) + (when s + (stream-write-entire-string (xp-base-stream xp) + (get-output-stream-string s))))) + (when (catch 'line-limit-abbreviation-exit + (attempt-to-output xp nil T) + nil) + (attempt-to-output xp T T)) + (free-pretty-print-stream xp) + result)) + + + +(defun write+ (object xp &optional interior-cdr circle) + (let ((pretty *print-pretty*)) ;((*parents* *parents*)) + (when (or circle + (not (and *circularity-hash-table* + (eq (setq circle (circularity-process xp object interior-cdr)) :subsequent)))) + (when *circularity-hash-table* + (setq *xp-current-object* object)) + (let ((printer (if pretty (get-printer object *print-pprint-dispatch*) nil)) + #|type|#) + (cond (printer + (funcall printer xp object)) + ((and pretty (maybe-print-fast xp object))) + (t (write-not-pretty xp object + (if *print-level* + (- *print-level* *current-level*) + most-positive-fixnum) + interior-cdr circle))))))) + +;It is vital that this function be called EXACTLY once for each occurrence of +; each thing in something being printed. +;Returns nil if printing should just continue on. +; Either it is not a duplicate, or we are in the first pass and do not know. +;returns :FIRST if object is first occurrence of a DUPLICATE. +; (This can only be returned on a second pass.) +; After an initial code (printed by this routine on the second pass) +; printing should continue on for the object. +;returns :SUBSEQUENT if second or later occurrence. +; Printing is all taken care of by this routine. + +;Note many (maybe most) lisp implementations have characters and small numbers +;represented in a single word so that the are always eq when they are equal and the +;reader takes care of properly sharing them (just as it does with symbols). +;Therefore, we do not want circularity processing applied to them. However, +;some kinds of numbers (e.g., bignums) undoubtedly are complex structures that +;the reader does not share. However, they cannot have circular pointers in them +;and it is therefore probably a waste to do circularity checking on them. In +;any case, it is not clear that it easy to tell exactly what kinds of numbers a +;given implementation of CL is going to have the reader automatically share. + +; if not pretty print a space before dot + +(defun circularity-process (xp object interior-cdr? &aux (not-pretty (not *print-pretty*))) + (unless (or (numberp object) + (characterp object) + (and (symbolp object) ;Reader takes care of sharing. + (or (null *print-gensym*) (symbol-package object)))) + (let ((id (gethash object *circularity-hash-table*))) + (if (and *locating-circularities* *print-circle*) ; << was *locating-circularities* + (progn ;(push (list object id info-p) barf) + (cond ((null id) ;never seen before + ;(when *parents* (push object *parents*)) + (setf (gethash object *circularity-hash-table*) 0) + nil) + ((zerop id) ;possible second occurrence + (setf (gethash object *circularity-hash-table*) + (incf *locating-circularities*)) + :subsequent) + (T :subsequent)));third or later occurrence + (progn ;(push (list object id info-p interior-cdr?) barf2) + (cond + ((or (null id) ;never seen before (note ~@* etc. conses) + (zerop id));no duplicates + nil) + (t (when interior-cdr? + (write-string++ (if not-pretty " . #" ". #") + xp 0 + (if not-pretty 4 3))) + (cond ((plusp id) + (cond (interior-cdr? + (decf *current-level*)) + (T (write-char++ #\# xp))) + (print-fixnum xp id) + (write-char++ #\= xp) + (setf (gethash object *circularity-hash-table*) (- id)) + :first) + (T (when (not interior-cdr?) (write-char++ #\# xp)) + (print-fixnum xp (- id)) + (write-char++ #\# xp) + :subsequent))))))))) + + +;This prints a few very common, simple atoms very fast. +;Pragmatically, this turns out to be an enormous savings over going to the +;standard printer all the time. There would be diminishing returns from making +;this work with more things, but might be worth it. +; does this really win? + +(defun maybe-print-fast (xp object) + (cond ((stringp object) + (cond ((null *print-escape*) (write-string+ object xp 0 (length object)) T) + ((every #'(lambda (c) (not (or (eq c #\") (eq c #\\)))) + object) + (write-char++ #\" xp) + (write-string+ object xp 0 (length object)) + (write-char++ #\" xp) T))) + ((typep object 'fixnum) + (when (and (null *print-radix*) (= *print-base* 10.)) + (when (minusp object) + (write-char++ #\- xp) + (setq object (- object))) + (print-fixnum xp object) T)) + ((symbolp object) + (if (> *print-base* 10) ; may need to escape potential numbers + (write-a-symbol object (xp-stream xp)) + (let ((s (symbol-name object)) + (p (symbol-package object)) + (is-key (keywordp object)) + (mode (case *print-case* + (:downcase :down) + (:capitalize :cap1) + (T nil)))) ; note no-escapes-needed requires all caps + (declare (string s)) + (cond ((and (or is-key (eq p *package*) + (and ;*package* ;can be NIL on symbolics + (multiple-value-bind (symbol type) (find-symbol s) + (and type (eq object symbol))))) + (eq (readtable-case *readtable*) :upcase) + (neq *print-case* :studly) + (no-escapes-needed s)) + (when (and is-key *print-escape*) + (write-char++ #\: xp)) + (if mode (push-char-mode xp mode)) + (write-string++ s xp 0 (length s)) + (if mode (pop-char-mode xp)) T))))))) + +(defun print-fixnum (xp fixnum) + (multiple-value-bind (digits d) + (truncate fixnum 10) + (unless (zerop digits) + (print-fixnum xp digits)) + (write-char++ (code-char (+ #.(char-code #\0) d)) xp))) + +;just wants to succeed fast in a lot of common cases. +;assumes no funny readtable junk for the characters shown. + +(defun no-escapes-needed (s) + (declare (string s)) + (let ((n (length s))) + (declare (fixnum n)) + (and (not (zerop n)) + (let ((c (schar s 0))) + (or (and (alpha-char-p c) (upper-case-p c)) (%str-member c "*<>"))) + (do ((i 1 (1+ i))) ((= i n) T) + (declare (fixnum i)) + (let ((c (schar s i))) + (if (not (or (digit-char-p c) + (and (alpha-char-p c) (upper-case-p c)) + (%str-member c "*+<>-"))) + (return nil))))))) + + + +(without-duplicate-definition-warnings ;; override l1-io version. + (defun pprint (object &optional (stream *standard-output*)) + "Prettily output OBJECT preceded by a newline." + (setq stream (decode-stream-arg stream)) + (terpri stream) + (let ((*print-escape* T) (*print-pretty* T)) + (write-1 object stream)) + (values))) + + + +;Any format string that is converted to a function is always printed +;via an XP stream (See formatter). + +(defvar *format-string-cache* nil) + +(defun process-format-string (string-or-fn force-fn?) + (declare (ignore force-fn?)) + string-or-fn) + + + +;Each of these causes the stream to be pessimistic and insert +;newlines wherever it might have to, when forcing the partial output +;out. This is so that things will be in a consistent state if +;output continues to the stream later. + +(defmethod stream-force-output ((xp xp-structure)) + (attempt-to-output xp t t)) + +(defmethod stream-finish-output ((xp xp-structure)) + (attempt-to-output xp t t)) + + + +; ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ---- + +;The internal functions in this file, and the (formatter "...") expansions +;use the '+' forms of these functions directly (which is faster) because, +;they do not need error checking or fancy stream coercion. The '++' forms +;additionally assume the thing being output does not contain a newline. + + + +(defun pprint-newline (kind &optional (stream *standard-output*)) + "Output a conditional newline to STREAM (which defaults to + *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do + nothing if not. KIND can be one of: + :LINEAR - A line break is inserted if and only if the immediatly + containing section cannot be printed on one line. + :MISER - Same as LINEAR, but only if ``miser-style'' is in effect. + (See *PRINT-MISER-WIDTH*.) + :FILL - A line break is inserted if and only if either: + (a) the following section cannot be printed on the end of the + current line, + (b) the preceding section was not printed on a single line, or + (c) the immediately containing section cannot be printed on one + line and miser-style is in effect. + :MANDATORY - A line break is always inserted. + When a line break is inserted by any type of conditional newline, any + blanks that immediately precede the conditional newline are ommitted + from the output and indentation is introduced at the beginning of the + next line. (See PPRINT-INDENT.)" + (when (not (memq kind '(:linear :miser :fill :mandatory))) + (signal-type-error kind '(member :linear :miser :fill :mandatory) + "Invalid KIND argument ~A to PPRINT-NEWLINE")) + (when (and *print-pretty* *logical-block-p*) + (setq stream (decode-stream-arg stream)) + (cond ((xp-structure-p stream) + (pprint-newline+ kind stream)) + ((typep stream 'xp-stream) + (pprint-newline+ kind (slot-value stream 'xp-structure))) + (t (pp-newline stream kind)))) + nil) + +(defun pprint-indent (relative-to n &optional (stream *standard-output*)) + "Specify the indentation to use in the current logical block if STREAM + (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream + and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indentation + to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: + :BLOCK - Indent relative to the column the current logical block + started on. + :CURRENT - Indent relative to the current column. + The new indentation value does not take effect until the following line + break." + (setq stream (decode-stream-arg stream)) + (when (not (memq relative-to '(:block :current))) + (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to)) + (cond ((xp-structure-p stream) + (pprint-indent+ relative-to (truncate n) stream)) + ((typep stream 'xp-stream) + (pprint-indent+ relative-to (truncate n) (slot-value stream 'xp-structure))) + (t nil)) ; ???(break))) + nil) + +(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*)) + "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing + stream, perform tabbing based on KIND, otherwise do nothing. KIND can + be one of: + :LINE - Tab to column COLNUM. If already past COLNUM tab to the next + multiple of COLINC. + :SECTION - Same as :LINE, but count from the start of the current + section, not the start of the line. + :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of + COLINC. + :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start + of the current section, not the start of the line." + (setq stream (decode-stream-arg stream)) + (when (not (memq kind '(:line :section :line-relative :section-relative))) + (error "Invalid KIND argument ~A to PPRINT-TAB" kind)) + + (when (and *print-pretty* *logical-block-p*) + (cond ((xp-structure-p stream) + (pprint-tab+ kind colnum colinc stream)) + ((typep stream 'xp-stream) + (pprint-tab+ kind colnum colinc (slot-value stream 'xp-structure))))) + nil) + + +; ---- COMPILED FORMAT ---- + +;Note that compiled format strings always print through xp streams even if +;they don't have any xp directives in them. As a result, the compiled code +;can depend on the fact that the stream being operated on is an xp +;stream not an ordinary one. + + +(eval-when (:compile-toplevel :load-toplevel :execute) +; called by formatter frobs +(defun do-sub-format-0 (s control-string args) + (setq s (if (xp-structure-p s)(xp-stream s) + (if (output-stream-p s) + s + (require-type s '(satisfies output-stream-p))))) + + (let ((*format-control-string* control-string) + (*format-top-level* t)) + (cond ((and (or *print-pretty* *print-circle*) + (not (typep s 'xp-stream))) + (maybe-initiate-xp-printing + #'do-sub-format-1 s args)) + (t (do-sub-format-1 s args))))) + +; called from above, format, and logical-block-sub +(defun do-sub-format-1 (stream args) + (let ((*format-original-arguments* args) + (*format-arguments* args) + (*format-colon-rest* 'error)) + (declare (special *format-colon-rest*)) + (if (xp-structure-p stream)(setq stream (xp-stream stream))) + (do-sub-format stream) + ; copylist cause args is dynamic extent in format & formatter + ; n.b. when printing lisp code its nearly always nil + (setq args *format-arguments*) + (if (and (consp args) *format-top-level*)(copy-list args) args))) + +(defmacro formatter (control-string) ; maybe-initiate-xp-printing? + (setq control-string (require-type control-string 'string)) + `(function + (lambda (s &rest args) + ; IFFY because things can end up in the same place on the stack + ; appearing EQ giving bogus circularity detection + ; But now we have fixed things so we don't circle check rest args (ha!) + (do-sub-format-0 s ,control-string args)))) + +(defmacro pprint-pop+ (args xp) + `(if (pprint-pop-check+ ,args ,xp) + (return-from logical-block nil) + (pop ,args))) + +(defun pprint-pop-check+ (args xp) + (let ((current-length *current-length*)) + (declare (fixnum current-length)) + (setq current-length (setq *current-length* (1+ *current-length*))) + (cond ((not (listp args)) ;must be first so supersedes length abbrev + (write-string++ ". " xp 0 2) + (write+ args xp) + T) + ((and *print-length* ;must supersede circle check + (not (< current-length *print-length*))) + (write-string++ "..." xp 0 3) + ;(setq *abbreviation-happened* T) + T) + ((and *circularity-hash-table* (not *format-top-level*) + (not (zerop current-length))) + (let ((circle (circularity-process xp args T))) + (case circle + (:first ;; note must inhibit rechecking of circularity for args. + (write+ args xp T circle) + T) + (:subsequent T) + (T nil))))))) + +(defun check-block-abbreviation (xp args circle-check?) + (cond ((not (listp args)) (write+ args xp) T) + ((and *print-level* (> *current-level* *print-level*)) + (write-char++ #\# XP) + ;(setq *abbreviation-happened* T) + T) + ((and *circularity-hash-table* circle-check? (neq args *xp-current-object*) + (eq (circularity-process xp args nil) :subsequent)) + T) + (T nil))) + + +) + + + +; ---- PRETTY PRINTING FORMATS ---- + +(defun pretty-array (xp array) + (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure))) + (cond ((vectorp array) (pretty-vector xp array)) + ((zerop (array-rank array)) + (write-string++ "#0A" xp 0 3) + (write+ (aref array) xp)) + (T (pretty-non-vector xp array)))) + +(defun pretty-vector (xp v) + (pprint-logical-block (xp nil :prefix "#(" :suffix ")") + (let ((end (length v)) (i 0)) + (declare (fixnum end i)) + (when (plusp end) + (loop (pprint-pop) ;HUH + (write+ (aref v i) xp) + (if (= (incf i) end) (return nil)) + (write-char++ #\space xp) + (pprint-newline+ :fill xp)))))) + +(defun pretty-non-vector (xp array) + (let* ((bottom (1- (array-rank array))) + (indices (make-list (1+ bottom) :initial-element 0)) + (dims (array-dimensions array))) + (funcall (formatter "#~DA") xp (1+ bottom)) + (labels ((pretty-slice (slice) + (pprint-logical-block (xp nil :prefix "(" :suffix ")") + (let ((end (nth slice dims)) + (spot (nthcdr slice indices)) + (i 0)) + (when (plusp end) + (loop (pprint-pop) + (setf (car spot) i) + (if (= slice bottom) + (write+ (apply #'aref array indices) xp) + (pretty-slice (1+ slice))) + (if (= (incf i) end) (return nil)) + (write-char++ #\space xp) + (pprint-newline+ (if (= slice bottom) :fill :linear) xp))))))) + (pretty-slice 0)))) + +(defun pretty-structure (xp struc &aux (class (struct-def struc)) (slots (sd-slots class))) + (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure))) + (let* ((class (ccl::struct-def struc)) ;;guaranteed non-NIL if this function is called + (pf (structure-print-function class))) + (cond + (pf + (if (consp pf) + (funcall (car pf) struc (xp-stream xp)) + (funcall pf struc (xp-stream xp) *current-level*))) + (t + (pprint-logical-block (xp nil :prefix "#S(" :suffix ")") + (pprint-pop) + (write+ (sd-name class) xp) + (start-block xp (if (cdr slots) " " "") nil "") + (when slots + (let ((pcase *print-case*)) + (loop + (let* ((slot (pop slots))(name (ssd-name slot))) + (cond + ((symbolp name) + (pprint-pop) + (write-char++ #\: xp) + (write-pname (symbol-name name) pcase xp) + (write-char++ #\space xp) + (pprint-pop) + (write+ (uvref struc (ssd-offset slot)) xp) + (when (null slots)(return nil)) + (write-char++ #\space xp) + (pprint-newline+ :fill xp)) + ((null slots)(return nil))))))) + (end-block xp "")))))) + + + + +;Must use pprint-logical-block (no +) in the following three, because they are +;exported functions. + +(defun pprint-linear (s list &optional (colon? T) atsign?) + "Output LIST to STREAM putting :LINEAR conditional newlines between each + element. If COLON? is NIL (defaults to T), then no parens are printed + around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR + can be used with the ~/.../ format directive." + (declare (ignore atsign?)) + (pprint-logical-block (s list :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (loop (write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (write-char++ #\space s) + (pprint-newline+ :linear s)))) + +(defun pprint-fill (s list &optional (colon? T) atsign?) + "Output LIST to STREAM putting :FILL conditional newlines between each + element. If COLON? is NIL (defaults to T), then no parens are printed + around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL + can be used with the ~/.../ format directive." + (declare (ignore atsign?)) + (pprint-logical-block (s list :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (loop (write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (write-char++ #\space s) + (pprint-newline+ :fill s)))) + +(defun pprint-tabular (s list &optional (colon? T) atsign? (tabsize nil)) + "Output LIST to STREAM tabbing to the next column that is an even multiple + of TABSIZE (which defaults to 16) between each element. :FILL style + conditional newlines are also output between each element. If COLON? is + NIL (defaults to T), then no parens are printed around the output. + ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with + the ~/.../ format directive." + (declare (ignore atsign?)) + (when (null tabsize) (setq tabsize 16)) + (pprint-logical-block (s list :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (loop (write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (write-char++ #\space s) + (pprint-tab+ :section-relative 0 tabsize s) + (pprint-newline+ :fill s)))) + +; perhaps should use alternate-fn-call instead +(defun fn-call (xp list) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)) + +;Although idiosyncratic, I have found this very useful to avoid large +;indentations when printing out code. + +(defun alternative-fn-call (xp list) + (if (> (length (symbol-name (car list))) 12) + (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))) + + +(defun bind-list (xp list &rest args) + (declare (ignore args)) + (if (do ((i 50 (1- i)) + (ls list (cdr ls))) ((null ls) t) + (when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i)) + (return nil))) + (pprint-fill xp list) + (funcall (formatter "~:<~@{~:/pprint-fill/~^ ~_~}~:>") xp list))) + +(defun block-like (xp list &rest args) + (declare (ignore args)) + (funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list)) + +(defun defun-like (xp list &rest args) + (declare (ignore args)) + (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/pprint-fill/~^~@{ ~_~W~^~}~:>") + xp list)) + +(defun print-fancy-fn-call (xp list template) + (let ((i 0) (in-first-section T)) + (declare (fixnum i)) + (pprint-logical-block+ (xp list "(" ")" nil T nil) + (write+ (pprint-pop) xp) + (pprint-indent+ :current 1 xp) + (loop + (pprint-exit-if-list-exhausted) + (write-char++ #\space xp) + (when (eq i (car template)) + (pprint-indent+ :block (cadr template) xp) + (setq template (cddr template)) + (setq in-first-section nil)) + (pprint-newline (cond ((and (zerop i) in-first-section) :miser) + (in-first-section :fill) + (T :linear)) + xp) + (write+ (pprint-pop) xp) + (incf i))))) + +(defun defmethod-like (xp list &rest args) + (declare (ignore args)) + (cond ((and (consp (cdr list))(consp (cddr list))(listp (caddr list))) + (defun-like xp list)) + (t (defsetf-print xp list)))) + + +(defun maybelab (xp item &rest args) + (declare (ignore args) (special need-newline indentation)) + (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure))) + (when need-newline (pprint-newline+ :mandatory xp)) + (cond ((and item (symbolp item)) + (write+ item xp) + (setq need-newline nil)) + (T (pprint-tab+ :section indentation 0 xp) + (write+ item xp) + (setq need-newline T)))) + +(defun function-call-p (x) + (and (consp x) (symbolp (car x)) (fboundp (car x)))) + + + + +;THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH* + +;This is an attempt to specify a correct format for every form in the CL book +;that does not just get printed out like an ordinary function call +;(i.e., most special forms and many macros). This of course does not +;cover anything new you define. + +(defun let-print (xp obj) + (funcall (formatter "~:<~1I~W~^ ~@_~/ccl::bind-list/~^~@{ ~_~W~^~}~:>") xp obj)) + +(defun cond-print (xp obj) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~:/pprint-linear/~^ ~_~}~:>") xp obj)) + +(defun dmm-print (xp list) + (print-fancy-fn-call xp list '(3 1))) + +(defun defsetf-print (xp list) + (print-fancy-fn-call xp list '(3 1))) + +(defun do-print (xp obj) + (funcall + (formatter "~:<~W~^ ~:I~@_~/ccl::bind-list/~^ ~_~:/pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") + xp obj)) + + +(defun flet-print (xp obj) + (funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/ccl::block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>") + xp obj)) + +(defun function-print (xp list) + (if (and *print-abbreviate-quote* (consp (cdr list)) (null (cddr list))) + (format (xp-stream xp) "#'~W" (cadr list)) + (fn-call xp list))) + +(defun mvb-print (xp list) + (print-fancy-fn-call xp list '(1 3 2 1))) + +(defun prog-print (xp list) + (let ((need-newline T) (indentation (1+ (length (symbol-name (car list)))))) ; less? + (declare (special need-newline indentation)) + (funcall (formatter "~:<~W~^ ~:/pprint-fill/~^ ~@{~/ccl::maybelab/~^ ~}~:>") + xp list))) + + +(defun progn-print (xp list) + (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list)) + +(defun setq-print (xp obj) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj)) + +(defun quote-print (xp list) + (if (and (consp (cdr list)) (null (cddr list))) + (format (xp-stream xp) "'~W" (cadr list)) + (pprint-fill xp list))) + +(defun tagbody-print (xp list) + (let ((need-newline (and (consp (cdr list)) + (symbolp (cadr list)) (cadr list))) + (indentation (1+ (length (symbol-name (car list)))))) + (declare (special need-newline indentation)) + (funcall (formatter "~:<~W~^ ~@{~/ccl::maybelab/~^ ~}~:>") xp list))) + +(defun up-print (xp list) + (print-fancy-fn-call xp list '(0 3 1 1))) + + +;here is some simple stuff for printing LOOP + +;The challange here is that we have to effectively parse the clauses of the +;loop in order to know how to print things. Also you want to do this in a +;purely incremental way so that all of the abbreviation things work, and +;you wont blow up on circular lists or the like. (More aesthic output could +;be produced by really parsing the clauses into nested lists before printing them.) + +;The following program assumes the following simplified grammar of the loop +;clauses that explains how to print them. Note that it does not bare much +;resemblence to the right parsing grammar, however, it produces half decent +;output. The way to make the output better is to make the grammar more +;detailed. +; +;loop == (LOOP {clause}*) ;one clause on each line. +;clause == block | linear | cond | finally +;block == block-head {expr}* ;as many exprs as possible on each line. +;linear == linear-head {expr}* ;one expr on each line. +;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. +;cond == cond-head [expr] +; clause +; {AND clause}* ;one AND on each line. +; [ELSE +; clause +; {AND clause}*] ;one AND on each line. +; [END] +;block-head == FOR | AS | WITH | AND +; | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN +; | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT +; | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING +;linear-head == DO | DOING | INITIALLY +;var-head == FOR | AS | WITH +;cond-head == IF | WHEN | UNLESS +;expr == + +;Note all the string comparisons below are required to support some +;existing implementations of LOOP. +(defun token-type (token &aux string) + (cond ((not (symbolp token)) :expr) + ((string= (setq string (string token)) "FINALLY") :finally) + ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head) + ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head) + ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE" + "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER" + "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND" + "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING" + "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING" + "MINIMIZE" "MINIMIZING") + :test #'string=) + :block-head) + (T :expr))) + + +; maybe put in a separate file (replace write-char by write-char+) +(defun pretty-loop (xp loop) + (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop + (tagbody-print xp loop) + (pprint-logical-block (xp loop :prefix "(" :suffix ")") + (let (token type) + (labels ((next-token () + (pprint-exit-if-list-exhausted) + (setq token (pprint-pop)) + (setq type (token-type token))) + (print-clause (xp) + (case type + (:linear-head (print-exprs xp nil :mandatory)) + (:cond-head (print-cond xp)) + (:finally (print-exprs xp T :mandatory)) + (otherwise (print-exprs xp nil :fill)))) + (print-exprs (xp skip-first-non-expr newline-type) + (pprint-logical-block (xp nil) + (write+ token xp) + (next-token) + (when (and skip-first-non-expr (not (eq type :expr))) + (write-char+ #\space xp) + (write+ token xp) + (next-token)) + (when (eq type :expr) + (write-char+ #\space xp) + (pprint-indent :current 0 xp) + (loop (write+ token xp) + (next-token) + (when (not (eq type :expr)) (return nil)) + (write-char+ #\space xp) + (pprint-newline newline-type xp))))) + (print-cond (xp) + (pprint-logical-block (xp nil) + (write+ token xp) + (next-token) + (when (eq type :expr) + (write-char+ #\space xp) + (write+ token xp) + (next-token)) + (write-char+ #\space xp) + (pprint-indent :block 2 xp) + (pprint-newline :linear xp) + (print-clause xp) + (print-and-list xp) + (when (string= (string token) "ELSE") + (print-else-or-end xp) + (write-char+ #\space xp) + (pprint-newline :linear xp) + (print-clause xp) + (print-and-list xp)) + (when (string= (string token) "END") + (print-else-or-end xp)))) + (print-and-list (xp) + (loop (when (not (string= (string token) "AND")) (return nil)) + (write-char+ #\space xp) + (pprint-newline :mandatory xp) + (write+ token xp) + (next-token) + (write-char+ #\space xp) + (print-clause xp))) + (print-else-or-end (xp) + (write-char+ #\space xp) + (pprint-indent :block 0 xp) + (pprint-newline :linear xp) + (write+ token xp) + (next-token) + (pprint-indent :block 2 xp))) + (pprint-exit-if-list-exhausted) + (write+ (pprint-pop) xp) + (next-token) + (write-char+ #\space xp) + (pprint-indent :current 0 xp) + (loop (print-clause xp) + (write-char+ #\space xp) + (pprint-newline :linear xp) + ; without this we can loop forever + (if (and *print-level* + (>= *current-level* *print-level*)) + (return)))))))) + + +;Backquote is a big problem we MUST do all this reconsing of structure in +;order to get a list that will trigger the right formatting functions to +;operate on it. On the other side of the coin, we must use a non-list structure +;for the little backquote printing markers to ensure that they will always +;print out the way we want no matter what the code printers say. +; Note that since it is sometimes possible to write the same +;backquote form in several ways, this might not necessarily print out a +;form in exactly the way you wrote it. For example '`(a .,b) and '`(a ,@b) +;both print out as `'(a .,b), because the backquote reader produces the +;same code in both cases. + + + +(setq *IPD* (make-pprint-dispatch-table)) + +(set-pprint-dispatch+ '(satisfies function-call-p) #'alternative-fn-call '(-5) *IPD*) +(set-pprint-dispatch+ 'cons #'pprint-fill '(-10) *IPD*) + +(set-pprint-dispatch+ '(cons (member defstruct)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member block)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member case)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member catch)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ccase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member compiler-let)) #'let-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member cond)) #'cond-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defclass)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defconstant)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defmacro)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member define-modify-macro)) #'dmm-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defparameter)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defsetf)) #'defsetf-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member cl:defstruct)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member deftype)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defun)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defmethod)) #'defmethod-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defvar)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do)) #'do-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do*)) #'do-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do-all-symbols)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do-external-symbols)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do-symbols)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member dolist)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member dotimes)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member etypecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member eval-when)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member flet)) #'flet-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member function)) #'function-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member generic-function)) #'fn-call '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member labels)) #'flet-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member lambda)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member let)) #'let-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member let*)) #'let-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member locally)) #'block-like '(0) *IPD*) + +(set-pprint-dispatch+ '(cons (member loop)) #'pretty-loop '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member macrolet)) #'flet-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member multiple-value-bind)) #'mvb-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member multiple-value-setq)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member prog)) #'prog-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member prog*)) #'prog-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member progv)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member psetf)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member psetq)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member quote)) #'quote-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member return-from)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member setf)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member setq)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member tagbody)) #'tagbody-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member throw)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member typecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member unless)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member unwind-protect)) #'up-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member when)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-input-from-string)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-open-file)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-open-stream)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-output-to-string)) #'block-like '(0) *IPD*) + + + +;so only happens first time is loaded. - why doesn't this work right? +; cause we have *print-pprin... bound to NIL +(when t ;(eq *print-pprint-dispatch* T) + (setq *print-pprint-dispatch* (copy-pprint-dispatch nil))) + +(setq *error-print-circle* t) ; now we can circle-print + +; 82 bytes shorter but uglier +(defun write-not-pretty (stream object level list-kludge circle) + (declare (type fixnum level) (type (or null fixnum) list-kludge)) + (when (xp-structure-p stream)(setq stream (xp-stream stream))) + (cond ((eq circle :subsequent) + (if list-kludge (stream-write-char stream #\))) + (return-from write-not-pretty nil)) + ((not list-kludge)) + ((null object)(return-from write-not-pretty nil)) + ((not (consp object)) + (stream-write-entire-string stream " . ")) + ((eq circle :first) + (stream-write-char stream #\() + (write-a-frob object stream level list-kludge) + (stream-write-char stream #\)) + (return-from write-not-pretty nil)) + (t (stream-write-char stream #\space))) + (write-a-frob object stream level list-kludge)) + +(eval-when (:load-toplevel :execute) + (setq *error-print-circle* t)) + +;changes since last documentation. +;~/fn/ only refers to global function values, not lexical. + +;------------------------------------------------------------------------ + +;Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge, +;Massachusetts. + +;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. + +;------------------------------------------------------------------------ + +#| + Change History (most recent last): + 2 12/29/94 akh merge with d13 +|# ;(do not edit past this line!!) Index: /branches/qres/ccl/lib/prepare-mcl-environment.lisp =================================================================== --- /branches/qres/ccl/lib/prepare-mcl-environment.lisp (revision 13564) +++ /branches/qres/ccl/lib/prepare-mcl-environment.lisp (revision 13564) @@ -0,0 +1,91 @@ +;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; prepare-mcl-environment.lisp +;; Load this into a PPCCL to make it into an MCL-PPC for shipping +;; Sort of. + +(in-package "CCL") + +(defun %reset-outermost-binding (symbol value) + (let* ((symvector (symptr->symvector symbol)) + (idx (%svref symvector target::symbol.binding-index-cell)) + (marker (%no-thread-local-binding-marker))) + (if (> idx 0) + (do-db-links (db var) + (when (eq var idx) + (let* ((oldval (%fixnum-ref db (* 2 target::node-size)))) + (unless (eq oldval marker) + (setf (%fixnum-ref db (* 2 target::node-size)) value)))))) + (setf (uvref symvector target::symbol.vcell-cell) value))) + +(defun freeze-current-definitions () + ;; Set the frozen bits so that redefine-kernel-function + ;; will error if a builtin function is redefined. + (do-all-symbols (s) + (when (fboundp s) + (%symbol-bits s (bitset $sym_fbit_frozen (%symbol-bits s))))) + ;; Force an error if a kernel method is redefined. + (make-all-methods-kernel)) + +(defun thaw-current-definitions () + ;; Clear the frozen bits on all fboundp symbols + (do-all-symbols (s) + (when (fboundp s) + (%symbol-bits s (bitclr $sym_fbit_frozen (%symbol-bits s))))) + ;; Allow redefinition of kernel methods. + (make-all-methods-non-kernel)) + +(defun set-user-environment (&optional (freeze-definitions nil)) + "Arrange that the outermost special bindings of *PACKAGE* and +*WARN-IF-REDEFINE-KERNEL* restore values of the CL-USER package and T +respectively, and set *CCL-SAVE-SOURCE-LOCATIONS* to :NO-TEXT. +If the optional argument is true, marks all globally defined +functions and methods as being predefined (this is a fairly +expensive operation.)" + (when freeze-definitions + (freeze-current-definitions)) + ;; enable redefine-kernel-function's error checking + (%reset-outermost-binding '*warn-if-redefine-kernel* t) + ;; Set the top-level *package* to the CL-USER package + (%reset-outermost-binding '*package* (find-package "CL-USER")) + (setq *ccl-save-source-locations* :NO-TEXT)) + +(defun set-development-environment (&optional (thaw-definitions nil)) + "Arrange that the outermost special bindings of *PACKAGE* and +*WARN-IF-REDEFINE-KERNEL* restore values of the CCL package and NIL +respectively, and set *ccl-save-source-locations* to T. If the +optional argument is true, mark all globally defined functions and +methods as being not predefined (this is a fairly expensive operation.)" + (when thaw-definitions + (thaw-current-definitions)) + ;; enable redefine-kernel-function's error checking + (%reset-outermost-binding '*warn-if-redefine-kernel* nil) + ;; Set the top-level *package* to the CCL package + (%reset-outermost-binding '*package* (find-package "CCL")) + (setq *ccl-save-source-locations* T)) + + + +(defmacro in-development-mode (&body body) + `(let* ((*package* (find-package "CCL")) + (*warn-if-redefine-kernel* nil)) + ,@body)) + + + + Index: /branches/qres/ccl/lib/print-db.lisp =================================================================== --- /branches/qres/ccl/lib/print-db.lisp (revision 13564) +++ /branches/qres/ccl/lib/print-db.lisp (revision 13564) @@ -0,0 +1,39 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defmacro print-db (&rest forms &aux) + `(multiple-value-prog1 + (progn ,@(print-db-aux forms)) + (terpri *trace-output*))) + +(defun print-db-aux (forms) + (when forms + (cond ((stringp (car forms)) + `((print ',(car forms) *trace-output*) + ,@(print-db-aux (cdr forms)))) + ((null (cdr forms)) + `((print ',(car forms) *trace-output*) + (let ((values (multiple-value-list ,(car forms)))) + (prin1 (car values) *trace-output*) + (apply #'values values)))) + (t `((print ',(car forms) *trace-output*) + (prin1 ,(car forms) *trace-output*) + ,@(print-db-aux (cdr forms))))))) + + Index: /branches/qres/ccl/lib/read.lisp =================================================================== --- /branches/qres/ccl/lib/read.lisp (revision 13564) +++ /branches/qres/ccl/lib/read.lisp (revision 13564) @@ -0,0 +1,250 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + +(define-condition simple-reader-error (reader-error simple-error) () + (:report (lambda (c output-stream) + (format output-stream "Reader error ~a:~%~?" + (stream-error-context c) + (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(defun signal-reader-error (input-stream format-string &rest format-args) + (error 'simple-reader-error :stream input-stream + :format-control format-string :format-arguments format-args)) + +#| ; Can't see any reason to leave this in +(defun read-file-to-list (file &aux result) + ;(print-db (setq file (prepend-default-dir file))) + (with-open-file (stream file :direction :input) + (setq result (read-file-to-list-aux stream))) + result) + +(defun read-file-to-list-aux (stream) + (if (eofp stream) + nil + (let ((form (read stream nil *eof-value* nil))) + ;(%print "just read " form) + (if (eq form *eof-value*) + nil + (cons form (read-file-to-list-aux stream)))))) +|# + +(set-dispatch-macro-character #\# #\* + (qlfun |#*-reader| (input-stream sub-char int + &aux list list-length array array-length last-bit) + (declare (ignore sub-char)) + (do* ((char (read-char input-stream nil nil t) + (read-char input-stream nil nil t)) + (attr (%character-attribute char (rdtab.ttab *readtable*)) + (%character-attribute char (rdtab.ttab *readtable*)))) + ((or (null char) + (= $cht_tmac attr) + (= $cht_wsp attr)) + (if char (unread-char char input-stream))) + (let ((number (- (char-code char) 48))) + (if (or (<= 0 number 1) *read-suppress*) + (setq list (cons number list)) + (signal-reader-error input-stream "reader macro #* got illegal character ~S" char)))) + (setq last-bit (car list)) + (setq list (nreverse list)) + (setq list-length (list-length list)) + (if (not (integerp int)) + (setq int list-length)) + (cond (*read-suppress* nil) + ((and (= 0 list-length) (> int 0)) + (signal-reader-error input-stream "reader macro #~S* needs something" int)) + ((> list-length int) + (signal-reader-error input-stream "reader macro #~S* can't fit ~S" int list)) + (t (setq array-length (if int int list-length)) + (setq array (make-array array-length :element-type 'bit)) + (do ((i 0 (1+ i)) + (bit-list list (cdr bit-list))) + ((>= i array-length)) + (aset array i (if bit-list + (car bit-list) + last-bit))) + array)))) + +(set-dispatch-macro-character #\# #\A + (qlfun |#A-reader| (stream ignore dimensions) + (declare (ignore ignore)) + (cond (*read-suppress* + (read stream () () t) + nil) + ((not dimensions) + (signal-reader-error stream "reader macro #A used without a rank integer")) + ((eql dimensions 0) ;0 dimensional array + (make-array nil :initial-contents (read-internal stream t nil t))) + ((and (integerp dimensions) (> dimensions 0)) + (let ((init-list (read-internal stream t nil t))) + (cond ((not (typep init-list 'sequence)) + (signal-reader-error stream "The form following a #~SA reader macro should have been a sequence, but it was: ~S" dimensions init-list)) + ((= (length init-list) 0) + (make-array (make-list dimensions :initial-element 0))) + ((= dimensions 1) + (make-array (length init-list) :initial-contents init-list)) + ((vectorp init-list) + (let ((dlist (make-list dimensions))) + (do ((dl dlist (cdr dl)) + (il init-list (svref il 0))) + ((null dl)) + (if (vectorp il) + (rplaca dl (length il)) + (signal-reader-error stream "Initial contents for #A is inconsistent with dimensions: #~SA~S" dimensions init-list))) + (make-array dlist :initial-contents init-list))) + ((listp init-list) + (let ((dlist (make-list dimensions))) + (do ((dl dlist (cdr dl)) + (il init-list (car il))) + ((null dl)) + (if (listp il) + (rplaca dl (list-length il)) + (signal-reader-error stream "Initial contents for #A is inconsistent with dimensions: #~SA~S" dimensions init-list))) + (make-array dlist :initial-contents init-list))) + (t + (signal-reader-error stream "#~SA~S invalid." dimensions init-list))))) + (t (signal-reader-error stream "Dimensions argument to #A not a non-negative integer: ~S" dimensions))))) + +(set-dispatch-macro-character #\# #\S + (qlfun |#S-reader| (input-stream sub-char int &aux list sd) + (declare (ignore sub-char int)) + (setq list (read-internal input-stream t nil t)) + (unless *read-suppress* + (unless (and (consp list) + (symbolp (%car list)) + (setq sd (gethash (%car list) %defstructs%)) + (setq sd (sd-constructor sd))) + (error "Can't initialize structure from ~S." list)) + (let ((args ()) (plist (cdr list))) + (unless (plistp plist) (report-bad-arg plist '(satisfies plistp))) + (while plist + (push (make-keyword (pop plist)) args) + (push (pop plist) args)) + (apply sd (nreverse args)))))) + +;;;from slisp reader2.lisp, and apparently not touched in 20 years. +(defun parse-integer (string &key (start 0) end + (radix 10) junk-allowed) + "Examine the substring of string delimited by start and end + (default to the beginning and end of the string) It skips over + whitespace characters and then tries to parse an integer. The + radix parameter must be between 2 and 36." + (flet ((parse-integer-not-integer-string (s) + (error 'parse-integer-not-integer-string :string s))) + (declare (inline parse-integer-not-integer-string)) + (unless (typep string 'string) + (setq string (require-type string 'string))) + (setq end (check-sequence-bounds string start end)) + (setq radix (%validate-radix radix)) + (let ((index (do ((i start (1+ i))) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (parse-integer-not-integer-string string))) + (unless (whitespacep (char string i)) (return i)))) + (minusp nil) + (found-digit nil) + (result 0)) + (let ((char (char string index))) + (cond ((char= char #\-) + (setq minusp t) + (setq index (1+ index))) + ((char= char #\+) + (setq index (1+ index)) + ))) + (loop + (when (= index end) (return nil)) + (let* ((char (char string index)) + (weight (digit-char-p char radix))) + (cond (weight + (setq result (+ weight (* result radix)) + found-digit t)) + (junk-allowed (return nil)) + ((whitespacep char) + (until (eq (setq index (1+ index)) end) + (unless (whitespacep (char string index)) + (parse-integer-not-integer-string string))) + (return nil)) + (t + (parse-integer-not-integer-string string)))) + (setq index (1+ index))) + (values + (if found-digit + (if minusp (- result) result) + (if junk-allowed + nil + (parse-integer-not-integer-string string))) + index)))) + + +(set-dispatch-macro-character #\# #\# + #'(lambda (stream char arg) + (declare (ignore stream)) + (if *read-suppress* + nil + (if arg + (let ((pair (assoc arg %read-objects%))) ;Not assq, could be bignum! + (if pair + (cdr pair) + (%err-disp $xnordlbl arg))) + (%err-disp $xrdndarg char))))) + +(set-dispatch-macro-character + #\# + #\= + #'(lambda (stream char arg &aux lab form) + (cond (*read-suppress* (values)) + ((null arg) (%err-disp $xrdndarg char)) + ((assoc arg %read-objects%) ;Not assq, could be bignum! + (%err-disp $xduprdlbl arg)) + (t (setq lab (cons arg nil)) + (push (%rplacd lab lab) %read-objects%) + (setq form (read stream t nil t)) + (when (eq form lab) ;#n= #n#. No can do. + (%err-disp $xnordlbl (%car lab))) + (%rplacd lab form) + (let ((scanned nil)) + (labels ((circle-subst (tree) + (if (memq tree %read-objects%) + (progn + (unless (memq tree scanned) + (setq scanned (%temp-cons tree scanned)) + (circle-subst (cdr tree))) + (cdr tree)) + (let ((gvectorp (and (gvectorp tree) (not (or (symbolp tree) (functionp tree)))))) + (unless (or (and (atom tree) (not gvectorp)) (memq tree scanned)) + (setq scanned (%temp-cons tree scanned)) + (if gvectorp + (let* ((subtype (typecode tree))) + (dotimes (i (uvsize tree)) + (declare (fixnum i)) + (unless (and (eql i 0) (eql subtype target::subtag-instance)) + (setf (uvref tree i) (circle-subst (uvref tree i)))))) + (locally + (declare (type cons tree)) + (rplaca tree (circle-subst (car tree))) + (rplacd tree (circle-subst (cdr tree)))))) + tree)))) + (declare (dynamic-extent #'circle-subst)) + (circle-subst form))))))) + + + Index: /branches/qres/ccl/lib/sequences.lisp =================================================================== --- /branches/qres/ccl/lib/sequences.lisp (revision 13564) +++ /branches/qres/ccl/lib/sequences.lisp (revision 13564) @@ -0,0 +1,2154 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; +;; utility functions +;; +;; these probably want to be in-line + +(defun make-sequence-like (sequence length) + (seq-dispatch + sequence + (make-list length) + (make-array length :element-type (array-element-type sequence)))) + +(defun adjust-test-args (item test test-not) + ;; after running this "test" is the real test, a null test means "eq" + ;; and "test-not" is used as a flag + (when test-not + (if test + (error "Both ~s and ~s keywords supplied" :test :test-not) + (setq test test-not))) + (if test + (if (or (eq test #'eq) + (eq test 'eq) + (and (or (eq test #'equal) (eq test 'equal)) + (or (fixnump item) (symbolp item)))) + (setq test nil) + (if (eq test #'funcall) + (setq test 'funcall))) + (if (or (macptrp item) (and (not (fixnump item)) (numberp item))) + (setq test #'eql))) + (values test test-not)) + +(defun adjust-key (key) + (and (neq key 'identity) + (neq key #'identity) + key)) + +(defun matchp2 (item elt test test-not key) + (if key + (setq elt (funcall key elt))) + (let ((res (if test + (if (eq test 'funcall) + (funcall item elt) + (funcall test item elt)) + (eq item elt)))) + (if test-not + (not res) + res))) + +;;; CTYPE is a recognizable subtype of VECTOR, which means that it's either +;;; a) an ARRAY-CTYPE +;;; b) a UNION-CTYPE whose leaves are ARRAY-CTYPE +;;; c) the NIL type, which is trivially a subtype of VECTOR but isn't really +;;; worth considering here +;;; d) a MEMBER-CTYPE whose members are all vectors and which therefore have +;;; corresponding ARRAY-CTYPEs. +;;; Try to find the interesection of all ARRAY-CTYPEs referenced in CTYPE and +;;; return it. +;;; Note that this intersection may be the null type. +(defun simplify-vector-ctype (ctype) + (typecase ctype + (array-ctype + (make-array-ctype :complexp nil + :element-type (array-ctype-element-type ctype) + :specialized-element-type (array-ctype-specialized-element-type ctype) + :dimensions '(*))) + + (named-ctype ctype) + (member-ctype + (apply #'type-intersection (mapcar #'(lambda (x) + (simplify-vector-ctype + (ctype-of x))) + (member-ctype-members ctype)))) + (union-ctype + (apply #'type-intersection (mapcar #'simplify-vector-ctype (union-ctype-types ctype)))))) + +(defun make-sequence (type length &key (initial-element nil initial-element-p)) + "Return a sequence of the given TYPE and LENGTH, with elements initialized + to INITIAL-ELEMENT." + (setq length (require-type length 'fixnum)) + (let* ((ctype (specifier-type type))) + (declare (fixnum length)) + (if (< length 0) (report-bad-arg length '(and fixnum unsigned-byte))) + (let ((tlength (array-ctype-length ctype))) + (if (and tlength (neq tlength length)) + (error 'invalid-subtype-error + :datum type + :expected-type `(vector ,(type-specifier (array-ctype-element-type ctype)) ,length)))) + (cond + ((csubtypep ctype (specifier-type 'base-string)) + (if initial-element-p + (make-string length + :element-type 'base-char + :initial-element initial-element) + (make-string length + :element-type 'base-char))) + ((csubtypep ctype (specifier-type 'vector)) + (let* ((atype (simplify-vector-ctype ctype))) + (unless (typep atype 'array-ctype) + (error "Can't determine vector element-type of ~s" (type-specifier ctype))) + (let* ((element-type (type-specifier (array-ctype-element-type atype)))) + (if (eq element-type '*) (setq element-type t)) + (if initial-element-p + (make-array (the fixnum length) + :element-type element-type + :initial-element initial-element) + (make-array (the fixnum length) + :element-type element-type))))) + ((csubtypep ctype (specifier-type 'null)) + (unless (zerop length) + (error 'invalid-subtype-error :datum type :expected-type 'cons))) + ((csubtypep ctype (specifier-type 'cons)) + (if (zerop length) + (error 'invalid-subtype-error :datum type :expected-type 'null) + (make-list length :initial-element initial-element))) + ((csubtypep ctype (specifier-type 'list)) + (make-list length :initial-element initial-element)) + (t (error 'invalid-subtype-error :datum type + :expected-type 'sequence))))) + + + +;;; Subseq: + +;;; SRC is a (SIMPLE-ARRAY * (*)), TYPECODE is its ... typecode, +;;; START and END are fixnums and sanity-checked. +(defun simple-1d-array-subseq (src typecode start end) + (declare (fixnum start end typecode)) + (let* ((n (- end start)) + (dest (%alloc-misc n typecode))) + (declare (fixnum n)) + (if (= typecode target::subtag-simple-vector) + (%copy-gvector-to-gvector src start dest 0 n) + (ecase typecode + ((#.target::subtag-s8-vector + #.target::subtag-u8-vector) + (%copy-ivector-to-ivector src start dest 0 n)) + ((#.target::subtag-s16-vector + #.target::subtag-u16-vector) + (%copy-ivector-to-ivector src + (the fixnum (+ start start)) + dest + 0 + (the fixnum (+ n n)))) + ((#.target::subtag-s32-vector + #.target::subtag-u32-vector + #.target::subtag-single-float-vector + #+32-bit-target #.target::subtag-fixnum-vector + #.target::subtag-simple-base-string) + (%copy-ivector-to-ivector src + (the fixnum (ash start 2)) + dest + 0 + (the fixnum (ash n 2)))) + ;; DOUBLE-FLOAT vectors have extra alignment padding on ppc32/x8632. + #+(or ppc32-target x8632-target) + (#.target::subtag-double-float-vector + (%copy-ivector-to-ivector src + (the fixnum (+ (the fixnum (ash start 3)) + (- target::misc-dfloat-offset + target::misc-data-offset))) + dest + (- target::misc-dfloat-offset + target::misc-data-offset) + (the fixnum (ash n 3)))) + #+64-bit-target + ((#.target::subtag-double-float-vector + #.target::subtag-s64-vector + #.target::subtag-u64-vector + #.target::subtag-fixnum-vector) + (%copy-ivector-to-ivector src + (the fixnum (ash start 3)) + dest + 0 + (the fixnum (ash n 3)))) + (#.target::subtag-bit-vector + ;; We can probably do a byte at a time if (not (logtest start 7)) + (if (not (logtest start 7)) + (%copy-ivector-to-ivector src + (the fixnum (ash (the fixnum (+ start 7)) + -3)) + dest + 0 + (the fixnum (ash (the fixnum (+ n 7)) + -3))) + ;; Harder to optimize this case. + (locally (declare (simple-bit-vector src dest) + (optimize (speed 3) (safety 0))) + (do* ((i start (1+ i)) + (j 0 (1+ j))) + ((= i end) dest) + (declare (fixnum i j)) + (setf (sbit dest j) (sbit src i)))))))))) + + +(defun nthcdr-error (index list &aux (copy list)) + "If index > length, error" + (dotimes (i index copy) + (declare (fixnum i)) + (if copy + (setq copy (cdr copy)) + (%err-disp $XACCESSNTH index list)))) + +; slisp didn't error if end > length, or if start > end. +(defun list-subseq* (sequence start end) + (declare (fixnum start end)) + (if (= start end) + nil + (let* ((groveled (nthcdr-error start sequence)) + (result (list (car groveled)))) + (when groveled + (do ((list (cdr groveled) (cdr list)) + (splice result (cdr (rplacd splice (list (car list))))) + (index (1+ start) (1+ index))) + ((= index end) result) + (declare (fixnum index)) + ()))))) + +; This ensures that start & end will be non-negative FIXNUMS ... +; This implies that the address space is < 2^31 bytes, i.e., no list +; can have a length > most-positive fixnum. Let them report it as a +; bug ... + +(defun subseq (sequence start &optional end) + "Return a copy of a subsequence of SEQUENCE starting with element number + START and continuing to the end of SEQUENCE or the optional END." + (setq end (check-sequence-bounds sequence start end)) + (locally + (declare (fixnum start end)) + (seq-dispatch + sequence + (list-subseq* sequence start end) + (let* ((typecode (typecode sequence))) + (declare (fixnum typecode)) + (when (= typecode target::subtag-vectorH) + (multiple-value-bind (data offset) + (array-data-and-offset sequence) + (declare (fixnum offset)) + (incf start offset) + (incf end offset) + (setq sequence data typecode (typecode data)))) + (simple-1d-array-subseq sequence typecode start end))))) + + +;;; Copy-seq: + +(defun copy-seq (sequence) + "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." + (seq-dispatch + sequence + (copy-list sequence) + (let* ((length (length sequence)) + (subtype (element-type-subtype (array-element-type sequence))) + (result (%alloc-misc length subtype)) + ) + (multiple-value-bind (src offset) (array-data-and-offset sequence) + (declare (fixnum offset)) + (dotimes (i length result) + (declare (fixnum i)) + (setf (uvref result i) (uvref src offset)) + (incf offset)))))) + + + +;;; Fill: + +(defun fill (sequence item &key (start 0) end) + "Replace the specified elements of SEQUENCE with ITEM. + !$ could be sped up by calling iv-fill, sv-fill to avoid aref overhead." + (setq end (check-sequence-bounds sequence start end)) + (seq-dispatch + sequence + (do* ((current (nthcdr start sequence) (cdr (the list current))) + (index start (1+ index))) + ((or (atom current) (= index end)) sequence) + (rplaca (the cons current) item)) + (if (and (typep sequence 'ivector) + (eql start 0) + (eql end (uvsize sequence))) + (%init-misc item sequence) + (do ((index start (1+ index))) + ((= index end) sequence) + (aset sequence index item))))) + +;;; Replace: + +(defun replace (target-sequence source-sequence &key + ((:start1 target-start) 0) + ((:end1 target-end)) + ((:start2 source-start) 0) + ((:end2 source-end))) + "The target sequence is destructively modified by copying successive + elements into it from the source sequence." + (setq target-end (check-sequence-bounds target-sequence target-start + target-end)) + (setq source-end (check-sequence-bounds source-sequence source-start + source-end)) + (locally (declare (fixnum target-start target-end source-start source-end)) + (seq-dispatch + target-sequence + (seq-dispatch + source-sequence + (if (and (eq target-sequence source-sequence) + (> target-start source-start)) + (let ((new-elts (subseq source-sequence source-start + (+ source-start + (min (- target-end target-start) + (- source-end source-start)))))) + (do ((n new-elts (cdr n)) + (o (nthcdr target-start target-sequence) (cdr o))) + ((null n) target-sequence) + (rplaca o (car n)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref)) + (source-sequence-ref (nthcdr source-start source-sequence) + (cdr source-sequence-ref))) + ((or (= target-index target-end) (= source-index source-end) + (null target-sequence-ref) (null source-sequence-ref)) + target-sequence) + (declare (fixnum target-index source-index)) + (rplaca target-sequence-ref (car source-sequence-ref)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref))) + ((or (= target-index target-end) (= source-index source-end) + (null target-sequence-ref)) + target-sequence) + (declare (fixnum target-index source-index)) + (rplaca target-sequence-ref (aref source-sequence source-index)))) + (seq-dispatch + source-sequence + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (source-sequence (nthcdr source-start source-sequence) + (cdr source-sequence))) + ((or (= target-index target-end) (= source-index source-end) + (null source-sequence)) + target-sequence) + (declare (fixnum target-index source-index)) + (aset target-sequence target-index (car source-sequence))) + ;; If we are copying around in the same vector, be careful not + ;; to copy the same elements over repeatedly. We do this by + ;; copying backwards. + (if (and (eq target-sequence source-sequence) + (> target-start source-start)) + (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) + (aset target-sequence target-index + (aref source-sequence source-index)))) + (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 (fixnum target-index source-index)) + (aset target-sequence target-index + (aref source-sequence source-index)))))))) + +;;; Concatenate: + + +(defun concatenate (output-type-spec &rest sequences) + "Return a new sequence of all the argument sequences concatenated together + which shares no structure with the original argument sequences of the + specified OUTPUT-TYPE-SPEC." + (declare (dynamic-extent sequences)) + (if (memq output-type-spec '(string simple-string)) + (setq output-type-spec 'base-string) + (unless (memq output-type-spec '(string simple-string base-string list vector + simple-base-string + bit-vector simple-bit-vector)) + (setq output-type-spec (type-expand output-type-spec)))) + (case (if (atom output-type-spec) output-type-spec (car output-type-spec)) + (list (apply #'concat-to-list* sequences)) + ((simple-vector simple-string simple-base-string base-string vector string array + bit-vector simple-bit-vector) + (apply #'concat-to-simple* output-type-spec sequences)) + (t + (if (subtypep output-type-spec 'vector) + (apply #'concat-to-simple* output-type-spec sequences) + (if (subtypep output-type-spec 'list) + (apply #'concat-to-list* sequences) + (error "~S: invalid output type specification." output-type-spec)))))) + +;;; Internal Frobs: + +(defun concat-to-list* (&rest sequences) + (declare (dynamic-extent sequences)) + (let* ((result (list nil)) + (splice result)) + (dolist (sequence sequences (%cdr result)) + (seq-dispatch + sequence + (dolist (item sequence) + (setq splice (%cdr (%rplacd splice (list item))))) + (dotimes (i (length sequence)) + (setq splice (%cdr (%rplacd splice (list (aref sequence i)))))))))) + + +(defun concat-to-simple* (output-type-spec &rest arg-sequences) + (declare (dynamic-extent arg-sequences)) + (do ((seqs arg-sequences (cdr seqs)) + (total-length 0) + ;(lengths ()) + ) + ((null seqs) + (do ((sequences arg-sequences (cdr sequences)) + ;(lengths lengths (cdr lengths)) + (index 0) + (result (make-sequence output-type-spec total-length))) + ((= index total-length) result) + (let ((sequence (car sequences))) + (seq-dispatch + sequence + (do ((sequence sequence (cdr sequence))) + ((atom sequence)) + (aset result index (car sequence)) + (setq index (1+ index))) + (let ((len (length sequence))) + (do ((jndex 0 (1+ jndex))) + ((= jndex len)) + (aset result index (aref sequence jndex)) + (setq index (1+ index)))))))) + (let ((length (length (car seqs)))) + ;(setq lengths (nconc lengths (list length))) ; if itsa list, we dont care about its length, if itsan array, length twice is cheap + (setq total-length (+ total-length length))))) + +(defun concat-to-string (&rest sequences) + (declare (dynamic-extent sequences)) + (let* ((size 0)) + (declare (fixnum size)) + (dolist (seq sequences) + (setq size (+ size (the fixnum (length seq))))) + (let* ((result (make-string size)) + (out 0)) + (declare (simple-string result) (fixnum out)) + (dolist (seq sequences result) + (etypecase seq + (simple-string + (let* ((n (length seq))) + (declare (fixnum n)) + (%copy-ivector-to-ivector seq + 0 + result + (the fixnum (ash out 2)) + (the fixnum (ash n 2))) + (incf out n))) + (string + (let* ((n (length seq))) + (declare (fixnum n)) + (multiple-value-bind (data offset) (array-data-and-offset seq) + (declare (fixnum offset)) + (%copy-ivector-to-ivector data + (the fixnum (ash offset 2)) + result + (the fixnum (ash out 2)) + (the fixnum (ash n 2))) + (incf out n)))) + (vector + (dotimes (i (length seq)) + (setf (schar result out) (aref seq i)) + (incf out))) + (list + (dolist (elt seq) + (setf (schar result out) elt)))))))) + +;This one doesn't choke on circular lists, doesn't cons as much, and is +;about 1/8K smaller to boot. +(defun map (type function sequence &rest more-sequences) + (declare (dynamic-extent more-sequences)) + (let* ((sequences (cons sequence more-sequences)) + (arglist (make-list (length sequences))) + (index 0) + args seq p (ans ())) + (declare (dynamic-extent sequences arglist)) + (unless (or (null type) + (eq type 'list) + (memq (if (consp type) (%car type) type) + '(simple-vector simple-string vector string array + simple-array bit-vector simple-bit-vector)) + (subtypep type 'sequence)) + (report-bad-arg type 'sequence)) + (loop + (setq p sequences args arglist) + (while p + (cond ((null (setq seq (%car p))) (return)) + ((consp seq) + (%rplaca p (%cdr seq)) + (%rplaca args (%car seq))) + ((eq index (length seq)) (return)) + (t (%rplaca args (elt seq index)))) + (setq args (%cdr args) p (%cdr p))) + (setq p (apply function arglist)) + (if type (push p ans)) + (setq index (%i+ index 1))) + (when type + (setq ans (nreverse ans)) + (if (eq type 'list) ans (coerce ans type))))) + +;;;;;;;;;;;;;;;;; +;; +;; some, every, notevery, notany +;; +;; these all call SOME-XX-MULTI or SOME-XX-ONE +;; SOME-XX-MULTI should probably be coded in lap +;; +;; these should be transformed at compile time +;; +;; we may want to consider open-coding when +;; the predicate is a lambda +;; + +(eval-when (:execute :compile-toplevel) + (defmacro negating-quantifier-p (quantifier-constant) + `(%i> ,quantifier-constant $notany)) + ) + +; Vector is guaranteed to be simple; new-size is guaranteed <= (length vector). +; Return vector with its size adjusted and extra doublewords zeroed out. +; Should only be called on freshly consed vectors... + + + +(defun some (predicate one-seq &rest sequences) + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return the first + non-NIL value encountered, or NIL if the end of any sequence is reached." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $some nil predicate one-seq sequences) + (some-xx-one $some nil predicate one-seq))) + +(defun notany (predicate one-seq &rest sequences) + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns a non-NIL value, or T if the end + of any sequence is reached." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $notany t predicate one-seq sequences) + (some-xx-one $notany t predicate one-seq))) + +(defun every (predicate one-seq &rest sequences) + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns NIL, or T if every invocation + is non-NIL." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $every t predicate one-seq sequences) + (some-xx-one $every t predicate one-seq))) + +(defun notevery (predicate one-seq &rest sequences) + "Apply PREDICATE to 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return T as soon + as any invocation of PREDICATE returns NIL, or NIL if every invocation + is non-NIL." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $notevery nil predicate one-seq sequences) + (some-xx-one $notevery nil predicate one-seq))) + +(defun some-xx-multi (caller at-end predicate first-seq sequences) + (let* ((sequences (cons first-seq sequences)) + (min-vector-length target::target-most-positive-fixnum) + (arg-slice (make-list (list-length sequences))) + (cur-slice arg-slice) + (not-result (negating-quantifier-p caller)) + result) + (declare (fixnum min-vector-length) + (list sequences arg-slice cur-slice) + (dynamic-extent sequences arg-slice)) + (dolist (seq sequences) + (seq-dispatch seq + nil + (setq min-vector-length (min min-vector-length + (length seq))))) + (dotimes (index min-vector-length) + (dolist (one-seq sequences) + (%rplaca cur-slice + (if (vectorp one-seq) + (aref one-seq index) + (if one-seq + (progn + (%rplaca (memq one-seq sequences) (cdr one-seq)) + (%car one-seq)) + (return-from some-xx-multi at-end)))) + (setq cur-slice (%cdr cur-slice))) + (setq result (apply predicate arg-slice) + cur-slice arg-slice) + (if not-result + (when (not result) + (return-from some-xx-multi + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-multi + (if (eq caller $some) result nil))))) + at-end)) + + +(defun some-xx-one (caller at-end predicate seq + &aux (not-result (negating-quantifier-p caller)) + result) + (if (vectorp seq) + (if (simple-vector-p seq) + (locally (declare (type simple-vector seq)) + (dovector (element seq) + (setq result (funcall predicate element)) + (if not-result + (when (not result) + (return-from some-xx-one + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-one + (if (eq caller $some ) result nil)))))) + (dovector (element seq) + (setq result (funcall predicate element)) + (if not-result + (when (not result) + (return-from some-xx-one + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-one + (if (eq caller $some ) result nil)))))) + (dolist (element seq) + (setq result (funcall predicate element)) + (if not-result + (when (not result) + (return-from some-xx-one + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-one + (if (eq caller $some ) result nil)))))) + at-end) + +;;; simple positional versions of find, position + +(defun find-positional-test-key (item sequence test key) + (if sequence + (seq-dispatch + sequence + (let ((cons (member item sequence :test test :key key))) + (and cons (%car cons))) + (let ((pos (vector-position-1 item sequence nil test nil 0 nil key))) + (and pos (aref sequence pos)))))) + +(defun find-positional-test-not-key (item sequence test-not key) + (if sequence + (seq-dispatch + sequence + (let ((cons (member item sequence :test-not test-not :key key))) + (and cons (%car cons))) + (let ((pos (vector-position-1 item sequence nil nil test-not 0 nil key))) + (and pos (aref sequence pos)))))) + +(defun position-positional-test-key (item sequence test key) + (if sequence + (seq-dispatch + sequence + (progn + (setq key (adjust-key key)) + (setq test + (adjust-test-args item test nil)) + (if (or test key) + (list-position/find-complex nil item sequence 0 nil test nil key) + (list-position/find-simple nil item sequence 0 nil))) + (vector-position-1 item sequence nil test nil 0 nil key)))) + +(defun position-positional-test-not-key (item sequence test-not key) + (if sequence + (seq-dispatch + sequence + (progn + (setq key (adjust-key key)) + (multiple-value-bind (test test-not) + (adjust-test-args item nil test-not) + (list-position/find-complex nil item sequence 0 nil test test-not key))) + (vector-position-1 item sequence nil nil test-not 0 nil key)))) + + +;;; Reduce: + +(eval-when (:execute :compile-toplevel) + + (defmacro list-reduce (function sequence start end initial-value ivp key) + (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence)))) + `(let ((sequence (nthcdr ,start ,sequence))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value ,what) + (funcall ,function value ,what))) + ((= count ,end) value))))) + + (defmacro list-reduce-from-end (function sequence start end + initial-value ivp key) + (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence)))) + `(let ((sequence (nthcdr (- (length ,sequence) ,end) (reverse ,sequence)))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value ,what) + (funcall ,function ,what value))) + ((= count ,end) value))))) + + ) ;; end eval-when + +(defun reduce (function sequence &key from-end (start 0) + end (initial-value nil ivp) key) + "The specified Sequence is ``reduced'' using the given Function. + See manual for details." + (unless end (setq end (length sequence))) + (if (= end start) + (if ivp initial-value (funcall function)) + (seq-dispatch + sequence + (if from-end + (list-reduce-from-end function sequence start end initial-value ivp key) + (list-reduce function sequence start end initial-value ivp key)) + (let* ((disp (if from-end -1 1)) + (index (if from-end (1- end) start)) + (terminus (if from-end (1- start) end)) + (value (if ivp initial-value + (let ((elt (aref sequence index))) + (setq index (+ index disp)) + (if key (funcall key elt) elt)))) + (element nil)) + (do* () + ((= index terminus) value) + (setq element (aref sequence index) + index (+ index disp) + element (if key (funcall key element) element) + value (funcall function (if from-end element value) (if from-end value element)))))))) + +(defun map-into (result-sequence function &rest sequences) + (declare (dynamic-extent sequences)) + (let* ((nargs (list-length sequences)) + (temp (make-list (length sequences))) + (maxcnt (seq-dispatch result-sequence (length result-sequence) (array-total-size result-sequence))) + (rseq result-sequence)) + (declare (fixnum nargs maxcnt)) + (declare (dynamic-extent temp)) + ; this declaration is maybe bogus + (dolist (seq sequences) + (let ((len (length seq))) + (declare (fixnum len)) + (if (< len maxcnt)(setq maxcnt len)))) + (dotimes (cnt maxcnt) + (let ((args temp)(seqs sequences)) + (dotimes (i nargs) + (let ((seq (%car seqs))) + (cond ((listp seq) + (%rplaca seqs (%cdr seq)) + (%rplaca args (%car seq))) + (t (%rplaca args (aref seq cnt))))) + (setq args (%cdr args)) + (setq seqs (%cdr seqs)))) + (let ((res (apply function temp))) + (cond ((consp rseq) + (%rplaca rseq res) + (setq rseq (%cdr rseq))) + (t (setf (aref result-sequence cnt) res))))) + (when (and (not (listp result-sequence)) + (array-has-fill-pointer-p result-sequence)) + (setf (fill-pointer result-sequence) maxcnt)) + result-sequence)) + + +;;; Coerce: + +#| +; don't know if this is always right +; It's almost never right: the "type-spec" could be something +; defined with DEFTYPE, whose last element (if it has one) has +; nothing to do with the "length" of the specified type. +(defun specifier-length (type-spec) + (if (consp type-spec) + (let ((len? (car (last type-spec)))) + (if (fixnump len?) len?)))) +|# + + +(defun array-ctype-length (ctype) + (if (typep ctype 'array-ctype) + (let* ((dims (array-ctype-dimensions ctype))) + (if (listp dims) + (if (null (cdr dims)) + (let* ((dim0 (car dims))) + (unless (eq dim0 '*) dim0))))))) + + + + +; from optimizer - just return object if type is OK + + +;If you change this, remember to change the transform. +(defun coerce (object output-type-spec) + "Coerce the Object to an object of type Output-Type-Spec." + (let* ((type (specifier-type output-type-spec))) + (if (%typep object type) + object + (cond + ((csubtypep type (specifier-type 'character)) + (character object)) + ((eq output-type-spec 'standard-char) + (let ((char (character object))) + (unless (standard-char-p char) (%err-disp $xcoerce object 'standard-char)) + char)) + ((eq output-type-spec 'compiled-function) + (coerce-to-compiled-function object)) + ((csubtypep type (specifier-type 'function)) + (coerce-to-function-1 object)) + ((csubtypep type (specifier-type 'cons)) + (if object + (coerce-to-list object) + (report-bad-arg object 'cons))) + ((csubtypep type (specifier-type 'list)) + (coerce-to-list object)) + ((csubtypep type (specifier-type 'string)) + (let ((length (array-ctype-length type))) + (if (and length (neq length (length object))) + (report-bad-arg (make-string length) `(string ,(length object))))) + (coerce-to-uarray object #.(type-keyword-code :simple-string) + t)) + ((csubtypep type (specifier-type 'vector)) + (let ((length (array-ctype-length type))) + (if (and length (neq length (length object))) + (error 'invalid-subtype-error + :datum output-type-spec + :expected-type `(vector * ,(length object))))) + (let* ((atype (simplify-vector-ctype type))) + (unless (typep atype 'array-ctype) + (error "Can't determine vector type of ~s" output-type-spec)) + (let* ((element-type (type-specifier (array-ctype-element-type atype)))) + (let ((length (array-ctype-length atype))) + (if (and length (neq length (length object))) + (report-bad-arg (make-array length :element-type element-type) + `(vector ,element-type ,(length object)))) + (coerce-to-uarray object (element-type-subtype element-type) t))))) + ((csubtypep type (specifier-type 'array)) + (let* ((dims (array-ctype-dimensions type))) + (when (consp dims) + (when (not (null (cdr dims)))(error "~s is not a sequence type." output-type-spec)))) + (let ((length (array-ctype-length type))) + (if (and length (neq length (length object))) + (error "Length of ~s is not ~s." object length))) + (coerce-to-uarray object (element-type-subtype (type-specifier + (array-ctype-element-type type))) t)) + ((numberp object) + (let ((res + (cond + ((csubtypep type (specifier-type 'double-float)) + (float object 1.0d0)) + ((csubtypep type (specifier-type 'float)) + (float object 1.0s0)) + ((csubtypep type (specifier-type 'complex)) + (coerce-to-complex object output-type-spec))))) + (unless res ;(and res (%typep res type)) + (error "~S can't be coerced to type ~S." object output-type-spec)) + res)) + (t (error "~S can't be coerced to type ~S." object output-type-spec)))))) + +(defun %coerce-to-string (seq) + (let* ((len (length seq)) + (string (make-string len))) + (declare (fixnum len) (simple-base-string string)) + (if (typep seq 'list) + (do* ((l seq (cdr l)) + (i 0 (1+ i))) + ((null l) string) + (declare (list l) ; we know that it's a proper list because LENGTH won + (fixnum i)) + (setf (schar string i) (car l))) + (dotimes (i len string) + (setf (schar string i) (aref seq i)))))) + +(defun %coerce-to-vector (seq subtype) + (let* ((len (length seq)) + (vector (%alloc-misc len subtype))) + (declare (fixnum len) (type (simple-array * (*)) vector)) + (if (typep seq 'list) + (do* ((l seq (cdr l)) + (i 0 (1+ i))) + ((null l) vector) + (declare (list l) ; we know that it's a proper list because LENGTH won + (fixnum i)) + (setf (uvref vector i) (car l))) + (dotimes (i len vector) + (setf (uvref vector i) (aref seq i)))))) + +(defun %coerce-to-list (seq) + (if (typep seq 'list) + seq + (collect ((result)) + (dotimes (i (length seq) (result)) + (result (aref seq i)))))) + + + + +(defun coerce-to-complex (object output-type-spec) + (if (consp output-type-spec) + (let ((type2 (cadr output-type-spec))) + (if (complexp object) + (complex (coerce (realpart object) type2)(coerce (imagpart object) type2)) + (complex (coerce object type2) 0))) + (complex object))) + + +(defun coerce-to-function-1 (thing) + (if (functionp thing) + thing + (if (symbolp thing) + (%function thing) + (if (lambda-expression-p thing) + (%make-function nil thing nil) + (%err-disp $xcoerce thing 'function))))) + +;;; Internal Frobs: +;(coerce object ') +(defun coerce-to-uarray (object subtype simple-p) + (if (typep object 'array) + (if (and (or (not simple-p) (typep object 'simple-array)) + (or (null subtype) (eq (array-element-subtype object) subtype))) + object + ;Make an array of the same shape as object but different subtype.. + (%copy-array subtype object)) + (if (typep object 'list) + (%list-to-uvector subtype object) + (%err-disp $xcoerce object 'array)))) + +;(coerce object 'list) +(defun coerce-to-list (object) + (seq-dispatch + object + object + (let* ((n (length object))) + (declare (fixnum n)) + (multiple-value-bind (data offset) (array-data-and-offset object) + (let* ((head (cons nil nil)) + (tail head)) + (declare (dynamic-extent head) + (cons head tail)) + (do* ((i 0 (1+ i)) + (j offset (1+ j))) + ((= i n) (cdr head)) + (declare (fixnum i j)) + (setq tail (cdr (rplacd tail (cons (uvref data j) nil)))))))))) + + +(defun %copy-array (new-subtype array) + ;To be rewritten once make-array disentangled (so have a subtype-based entry + ;point) + (make-array (if (eql 1 (array-rank array)) + (length array) + (array-dimensions array)) + :element-type (element-subtype-type new-subtype) + :initial-contents array ;***** WRONG ***** + )) + +(defun check-count (c) + (if c + (min (max (require-type c 'integer) 0) target::target-most-positive-fixnum) + target::target-most-positive-fixnum)) + +;;; Delete: + +(defun list-delete-1 (item list from-end test test-not start end count key + &aux (temp list) revp) + (unless end (setq end target::target-most-positive-fixnum)) + (when (and from-end count) + (let ((len (length temp))) + (if (not (%i< start len)) + (return-from list-delete-1 temp)) + (setq temp (nreverse temp) revp t) + (psetq end (%i- len start) + start (%i- len (%imin len end))))) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq temp + (if (or test key test-not) + (list-delete-moderately-complex item temp start end count test test-not key) + (list-delete-very-simple item temp start end count))) + (if revp + (nreverse temp) + temp)) + + +(defun list-delete-very-simple (item list start end count) + (unless start (setq start 0)) + (unless end (setq end target::target-most-positive-fixnum)) + (setq count (check-count count)) + (do* ((handle (cons nil list)) + (splice handle) + (numdeleted 0) + (i 0 (1+ i))) + ((or (eq i end) (null (%cdr splice)) (eq numdeleted count)) + (%cdr handle)) + (declare (fixnum i start end count numdeleted) ; declare-type-free !! + (dynamic-extent handle) + (list splice handle)) + (if (and (%i>= i start) (eq item (car (%cdr splice)))) + (progn + (%rplacd splice (%cddr splice)) + (setq numdeleted (%i+ numdeleted 1))) + (setq splice (%cdr splice))))) + +(defun list-delete-moderately-complex (item list start end count test test-not key) + (unless start (setq start 0)) + (unless end (setq end target::target-most-positive-fixnum)) + (setq count (check-count count)) + (do* ((handle (cons nil list)) + (splice handle) + (numdeleted 0) + (i 0 (1+ i))) + ((or (= i end) (null (cdr splice)) (= numdeleted count)) + (cdr handle)) + (declare (fixnum i start end count numdeleted) + (dynamic-extent handle) + (list splice)) + (if (and (>= i start) (matchp2 item (cadr splice) test test-not key)) + (progn + (rplacd splice (cddr splice)) + (setq numdeleted (1+ numdeleted))) + (setq splice (cdr splice))))) + +(defun list-delete (item list &key from-end test test-not (start 0) + end count key + &aux (temp list) revp) + (unless end (setq end target::target-most-positive-fixnum)) + (when (and from-end count) + (let ((len (length temp))) + (if (not (%i< start len)) + (return-from list-delete temp)) + (setq temp (nreverse temp) revp t) + (psetq end (%i- len start) + start (%i- len (%imin len end))))) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq temp + (if (or test key test-not) + (list-delete-moderately-complex item temp start end count test test-not key) + (list-delete-very-simple item temp start end count))) + (if revp + (nreverse temp) + temp)) + +; The vector will be freshly consed & nothing is displaced to it, +; so it's legit to destructively truncate it. +; Likewise, it's ok to access its components with UVREF. + +(defun simple-vector-delete (item vector test test-not key start end inc count + &aux (length (length vector)) + subtype pos fill) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds vector start end)) + (setq fill start) + (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1))) + (let* ((bv (make-array (the fixnum (length vector)) :element-type 'bit :Initial-element 0)) + offset) + (declare (dynamic-extent bv) + (type (simple-array bit (*)) bv)) + (multiple-value-setq (vector offset)(array-data-and-offset vector)) + (setq subtype (typecode vector)) + (setq pos start) + (loop + (when (or (eq count 0) (eq pos end)) + (unless (eq pos end) + (incf fill (abs (- pos end)))) + (return)) + (if (matchp2 item (uvref vector (%i+ pos offset)) + test test-not key) + (progn (setf (aref bv pos) 1) + (setq count (%i- count 1))) + (setq fill (%i+ fill 1))) + (setq pos (%i+ pos inc))) + (when (%i< inc 0) + (psetq start (%i+ end 1) end (%i+ start 1))) + (let* ((tail (- length end)) + (size (+ fill tail)) + (new-vect (%alloc-misc size subtype)) + (fill-end fill)) + (declare (fixnum tail size)) + (when (neq 0 start) + (dotimes (i start) + (setf (uvref new-vect i) (uvref vector (%i+ offset i))) + )) + (setq fill start) + (setq pos start) + (loop + (if (eq fill fill-end) (return)) + (if (neq 1 (aref bv pos)) + (progn + (setf (uvref new-vect fill) (uvref vector (%i+ offset pos))) + (setq fill (%i+ fill 1)))) + (setq pos (%i+ pos 1))) + (setq pos end) + (loop + (when (eq fill size) (return)) + (setf (uvref new-vect fill) (uvref vector (%i+ offset pos))) + (setq fill (%i+ fill 1) + pos (%i+ pos 1))) + new-vect))) + + +; When a vector has a fill pointer & it can be "destructively modified" by adjusting +; that fill pointer. +(defun vector-delete (item vector test test-not key start end inc count + &aux (length (length vector)) pos fill val) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds vector start end)) + (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1))) + (setq fill (setq pos start)) + (loop + (if (or (eq count 0) (eq pos end)) (return)) + (if (matchp2 item (setq val (aref vector pos)) test test-not key) + (setq count (%i- count 1)) + (progn + (if (neq fill pos) (setf (aref vector fill) val)) + (setq fill (%i+ fill inc)))) + (setq pos (%i+ pos inc))) + (if (%i> fill pos) (psetq fill (%i+ pos 1) pos (%i+ fill 1))) + (loop + (if (eq pos length) (return)) + (setf (aref vector fill) (aref vector pos)) + (setq fill (%i+ fill 1) pos (%i+ pos 1))) + (when (eq t (array-element-type vector)) + (let ((old-fill (fill-pointer vector)) + (i fill)) + (declare (fixnum i old-fill)) + (loop + (when (>= i old-fill) (return)) + (setf (aref vector i) nil) + (incf i)))) + (setf (fill-pointer vector) fill) + vector) + +(defun delete (item sequence &key from-end test test-not (start 0) + end count key) + "Return a sequence formed by destructively removing the specified ITEM from + the given SEQUENCE." + (setq count (check-count count)) + (if sequence + (seq-dispatch + sequence + (list-delete-1 item + sequence + from-end + test + test-not + start + end + count + key) + (if (array-has-fill-pointer-p sequence) + (vector-delete item sequence test test-not key start end (if from-end -1 1) count) + (simple-vector-delete item + sequence + test test-not key start end (if from-end -1 1) count))))) + +(defun delete-if (test sequence &key from-end (start 0) + end count key) + "Return a sequence formed by destructively removing the elements satisfying + the specified PREDICATE from the given SEQUENCE." + (delete test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + +(defun delete-if-not (test sequence &key from-end (start 0) end count key) + "Return a sequence formed by destructively removing the elements not + satisfying the specified PREDICATE from the given SEQUENCE." + (delete test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + + + +;;; Remove: + + + +(defun remove (item sequence &key from-end test test-not (start 0) + end count key) + "Return a copy of SEQUENCE with elements satisfying the test (default is + EQL) with ITEM removed." + (setq count (check-count count)) + (seq-dispatch + sequence + (list-delete-1 item + (copy-list sequence) + from-end + test + test-not + start + end + count + key) + (simple-vector-delete item + sequence + test + test-not + key + start + end + (if from-end -1 1) + count))) + + + + +(defun remove-if (test sequence &key from-end (start 0) + end count key) + "Return a copy of sequence with elements such that predicate(element) + is non-null removed" + (setq count (check-count count)) + (remove test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + +(defun remove-if-not (test sequence &key from-end (start 0) + end count key) + "Return a copy of sequence with elements such that predicate(element) + is null removed" + (setq count (check-count count)) + (remove test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + +;;; Remove-Duplicates: + +;;; Remove duplicates from a list. If from-end, remove the later duplicates, +;;; not the earlier ones. Thus if we check from-end we don't copy an item +;;; if we look into the already copied structure (from after :start) and see +;;; the item. If we check from beginning we check into the rest of the +;;; original list up to the :end marker (this we have to do by running a +;;; do loop down the list that far and using our test. +; test-not is typically NIL, but member doesn't like getting passed NIL +; for its test-not fn, so I special cased the call to member. --- cfry + +(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) + from-end end key) + "The elements of SEQUENCE are compared pairwise, and if any two match, + the one occurring earlier is discarded, unless FROM-END is true, in + which case the one later in the sequence is discarded. The resulting + sequence is returned. + + The :TEST-NOT argument is deprecated." + (setq end (check-sequence-bounds sequence start end)) + (delete-duplicates (copy-seq sequence) :from-end from-end :test test + :test-not test-not :start start :end end :key key)) + +;;; Delete-Duplicates: + +(defparameter *delete-duplicates-hash-threshold* 200) + +(defun list-delete-duplicates* (list test test-not key from-end start end) + ;;(%print "test:" test "test-not:" test-not "key:" key) + (let* ((len (- end start)) + (handle (cons nil list)) + (previous (nthcdr start handle))) + (declare (dynamic-extent handle)) + (if (and (> len *delete-duplicates-hash-threshold*) + (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp) + (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp))) + (let ((hash (make-hash-table :size len :test test :shared nil))) + (loop for i from start below end as obj in (cdr previous) + do (incf (gethash (funcall key obj) hash 0))) + (loop for i from start below end while (cdr previous) + do (let* ((current (cdr previous)) + (obj (car current)) + (obj-key (funcall key obj))) + (if (if from-end + ;; Keep first ref + (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil)) + ;; Keep last ref + (eql (decf (gethash obj-key hash)) 0)) + (setq previous current) + (rplacd previous (cdr current)))))) + (do ((current (cdr previous) (cdr current)) + (index start (1+ index))) + ((or (= index end) (null current))) + ;;(%print "outer loop top current:" current "previous:" previous) + (if (do ((x (if from-end + (nthcdr (1+ start) handle) + (cdr current)) + (cdr x)) + (i (1+ index) (1+ i))) + ((or (null x) + (and (not from-end) (= i end)) + (eq x current)) + nil) + ;;(%print "inner loop top x:" x "i:" i) + (if (list-delete-duplicates*-aux current x test test-not key) + (return t))) + (rplacd previous (cdr current)) + (setq previous (cdr previous))))) + (cdr handle))) + +(defun list-delete-duplicates*-aux (current x test test-not key) + (if test-not + (not (funcall test-not + (funcall key (car current)) + (funcall key (car x)))) + (funcall test + (funcall key (car current)) + (funcall key (car x))))) + + +(defun vector-delete-duplicates* (vector test test-not key from-end start end + &optional (length (length vector))) + (declare (vector vector)) + (let* ((len (- end start)) + (index start) + (jndex start)) + (if (and (not test-not) + (> len *delete-duplicates-hash-threshold*) + (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp) + (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp))) + (let ((hash (make-hash-table :size len :test test :shared nil))) + (loop for i from start below end as obj = (aref vector i) + do (incf (gethash (funcall key obj) hash 0))) + (loop while (< index end) as obj = (aref vector index) as obj-key = (funcall key obj) + do (incf index) + do (when (if from-end + (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil)) + (eql (decf (gethash obj-key hash)) 0)) + (aset vector jndex obj) + (incf jndex)))) + (loop while (< index end) as obj = (aref vector index) + do (incf index) + do (unless (position (funcall key obj) vector :key key + :start (if from-end start index) :test test + :end (if from-end jndex end) :test-not test-not) + (aset vector jndex obj) + (incf jndex)))) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index length) + (setq vector (shrink-vector vector jndex))) + (aset vector jndex (aref vector index))))) + + +(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key) + "The elements of SEQUENCE are examined, and if any two match, one is + discarded. The resulting sequence, which may be formed by destroying the + given sequence, is returned. + Sequences of type STR have a NEW str returned." + (setq end (check-sequence-bounds sequence start end)) + (unless key (setq key #'identity)) + (seq-dispatch sequence + (if sequence + (list-delete-duplicates* sequence test test-not key from-end start end)) + (vector-delete-duplicates* sequence test test-not key from-end start end))) + +(defun list-substitute* (pred new list start end count key + test test-not old) + ;(print-db pred new list start end count key test test-not old) + (let* ((result (list nil)) + elt + (splice result) + (list list)) ; Get a local list for a stepper. + (do ((index 0 (1+ index))) + ((= index start)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (do ((index start (1+ index))) + ((or (and end (= index end)) (null list) (= count 0))) + (setq elt (car list)) + (setq splice + (cdr (rplacd splice + (list + (cond ((case pred + (normal + (if test-not + (not (funcall test-not old + ;fry mod to slisp, which had arg order of OLD and ELT reversed. + (funcall key elt))) + (funcall test old + (funcall key elt)))) + (if (funcall test (funcall key elt))) + (if-not (not (funcall test + (funcall key elt))))) + (setq count (1- count)) + new) + (t elt)))))) + (setq list (cdr list))) + (do () + ((null list)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (cdr result))) + +;;; Replace old with new in sequence moving from left to right by incrementer +;;; on each pass through the loop. Called by all three substitute functions. +(defun vector-substitute* (pred new sequence incrementer left right length + start end count key test test-not old) + (let ((result (make-sequence-like sequence length)) + (index left)) + (do () + ((= index start)) + (aset result index (aref sequence index)) + (setq index (+ index incrementer))) + (do ((elt)) + ((or (= index end) (= count 0))) + (setq elt (aref sequence index)) + (aset result index + (cond ((case pred + (normal + (if test-not + (not (funcall test-not old (funcall key elt))) ;cfry mod + (funcall test old (funcall key elt)))) ;cfry mod + (if (funcall test (funcall key elt))) + (if-not (not (funcall test (funcall key elt))))) + (setq count (1- count)) + new) + (t elt))) + (setq index (+ index incrementer))) + (do () + ((= index right)) + (aset result index (aref sequence index)) + (setq index (+ index incrementer))) + result)) + +;;; Substitute: + +(defun substitute (new old sequence &key from-end (test #'eql) test-not + (start 0) count + end (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements, + except that all elements equal to OLD are replaced with NEW. See manual + for details." + (setq count (check-count count)) + (let ((length (length sequence)) ) + (setq end (check-sequence-bounds sequence start end)) + (seq-dispatch + sequence + (if from-end + (nreverse (list-substitute* 'normal new (reverse sequence) (- length end) + (- length start) count key test test-not old)) + (list-substitute* 'normal new sequence start end count key test test-not + old)) + (if from-end + (vector-substitute* 'normal new sequence -1 (1- length) -1 length + (1- end) (1- start) count key test test-not old) + (vector-substitute* 'normal new sequence 1 0 length length + start end count key test test-not old))))) + + +(defun substitute-if (new test sequence &key from-end (start 0) + (end (length sequence)) + count (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements satisfying the PRED are replaced with NEW. See + manual for details." + (substitute new test sequence + :from-end from-end + :test #'funcall + :start start + :end end + :from-end from-end + :count count + :key key)) + +(defun substitute-if-not (new test sequence &key from-end (start 0) + (end (length sequence)) + count (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements not satisfying the PRED are replaced with NEW. + See manual for details." + (substitute new test sequence + :from-end from-end + :test-not #'funcall + :start start + :end end + :from-end from-end + :count count + :key key)) + +;;; NSubstitute: + +(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not + end + (count target::target-most-positive-fixnum) (key #'identity) (start 0)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements equal to OLD are replaced with NEW. The SEQUENCE + may be destructively modified. See manual for details." + (setq count (check-count count)) + (let ((incrementer 1) + (length (length sequence))) + (setq end (check-sequence-bounds sequence start end)) + (seq-dispatch + sequence + (if from-end + (nreverse (nlist-substitute* + new old (nreverse (the list sequence)) + test test-not + (- length end) + (- length start) + count key)) + (nlist-substitute* new old sequence + test test-not start end count key)) + (progn + (if from-end + (psetq start (1- end) + end (1- start) + incrementer -1)) + (nvector-substitute* new old sequence incrementer + test test-not start end count key))))) + +(defun nlist-substitute* (new old sequence test test-not start end count key) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (and end (= index end)) (null list) (= count 0)) sequence) + (when (if test-not + (not (funcall test-not old (funcall key (car list)))) ;cfry mod + (funcall test old (funcall key (car list)))) ;cfry mod + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute* (new old sequence incrementer + test test-not start end count key) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (when (if test-not + (not (funcall test-not old (funcall key (aref sequence index)))) + ;above cfry mod. both order of argss to test-not and paren error + ; between the funcall key and the funcall test-not + (funcall test old (funcall key (aref sequence index)))) ;cfry mod + (aset sequence index new) + (setq count (1- count))))) + +;;; NSubstitute-If: + +(defun nsubstitute-if (new test sequence &key from-end (start 0) + end + (count target::target-most-positive-fixnum) (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements satisfying the PRED are replaced with NEW. + SEQUENCE may be destructively modified. See manual for details." + (nsubstitute new test sequence + :from-end from-end + :test #'funcall + :start start + :end end + :count count + :key key)) + + +;;; NSubstitute-If-Not: + +(defun nsubstitute-if-not (new test sequence &key from-end (start 0) + end (count target::target-most-positive-fixnum) (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements not satisfying the TEST are replaced with NEW. + SEQUENCE may be destructively modified. See manual for details." + (nsubstitute new test sequence + :from-end from-end + :test-not #'funcall + :start start + :end end + :count count + :key key)) + + +;;; Position: + +(defun list-position/find-1 (eltp item list from-end test test-not start end key &aux hard) + ;;if eltp is true, return element, otherwise return position + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds list start end) + hard (or test key test-not)) + (if from-end + (if hard + (list-position/find-from-end-complex eltp item list start end test test-not key) + (list-position/find-from-end-simple eltp item list start end)) + (if hard + (list-position/find-complex eltp item list start end test test-not key) + (list-position/find-simple eltp item list start end)))) + +(defun position (item sequence &key from-end test test-not (start 0) end key) + (if sequence + (seq-dispatch + sequence + (list-position/find-1 nil item sequence from-end test test-not start end key) + (vector-position-1 item sequence from-end test test-not start end key)))) + +;Is it really necessary for these internal functions to take keyword args? +(defun list-position/find (eltp item list &key from-end test test-not (start 0) end key &aux hard) + ;;if eltp is true, return element, otherwise return position + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds list start end) + hard (or test key test-not)) + (if from-end + (if hard + (list-position/find-from-end-complex eltp item list start end test test-not key) + (list-position/find-from-end-simple eltp item list start end)) + (if hard + (list-position/find-complex eltp item list start end test test-not key) + (list-position/find-simple eltp item list start end)))) + +;;; make these things positional + + + +;;; add a simple-vector case + +(defun vector-position-1 (item vector from-end test test-not start end key + &aux (inc (if from-end -1 1)) pos) + (setq end (check-sequence-bounds vector start end)) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (if from-end (psetq start (%i- end 1) end (%i- start 1))) + (setq pos start) + (if (simple-vector-p vector) + (locally (declare (type simple-vector vector) + (optimize (speed 3) (safety 0))) + (loop + (if (eq pos end) (return)) + (if (matchp2 item (aref vector pos) test test-not key) (return pos)) + (setq pos (%i+ pos inc)))) + (loop + (if (eq pos end) (return)) + (if (matchp2 item (aref vector pos) test test-not key) (return pos)) + (setq pos (%i+ pos inc))))) + +(defun list-position/find-simple (eltp item list start end &aux (pos 0)) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (if (eq item (car list)) + (return (if eltp item pos)) + (setq list (%cdr list) pos (%i+ pos 1))) + (return)))) + +(defun list-position/find-complex (eltp item list start end test test-not key &aux (pos 0)) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (progn + (if (matchp2 item (car list) test test-not key) + (return (if eltp (%car list) pos)) + (setq list (%cdr list) pos (%i+ pos 1)))) + (return)))) + +(defun list-position/find-from-end-simple (eltp item list start end &aux (pos 0) ret) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (progn + (if (eq item (car list)) (setq ret pos)) + (setq list (%cdr list) pos (%i+ pos 1))) + (return (if eltp (if ret item) ret))))) + +(defun list-position/find-from-end-complex (eltp item list start end test test-not key + &aux (pos 0) ret val) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (progn + (if (matchp2 item (setq val (car list)) test test-not key) + (setq ret (if eltp val pos))) + (setq list (%cdr list) pos (%i+ pos 1))) + (return ret)))) + +(defun vector-position (item vector &key from-end test test-not (start 0) end key + &aux (inc (if from-end -1 1)) pos) + (setq end (check-sequence-bounds vector start end)) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (if from-end (psetq start (%i- end 1) end (%i- start 1))) + (setq pos start) + (loop + (if (eq pos end) (return)) + (if (matchp2 item (aref vector pos) test test-not key) (return pos)) + (setq pos (%i+ pos inc)))) + +;;; Position-if: + +(defun position-if (test sequence &key from-end (start 0) end key) + (position test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :key key)) + + +;;; Position-if-not: + +(defun position-if-not (test sequence &key from-end (start 0) end key) + (position test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :key key)) + +;;; Count: + +(defun vector-count-from-start (test item sequence start end key) + (declare (fixnum start end)) + (do* ((index start (1+ index)) + (count 0)) + ((= index end) count) + (declare (fixnum index count)) + (when (funcall test item (funcall key (aref sequence index))) + (incf count)))) + +(defun vector-count-from-end (test item sequence start end key) + (declare (fixnum start end)) + (do* ((index (1- end) (1- index)) + (count 0) + (limit (1- start))) + ((= index limit) count) + (declare (fixnum index count limit)) + (when (funcall test item (funcall key (aref sequence index))) + (incf count)))) + +(defun vector-count-not-p-from-start (test-not item sequence start end key) + (declare (fixnum start end)) + (do* ((index start (1+ index)) + (count 0)) + ((= index end) count) + (declare (fixnum index count)) + (unless (funcall test-not item (funcall key (aref sequence index))) + (incf count)))) + +(defun vector-count-not-p-from-end (test-not item sequence start end key) + (declare (fixnum start end)) + (do* ((index (1- end) (1- index)) + (count 0) + (limit (1- start))) + ((= index limit) count) + (declare (fixnum index count limit)) + (unless (funcall test-not item (funcall key (aref sequence index))) + (incf count)))) + +(defun list-count-from-start (test item sequence start end key) + (declare (fixnum start end) (list sequence)) + (do* ((seq (nthcdr start sequence) (cdr seq)) + (element (car seq) (car seq)) + (index start (1+ index)) + (count 0)) + ((or (= index end) (null seq)) count) + (declare (fixnum index count) (list seq)) + (when (funcall test item (funcall key element)) + (incf count)))) + +(defun list-count-from-end (test item sequence start end key) + (declare (fixnum start end)) + (let* ((len (length sequence))) + (declare (fixnum len)) + (list-count-from-start test item (reverse sequence) (- len end) (- len start) key))) + +(defun list-count-not-p-from-start (test-not item sequence start end key) + (declare (fixnum start end) (list sequence)) + (do* ((seq (nthcdr start sequence) (cdr seq)) + (element (car seq) (car seq)) + (index start (1+ index)) + (count 0)) + ((or (= index end) (null seq)) count) + (declare (fixnum index count) (list seq)) + (unless (funcall test-not item (funcall key element)) + (incf count)))) + +(defun list-count-not-p-from-end (test-not item sequence start end key) + (declare (fixnum start end)) + (let* ((len (length sequence))) + (declare (fixnum len)) + (list-count-not-p-from-start test-not item (reverse sequence) (- len end) (- len start) key))) + +(defun count (item sequence &key from-end (test #'eql testp) + (test-not nil notp) (start 0) end key) + "Return the number of elements in SEQUENCE satisfying a test with ITEM, + which defaults to EQL." + (if (and testp notp) + (test-not-error test test-not)) + (unless key + (setq key #'identity)) + (setq end (check-sequence-bounds sequence start end)) + (if sequence + (seq-dispatch + sequence + (if notp + (if from-end + (list-count-not-p-from-end test-not item sequence start end key) + (list-count-not-p-from-start test-not item sequence start end key)) + (if from-end + (list-count-from-end test item sequence start end key) + (list-count-from-start test item sequence start end key))) + (if notp + (if from-end + (vector-count-not-p-from-end test-not item sequence start end key) + (vector-count-not-p-from-start test-not item sequence start end key)) + (if from-end + (vector-count-from-end test item sequence start end key) + (vector-count-from-start test item sequence start end key)))) + 0)) + + +;;; Count-if: + +(defun count-if (test sequence &key from-end (start 0) end key) + "Return the number of elements in SEQUENCE satisfying PRED(el)." + (count test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :key key)) + +;;; Count-if-not: + +(defun count-if-not (test sequence &key from-end (start 0) end key) + "Return the number of elements in SEQUENCE not satisfying TEST(el)." + (count test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :key key)) + + +;;; Find: + +(defun find (item sequence &key from-end test test-not (start 0) end key &aux temp) + (if sequence + (seq-dispatch + sequence + (list-position/find-1 t item sequence from-end test test-not start end key) + (if (setq temp (vector-position-1 item sequence from-end test test-not start end key)) + (aref sequence temp))))) + +(defun find-if (test sequence &key from-end (start 0) end key) + (find test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :key key)) + +(defun find-if-not (test sequence &key from-end (start 0) end key) + (find test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :key key)) + + +;;; Mismatch: + +(defun mismatch (seq1 seq2 &key (from-end nil) + (test #'eql) + (test-not nil) + (key #'identity) + (start1 0) + (start2 0) + (end1 nil) + (end2 nil) + &aux (length1 (length seq1)) + (length2 (length seq2)) + (vectorp1 (vectorp seq1)) + (vectorp2 (vectorp seq2))) + "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared + element-wise. If they are of equal length and match in every element, the + result is NIL. Otherwise, the result is a non-negative integer, the index + within SEQUENCE1 of the leftmost position at which they fail to match; or, + if one is shorter than and a matching prefix of the other, the index within + SEQUENCE1 beyond the last position tested is returned. If a non-NIL + :FROM-END argument is given, then one plus the index of the rightmost + position in which the sequences differ is returned." + ;seq type-checking is done by length + ;start/end type-cheking is done by <= (below) + ;test/key type-checking is done by funcall + ;no check for both test and test-not + (or end1 (setq end1 length1)) + (or end2 (setq end2 length2)) + (unless (and (<= start1 end1 length1) + (<= start2 end2 length2)) + (error "Sequence arg out of range")) + (unless vectorp1 + (setq seq1 (nthcdr start1 seq1)) + (if from-end + (do* ((s1 ()) + (i start1 (1+ i))) + ((= i end1) (setq seq1 s1)) + (push (pop seq1) s1)))) + (unless vectorp2 + (setq seq2 (nthcdr start2 seq2)) + (if from-end + (do* ((s2 ()) + (i start2 (1+ i))) + ((= i end2) (setq seq2 s2)) + (push (pop seq2) s2)))) + (when test-not (setq test test-not)) + (if from-end + ;from-end + (let* ((count1 end1) + (count2 end2) + (elt1) + (elt2)) + (loop + (if (or (eq count1 start1) + (eq count2 start2)) + (return-from mismatch + (if (and (eq count1 start1) + (eq count2 start2)) + nil + count1))) + + (setq count1 (%i- count1 1) + count2 (%i- count2 1)) + + (setq elt1 (funcall key (if vectorp1 + (aref seq1 count1) + (prog1 + (%car seq1) + (setq seq1 (%cdr seq1))))) + elt2 (funcall key (if vectorp2 + (aref seq2 count2) + (prog1 + (%car seq2) + (setq seq2 (%cdr seq2)))))) + + (when (if test-not + (funcall test elt1 elt2) + (not (funcall test elt1 elt2))) + (return-from mismatch (%i+ count1 1))))) + ;from-start + (let* ((count1 start1) + (count2 start2) + (elt1) + (elt2)) + (loop + (if (or (eq count1 end1) + (eq count2 end2)) + (return-from mismatch + (if (and (eq count1 end1) + (eq count2 end2)) + nil + count1))) + (setq elt1 (funcall key (if vectorp1 + (aref seq1 count1) + (prog1 + (%car seq1) + (setq seq1 (%cdr seq1))))) + elt2 (funcall key (if vectorp2 + (aref seq2 count2) + (prog1 + (%car seq2) + (setq seq2 (%cdr seq2)))))) + + (when (if test-not + (funcall test elt1 elt2) + (not (funcall test elt1 elt2))) + (return-from mismatch count1)) + (setq count1 (%i+ count1 1) + count2 (%i+ count2 1)) + + )))) + + +;;; Search comparison functions: + +(eval-when (:execute :compile-toplevel) + + ;;; Compare two elements + + (defmacro xcompare-elements (elt1 elt2) + `(if (not key) + (if test-not + (not (funcall test-not ,elt1 ,elt2)) + (funcall test ,elt1 ,elt2)) + (let* ((e1 (funcall key ,elt1)) + (e2 (funcall key ,elt2))) + (if test-not + (not (funcall test-not e1 e2)) + (funcall test e1 e2))))) + + (defmacro vector-vector-search (sub main) + `(let ((first-elt (aref ,sub start1)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (aref ,main index2)) + (if (do* ((subi1 (1+ start1)(1+ subi1)) + (subi2 (1+ index2) (1+ subi2))) + ((eq subi1 end1) t) + (declare (fixnum subi1 subi2)) + (if (not (xcompare-elements (aref ,sub subi1) (aref ,main subi2))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + (defmacro list-list-search (sub main) + `(let* ((sub-sub (nthcdr start1 ,sub)) + (first-elt (%car sub-sub)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (sub-main (nthcdr start2 ,main) (%cdr sub-main)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (car sub-main)) + (if (do* ((ss (%cdr sub-sub) (%cdr ss)) + (pos (1+ start1) (1+ pos)) + (sm (%cdr sub-main) (cdr sm))) + ((or (null ss) (= pos end1)) t) + (declare (fixnum pos)) + (if (not (xcompare-elements (%car ss) (%car sm))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + (defmacro list-vector-search (sub main) + `(let* ((sub-sub (nthcdr start1 ,sub)) + (first-elt (%car sub-sub)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (aref ,main index2)) + (if (do* ((ss (%cdr sub-sub) (%cdr ss)) + (pos (1+ start1) (1+ pos)) + (subi2 (1+ index2) (1+ subi2))) + ((or (null ss) (= pos end1)) t) + (declare (fixnum subi2 pos)) + (if (not (xcompare-elements (%car ss) (aref ,main subi2))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + (defmacro vector-list-search (sub main) + `(let ((first-elt (aref ,sub start1)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (sub-main (nthcdr start2 ,main) (%cdr sub-main)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (car sub-main)) + (if (do* ((subi1 (1+ start1)(1+ subi1)) + (sm (%cdr sub-main) (cdr sm))) + ((eq subi1 end1) t) + (declare (fixnum subi1)) + (if (not (xcompare-elements (aref ,sub subi1) (car sm))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + + ) + + + +(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not + (start1 0) end1 (start2 0) end2 (key #'identity)) + (setq end1 (check-sequence-bounds sequence1 start1 end1)) + (setq end2 (check-sequence-bounds sequence2 start2 end2)) + (setq key (adjust-key key)) + (locally (declare (fixnum start1 end1 start2 end2)) + (if (eq 0 (%i- end1 start1))(if from-end end2 start2) + (seq-dispatch sequence1 + (seq-dispatch sequence2 + (list-list-search sequence1 sequence2) + (list-vector-search sequence1 sequence2)) + (seq-dispatch sequence2 + (vector-list-search sequence1 sequence2) + (vector-vector-search sequence1 sequence2)))))) + +(defun make-string (size &key (initial-element () initial-element-p) (element-type 'character element-type-p)) + "Given a character count and an optional fill character, makes and returns + a new string COUNT long filled with the fill character." + (declare (optimize (speed 1) (safety 1))) + (when (and initial-element-p (not (typep initial-element 'character))) + (report-bad-arg initial-element 'character)) + (when (and element-type-p + (not (or (member element-type '(character base-char standard-char)) + (subtypep element-type 'character)))) + (error ":element-type ~S is not a subtype of CHARACTER" element-type)) + (if initial-element-p + (make-string size :element-type 'base-char :initial-element initial-element) + (make-string size :element-type 'base-char))) Index: /branches/qres/ccl/lib/setf-runtime.lisp =================================================================== --- /branches/qres/ccl/lib/setf-runtime.lisp (revision 13564) +++ /branches/qres/ccl/lib/setf-runtime.lisp (revision 13564) @@ -0,0 +1,134 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; +; setf-runtime.lisp - runtime support for setf expressions + +(in-package "CCL") + +(defun set-cadr (list new-value) + (set-car (cdr list) new-value)) + +(defun set-cdar (list new-value) + (set-cdr (car list) new-value)) + +(defun set-caar (list new-value) + (set-car (car list) new-value)) + +(defun set-cddr (list new-value) + (set-cdr (cdr list) new-value)) + +(defun %set-nthcdr (index list new-value) + "If INDEX is 0, just return NEW-VALUE." + (if (not (zerop index)) + (rplacd (nthcdr (1- index) list) + new-value)) + new-value) + +(defun set-fifth (list new-value) + (set-car (cddddr list) new-value)) + +(defun set-sixth (list new-value) + (set-car (cdr (cddddr list)) new-value)) + +(defun set-seventh (list new-value) + (set-car (cddr (cddddr list)) new-value)) + +(defun set-eighth (list new-value) + (set-car (cdddr (cddddr list)) new-value)) + +(defun set-ninth (list new-value) + (set-car (cddddr (cddddr list)) new-value)) + +(defun set-tenth (list new-value) + (set-car (cdr (cddddr (cddddr list))) new-value)) + +(defun set-caaar (list new-value) + (set-car (caar list) new-value)) + +(defun set-caadr (list new-value) + (set-car (cadr list) new-value)) + +(defun set-cadar (list new-value) + (set-car (cdar list) new-value)) + +(defun set-caddr (list new-value) + (set-car (cddr list) new-value)) + +(defun set-cdaar (list new-value) + (set-cdr (caar list) new-value)) + +(defun set-cdadr (list new-value) + (set-cdr (cadr list) new-value)) + +(defun set-cddar (list new-value) + (set-cdr (cdar list) new-value)) + +(defun set-cdddr (list new-value) + (set-cdr (cddr list) new-value)) + +(defun set-caaaar (list new-value) + (set-car (caaar list) new-value)) + +(defun set-caaadr (list new-value) + (set-car (caadr list) new-value)) + +(defun set-caadar (list new-value) + (set-car (cadar list) new-value)) + +(defun set-caaddr (list new-value) + (set-car (caddr list) new-value)) + +(defun set-cadaar (list new-value) + (set-car (cdaar list) new-value)) + +(defun set-cadadr (list new-value) + (set-car (cdadr list) new-value)) + +(defun set-caddar (list new-value) + (set-car (cddar list) new-value)) + +(defun set-cadddr (list new-value) + (set-car (cdddr list) new-value)) + +(defun set-cdaaar (list new-value) + (set-cdr (caaar list) new-value)) + +(defun set-cdaadr (list new-value) + (set-cdr (caadr list) new-value)) + +(defun set-cdadar (list new-value) + (set-cdr (cadar list) new-value)) + +(defun set-cdaddr (list new-value) + (set-cdr (caddr list) new-value)) + +(defun set-cddaar (list new-value) + (set-cdr (cdaar list) new-value)) + +(defun set-cddadr (list new-value) + (set-cdr (cdadr list) new-value)) + +(defun set-cdddar (list new-value) + (set-cdr (cddar list) new-value)) + +(defun set-cddddr (list new-value) + (set-cdr (cdddr list) new-value)) + + + +; End of setf-runtime.lisp Index: /branches/qres/ccl/lib/setf.lisp =================================================================== --- /branches/qres/ccl/lib/setf.lisp (revision 13564) +++ /branches/qres/ccl/lib/setf.lisp (revision 13564) @@ -0,0 +1,908 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;Bootstrapping. +(defvar %setf-methods% (let ((a (make-hash-table :test #'eq))) + (do-all-symbols (s) + (let ((f (get s 'bootstrapping-setf-method))) + (when f + (setf (gethash s a) f) + (remprop s 'bootstrapping-setf-method)))) + a)) +(defun %setf-method (name) + (gethash name %setf-methods%)) + +(defun store-setf-method (name fn &optional doc) + (puthash name %setf-methods% fn) + (let ((type-and-refinfo (and #-bccl (boundp '%structure-refs%) + (gethash name %structure-refs%)))) + (typecase type-and-refinfo + (fixnum + (puthash name %structure-refs% (%ilogior2 (%ilsl $struct-r/o 1) + type-and-refinfo))) + (cons + (setf (%cdr type-and-refinfo) (%ilogior2 (%ilsl $struct-r/o 1) + (%cdr type-and-refinfo)))) + (otherwise nil))) + (set-documentation name 'setf doc) ;clears it if doc = nil. + name) + + +;;; Note: The expansions for SETF and friends create needless LET-bindings of +;;; argument values when using get-setf-method. +;;; That's why SETF no longer uses get-setf-method. If you change anything +;;; here, be sure to make the corresponding change in SETF. + +(defun get-setf-expansion (form &optional env) + "Return five values needed by the SETF machinery: a list of temporary + variables, a list of values with which to fill them, a list of temporaries + for the new values, the setting function, and the accessing function." + ;This isn't actually used by setf, but it has to be compatible. + (get-setf-expansion-aux form env t)) + +(defun get-setf-expansion-aux (form environment multiple-store-vars-p) + (let* ((temp nil) + (accessor nil)) + (if (atom form) + (progn + (unless (symbolp form) (signal-program-error $XNotSym form)) + (multiple-value-bind (symbol-macro-expansion expanded) + (macroexpand-1 form environment) + (if expanded + (get-setf-expansion-aux symbol-macro-expansion environment + multiple-store-vars-p) + (let ((new-var (gensym))) + (values nil nil (list new-var) `(setq ,form ,new-var) form))))) + (multiple-value-bind (ftype local-p) + (function-information (setq accessor (car form)) environment) + (if local-p + (if (eq ftype :function) + ;Local function or macro, so don't use global setf definitions. + (default-setf-method form) + (get-setf-expansion-aux (macroexpand-1 form environment) environment multiple-store-vars-p)) + (cond + ((setq temp (gethash accessor %setf-methods%)) + (if (symbolp temp) + (let ((new-var (gensym)) + (args nil) + (vars nil) + (vals nil)) + (dolist (x (cdr form)) + ;; Rebinding defeats optimizations, so avoid it if can. + (if (constantp x environment) + (push x args) + (let ((var (gensym))) + (push var vars) + (push var args) + (push x vals)))) + (setq args (nreverse args)) + (values (nreverse vars) + (nreverse vals) + (list new-var) + `(,temp ,@args ,new-var) + `(,accessor ,@args))) + (multiple-value-bind (temps values storevars storeform accessform) + (funcall temp form environment) + (when (and (not multiple-store-vars-p) (not (= (length storevars) 1))) + (signal-program-error "Multiple store variables not expected in setf expansion of ~S" form)) + (values temps values storevars storeform accessform)))) + ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor environment) + (and #-bccl (boundp '%structure-refs%) + (gethash accessor %structure-refs%))))) + (not (refinfo-r/o (if (consp temp) (%cdr temp) temp)))) + (if (consp temp) + (let ((type (%car temp))) + (multiple-value-bind + (temps values storevars storeform accessform) + (get-setf-method (defstruct-ref-transform (%cdr temp) (%cdr form) environment) environment) + (values temps values storevars + (let ((storevar (first storevars))) + `(the ,type + (let ((,storevar (require-type ,storevar ',type))) + ,storeform))) + `(the ,type ,accessform)))) + (get-setf-method (defstruct-ref-transform temp (%cdr form) environment) environment))) + (t + (multiple-value-bind (res win) + (macroexpand-1 form environment) + (if win + (get-setf-expansion-aux res environment multiple-store-vars-p) + (default-setf-method form)))))))))) + +(defun default-setf-method (form) + (let ((new-value (gensym)) + (temp-vars ()) + (temp-args ()) + (temp-vals ())) + (dolist (val (cdr form)) + (if (fixnump val) + (push val temp-args) + (let ((var (gensym))) + (push var temp-vars) + (push val temp-vals) + (push var temp-args)))) + (setq temp-vars (nreverse temp-vars) + temp-args (nreverse temp-args) + temp-vals (nreverse temp-vals)) + (values temp-vars + temp-vals + (list new-value) + `(funcall #'(setf ,(car form)) ,new-value ,@temp-args) + `(,(car form) ,@temp-args)))) + +;;; The inverse for a generalized-variable reference function is stored in +;;; one of two ways: +;;; +;;; A SETF-INVERSE property corresponds to the short form of DEFSETF. It is +;;; the name of a function takes the same args as the reference form, plus a +;;; new-value arg at the end. +;;; +;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or +;;; by DEFINE-SETF-METHOD. It is a function that is called on the reference +;;; form and that produces five values: a list of temporary variables, a list +;;; of value forms, a list of the single store-value form, a storing function, +;;; and an accessing function. + +(eval-when (eval compile) + (require 'defstruct-macros)) + +(defmacro set-get (symbol indicator value &optional (value1 () default-p)) + (if default-p + `(put ,symbol ,indicator (progn ,value ,value1)) + `(put ,symbol ,indicator ,value))) + +; (defsetf get set-get) +(store-setf-method 'get 'SET-GET) + +; does this wrap a named block around the body yet ? +(defmacro define-setf-expander (access-fn lambda-list &body body) + "Syntax like DEFMACRO, but creates a setf expander function. The body + of the definition must be a form that returns five appropriate values." + (unless (symbolp access-fn) + (signal-program-error $xnotsym access-fn)) + (multiple-value-bind (lambda-form doc) + (parse-macro-1 access-fn lambda-list body) + `(eval-when (load compile eval) + (record-source-file ',access-fn 'setf-expander) + (store-setf-method ',access-fn + (nfunction ,access-fn ,lambda-form) + ,@(when doc (list doc)))))) + +(defun rename-lambda-vars (lambda-list) + (let* ((vars nil) + (temps nil) + (new-lambda nil) + (state nil)) + (flet ((temp-symbol (s) (make-symbol (symbol-name s)))) + (declare (inline temp-symbol)) + (dolist (item lambda-list) + (if (memq item lambda-list-keywords) + (setq state item item (list 'quote item)) + (if (atom item) + (progn + (push item vars)) + (locally (declare (type cons item)) + (when (consp (cddr item)) + (push (caddr item) vars)) + (if (and (eq state '&key) (consp (car item))) + (progn + (push (cadar item) vars) + (setq item `(list (list ,(list 'quote (caar item)) ,(cadar item)) ,@(cdr item)))) + (progn + (push (car item) vars) + (setq item `(list ,(car item) ,@(cdr item)))))))) + (push item new-lambda)) + (setq temps (mapcar #'temp-symbol vars)) + (values `(list ,@(nreverse new-lambda)) (nreverse temps) (nreverse vars))))) + +(defmacro defsetf (access-fn &rest rest &environment env) + "Associates a SETF update function or macro with the specified access + function or macro. The format is complex. See the manual for details." + (unless (symbolp access-fn) (signal-program-error $xnotsym access-fn)) + (if (non-nil-symbol-p (%car rest)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (store-setf-method + ',access-fn + ',(%car rest) + ,@(%cdr rest))) + (destructuring-bind (lambda-list (store-var &rest mv-store-vars) &body body) + rest + (unless (verify-lambda-list lambda-list) + (signal-program-error $XBadLambdaList lambda-list)) + (let* ((store-vars (cons store-var mv-store-vars))) + (multiple-value-bind (lambda-list lambda-temps lambda-vars) + (rename-lambda-vars lambda-list) + (multiple-value-bind (body decls doc) + (parse-body body env t) + (setq body `((block ,access-fn ,@body))) + (let* ((args (gensym)) + (dummies (gensym)) + (newval-vars (gensym)) + (new-access-form (gensym)) + (access-form (gensym)) + (environment (gensym))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (record-source-file ',access-fn 'setf-expander) + (store-setf-method + ',access-fn + #'(lambda (,access-form ,environment) + (declare (ignore ,environment)) + (do* ((,args (cdr ,access-form) (cdr ,args)) + (,dummies nil (cons (gensym) ,dummies)) + (,newval-vars (mapcar #'(lambda (v) (declare (ignore v)) (gensym)) ',store-vars)) + (,new-access-form nil)) + ((atom ,args) + (setq ,new-access-form + (cons (car ,access-form) ,dummies)) + (destructuring-bind ,(append lambda-vars store-vars ) + `,(append ',lambda-temps ,newval-vars) + ,@decls + (values + ,dummies + (cdr ,access-form) + ,newval-vars + `((lambda ,,lambda-list ,,@body) + ,@,dummies) + ,new-access-form)))))) + ,@(if doc (list doc)) + ',access-fn)))))))) + +(defmacro define-modify-macro (name lambda-list function &optional doc-string) + "Creates a new read-modify-write macro like PUSH or INCF." + (let ((other-args nil) + (rest-arg nil) + (env (gensym)) + (reference (gensym))) + + ;; Parse out the variable names and rest arg from the lambda list. + (do ((ll lambda-list (cdr ll)) + (arg nil)) + ((null ll)) + (setq arg (car ll)) + (cond ((eq arg '&optional)) + ((eq arg '&rest) + (if (symbolp (cadr ll)) + (setq rest-arg (cadr ll)) + (error "Non-symbol &rest arg in definition of ~S." name)) + (if (null (cddr ll)) + (return nil) + (error "Illegal stuff after &rest arg in Define-Modify-Macro."))) + ((memq arg '(&key &allow-other-keys &aux)) + (error "~S not allowed in Define-Modify-Macro lambda list." arg)) + ((symbolp arg) + (push arg other-args)) + ((and (listp arg) (symbolp (car arg))) + (push (car arg) other-args)) + (t (error "Illegal stuff in lambda list of Define-Modify-Macro.")))) + (setq other-args (nreverse other-args)) + `(defmacro ,name (,reference ,@lambda-list &environment ,env) + ,doc-string + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method ,reference ,env) + (do ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil (cons (list (car d) (car v)) let-list))) + ((null d) + (push + (list (car newval) + ,(if rest-arg + `(list* ',function getter ,@other-args ,rest-arg) + `(list ',function getter ,@other-args))) + let-list) + `(let* ,(nreverse let-list) + ,setter))))))) + +(defmacro incf (place &optional (delta 1) &environment env) + "The first argument is some location holding a number. This number is +incremented by the second argument, DELTA, which defaults to 1." + (if (and (symbolp (setq place (%symbol-macroexpand place env))) + (or (constantp delta) + (and (symbolp delta) + (not (nth-value 1 (%symbol-macroexpand delta env)))))) + `(setq ,place (+ ,place ,delta)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((d (gensym)) + ;; Doesn't propagate inferred types, but better than nothing. + (d-type (cond ((constantp delta) (type-of delta)) + ((and (consp delta) (eq (car delta) 'the)) (cadr delta)) + (t t))) + (v-type (if (and (consp place) (eq (car place) 'the)) (cadr place) t))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (+ ,getter ,d))) + (declare (type ,d-type ,d) (type ,v-type ,(car newval))) + ,setter))))) + +(defmacro decf (place &optional (delta 1) &environment env) + "The first argument is some location holding a number. This number is +decremented by the second argument, DELTA, which defaults to 1." + (if (and (symbolp (setq place (%symbol-macroexpand place env))) + (or (constantp delta) + (and (symbolp delta) + (not (nth-value 1 (%symbol-macroexpand delta env)))))) + `(setq ,place (- ,place ,delta)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let* ((d (gensym)) + ;; Doesn't propagate inferred types, but better than nothing. + (d-type (cond ((constantp delta) (type-of delta)) + ((and (consp delta) (eq (car delta) 'the)) (cadr delta)) + (t t))) + (v-type (if (and (consp place) (eq (car place) 'the)) (cadr place) t))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (- ,getter ,d))) + (declare (type ,d-type ,d) (type ,v-type ,(car newval))) + ,setter))))) + +(defmacro psetf (&whole call &rest pairs &environment env) ;same structure as psetq + "This is to SETF as PSETQ is to SETQ. Args are alternating place + expressions and values to go into those places. All of the subforms and + values are determined, left to right, and only then are the locations + updated. Returns NIL." + (when pairs + (if (evenp (length pairs)) + (let* ((places nil) + (values nil) + (tempsets nil) + (the-progn (list 'progn)) + (place nil) + (body the-progn) + (valform nil)) + (loop + (setq place (pop pairs) valform (pop pairs)) + (if (null pairs) (return)) + (push place places) + (push valform values) + (multiple-value-bind (temps vals newvals setter getter) + (get-setf-method-multiple-value place env) + (push (list temps vals newvals setter getter) tempsets))) + (dolist (temp tempsets) + (destructuring-bind (temps vals newvals setter getter) temp + (declare (ignore getter)) + (setq body + `(let + ,(let* ((let-list nil)) + (dolist (x temps (nreverse let-list)) + (push (list x (pop vals)) let-list))) + (multiple-value-bind ,newvals ,(pop values) + ,body))) + (push setter (cdr the-progn)))) + (push `(setf ,place ,valform) (cdr the-progn)) + `(progn ,body nil)) + (error "Odd number of args in the call ~S" call)))) + +;;Simple Setf specializations + + + +(defsetf cadr set-cadr) +(defsetf second set-cadr) + + +(defsetf cdar set-cdar) + +(defsetf caar set-caar) + +(defsetf cddr set-cddr) + +(defsetf elt set-elt) +(defsetf aref aset) +(defsetf svref svset) +(defsetf char set-char) +(defsetf bit %bitset) + +(defsetf schar set-schar) +(defsetf sbit %sbitset) +(defsetf symbol-value set) +(defsetf %schar %set-schar) + + +(defsetf symbol-plist set-symbol-plist) +(defsetf nth %setnth) + +(defsetf nthcdr %set-nthcdr) + +(defsetf fill-pointer set-fill-pointer) + + +(defsetf subseq (sequence start &optional (end nil)) (new-seq) + `(progn (replace ,sequence ,new-seq :start1 ,start :end1 ,end) + ,new-seq)) + + + +(defsetf third set-caddr) +(defsetf fourth set-cadddr) +(defsetf fifth set-fifth) +(defsetf sixth set-sixth) +(defsetf seventh set-seventh) +(defsetf eighth set-eighth) +(defsetf ninth set-ninth) +(defsetf tenth set-tenth) + + +(defsetf caaar set-caaar) +(defsetf caadr set-caadr) +(defsetf cadar set-cadar) +(defsetf caddr set-caddr) +(defsetf cdaar set-cdaar) +(defsetf cdadr set-cdadr) +(defsetf cddar set-cddar) +(defsetf cdddr set-cdddr) + + + + +(defsetf caaaar set-caaaar) +(defsetf caaadr set-caaadr) +(defsetf caadar set-caadar) +(defsetf caaddr set-caaddr) +(defsetf cadaar set-cadaar) +(defsetf cadadr set-cadadr) +(defsetf caddar set-caddar) +(defsetf cadddr set-cadddr) + + +(defsetf cdaaar set-cdaaar) +(defsetf cdaadr set-cdaadr) +(defsetf cdadar set-cdadar) +(defsetf cdaddr set-cdaddr) +(defsetf cddaar set-cddaar) +(defsetf cddadr set-cddadr) +(defsetf cdddar set-cdddar) +(defsetf cddddr set-cddddr) + +(defsetf %fixnum-ref %fixnum-set) + +(define-setf-method the (typespec expr &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method expr env) + (let ((store-var (gensym))) + (values + dummies + vals + (list store-var) + `(let ((,(car newval) ,store-var)) + ,setter) + `(the ,typespec ,getter))))) + + +(define-setf-method apply (function &rest args &environment env) + (if (and (listp function) + (= (list-length function) 2) + (eq (first function) 'function) + (symbolp (second function))) + (setq function (second function)) + (error + "Setf of Apply is only defined for function args of form #'symbol.")) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion (cons function args) env) + ;; Make sure the place is one that we can handle. + ;;Mainly to insure against cases of ldb and mask-field and such creeping in. + (let* ((last-arg (car (last args))) + (last-val (car (last vals))) + (last-dummy (car (last dummies))) + (last-getter (car (last getter))) + (last2-setter (car (last setter 2))) + (last-setter (car (last setter)))) + (cond ((and (or (and (eq last-arg last-val) + (eq last-getter last-dummy)) + (eq last-arg last-getter)) + newval + (null (cdr newval)) + (eq last-setter (car newval)) + (or (and (eq last-arg last-val) + (eq last2-setter last-dummy)) + (eq last-arg last2-setter))) + ;; (setf (foo ... argn) bar) -> (set-foo ... argn bar) + (values dummies vals newval + `(apply+ (function ,(car setter)) ,@(cdr setter)) + `(apply (function ,(car getter)) ,@(cdr getter)))) + ((and (or (and (eq last-arg last-val) + (eq last-getter last-dummy)) + (eq last-arg last-getter)) + newval + (null (cdr newval)) + (eq (car setter) 'funcall) + (eq (third setter) (car newval)) + (or (and (eq last-arg last-val) + (eq last-setter last-dummy)) + (eq last-arg last-setter))) + ;; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn) [with bindings for evaluation order] + (values dummies vals newval + `(apply ,@(cdr setter)) + `(apply (function ,(car getter)) ,@(cdr getter)))) + (t (error "Apply of ~S is not understood as a location for Setf." + function)))))) + +;;These are the supporting functions for the am-style hard-cases of setf. +(defun assoc-2-lists (list1 list2) + "Not CL. Returns an assoc-like list with members taken by associating corresponding + elements of each list. uses list instead of cons. + Will stop when first list runs out." + (do* ((lst1 list1 (cdr lst1)) + (lst2 list2 (cdr lst2)) + (result nil)) + ((null lst1) result) + (setq result (cons (list (car lst1) + (car lst2)) + result)))) + +(defun make-gsym-list (size) + "Not CL. Returns a list with size members, each being a different gensym" + (let ((temp nil)) + (dotimes (arg size temp) + (declare (fixnum arg)) + (setq temp (cons (gensym) temp))))) +;;;;;;; + +(define-setf-method getf (plist prop &optional (default () default-p) + &aux (prop-p (not (quoted-form-p prop))) + &environment env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method plist env) + (when default-p (setq default (list default))) + (let ((prop-var (if prop-p (gensym) prop)) + (store-var (gensym)) + (default-var (if default-p (list (gensym))))) + (values + `(,@vars ,.(if prop-p (list prop-var)) ,@default-var) + `(,@vals ,.(if prop-p (list prop)) ,@default) + (list store-var) + `(let* ((,(car stores) (setprop ,access-form ,prop-var ,store-var))) + ,store-form + ,store-var) + `(getf ,access-form ,prop-var ,@default-var))))) + +(define-setf-method getf-test (plist prop test &optional (default () default-p) + &aux (prop-p (not (quoted-form-p prop))) + &environment env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method plist env) + (when default-p (setq default (list default))) + (let ((prop-var (if prop-p (gensym) prop)) + (test-var (gensym)) + (store-var (gensym)) + (default-var (if default-p (list (gensym))))) + (values + `(,@vars ,.(if prop-p (list prop-var)) ,test-var ,@default-var) + `(,@vals ,.(if prop-p (list prop)) ,test ,@default) + (list store-var) + `(let* ((,(car stores) (setprop-test ,access-form ,prop-var ,test-var ,store-var))) + ,store-form + ,store-var) + `(getf-test ,access-form ,prop-var ,test-var ,@default-var))))) + +(define-setf-method ldb (bytespec place &environment env) + "The first argument is a byte specifier. The second is any place form + acceptable to SETF. Replace the specified byte of the number in this + place with bits from the low-order end of the new value." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(ldb ,btemp ,getter))))) + + +(define-setf-method mask-field (bytespec place &environment env) + "The first argument is a byte specifier. The second is any place form + acceptable to SETF. Replaces the specified byte of the number in this place + with bits from the corresponding position in the new value." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(mask-field ,btemp ,getter))))) + +(defmacro shiftf (arg1 arg2 &rest places-&-nuval &environment env) + "One or more SETF-style place expressions, followed by a single + value expression. Evaluates all of the expressions in turn, then + assigns the value of each expression to the place on its left, + returning the value of the leftmost." + (setq places-&-nuval (list* arg1 arg2 places-&-nuval)) + (let* ((nuval (car (last places-&-nuval))) + (places (cdr (reverse places-&-nuval))) ; not nreverse, since &rest arg shares structure with &whole. + (setters (list 'progn)) + (last-getter nuval) + last-let-list + let-list + (body setters)) + (dolist (place places) + (multiple-value-bind (vars values storevars setter getter) + (get-setf-method-multiple-value place env) + (dolist (v vars) + (push (list v (pop values)) let-list)) + (push setter (cdr setters)) + (setq body + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-bind ,storevars ,last-getter + ,body)) + `(multiple-value-bind ,storevars ,last-getter + ,body)) + last-let-list let-list + let-list nil + last-getter getter))) + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-prog1 ,last-getter + ,body)) + `(multiple-value-prog1 ,last-getter + ,body)))) + +;(shiftf (car x)(cadr x) 3) + +#| +(defmacro rotatef (&rest args &environment env) + (let* ((setf-result nil) + (let-result nil) + (last-store nil) + (fixpair nil)) + (dolist (arg args) + (multiple-value-bind (vars vals storevars setter getter) + (get-setf-method arg env) + (dolist (var vars) + (push (list var (pop vals)) let-result)) + (push (list last-store getter) let-result) + (unless fixpair (setq fixpair (car let-result))) + (push setter setf-result) + (setq last-store (car storevars)))) + (rplaca fixpair last-store) + `(let* ,(nreverse let-result) ,@(nreverse setf-result) nil))) + + +;(rotatef (blob x)(blob y)) +(defun blob (x) (values (car x)(cadr x))) +(define-setf-method blob (x) + (let ((v1 (gensym))(v2 (gensym))(v3 (gensym))) + (values + (list v1) + (list x) + (list v2 v3) + `(progn (setf (car ,v1) ,v2) + (setf (cadr ,v1) ,v3)) + `(values (car ,v1)(cadr ,v1))))) +|# + +(defmacro rotatef (&rest args &environment env) + "Takes any number of SETF-style place expressions. Evaluates all of the + expressions in turn, then assigns to each place the value of the form to + its right. The rightmost form gets the value of the leftmost. + Returns NIL." + (when args + (let* ((places (reverse args)) ; not nreverse, since &rest arg shares structure with &whole. + (final-place (pop places)) + (setters (list 'progn nil)) + last-let-list + let-list + (body setters)) + (multiple-value-bind (final-vars final-values final-storevars + final-setter last-getter) + (get-setf-method-multiple-value final-place env) + (dolist (v final-vars) + (push (list v (pop final-values)) last-let-list)) + (push final-setter (cdr setters)) + (dolist (place places) + (multiple-value-bind (vars values storevars setter getter) + (get-setf-method-multiple-value place env) + (dolist (v vars) + (push (list v (pop values)) let-list)) + (push setter (cdr setters)) + (setq body + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-bind ,storevars ,last-getter + ,body)) + `(multiple-value-bind ,storevars ,last-getter + ,body)) + last-let-list let-list + let-list nil + last-getter getter))) + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-bind ,final-storevars ,last-getter + ,body)) + `(multiple-value-bind ,final-storevars ,last-getter + ,body)))))) + + + +(defmacro push (value place &environment env) + "Takes an object and a location holding a list. Conses the object onto + the list, returning the modified list. OBJ is evaluated before PLACE." + (if (not (consp place)) + `(setq ,place (cons ,value ,place)) + (multiple-value-bind (dummies vals store-var setter getter) + (get-setf-method place env) + (let ((valvar (gensym))) + `(let* ((,valvar ,value) + ,@(mapcar #'list dummies vals) + (,(car store-var) (cons ,valvar ,getter))) + ,@dummies + ,(car store-var) + ,setter))))) + +(defmacro pushnew (value place &rest keys &environment env) + "Takes an object and a location holding a list. If the object is + already in the list, does nothing; otherwise, conses the object onto + the list. Returns the modified list. If there is a :TEST keyword, this + is used for the comparison." + (if (not (consp place)) + `(setq ,place (adjoin ,value ,place ,@keys)) + (let ((valvar (gensym))) + (multiple-value-bind (dummies vals store-var setter getter) + (get-setf-method place env) + `(let* ((,valvar ,value) + ,@(mapcar #'list dummies vals) + (,(car store-var) (adjoin ,valvar ,getter ,@keys))) + ,@dummies + ,(car store-var) + ,setter))))) + +(defmacro pop (place &environment env &aux win) + "The argument is a location holding a list. Pops one item off the front + of the list and returns it." + (while (atom place) + (multiple-value-setq (place win) (macroexpand-1 place env)) + (unless win + (return-from pop + `(prog1 (car ,place) (setq ,place (cdr (the list ,place))))))) + (let ((value (gensym))) + (multiple-value-bind (dummies vals store-var setter getter) + (get-setf-method place env) + `(let* (,@(mapcar #'list dummies vals) + (,value ,getter) + (,(car store-var) (cdr ,value))) + ,@dummies + ,(car store-var) + (prog1 + (%car ,value) + ,setter))))) + +(defmacro %pop (symbol) + `(prog1 (%car ,symbol) (setq ,symbol (%cdr ,symbol)))) + +#| +(defmacro push (item place) + (if (not (consp place)) + `(setq ,place (cons ,item ,place)) + (let* ((arg-num (1- (length place))) + (place-args (make-gsym-list arg-num))) + `(let ,(cons (list 'nu-item item) + (reverse (assoc-2-lists place-args (cdr place)))) + (setf (,(car place) ,@place-args) + (cons nu-item (,(car place) ,@place-args))))))) + +(defmacro pushnew (item place &rest key-args) + (let ((item-gsym (gensym))) + (if (not (consp place)) + `(let ((,item-gsym ,item)) + (setq ,place (adjoin ,item-gsym ,place ,@key-args))) + (let* ((arg-num (1- (length place))) + (place-args (make-gsym-list arg-num))) + `(let ,(cons (list item-gsym item) + (reverse (assoc-2-lists place-args (cdr place)))) + (setf (,(car place) ,@place-args) + (adjoin ,item-gsym (,(car place) ,@place-args) + ,@key-args))))))) +(defmacro pop (place) + (if (not (consp place)) ; screw: symbol macros. + `(prog1 (car ,place) (setq ,place (%cdr ,place))) + (let* ((arg-num (1- (length place))) + (place-args (make-gsym-list arg-num))) + `(let ,(reverse (assoc-2-lists place-args (cdr place))) + (prog1 (car (,(car place) ,@place-args)) + (setf (,(car place) ,@place-args) + (cdr (,(car place) ,@place-args)))))))) +|# + +(defmacro remf (place indicator &environment env) + "Place may be any place expression acceptable to SETF, and is expected + to hold a property list or (). This list is destructively altered to + remove the property specified by the indicator. Returns T if such a + property was present, NIL if not." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (local1 (gensym)) + (local2 (gensym))) + ((null d) + (push (list ind-temp indicator) let-list) + (push (list (car newval) getter) let-list) + `(let* ,(nreverse let-list) + (do ((,local1 ,(car newval) (cddr ,local1)) + (,local2 nil ,local1)) + ((atom ,local1) nil) + (cond ((atom (cdr ,local1)) + (error "Odd-length property list in REMF.")) + ((eq (car ,local1) ,ind-temp) + (cond (,local2 + (rplacd (cdr ,local2) (cddr ,local1)) + (return t)) + (t (setq ,(car newval) (cddr ,(car newval))) + ,setter + (return t)))))))) + (push (list (car d) (car v)) let-list)))) + +(defmacro remf-test (place indicator test &environment env) + "Place may be any place expression acceptable to SETF, and is expected + to hold a property list or (). This list is destructively altered to + remove the property specified by the indicator. Returns T if such a + property was present, NIL if not." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (test-temp (gensym)) + (local1 (gensym)) + (local2 (gensym))) + ((null d) + (push (list (car newval) getter) let-list) + (push (list ind-temp indicator) let-list) + (push (list test-temp test) let-list) + `(let* ,(nreverse let-list) + (do ((,local1 ,(car newval) (cddr ,local1)) + (,local2 nil ,local1)) + ((atom ,local1) nil) + (cond ((atom (cdr ,local1)) + (error "Odd-length property list in REMF.")) + ((funcall ,test-temp (car ,local1) ,ind-temp) + (cond (,local2 + (rplacd (cdr ,local2) (cddr ,local1)) + (return t)) + (t (setq ,(car newval) (cddr ,(car newval))) + ,setter + (return t)))))))) + (push (list (car d) (car v)) let-list)))) + +(define-setf-expander values (&rest places &environment env) + (let* ((setters ()) + (getters ()) + (all-dummies ()) + (all-vals ()) + (newvals ())) + (dolist (place places) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (setf all-dummies (append all-dummies dummies (cdr newval))) + (setf all-vals (append all-vals vals (mapcar (constantly nil) (cdr newval)))) + (setf newvals (append newvals (list (car newval)))) + (push setter setters) + (push getter getters))) + (values all-dummies all-vals newvals + `(values ,@(nreverse setters)) `(values ,@(nreverse getters))))) Index: /branches/qres/ccl/lib/sort.lisp =================================================================== --- /branches/qres/ccl/lib/sort.lisp (revision 13564) +++ /branches/qres/ccl/lib/sort.lisp (revision 13564) @@ -0,0 +1,505 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Sort + +;;; sorts a sequence destructively using a predicate which must be a +;;; of two arguments which returns non-() only if the first argument is +;;; strictly less than the second. The keyfun (if present) must be a +;;; function of one argument. The predicate is applied to keyfun of the +;;; sequence elements, or directly to the elements if the keyfun is not +;;; given. + +;;; Sort dispatches to type specific sorting routines. + +(in-package "CCL") + +(defun sort (sequence predicate &key key) + "Returns SEQUENCE, which has been modified to be in order. + If sequence is a displaced array, sorts just that portion of the + data-array which is part of SEQUENCE." + (if (< (length sequence) 2) + sequence + (if (listp sequence) + (sort-list sequence predicate key) + (quick-sort-vector sequence predicate key)))) + +(defun stable-sort (sequence predicate &key key) + "Returns SEQUENCE, which has been modified to be in order. + If sequence is a displaced array, sorts just that portion of the + data-array which is part of SEQUENCE." + (if (< (length sequence) 2) + sequence + (if (listp sequence) + (sort-list sequence predicate key) + (merge-sort-vector sequence predicate key)))) + + +;;; Vector sorting. +;;; The quick-sort is a little slower than the merge-sort, but it doesn't cons. +;;; The merge-sort is stable. +;;; Note that there are three version of each: +;;; AREF for non-simple (eventually) vectors. +;;; %SVREF with a key. +;;; %SVREF without a key. +;;; Other than that, the three versions are duplicates. +(defun merge-sort-vector (vector pred key) + (canonicalize-pred-and-key) + (let* ((end (length vector))) + (when (> end 1) + (multiple-value-bind (real-vector start) + (array-data-and-offset vector) + (incf end start) + (unless (fixnump end) + (error "Sorry, can't sort vectors larger than ~d." most-positive-fixnum)) + (let* ((temp-array (make-array (the fixnum end)))) + (declare (dynamic-extent temp-array)) + (if (simple-vector-p real-vector) + (if key + (%merge-sort-simple-vector + real-vector start end pred key temp-array nil) + (%merge-sort-simple-vector-no-key + real-vector start end pred temp-array nil)) + (%merge-sort-vector real-vector start end pred key temp-array nil)))))) + vector) + +(defun quick-sort-vector (vector pred key) + (canonicalize-pred-and-key) + (let ((end (length vector))) + (when (> end 1) + (multiple-value-bind (real-vector start) + (array-data-and-offset vector) + (incf end (%i- start 1)) +; No vector should have a length that's not a fixnum. + '(unless (fixnump end) + (error "Sorry, can't sort vectors larger than ~d." most-positive-fixnum)) + (if (simple-vector-p real-vector) + (if key + (%quick-sort-simple-vector real-vector start end pred key) + (%quick-sort-simple-vector-no-key real-vector start end pred)) + (%quick-sort-vector + real-vector start end pred (or key #'identity)))))) + vector) + +;;; merge-sort internals + +(defun %merge-sort-vector (vector start end pred key + temp-vec res-temp?) + ;; If somebody wanted to do it, half of these arefs can be %svrefs, + ;; but you'd need two loops in the merge code + ;; (temp-vec is simple if res-temp? is false). + ;; But who sorts non-svref'able vectors anyway? + (let* ((mid (%ilsr 1 (%i+ start end)))) + (if (%i<= (%i- mid 1) start) + (unless res-temp? + (setf (aref temp-vec start) (aref vector start))) + (%merge-sort-vector + vector start mid pred key temp-vec (not res-temp?))) + (if (%i>= (%i+ mid 1) end) + (unless res-temp? + (setf (aref temp-vec mid) (aref vector mid))) + (%merge-sort-vector + vector mid end pred key temp-vec (not res-temp?))) + + (unless res-temp? + (psetq vector temp-vec temp-vec vector)) + + (%merge-vectors vector start mid vector mid end temp-vec start pred key))) + +(defun %merge-sort-simple-vector (vector start end pred key + temp-vec res-temp?) + (let* ((mid (%ilsr 1 (%i+ start end)))) + (if (%i<= (%i- mid 1) start) + (unless res-temp? + (setf (%svref temp-vec start) (%svref vector start))) + (%merge-sort-simple-vector + vector start mid pred key temp-vec (not res-temp?))) + (if (%i>= (%i+ mid 1) end) + (unless res-temp? + (setf (%svref temp-vec mid) (%svref vector mid))) + (%merge-sort-simple-vector + vector mid end pred key temp-vec (not res-temp?))) + + (unless res-temp? + (psetq vector temp-vec temp-vec vector)) + + (%merge-simple-vectors + vector start mid vector mid end temp-vec start pred key))) + +(defun %merge-sort-simple-vector-no-key (vector start end pred + temp-vec res-temp?) + (let* ((mid (%ilsr 1 (%i+ start end)))) + (if (%i<= (%i- mid 1) start) + (unless res-temp? + (setf (%svref temp-vec start) (%svref vector start))) + (%merge-sort-simple-vector-no-key + vector start mid pred temp-vec (not res-temp?))) + (if (%i>= (%i+ mid 1) end) + (unless res-temp? + (setf (%svref temp-vec mid) (%svref vector mid))) + (%merge-sort-simple-vector-no-key + vector mid end pred temp-vec (not res-temp?))) + + (unless res-temp? + (psetq vector temp-vec temp-vec vector)) + + (%merge-simple-vectors-no-key + vector start mid vector mid end temp-vec start pred))) + +(defun %merge-vectors (a1 start1 end1 a2 start2 end2 + out start-out pred key) + (let* ((i1 start1) + (i2 start2) + (i-out start-out) + v1 v2 k1 k2) + (cond ((eq start1 end1) + (when (eq start2 end2) + (return-from %merge-vectors out)) + (setq i1 start2 + end1 end2 + a1 a2 + v1 (aref a1 i1))) + ((eq start2 end2) + (setq i1 start1 + v1 (aref a1 i1))) + (t + (setq v1 (aref a1 i1) + v2 (aref a2 i2) + k1 (if key (funcall key v1) v1) + k2 (if key (funcall key v2) v2)) + (loop (if (funcall pred k2 k1) + (progn (setf (aref out i-out) v2 + i-out (%i+ i-out 1) + i2 (%i+ i2 1)) + (when (eq i2 end2) + (return)) + (setq v2 (aref a2 i2) + k2 (if key (funcall key v2) v2))) + (progn (setf (aref out i-out) v1 + i-out (%i+ i-out 1) + i1 (%i+ i1 1)) + (when (eq i1 end1) + (setq a1 a2 i1 i2 end1 end2 v1 v2) + (return)) + (setq v1 (aref a1 i1) + k1 (if key (funcall key v1) v1))))))) + (loop + (setf (aref out i-out) v1 + i1 (%i+ i1 1)) + (if (eq i1 end1) + (return out)) + (setq v1 (aref a1 i1) + i-out (%i+ i-out 1))))) + +(defun %merge-simple-vectors (a1 start1 end1 a2 start2 end2 + out start-out pred key) + (let* ((i1 start1) + (i2 start2) + (i-out start-out) + v1 v2 k1 k2) + (cond ((eq start1 end1) + (when (eq start2 end2) + (return-from %merge-simple-vectors out)) + (setq i1 start2 + end1 end2 + a1 a2 + v1 (%svref a1 i1))) + ((eq start2 end2) + (setq i1 start1 + v1 (%svref a1 i1))) + (t + (setq v1 (%svref a1 i1) + v2 (%svref a2 i2) + k1 (if key (funcall key v1) v1) + k2 (if key (funcall key v2) v2)) + (loop (if (funcall pred k2 k1) + (progn (setf (%svref out i-out) v2 + i-out (%i+ i-out 1) + i2 (%i+ i2 1)) + (when (eq i2 end2) + (return)) + (setq v2 (%svref a2 i2) + k2 (funcall key v2))) + (progn (setf (%svref out i-out) v1 + i-out (%i+ i-out 1) + i1 (%i+ i1 1)) + (when (eq i1 end1) + (setq a1 a2 i1 i2 end1 end2 v1 v2) + (return)) + (setq v1 (%svref a1 i1) + k1 (funcall key v1))))))) + (loop + (setf (%svref out i-out) v1 + i1 (%i+ i1 1)) + (if (eq i1 end1) + (return out)) + (setq v1 (%svref a1 i1) + i-out (%i+ i-out 1))))) + +(defun %merge-simple-vectors-no-key (a1 start1 end1 a2 start2 end2 + out start-out pred) + (let* ((i1 start1) + (i2 start2) + (i-out start-out) + v1 v2) + (cond ((eq start1 end1) + (when (eq start2 end2) + (return-from %merge-simple-vectors-no-key out)) + (setq i1 start2 + end1 end2 + a1 a2 + v1 (%svref a1 i1))) + ((eq start2 end2) + (setq i1 start1 + v1 (%svref a1 i1))) + (t + (setq v1 (%svref a1 i1) + v2 (%svref a2 i2)) + (loop (if (funcall pred v2 v1) + (progn (setf (%svref out i-out) v2 + i-out (%i+ i-out 1) + i2 (%i+ i2 1)) + (when (eq i2 end2) + (return)) + (setq v2 (%svref a2 i2))) + (progn (setf (%svref out i-out) v1 + i-out (%i+ i-out 1) + i1 (%i+ i1 1)) + (when (eq i1 end1) + (setq a1 a2 i1 i2 end1 end2 v1 v2) + (return)) + (setq v1 (%svref a1 i1))))))) + (loop + (setf (%svref out i-out) v1 + i1 (%i+ i1 1)) + (if (eq i1 end1) + (return out)) + (setq v1 (%svref a1 i1) + i-out (%i+ i-out 1))))) + + +;;; Quick sort internals +(defun %quick-sort-vector (vector start end pred key) + (declare (optimize (speed 3) (safety 0))) + (declare (fixnum start end)) + (if (< start end) + (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1))))) + (Ai (aref vector p)) + (x (funcall key Ai)) + (pivot Ai) + (i start) + (j (the fixnum (1+ end))) + Aj) + (declare (fixnum p i j)) + (setf (aref vector p) (aref vector start) + (aref vector start) Ai) + (block partition + (loop + (loop (unless (> (decf j) i) (return-from partition)) + (unless (funcall pred + x + (funcall key (setq Aj (aref vector j)))) + (return))) + (loop (unless (< (incf i) j) (return-from partition)) + (unless (funcall pred + (funcall key (setq Ai (aref vector i))) + x) + (return))) + (setf (aref vector i) Aj + (aref vector j) Ai))) + (setf (aref vector start) (aref vector j) + (aref vector j) pivot) + ; This compare is important. It limits stack depth to log(end-start) + (if (< (the fixnum (- j start)) (the fixnum (- end j))) + (progn + (%quick-sort-vector vector start (the fixnum (1- j)) pred key) + (%quick-sort-vector vector (the fixnum (1+ j)) end pred key)) + (progn + (%quick-sort-vector vector (the fixnum (1+ j)) end pred key) + (%quick-sort-vector vector start (the fixnum (1- j)) pred key)))) + vector)) + +(defun %quick-sort-simple-vector (vector start end pred key) + (declare (optimize (speed 3) (safety 0))) + (declare (type simple-vector vector) + (fixnum start end)) + (if (< start end) + (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1))))) + (Ai (svref vector p)) + (pivot Ai) + (x (funcall key Ai)) + (i start) + (j (the fixnum (1+ end))) + Aj) + (declare (fixnum p i j)) + (setf (svref vector p) (svref vector start) + (svref vector start) Ai) + (block partition + (loop + (loop (unless (> (decf j) i) (return-from partition)) + (unless (funcall pred + x + (funcall key (setq Aj (svref vector j)))) + (return))) + (loop (unless (< (incf i) j) (return-from partition)) + (unless (funcall pred + (funcall key (setq Ai (svref vector i))) + x) + (return))) + (setf (aref vector i) Aj + (aref vector j) Ai))) + (setf (svref vector start) (svref vector j) + (svref vector j) pivot) + (if (< (the fixnum (- j start)) (the fixnum (- end j))) + (progn + (%quick-sort-simple-vector vector start (the fixnum (1- j)) pred key) + (%quick-sort-simple-vector vector (the fixnum (1+ j)) end pred key)) + (progn + (%quick-sort-simple-vector vector (the fixnum (1+ j)) end pred key) + (%quick-sort-simple-vector vector start (the fixnum (1- j)) pred key)))) + vector)) + +(defun %quick-sort-simple-vector-no-key (vector start end pred) + (declare (optimize (speed 3) (safety 0))) + (declare (type simple-vector vector) + (fixnum start end)) + (if (< start end) + (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1))))) + (x (svref vector p)) + (i start) + (j (the fixnum (1+ end))) + Ai Aj) + (declare (fixnum p i j)) + (setf (svref vector p) (svref vector start) + (svref vector start) x) + (block partition + (loop + (loop (unless (> (decf j) i) (return-from partition)) + (unless (funcall pred + x + (setq Aj (svref vector j))) + (return))) + (loop (unless (< (incf i) j) (return-from partition)) + (unless (funcall pred + (setq Ai (svref vector i)) + x) + (return))) + (setf (aref vector i) Aj + (aref vector j) Ai))) + (setf (svref vector start) (svref vector j) + (svref vector j) x) + (if (< (the fixnum (- j start)) (the fixnum (- end j))) + (progn + (%quick-sort-simple-vector-no-key vector start (the fixnum (1- j)) pred) + (%quick-sort-simple-vector-no-key vector (the fixnum (1+ j)) end pred)) + (progn + (%quick-sort-simple-vector-no-key vector (the fixnum (1+ j)) end pred) + (%quick-sort-simple-vector-no-key vector start (the fixnum (1- j)) pred)))) + vector)) + + + +;; This conses like crazy if you merge lists into vectors or vice-versa, but +;; I don't want to write 6 more merging routines. Fry's coerce's +;; will have to stand for now. +;; Only difficulty here is parsing the result-type for vectors. +(defun merge (result-type sequence1 sequence2 predicate &key key) + "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a + sequence of type RESULT-TYPE using PREDICATE to order the elements. + If result-type specifies an array, the returned array will not be + a complex array. Usually, result-type is either LIST, ARRAY or STRING." + (let* ((result-len (+ (length sequence1) (length sequence2))) + (result-ctype (specifier-type result-type))) + (cond ((csubtypep result-ctype (specifier-type 'null)) + (unless (zerop result-len) + (error 'invalid-subtype-error :datum result-type + :expected-type 'cons))) + ((csubtypep result-ctype (specifier-type 'list)) + (canonicalize-pred-and-key predicate key) + (values ; For the terminally pedantic. + (merge-lists* (if (listp sequence1) + sequence1 + (coerce sequence1 'list)) + (if (listp sequence2) + sequence2 + (coerce sequence2 'list)) + predicate key))) + ((csubtypep result-ctype (specifier-type 'vector)) + (merge-vectors (if (listp sequence1) + (coerce sequence1 'vector) + sequence1) + (if (listp sequence2) + (coerce sequence2 'vector) + sequence2) + predicate key + result-type)) + (t (error 'invalid-subtype-error + :datum result-type + :expected-type 'sequence))))) + +(defun merge-vectors (vector-1 vector-2 pred key + &optional (result-type 'vector)) + "Internal function. Use MERGE instead." + (canonicalize-pred-and-key) + (let* ((length-1 (length vector-1)) + (length-2 (length vector-2)) + (result-length (+ length-1 length-2)) + (result (make-merge-vectors-result + result-type result-length vector-1 vector-2)) + real-vector-1 start-1 real-vector-2 start-2) + (multiple-value-setq (real-vector-1 start-1) + (array-data-and-offset vector-1)) + (multiple-value-setq (real-vector-2 start-2) + (array-data-and-offset vector-2)) + (incf length-1 start-1) + (incf length-2 start-2) + (if (and (simple-vector-p real-vector-1) (simple-vector-p real-vector-2) + (simple-vector-p result)) + (if key + (%merge-simple-vectors real-vector-1 start-1 length-1 + real-vector-2 start-2 length-2 + result 0 pred key) + (%merge-simple-vectors-no-key real-vector-1 start-1 length-1 + real-vector-2 start-2 length-2 + result 0 pred)) + (%merge-vectors real-vector-1 start-1 length-1 + real-vector-2 start-2 length-2 + result 0 pred key)))) + +;; OK, here goes the type parsing... +(defun make-merge-vectors-result (result-type result-length vector-1 vector-2) + (let* ((ctype (specifier-type result-type))) + (let* ((size (array-ctype-length ctype)) + (elt-type (array-or-union-ctype-element-type ctype))) + (if (eq elt-type '*) + (let ((et1 (array-element-type vector-1)) + (et2 (array-element-type vector-2))) + (setq elt-type (if (eq et1 et2) et1 `(or ,et1 ,et2))))) + (if (and size (not (eq size result-length))) + (error 'invalid-subtype-error + :datum result-type + :expected-type `(vector ,elt-type ,result-length)) + (make-array (the fixnum (or size result-length)) + :element-type elt-type))))) + + +;; Gee, that wasn't so bad after all. +;; Well, when you're building on the shoulders of giants, +;; your little effort can seem great. + + +;; "If I haven't seen as far as others, it's because giants were standing on my shoulders." Index: /branches/qres/ccl/lib/source-files.lisp =================================================================== --- /branches/qres/ccl/lib/source-files.lisp (revision 13564) +++ /branches/qres/ccl/lib/source-files.lisp (revision 13564) @@ -0,0 +1,770 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; If we're reloading this file, don't want to be calling functions from here with +;; only some of them redefined. So revert to the bootstrapping version until the end. +(fset 'record-source-file #'level-1-record-source-file) + +(defvar *source-files-lock* (make-lock "Source Files Lock")) + +(defvar *unique-setf-names* (make-hash-table :test #'eq)) + +(defun canonical-maybe-setf-name (name) + (if (setf-function-name-p name) + (let ((tem (%setf-method (%cadr name)))) + (if (non-nil-symbol-p tem) ;; e.g. (setf car) => set-car + tem + (or (gethash (%cadr name) *unique-setf-names*) + (setf (gethash (%cadr name) *unique-setf-names*) (list 'setf (%cadr name)))))) + name)) + +(defgeneric name-of (thing) + (:method ((thing t)) thing) + (:method ((thing method-function)) (name-of (%method-function-method thing))) + (:method ((thing function)) (name-of (function-name thing))) + (:method ((thing method)) `(:method ,(method-name thing) ,@(method-qualifiers thing) ,(method-specializers thing))) + (:method ((thing class)) (class-name thing)) + (:method ((thing method-combination)) (method-combination-name thing)) + (:method ((thing package)) (package-name thing)) + (:method ((thing eql-specializer)) `(eql ,(eql-specializer-object thing)))) + +;; This used to be weak, but the keys are symbols-with-definitions, so why bother. +;; Set a high rehash threshold because space matters more than speed here. +;; Do not use lock-free hash tables, because they optimize reads at the expense of +;; writes/rehashes. Writes/rehashes affect file-compilation speed, which matters. +(defvar %source-files% (make-hash-table :test #'eq + :size 14000 + :rehash-size 1.8 ;; compensate for high threshold + :rehash-threshold .95 + :lock-free nil)) + + + +(defvar *direct-methods-only* t + "If true, method name source location lookup will find direct methods only. If false, + include all applicable methods") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Definition types +;; +;; Definition types are uniquely identified by a symbol, but are implemented as +;; classes so they can inherit/customize behavior. They have no instances other +;; than the class prototype, which is used to invoke methods. +;; + +(defgeneric definition-type-name (def-type) + (:documentation "The preferred user-visible name of the def-type. Used for +error messages etc. The default method returns the name specified in +define-definition-type.")) + +(defclass definition-type () + ((name :allocation :class :reader definition-type-name :initform t)) + (:documentation "Superclass of all definition types")) + +(defgeneric definition-base-name (def-type def) + ;; Note that a def can have multiple base names, but each one needs a different def-type + (:documentation "Return the name that, when the user asks for all definitions of that +name, this def should be included. Typically this is a symbol. It's used as a key in +an EQ hash table, so must return EQ values for equivalent definitions. +The default method returns the rightmost atom in name") + (:method ((dt definition-type) name) + (while (consp name) + (let ((x (last name))) + (setq name (or (cdr x) (car x))))) + name)) + +(defgeneric definition-same-p (def-type def1 def2) + (:documentation "Returns true if the two definitions are equivalent, i.e. one should +replace the other. The default method calls EQUAL.") + (:method ((dt definition-type) name1 name2) + (equal name1 name2))) + +(defgeneric definition-bound-p (def-type def) + (:documentation "Returns true if def is currently defined. Used to decide whether to issue +redefinition warnings. The default method returns T.") + (:method ((dt definition-type) name) + (declare (ignore name)) + t)) + +;;;;;;;;;; + +(defvar *definition-types* () + "alist of all known definition type names and their class prototypes") + +(defmethod print-object ((dt definition-type) stream) + (if *print-escape* + (let ((definedp (class-name (class-of dt)))) + (print-unreadable-object (dt stream :type definedp :identity t) + (unless definedp + (format stream "#:~s " 'definition-type)) ;; subtly indicate it's a subclass... + (format stream "~s" (definition-type-name dt)))) + (format stream "~s" (definition-type-name dt)))) + +(defmethod name-of ((thing definition-type)) + (definition-type-name thing)) + +(defmacro define-definition-type (name supers &rest options) + "Defines a class named name-DEFINITION-TYPE and registers it as the class of +definition type NAME" + (loop with known-keys = '( ;; Backward compatibility + #+ccl-0711 :default-name-function) + for (key . nil) in options + unless (memq key known-keys) + do (signal-program-error "Unknown option ~s" key)) + (let ((class-name (intern (%str-cat (symbol-name name) "-DEFINITION-TYPE")))) + `(progn + (defclass ,class-name ,(or supers '(definition-type)) + ((name :allocation :class :initform ',name))) + (record-source-file ',name 'definition-type) + (register-definition-type (find-class ',class-name) '(,name))))) + +(defun register-definition-type (class names) + (let ((instance (class-prototype class))) + (with-lock-grabbed (*source-files-lock*) + ;; If had a previous definition, the defclass will signal any duplicate + ;; definition warnings, so here just silently replace previous one. + (without-interrupts + (setq *definition-types* + (remove instance *definition-types* :key #'cdr))) + (loop for name in names + unless (without-interrupts + (unless (assq name *definition-types*) + (push (cons name instance) *definition-types*))) + do (error "There is already a different definition type ~s named ~s" + (cdr (assq name *definition-types*)) + name))) + ;; Return instance for use in make-load-form + instance)) + +(defun auto-create-definition-type (name) + ;; Use an anonymous class, so this means can't write methods on it. + ;; If you want to write methods on it, use define-definition-type first. + (let* ((super (find-class 'definition-type)) + (new-class (make-instance (class-of super) + :direct-superclasses (list super) + :direct-slots `((:name name + :allocation :class + :initform ',name + :initfunction ,(constantly name)))))) + (register-definition-type new-class (list name)) + (class-prototype new-class))) + +(defmethod definition-type-instance ((dt definition-type) &key (if-does-not-exist :error)) + (if (rassoc dt *definition-types* :test #'eq) + dt + (ecase if-does-not-exist + ((nil) nil) + ((:error) (error "~s is not a known definition-type" dt))))) + +(defmethod definition-type-instance ((name symbol) &key (if-does-not-exist :error)) + (or (cdr (assq name *definition-types*)) + (ecase if-does-not-exist + ((nil) nil) + ((:error) (error "~s is not a known definition-type" name)) + ((:create) (auto-create-definition-type name))))) + +(defmethod definition-type-instance ((class class) &key (if-does-not-exist :error)) + (definition-type-instance (class-prototype class) :if-does-not-exist if-does-not-exist)) + +(defmethod make-load-form ((dt definition-type) &optional env) + (declare (ignore env)) + (let ((names (loop for (name . instance) in *definition-types* + when (eq dt instance) collect name))) + `(register-definition-type ',(class-of dt) ',names))) + + +(register-definition-type (find-class 'definition-type) '(t)) + +(defparameter *t-definition-type* (definition-type-instance 't)) + +(define-definition-type function ()) + +(defparameter *function-definition-type* (definition-type-instance 'function)) + +(defmethod definition-base-name ((dt function-definition-type) name) + (while (and (consp name) (not (setf-function-name-p name))) + (let ((x (last name))) + (or (setq name (cdr x)) + ;; Try to detect the (:internal .... ) case + (when (and (setq name (car x)) + ;;check for plausible method name + (setq x (method-def-parameters name)) + (neq x 'setf) + (not (keywordp x))) + (setq name x))))) + (canonical-maybe-setf-name name)) + +(defmethod definition-bound-p ((dt function-definition-type) name) + (and (or (symbolp name) (setf-function-name-p name)) + (or (fboundp name) + ;; treat long-form setf expanders like macros. + (and (consp name) (functionp (%setf-method (cadr name))))))) + +(define-definition-type macro (function-definition-type)) + +(define-definition-type compiler-macro (macro-definition-type)) + +(define-definition-type symbol-macro (macro-definition-type)) + +(define-definition-type setf-expander (macro-definition-type)) + +(define-definition-type generic-function (function-definition-type)) + +(define-definition-type method ()) + +(defparameter *method-definition-type* (definition-type-instance 'method)) + +(defmethod definition-base-name ((dt method-definition-type) (name cons)) + (if (setf-function-name-p name) + (canonical-maybe-setf-name name) + (definition-base-name *function-definition-type* (car name)))) + +;; defmethod passes the actual method into record-source-file +(defmethod definition-base-name ((dt method-definition-type) (method method)) + (definition-base-name dt (method-name method))) + +(defmethod definition-base-name ((dt method-definition-type) (fn method-function)) + (definition-base-name dt (function-name fn))) + +(defmethod definition-same-p ((dt method-definition-type) m1 m2) + (multiple-value-bind (n1 q1 s1) (method-def-parameters m1) + (multiple-value-bind (n2 q2 s2) (method-def-parameters m2) + (and (definition-same-p *function-definition-type* n1 n2) + (equal q1 q2) + (eql (length s1) (length s2)) + (every #'(lambda (s1 s2) + (or (equal s1 s2) + (progn + (when (symbolp s2) (rotatef s1 s2)) + (and (symbolp s1) + (classp s2) + (or (eq (find-class s1 nil) s2) + (eq s1 (class-name s2))))))) + s1 s2))))) + +(defmethod definition-bound-p ((dt method-definition-type) meth &aux fn) + (when (setq fn (method-def-parameters meth)) + (loop for m in (and (setq fn (fboundp fn)) + (typep fn 'generic-function) + (generic-function-methods fn)) + thereis (definition-same-p dt meth m)))) + +(define-definition-type reader-method (method-definition-type)) + +(define-definition-type writer-method (method-definition-type)) + +(define-definition-type callback (function-definition-type)) + +(define-definition-type structure-accessor (function-definition-type)) + +(define-definition-type type ()) + +(define-definition-type class ()) + +(defmethod definition-bound-p ((dt class-definition-type) name) + (and (non-nil-symbol-p name) (find-class name nil))) + +(define-definition-type condition (class-definition-type)) + +(define-definition-type structure ()) + +(define-definition-type definition-type ()) + +(defmethod definition-bound-p ((dt definition-type-definition-type) name) + (definition-type-instance name :if-does-not-exist nil)) + +(define-definition-type method-combination ()) + +(define-definition-type variable ()) + +(defmethod definition-bound-p ((dt variable-definition-type) name) + (and (non-nil-symbol-p name) (boundp name))) + +(define-definition-type constant (variable-definition-type)) + +(define-definition-type package ()) + +(defmethod definition-base-name ((dt package-definition-type) name) + (if (or (stringp name) (non-nil-symbol-p name)) + (intern (string name) :keyword) + name)) + +(defmethod definition-bound-p ((dt package-definition-type) name) + (and (or (stringp name) (symbolp name)) + (find-package (string name)))) + +(defmethod definition-same-p ((dt package-definition-type) d1 d2) + (and (or (stringp d1) (symbolp d1)) + (or (stringp d2) (symbolp d2)) + (equal (string d1) (string d2)))) + + +;;;;;;;;;;; + +(declaim (inline default-definition-type)) + +(defun default-definition-type (name) + (if (typep name 'method) + *method-definition-type* + *function-definition-type*)) + +;; remember & reuse last few (TYPE . file) entries +(let ((cache (make-list 10 :initial-element nil))) + (defun type-file-cons (type files) + (loop for prev = nil then p for p = cache then (cdr p) + do (when (or (and (eq type (caar p)) (equal files (cdar p))) + (and (null (cdr p)) + (setf (car p) (cons type files)))) + (when prev ;; move to front unless already there + (setf (cdr prev) (cdr p)) + (setf (cdr p) cache) + (setq cache p)) + (return (car p)))))) + +(defun %source-file-entries (key) + (let ((data (gethash key %source-files%))) + (if (and (listp data) + (listp (%cdr data))) + data + (list data)))) + +(defun %set-source-file-entries (key list &aux data) + (setf (gethash key %source-files%) + (if (and list + (null (cdr list)) + ;; One element, but make sure can recognize it. + (not (and (listp (%car list)) + (listp (%cdar data))))) + (car list) + list))) + +(defun make-def-source-entry (key type name files) + (setq files (if (or (%cdr files) (listp (%car files))) files (%car files))) + (cond ((eq type (default-definition-type name)) + (if (and (eq name key) (atom files)) + files + (cons name files))) + ((eq name key) + (type-file-cons type files)) + (t + (cons (cons type name) files)))) + +(defun decode-def-source-entry (key entry) + (if (atom entry) + (and entry (values (default-definition-type key) key (list entry))) + (let* ((file-or-files (%cdr entry)) + (files (if (consp file-or-files) file-or-files (list file-or-files)))) + (cond ((typep (%car entry) 'definition-type) + (values (%car entry) key files)) + ((and (consp (%car entry)) (typep (%caar entry) 'definition-type)) + (values (%caar entry) (%cdar entry) files)) + (t + (values (default-definition-type (%car entry)) (%car entry) files)))))) + +(defun def-source-entry.name (key entry) + (assert (not (null entry))) + (cond ((atom entry) key) + ((typep (%car entry) 'definition-type) key) + ((and (consp (%car entry)) (typep (%caar entry) 'definition-type)) + (%cdar entry)) + (t + (%car entry)))) + +(defun def-source-entry.type (key entry) + (cond ((atom entry) (default-definition-type key)) + ((typep (%car entry) 'definition-type) (%car entry)) + ((and (consp (%car entry)) (typep (%caar entry) 'definition-type)) + (%caar entry)) + (t + (default-definition-type (%car entry))))) + +(defun def-source-entry.sources (key entry) + (declare (ignore key)) + (cond ((consp entry) + (if (consp (%cdr entry)) (%cdr entry) (list (%cdr entry)))) + (entry (list entry)) + (t nil))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + + +;; Some objects (specifically functions) have source location information associated with the +;; object itself, in addition to any source locations associated with its definition. This +;; allows us to find source for, e.g., anonymous functions. +(defgeneric get-object-sources (thing) + ;; returns a list of entries ((a-type . a-name) source . previous-sources) + (:method ((thing t)) nil) + (:method ((fn function)) + (let ((source (function-source-note fn))) + (when source + (list (list* (cons *function-definition-type* (or (name-of fn) fn)) source nil))))) + (:method ((fn method-function)) + (let ((source (function-source-note fn))) + (when source + (list (list* (cons *method-definition-type* (%method-function-method fn)) source nil))))) + (:method ((m method)) + (get-object-sources (method-function m)))) + +(defun find-definition-sources (name &optional (type t)) + "Returns a list of entries ((a-type . a-name) source . previous-sources), where +a-type is a subtype of TYPE, and a-name is either NAME or it's a special case of +NAME (e.g. if NAME is the name of generic function, a-name could be a method of NAME). + +If NAME is not a cons or symbol, it's assumed to be an object (e.g. class or +function) whose source location we try to heuristically locate, usually by looking up +the sources of its name. + +If NAME is a method name and *DIRECT-METHODS-ONLY* is false, will also locate all +applicable methods. + +The returned list is guaranteed freshly consed (ie suitable for nconc'ing)." + + (let* ((dt-class (class-of (definition-type-instance type))) + (matches (get-object-sources name))) + (if matches + (setq matches (delete-if-not (lambda (info) (typep (caar info) dt-class)) matches)) + ;; No intrinsic source info for the thing itself, look it up by name. + (let (seen-dts implicit-type implicit-dt-class implicit-name) + (typecase name + (method + (setq implicit-type 'method implicit-name name)) + (method-function + (setq implicit-type 'method implicit-name (%method-function-method name))) + (function + (setq implicit-type 'function implicit-name (name-of name))) + (method-combination + (setq implicit-type 'method-combination implicit-name (name-of name))) + (package + (setq implicit-type 'package implicit-name (name-of name))) + (class + (setq implicit-type 'class implicit-name (name-of name))) + (t + (locally + (declare (ftype function xref-entry-p xref-entry-full-name xref-entry-type)) + (if (and (find-class 'xref-entry nil) + (xref-entry-p name)) + (setq implicit-type (xref-entry-type name) implicit-name (xref-entry-full-name name)) + (setq implicit-type t implicit-name name))))) + (setq implicit-dt-class (class-of (definition-type-instance implicit-type))) + (with-lock-grabbed (*source-files-lock*) + (loop for (nil . dt) in *definition-types* + when (and (typep dt dt-class) (typep dt implicit-dt-class) (not (memq dt seen-dts))) + do (let* ((key (definition-base-name dt implicit-name)) + (all (%source-file-entries key))) + (push dt seen-dts) + (loop for entry in all + when (and (eq dt (def-source-entry.type key entry)) + (or (eq implicit-name key) ;; e.g. all methods on a gf + (definition-same-p dt implicit-name (def-source-entry.name key entry)))) + do (multiple-value-bind (type name files) + (decode-def-source-entry key entry) + (push (cons (cons type name) files) matches)))))))) + + ;; include indirect applicable methods. Who uses this case? + (when (and (eq type 'method) + (not (typep name 'method)) + (not *direct-methods-only*)) + (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name) + (when sym + (loop for m in (find-applicable-methods sym specializers qualifiers) + unless (definition-same-p *method-definition-type* m name) + do (setq matches (nconc (find-definition-sources m 'method) matches)))))) + matches)) + +;;; backward compatibility + +;;; modified version of %method-applicable-p - args are class names +;;; not instances +(defun %my-method-applicable-p (method args cpls) + (do* ((specs (%method-specializers method) (%cdr specs)) + (args args (%cdr args)) + (cpls cpls (%cdr cpls))) + ((null args) t) + (let ((spec (%car specs)) + (arg (%car args))) + (if (typep spec 'eql-specializer) + (if (consp arg) + (unless (eql (cadr arg) (eql-specializer-object spec)) + (return nil)) + (if (typep (eql-specializer-object spec) arg) + ;(unless (eq arg *null-class*) (return :undecidable)) + t ;; include if it's at all possible it might be applicable. + (return nil))) + (unless (memq spec (%car cpls)) + (return nil)))))) + +;;; modified version of %compute-applicable-methods* +;;; omit errors and args are class names not instances +;;; returns a new list. +(defun find-applicable-methods (name args qualifiers) + (let ((gf (fboundp name))) + (when (and gf (typep gf 'standard-generic-function)) + (let* ((methods (or (%gf-methods gf) + (return-from find-applicable-methods nil))) + (arg-count (length (%method-specializers (car methods)))) + (args-length (length args)) + (bits (inner-lfun-bits gf)) + res) + (unless (or (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (<= args-length + (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)))) + ;(error "Too many args for ~s" gf) + (return-from find-applicable-methods)) + (when (< arg-count args-length) + (setq args (subseq args 0 (setq args-length arg-count)))) + (setq args (mapcar (lambda (arg) + (typecase arg + (eql-specializer `(eql ,(eql-specializer-object arg))) + (class arg) + (symbol (or (find-class (or arg t) nil) + ;;(error "Invalid class name ~s" arg) + (return-from find-applicable-methods))) + (t + (unless (and (consp arg) (eql (car arg) 'eql) (null (cddr arg))) + ;;(error "Invalid specializer ~s" arg) + (return-from find-applicable-methods)) + arg))) + args)) + (let ((cpls (make-list args-length))) + (declare (dynamic-extent cpls)) + (do ((args-tail args (cdr args-tail)) + (cpls-tail cpls (cdr cpls-tail))) + ((null cpls-tail)) + (declare (type list args-tail cpls-tail)) + (let ((arg (car args-tail))) + (setf (car cpls-tail) + (%class-precedence-list (if (consp arg) + (class-of (cadr arg)) + arg))))) + (dolist (m methods) + (when (%my-method-applicable-p m args cpls) + (push m res))) + (let ((methods (sort-methods res cpls (%gf-precedence-list gf)))) + (when (eq (generic-function-method-combination gf) + *standard-method-combination*) + ; around* (befores) (afters) primaries* + (setq methods (compute-method-list methods)) + (when methods + (setq methods + (if (not (consp methods)) + (list methods) + (let ((afters (cadr (member-if #'listp methods)))) + (when afters (nremove afters methods)) + (nconc + (mapcan #'(lambda (x)(if (listp x) x (cons x nil))) + methods) + afters)))))) + (if (and qualifiers (neq qualifiers t)) + (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m)))) + methods) + methods))))))) + +;;; Do this just in case record source file doesn't remember the right +;;; definition +(defun methods-match-p (x y) + (or (eq x y) + (and (typep x 'method) + (typep y 'method) + (equal (method-name x) + (method-name y)) + (equal (method-specializers x) + (method-specializers y)) + (equal (method-qualifiers x) + (method-qualifiers y))))) + +(defun edit-definition-p (name &optional (type t)) ;exported + (let ((specs (get-source-files-with-types name type))) + (when (and (null specs) + (symbolp name)) + (let* ((str (symbol-name name)) + (len (length str))) + (when (and (> len 0) (memq (char str (1- len)) '(#\. #\, #\:))) + (let ((newsym (find-symbol (%substr str 0 (1- len)) (symbol-package name)))) + (when newsym + (setq specs (get-source-files-with-types newsym type))))))) + specs)) + +(defun get-source-files-with-types (name &optional (type t)) + (let ((list (find-definition-sources name type))) + ;; Convert to old format, (type-or-name . file) + (loop for ((dt . full-name) . sources) in list + as spec = (if (eq full-name name) (definition-type-name dt) full-name) + nconc (mapcan (lambda (s) + (when s (list (cons spec (source-note-filename s))))) + sources)))) + + +;; For ilisp. +(defun %source-files (name) + (let ((type-list ()) + (meth-list ())) + (loop for ((dt . full-name) . sources) in (find-definition-sources name t) + as files = (mapcan #'(lambda (s) + (and s (setq s (source-note-filename s)) (list s))) + sources) + when files + do (if (typep dt 'method-definition-type) + (dolist (file files) + (push (cons full-name file) meth-list)) + (push (cons (definition-type-name dt) files) type-list))) + (when meth-list + (push (cons 'method meth-list) type-list)) + type-list)) + +;; For CVS slime as of 11/15/2008. +(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method) + (let* ((name (or the-method + (and (or (eq type 'method) classes qualifiers) + `(sym ,@qualifiers ,classes)) + sym))) + (get-source-files-with-types name type))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; record-source-file + +;; Returns nil if not a method/method name +(defun method-def-parameters (m) + (when (typep m 'method-function) + (setq m (%method-function-method m))) + (if (typep m 'method) + (values (method-name m) + (method-qualifiers m) + (method-specializers m)) + (let (name quals specs data last) + (when (consp m) + (when (eq (car m) :method) (setq m (cdr m))) + ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn)) + (setq data (cdr m) last (last data)) + (when (null (cdr last)) + (setq last (car last)) + (if (and (listp last) (neq (car last) 'eql)) + (setq quals (butlast data) specs last) + (setq specs data)) + (setq name (car m)) + (when (and (or (non-nil-symbol-p name) (setf-function-name-p name)) + (every #'(lambda (q) (not (listp q))) quals) + (every #'(lambda (s) + (or (non-nil-symbol-p s) + (classp s) + (and (consp s) + (consp (cdr s)) + (null (cddr s)) + (eq (car s) 'eql)))) + specs)) + (values name quals specs))))))) + +(defmethod record-definition-source ((dt definition-type) name source) + (let* ((key (definition-base-name dt name)) + (all (%source-file-entries key)) + (e-loc nil) + (e-files nil)) + (loop for ptr on all as entry = (car ptr) + do (when (and (eq dt (def-source-entry.type key entry)) + (definition-same-p dt name (def-source-entry.name key entry))) + (setq e-files (def-source-entry.sources key entry)) + (let ((old (flet ((same-file (x y) + (setq x (source-note-filename x)) + (setq y (source-note-filename y)) + (or (equal x y) + (and x + y + (or (stringp x) (pathnamep x)) + (or (stringp y) (pathnamep y)) + (equal + (or (probe-file x) (full-pathname x)) + (or (probe-file y) (full-pathname y))))))) + (member source e-files :test #'same-file)))) + (when (and old (neq source (car e-files))) ;; move to front + (setq e-files (cons source (remove (car old) e-files :test #'eq))))) + (return (setq e-loc ptr)))) + (unless (and e-files (eq source (car e-files))) + ;; Never previously defined in this file + (when (and (car e-files) ; don't warn if last defined interactively + *warn-if-redefine* + (definition-bound-p dt name)) + (warn "~A ~S previously defined in: ~A is now being redefined in: ~A~%" + (definition-type-name dt) + name + (source-note-filename (car e-files)) + (or (source-note-filename source) "{No file}"))) + (setq e-files (cons source e-files))) + (let ((entry (make-def-source-entry key dt name e-files))) + (if e-loc + (setf (car e-loc) entry) + (push entry all)) + (%set-source-file-entries key all)) + name)) + +(defmethod record-definition-source ((dt method-definition-type) (m method) source) + ;; In cases of non-toplevel method definitions, as in the expansion of defgeneric, + ;; the method function note has more specific info than *loading-toplevel-location*. + (call-next-method dt m (or (function-source-note (method-function m)) source))) + +;;; avoid hanging onto beezillions of pathnames +(defparameter *last-back-translated-name* (cons nil nil)) + +;; Define the real record-source-file, which will be the last defn handled by the +;; bootstrapping record-source-file, so convert all queued up data right afterwards. +(progn + +(defun record-source-file (name def-type &optional (source (or *loading-toplevel-location* + *loading-file-source-file*))) + (when (and source *record-source-file*) + (with-lock-grabbed (*source-files-lock*) + (let ((file-name (source-note-filename source))) + (when file-name + (unless (equalp file-name (car *last-back-translated-name*)) + (setf (car *last-back-translated-name*) file-name) + (setf (cdr *last-back-translated-name*) + (if (physical-pathname-p file-name) + (namestring (back-translate-pathname file-name)) + file-name))) + (setq file-name (cdr *last-back-translated-name*)) + (if (source-note-p source) + (setf (source-note-filename source) file-name) + (setq source file-name)))) + (when (eq def-type 't) (report-bad-arg def-type '(not (eql t)))) + (record-definition-source (definition-type-instance def-type + :if-does-not-exist :create) + name + source)))) + +;; Collect level-0 source file info +(do-all-symbols (s) + (let ((f (get s 'bootstrapping-source-files))) + (when f + (if (consp f) + (destructuring-bind ((type . source)) f + (when source (record-source-file s type source))) + (record-source-file s 'function f)) + (remprop s 'bootstrapping-source-files)))) + +;; Collect level-1 source file info +(when (consp *record-source-file*) + (let ((list (nreverse (shiftf *record-source-file* t)))) + (while list + (apply #'record-source-file (pop list))))) +) Index: /branches/qres/ccl/lib/streams.lisp =================================================================== --- /branches/qres/ccl/lib/streams.lisp (revision 13564) +++ /branches/qres/ccl/lib/streams.lisp (revision 13564) @@ -0,0 +1,191 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; streams.lisp +;;;General io-functions + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require :level-2) + (require :streams) + (require :backquote) + + ) + + + + + + +(defun read-line (&optional input-stream (eof-error-p t) eof-value recursive-p) + + (declare (ignore recursive-p) + (optimize (speed 3))) + (let* ((input-stream (designated-input-stream input-stream))) + (multiple-value-bind (string eof) + (if (typep input-stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock input-stream))) + (with-ioblock-input-locked (ioblock) + (funcall (ioblock-read-line-function ioblock) ioblock))) + (stream-read-line input-stream)) + (if eof + (if (= (length string) 0) + (if eof-error-p + (signal-eof-error input-stream) + (values eof-value t)) + (values string t)) + (values string nil))))) + +(eval-when (:compile-toplevel) + (declaim (inline read-char-internal))) + +(defun read-char-internal (input-stream eof-error-p eof-value) + (declare (optimize (speed 3) (space 0))) + (check-eof + (if (or (typep input-stream 'basic-stream) + (typep (setq input-stream (designated-input-stream input-stream)) + 'basic-stream)) + (let* ((ioblock (basic-stream-ioblock input-stream))) + (funcall (ioblock-read-char-function ioblock) ioblock)) + (stream-read-char input-stream)) + input-stream eof-error-p eof-value)) + +(defun read-char (&optional input-stream (eof-error-p t) eof-value recursive-p) + (declare (ignore recursive-p)) + (read-char-internal input-stream eof-error-p eof-value)) + +(defun unread-char (char &optional input-stream) + (let* ((input-stream (designated-input-stream input-stream))) + (if (typep input-stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock input-stream))) + (funcall (ioblock-unread-char-function ioblock) ioblock char)) + (stream-unread-char input-stream char)) + nil)) + +(defun peek-char (&optional peek-type input-stream + (eof-error-p t) eof-value recursive-p) + (declare (ignore recursive-p)) + (let* ((input-stream (designated-input-stream input-stream))) + (cond ((null peek-type) + (check-eof (stream-peek-char input-stream) input-stream eof-error-p eof-value)) + (t + (do* ((value (stream-peek-char input-stream) (stream-peek-char input-stream))) + ((eq value :eof) + (return (check-eof value input-stream eof-error-p eof-value))) + (if (eq peek-type t) + (unless (whitespacep value) + (return value)) + (if (characterp peek-type) + (if (eql peek-type value) + (return value)) + (report-bad-arg peek-type '(or character (member nil t))))) + (stream-read-char input-stream)))))) + +(defun read-char-no-hang (&optional input-stream (eof-error-p t) eof-value recursive-p) + (declare (ignore recursive-p)) + (setq input-stream (designated-input-stream input-stream)) + (check-eof (stream-read-char-no-hang input-stream) input-stream eof-error-p eof-value)) + +(defun read-byte (stream &optional (eof-error-p t) eof-value) + (declare (optimize (speed 3) (space 0))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (check-eof (funcall (ioblock-read-byte-function ioblock) ioblock) + stream + eof-error-p + eof-value)) + (check-eof + (stream-read-byte stream) + stream + eof-error-p + eof-value))) + +;;;;;;;;;;;; OUTPUT STREAMS + +(defun clear-output (&optional stream) + (let* ((stream (real-print-stream stream))) + (stream-clear-output stream) + nil)) + +(defun finish-output (&optional stream) + (let* ((stream (real-print-stream stream))) + (stream-finish-output stream) + nil)) + + + +(defun line-length (stream) + (or (stream-line-length stream) 80)) + +(defun write-byte (byte stream) + (declare (optimize (speed 3) (space 0))) + "Write one byte, BYTE, to STREAM." + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-byte-function ioblock) ioblock byte)) + (stream-write-byte stream byte)) + byte) + + +;;;General stream functions + + + +(defmacro with-open-stream ((var stream) &body body &aux (svar (gensym))) + "Perform a series of operations on stream, return a value, and then +close the stream. VAR is bound to the value of STREAM, and then BODY is +executed as an implicit progn. STREAM is automatically closed on exit +from with-open-stream, no matter whether the exit is normal or abnormal. +The stream has dynamic extent; its extent ends when the form is exited." + `(let (,svar) + (unwind-protect + (let ((,var (setq ,svar ,stream))) + ,@body) + (when ,svar (close ,svar))))) + + + + +;; + +;;; from i/o chapter of steele +;;; Ever notice that -much- of this code is from the i/o chapter +;;; of steele ? Strange but true ... + +(defun read-from-string (string &optional (eof-error-p t) eof-value + &key (start 0) end preserve-whitespace + &aux idx) + "The characters of string are successively given to the lisp reader + and the lisp object built by the reader is returned. Macro chars + will take effect." + (values + (with-input-from-string (stream string :index idx :start start :end end) + (if preserve-whitespace + (read-preserving-whitespace stream eof-error-p eof-value) + (read stream eof-error-p eof-value))) + idx)) + + +;;;File Stuff here + +(defun dribble (&optional filename) + "With a file name as an argument, dribble opens the file and sends a + record of further I/O to that file. Without an argument, it closes + the dribble file, and quits logging." + (process-dribble *current-process* filename)) + Index: /branches/qres/ccl/lib/systems.lisp =================================================================== --- /branches/qres/ccl/lib/systems.lisp (revision 13564) +++ /branches/qres/ccl/lib/systems.lisp (revision 13564) @@ -0,0 +1,217 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; module-name binary (source . files-depends-on) +;;; ----------- ------ --------------------------- +(defparameter *ccl-system* + '( + (level-1 "ccl:ccl;level-1" ("ccl:l1;level-1.lisp")) + (runtime "ccl:ccl;runtime" ("ccl:l1;runtime.lisp")) + (level-1-test "ccl:level-1-test" ("ccl:l1;level-1-test.lisp")) + (l1-cl-package "ccl:l1f;l1-cl-package" ("ccl:l1;l1-cl-package.lisp")) + (l1-utils "ccl:l1f;l1-utils" ("ccl:l1;l1-utils.lisp")) + (l1-numbers "ccl:l1f;l1-numbers" ("ccl:l1;l1-numbers.lisp")) + (l1-init "ccl:l1f;l1-init" ("ccl:l1;l1-init.lisp")) + (version "ccl:l1f;version" ("ccl:l1;version.lisp")) + (l1-boot-1 "ccl:l1f;l1-boot-1" ("ccl:l1;l1-boot-1.lisp")) + (l1-boot-2 "ccl:l1f;l1-boot-2" ("ccl:l1;l1-boot-2.lisp")) + (l1-boot-3 "ccl:l1f;l1-boot-3" ("ccl:l1;l1-boot-3.lisp")) + (l1-boot-lds "ccl:l1f;l1-boot-lds" ("ccl:l1;l1-boot-lds.lisp")) + (l1-files "ccl:l1f;l1-files" ("ccl:l1;l1-files.lisp")) + (l1-sort "ccl:l1f;l1-sort" ("ccl:l1;l1-sort.lisp")) + (l1-dcode "ccl:l1f;l1-dcode" ("ccl:l1;l1-dcode.lisp")) + (l1-clos-boot "ccl:l1f;l1-clos-boot" ("ccl:l1;l1-clos-boot.lisp")) + (l1-clos "ccl:l1f;l1-clos" ("ccl:l1;l1-clos.lisp")) + (l1-io "ccl:l1f;l1-io" ("ccl:l1;l1-io.lisp")) + (l1-unicode "ccl:l1f;l1-unicode" ("ccl:l1;l1-unicode.lisp")) + + (l1-streams "ccl:l1f;l1-streams" ("ccl:l1;l1-streams.lisp")) + (l1-events "ccl:l1f;l1-events" ("ccl:l1;l1-events.lisp")) + (ppc-trap-support "ccl:l1f;ppc-trap-support" ("ccl:l1;ppc-trap-support.lisp")) + (x86-trap-support "ccl:l1f;x86-trap-support" ("ccl:l1;x86-trap-support.lisp")) + + (l1-format "ccl:l1f;l1-format" ("ccl:l1;l1-format.lisp")) + (l1-readloop "ccl:l1f;l1-readloop" ("ccl:l1;l1-readloop.lisp")) + (l1-readloop-lds "ccl:l1f;l1-readloop-lds" ("ccl:l1;l1-readloop-lds.lisp")) + (l1-reader "ccl:l1f;l1-reader" ("ccl:l1;l1-reader.lisp")) + (l1-error-system "ccl:l1f;l1-error-system" ("ccl:l1;l1-error-system.lisp")) + (ppc-error-signal "ccl:l1f;ppc-error-signal" ("ccl:l1;ppc-error-signal.lisp")) + (x86-error-signal "ccl:l1f;x86-error-signal" ("ccl:l1;x86-error-signal.lisp")) + (l1-error-signal "ccl:l1f;l1-error-signal" ("ccl:l1;l1-error-signal.lisp")) + (l1-aprims "ccl:l1f;l1-aprims" ("ccl:l1;l1-aprims.lisp")) + (l1-callbacks "ccl:l1f;l1-callbacks" ("ccl:l1;l1-callbacks.lisp")) + (ppc-callback-support "ccl:l1f;ppc-callback-support" ("ccl:l1;ppc-callback-support.lisp")) + (x86-callback-support "ccl:l1f;x86-callback-support" ("ccl:l1;x86-callback-support.lisp")) + (l1-sysio "ccl:l1f;l1-sysio" ("ccl:l1;l1-sysio.lisp")) + (l1-symhash "ccl:l1f;l1-symhash" ("ccl:l1;l1-symhash.lisp")) + (l1-pathnames "ccl:l1f;l1-pathnames" ("ccl:l1;l1-pathnames.lisp")) + (l1-lisp-threads "ccl:l1f;l1-lisp-threads" ("ccl:l1;l1-lisp-threads.lisp")) + (l1-sockets "ccl:l1f;l1-sockets" ("ccl:l1;l1-sockets.lisp")) + (ppc-threads-utils "ccl:l1f;ppc-threads-utils" ("ccl:l1;ppc-threads-utils.lisp")) + (x86-threads-utils "ccl:l1f;x86-threads-utils" ("ccl:l1;x86-threads-utils.lisp")) + (l1-application "ccl:l1f;l1-application" ("ccl:l1;l1-application.lisp")) + (l1-processes "ccl:l1f;l1-processes" ("ccl:l1;l1-processes.lisp")) + + (l1-typesys "ccl:l1f;l1-typesys" ("ccl:l1;l1-typesys.lisp")) + (sysutils "ccl:l1f;sysutils" ("ccl:l1;sysutils.lisp")) + (nx "ccl:l1f;nx" ("ccl:compiler;nx.lisp" + "ccl:compiler;nx0.lisp" + "ccl:compiler;lambda-list.lisp" + "ccl:compiler;nx-basic.lisp" + "ccl:compiler;nx1.lisp")) + (nxenv "ccl:bin;nxenv" ("ccl:compiler;nxenv.lisp")) + (nx2 "ccl:bin;nx2" ("ccl:compiler;nx2.lisp")) + (nx-base-app "ccl:l1f;nx-base-app" ("ccl:compiler;nx-base-app.lisp" + "ccl:compiler;lambda-list.lisp")) + (dll-node "ccl:bin;dll-node" ("ccl:compiler;dll-node.lisp")) + (ppc32-arch "ccl:bin;ppc32-arch" ("ccl:compiler;PPC;PPC32;ppc32-arch.lisp")) + (ppc-arch "ccl:bin;ppc-arch" ("ccl:compiler;PPC;ppc-arch.lisp")) + (x86-arch "ccl:bin;x86-arch" ("ccl:compiler;X86;x86-arch.lisp")) + (ppc64-arch "ccl:bin;ppc64-arch" ("ccl:compiler;PPC;PPC64;ppc64-arch.lisp")) + (x8632-arch "ccl:bin;x8632-arch" ("ccl:compiler;X86;X8632;x8632-arch.lisp")) + (x8664-arch "ccl:bin;x8664-arch" ("ccl:compiler;X86;X8664;x8664-arch.lisp")) + (arch "ccl:bin;arch" ("ccl:compiler;arch.lisp")) + (ppcenv "ccl:bin;ppcenv" ("ccl:lib;ppcenv.lisp")) + (x8664env "ccl:bin;x8664env" ("ccl:lib;x8664env.lisp")) + (x8632env "ccl:bin;x8632env" ("ccl:lib;x8632env.lisp")) + (vreg "ccl:bin;vreg" ("ccl:compiler;vreg.lisp")) + (ppc-asm "ccl:bin;ppc-asm" ("ccl:compiler;PPC;ppc-asm.lisp")) + (x86-asm "ccl:bin;x86-asm" ("ccl:compiler;X86;x86-asm.lisp")) + (vinsn "ccl:bin;vinsn" ("ccl:compiler;vinsn.lisp")) + (ppc32-vinsns "ccl:bin;ppc32-vinsns" ("ccl:compiler;PPC;PPC32;ppc32-vinsns.lisp")) + (ppc64-vinsns "ccl:bin;ppc64-vinsns" ("ccl:compiler;PPC;PPC64;ppc64-vinsns.lisp")) + (x8632-vinsns "ccl:bin;x8632-vinsns" ("ccl:compiler;X86;X8632;x8632-vinsns.lisp")) + (x8664-vinsns "ccl:bin;x8664-vinsns" ("ccl:compiler;X86;X8664;x8664-vinsns.lisp")) + (reg "ccl:bin;reg" ("ccl:compiler;reg.lisp")) + (subprims "ccl:bin;subprims" ("ccl:compiler;subprims.lisp")) + (risc-lap "ccl:bin;risc-lap" ("ccl:compiler;risc-lap.lisp")) + (ppc-lap "ccl:bin;ppc-lap" ("ccl:compiler;PPC;ppc-lap.lisp")) + (x86-lap "ccl:bin;x86-lap" ("ccl:compiler;X86;x86-lap.lisp")) + (backend "ccl:bin;backend" ("ccl:compiler;backend.lisp")) + (ppc32-backend "ccl:bin;ppc32-backend" ("ccl:compiler;PPC;PPC32;ppc32-backend.lisp")) + (ppc64-backend "ccl:bin;ppc64-backend" ("ccl:compiler;PPC;PPC64;ppc64-backend.lisp")) + (ppc-backend "ccl:bin;ppc-backend" ("ccl:compiler;PPC;ppc-backend.lisp")) + (x8632-backend "ccl:bin;x8632-backend" ("ccl:compiler;X86;X8632;x8632-backend.lisp")) + (x8664-backend "ccl:bin;x8664-backend" ("ccl:compiler;X86;X8664;x8664-backend.lisp")) + (x86-backend "ccl:bin;x86-backend" ("ccl:compiler;X86;x86-backend.lisp")) + (ppc2 "ccl:bin;ppc2" ("ccl:compiler;PPC;ppc2.lisp")) + (x862 "ccl:bin;x862" ("ccl:compiler;X86;x862.lisp")) + + (ppc-lapmacros "ccl:bin;ppc-lapmacros" ("ccl:compiler;PPC;ppc-lapmacros.lisp")) + (x86-lapmacros "ccl:bin;x86-lapmacros" ("ccl:compiler;X86;x86-lapmacros.lisp")) + (ppc-disassemble "ccl:bin;ppc-disassemble" ("ccl:compiler;PPC;ppc-disassemble.lisp")) + (x86-disassemble "ccl:bin;x86-disassemble" ("ccl:compiler;X86;x86-disassemble.lisp")) + (xfasload "ccl:xdump;xfasload" ("ccl:xdump;xfasload.lisp")) + (xppcfasload "ccl:xdump;xppcfasload" ("ccl:xdump;xppcfasload.lisp")) + (xx8632fasload "ccl:xdump;xx8632-fasload" ("ccl:xdump;xx8632-fasload.lisp")) + (xx8664fasload "ccl:xdump;xx8664-fasload" ("ccl:xdump;xx8664-fasload.lisp")) + (heap-image "ccl:xdump;heap-image" ("ccl:xdump;heap-image.lisp")) + (xsym "ccl:xdump;xsym" ("ccl:xdump;xsym.lisp")) + (number-macros "ccl:bin;number-macros" ("ccl:lib;number-macros.lisp")) + (number-case-macro "ccl:bin;number-case-macro" ("ccl:lib;number-case-macro.lisp")) + (optimizers "ccl:bin;optimizers" ("ccl:compiler;optimizers.lisp")) + (backquote "ccl:bin;backquote" ("ccl:lib;backquote.lisp")) + (lispequ "ccl:library;lispequ" ("ccl:library;lispequ.lisp")) + (sysequ "ccl:bin;sysequ" ("ccl:lib;sysequ.lisp")) + (toolequ "ccl:bin;toolequ" ("ccl:lib;toolequ.lisp")) + (level-2 "ccl:bin;level-2" ("ccl:lib;level-2.lisp")) + (macros "ccl:bin;macros" ("ccl:lib;macros.lisp")) + (defstruct-macros "ccl:bin;defstruct-macros" ("ccl:lib;defstruct-macros.lisp")) + (foreign-types "ccl:bin;foreign-types" ("ccl:lib;foreign-types.lisp")) + (ffi-linuxppc32 "ccl:bin;ffi-linuxppc32" ("ccl:lib;ffi-linuxppc32.lisp")) + (ffi-darwinppc32 "ccl:bin;ffi-darwinppc32" ("ccl:lib;ffi-darwinppc32.lisp")) + (ffi-darwinppc64 "ccl:bin;ffi-darwinppc64" ("ccl:lib;ffi-darwinppc64.lisp")) + (ffi-linuxppc64 "ccl:bin;ffi-linuxppc64" ("ccl:lib;ffi-linuxppc64.lisp")) + (ffi-darwinx8632 "ccl:bin;ffi-darwinx8632" ("ccl:lib;ffi-darwinx8632.lisp")) + (ffi-linuxx8664 "ccl:bin;ffi-linuxx8664" ("ccl:lib;ffi-linuxx8664.lisp")) + (ffi-darwinx8664 "ccl:bin;ffi-darwinx8664" ("ccl:lib;ffi-darwinx8664.lisp")) + (ffi-freebsdx8664 "ccl:bin;ffi-freebsdx8664" ("ccl:lib;ffi-freebsdx8664.lisp")) + (ffi-solarisx8664 "ccl:bin;ffi-solarisx8664" ("ccl:lib;ffi-solarisx8664.lisp")) + (ffi-win64 "ccl:bin;ffi-win64" ("ccl:lib;ffi-win64.lisp")) + (ffi-linuxx8632 "ccl:bin;ffi-linuxx8632" ("ccl:lib;ffi-linuxx8632.lisp")) + (ffi-win32 "ccl:bin;ffi-win32" ("ccl:lib;ffi-win32.lisp")) + (ffi-solarisx8632 "ccl:bin;ffi-solarisx8632" ("ccl:lib;ffi-solarisx8632.lisp")) + (ffi-freebsdx8632 "ccl:bin;ffi-freebsdx8632" ("ccl:lib;ffi-freebsdx8632.lisp")) + + (db-io "ccl:bin;db-io" ("ccl:lib;db-io.lisp")) + (hash "ccl:bin;hash" ("ccl:lib;hash.lisp")) + (nfcomp "ccl:bin;nfcomp" ("ccl:lib;nfcomp.lisp")) + (lists "ccl:bin;lists" ("ccl:lib;lists.lisp")) + (chars "ccl:bin;chars" ("ccl:lib;chars.lisp")) + (streams "ccl:bin;streams" ("ccl:lib;streams.lisp")) + (pathnames "ccl:bin;pathnames" ("ccl:lib;pathnames.lisp")) + (describe "ccl:bin;describe" ("ccl:lib;describe.lisp")) + (mcl-compat "ccl:bin;mcl-compat" ("ccl:lib;mcl-compat.lisp")) + (backtrace "ccl:bin;backtrace" ("ccl:lib;backtrace.lisp")) + (ppc-backtrace "ccl:bin;ppc-backtrace" ("ccl:lib;ppc-backtrace.lisp")) + (x86-backtrace "ccl:bin;x86-backtrace" ("ccl:lib;x86-backtrace.lisp")) + (x86-watch "ccl:bin;x86-watch" ("ccl:lib;x86-watch.lisp")) + (backtrace-lds "ccl:bin;backtrace-lds" ("ccl:lib;backtrace-lds.lisp")) + (apropos "ccl:bin;apropos" ("ccl:lib;apropos.lisp")) + (numbers "ccl:bin;numbers" ("ccl:lib;numbers.lisp")) + (dumplisp "ccl:bin;dumplisp" ("ccl:lib;dumplisp.lisp")) + (defstruct "ccl:bin;defstruct" ("ccl:lib;defstruct.lisp" + "ccl:lib;defstruct-macros.lisp")) + (defstruct-lds "ccl:bin;defstruct-lds" ("ccl:lib;defstruct-lds.lisp" + "ccl:lib;defstruct-macros.lisp")) + (method-combination + "ccl:bin;method-combination" + ("ccl:lib;method-combination.lisp")) + (encapsulate "ccl:bin;encapsulate" ("ccl:lib;encapsulate.lisp")) + (read "ccl:bin;read" ("ccl:lib;read.lisp")) + (misc "ccl:bin;misc" ("ccl:lib;misc.lisp")) + (arrays-fry "ccl:bin;arrays-fry" ("ccl:lib;arrays-fry.lisp")) + (sequences "ccl:bin;sequences" ("ccl:lib;sequences.lisp")) + (sort "ccl:bin;sort" ("ccl:lib;sort.lisp")) + (setf "ccl:bin;setf" ("ccl:lib;setf.lisp")) + (setf-runtime "ccl:bin;setf-runtime" ("ccl:lib;setf-runtime.lisp")) + (format "ccl:bin;format" ("ccl:lib;format.lisp")) + (case-error "ccl:bin;case-error" ("ccl:lib;case-error.lisp")) + (pprint "ccl:bin;pprint" ("ccl:lib;pprint.lisp")) + (time "ccl:bin;time" ("ccl:lib;time.lisp")) + (print-db "ccl:bin;print-db" ("ccl:lib;print-db.lisp")) +; (eval "ccl:bin;eval" ("ccl:lib;eval.lisp")) + + (arglist "ccl:bin;arglist" ("ccl:lib;arglist.lisp")) + + (edit-callers "ccl:bin;edit-callers" ("ccl:lib;edit-callers.lisp")) + ;; (hash-cons "ccl:library;hash-cons" ("ccl:library;hash-cons.lisp")) + ;; (step "ccl:bin;step" ("ccl:lib;step.lisp")) + (ccl-export-syms "ccl:bin;ccl-export-syms" ("ccl:lib;ccl-export-syms.lisp")) + (systems "ccl:bin;systems" ("ccl:lib;systems.lisp")) + (compile-ccl "ccl:bin;compile-ccl" ("ccl:lib;compile-ccl.lisp")) + (ppc-init-ccl "ccl:bin;ppc-init-ccl" ("ccl:lib;ppc-init-ccl.lisp")) + (distrib-inits "ccl:bin;distrib-inits" ("ccl:lib;distrib-inits.lisp")) + (lisp-package "ccl:library;lisp-package" ("ccl:library;lisp-package.lisp")) + ;; need to add swapping, xdump to CCL's *module-search-path* + (xdump "ccl:xdump;xdump" ("ccl:xdump;xdump.lisp")) + (fasload "ccl:xdump;fasload" ("ccl:xdump;fasload.lisp")) + (loop "ccl:library;loop" ("ccl:library;loop.lisp")) + (linux-files "ccl:l1f;linux-files" ("ccl:level-1;linux-files.lisp")) + (source-files "ccl:bin;source-files" ("ccl:lib;source-files.lisp")) + (cover "ccl:bin;cover" ("ccl:library;cover.lisp")) + (leaks "ccl:bin;leaks" ("ccl:library;leaks.lisp")) + (core-files "ccl:bin;core-files" ("ccl:library;core-files.lisp")) + (dominance "ccl:bin;dominance" ("ccl:library;dominance.lisp")) + + (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp")) + (defsystem "ccl:tools;defsystem" ("ccl:tools;defsystem.lisp")) + (asdf "ccl:tools;asdf" ("ccl:tools;asdf.lisp")) + (jp-encode "ccl:bin;jp-encode" ("ccl:library;jp-encode.lisp")))) + Index: /branches/qres/ccl/lib/time.lisp =================================================================== --- /branches/qres/ccl/lib/time.lisp (revision 13564) +++ /branches/qres/ccl/lib/time.lisp (revision 13564) @@ -0,0 +1,265 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (defconstant seconds-in-week (* 60 60 24 7)) + (defconstant weeks-offset 2145) + (defconstant seconds-offset 432000) + (defconstant minutes-per-day (* 24 60)) + (defconstant quarter-days-per-year (1+ (* 365 4))) + (defconstant quarter-days-per-century 146097) + (defconstant november-17-1858 678882) + (defconstant weekday-november-17-1858 2) +) + +(defun gctime () + (let* ((timeval-size (record-length :timeval))) + (%stack-block ((copy (* timeval-size 5))) + (#_memmove copy *total-gc-microseconds* (* timeval-size 5)) + (macrolet ((funk (arg) + (ecase internal-time-units-per-second + (1000000 `(timeval->microseconds ,arg)) + (1000 `(timeval->milliseconds ,arg))))) + (values + (funk copy) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size))))))) + + + + +;;; This should stop using #_localtime_r: not all times can be represented +;;; as a signed natural offset from the start of Unix time. +;;; For now, if the time won't fit in a :time_t, use an arbitrary time +;;; value to get the time zone and assume that DST was -not- in effect. +#-windows-target +(defun get-timezone (time) + (let* ((toobig (not (typep time '(signed-byte + #+32-bit-target 32 + #+64-bit-target 64))))) + (when toobig + (setq time 0)) + (rlet ((when :time_t) + (tm :tm)) + (setf (pref when :time_t) time) + (with-macptrs ((ltm (#_localtime_r when tm))) + (if (%null-ptr-p ltm) + (values 0 nil) + (progn + (values (floor #-solaris-target (pref tm :tm.tm_gmtoff) + #+solaris-target #&altzone + -60) + (unless toobig (not (zerop (pref tm :tm.tm_isdst))))))))))) + +#+windows-target +(defun get-timezone (time) + (declare (ignore time)) + (rlet ((tzinfo #>TIME_ZONE_INFORMATION)) + (let* ((id (#_GetTimeZoneInformation tzinfo)) + (minutes-west (pref tzinfo #>TIME_ZONE_INFORMATION.Bias)) + (is-dst (= id #$TIME_ZONE_ID_DAYLIGHT))) + (values (floor (+ minutes-west + (if is-dst + (pref tzinfo #>TIME_ZONE_INFORMATION.DaylightBias) + 0))) + is-dst)))) + + + +(defun decode-universal-time (universal-time &optional time-zone) + "Converts a universal-time to decoded time format returning the following + nine values: second, minute, hour, date, month, year, day of week (0 = + Monday), T (daylight savings time) or NIL (standard time), and timezone. + Completely ignores daylight-savings-time when time-zone is supplied." + (multiple-value-bind (weeks secs) + (truncate (+ universal-time seconds-offset) + seconds-in-week) + (let* ((weeks (+ weeks weeks-offset)) + (second NIL) + (minute NIL) + (hour NIL) + (date NIL) + (month NIL) + (year NIL) + (day NIL) + (daylight NIL) + (timezone (if (null time-zone) + (multiple-value-bind + (minwest dst) + (get-timezone (- universal-time + unix-to-universal-time)) + (setf daylight dst) + minwest) + (* time-zone 60)))) + (declare (fixnum timezone)) + (multiple-value-bind (t1 seconds) (truncate secs 60) + (setq second seconds) + (setq t1 (- t1 timezone)) + (let* ((tday (if (< t1 0) + (1- (truncate (1+ t1) minutes-per-day)) + (truncate t1 minutes-per-day)))) + (multiple-value-setq (hour minute) + (truncate (- t1 (* tday minutes-per-day)) 60)) + (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) + (tcent (truncate t2 quarter-days-per-century))) + (setq t2 (mod t2 quarter-days-per-century)) + (setq t2 (+ (- t2 (mod t2 4)) 3)) + (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year))) + (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year) + 4)))) + (setq day (mod (+ tday weekday-november-17-1858) 7)) + (let ((t3 (+ (* days-since-mar0 5) 456))) + (cond ((>= t3 1989) + (setq t3 (- t3 1836)) + (setq year (1+ year)))) + (multiple-value-setq (month t3) (truncate t3 153)) + (setq date (1+ (truncate t3 5)))))))) + (values second minute hour date month year day + daylight + (if daylight + (1+ (/ timezone 60)) + (/ timezone 60)))))) + +(defun get-decoded-time () + "Return nine values specifying the current time as follows: + second, minute, hour, date, month, year, day of week (0 = Monday), T + (daylight savings times) or NIL (standard time), and timezone." + (decode-universal-time (get-universal-time))) + +(defun current-year () + (nth-value 5 (get-decoded-time))) + +(defun leap-years-before (year) + (let ((years (- year 1901))) + (+ (- (truncate years 4) + (truncate years 100)) + (truncate (+ years 300) 400)))) + +(defvar *days-before-month* + (let* ((results (list nil))) + (let ((sum 0)) + (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31)) + (push sum results) + (incf sum days-per-month))) + (coerce (nreverse results) 'vector))) + +(defun encode-universal-time (second minute hour date month year + &optional time-zone) + "The time values specified in decoded format are converted to + universal time, which is returned." + (declare (type (mod 60) second) + (type (mod 60) minute) + (type (mod 24) hour) + (type (integer 1 31) date) + (type (integer 1 12) month) + (type unsigned-byte year) + (type (or null rational) time-zone)) + (when (< year 100) + (let* ((this (current-year)) + (past (- this 50)) + (future (+ this 49)) + (maybe-past (+ (- past (mod past 100)) year)) + (maybe-future (+ (- future (mod future 100)) year))) + (if (>= maybe-past past) + (setq year maybe-past) + (setq year maybe-future)))) + + (let* ((days (+ (1- date) + (aref *days-before-month* month) + (if (> month 2) + (leap-years-before (1+ year)) + (leap-years-before year)) + (* (- year 1900) 365))) + (hours (+ hour (* days 24)))) + (if time-zone + (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)) + (let* ((minwest-guess + (get-timezone (- (* hours 60 60) + unix-to-universal-time))) + (guess (+ minute (* hours 60) minwest-guess)) + (minwest + (get-timezone (- (* guess 60) + unix-to-universal-time)))) + (+ second (* (+ guess (- minwest minwest-guess)) 60)))))) + + +#+windows-target +(defun %windows-sleep (millis) + (do* ((start (floor (get-internal-real-time) + (floor internal-time-units-per-second 1000)) + (floor (get-internal-real-time) + (floor internal-time-units-per-second 1000))) + (millis millis (- stop start)) + (stop (+ start millis))) + ((or (<= millis 0) + (not (eql (#_SleepEx millis #$true) #$WAIT_IO_COMPLETION)))))) + +(defun sleep (seconds) + "This function causes execution to be suspended for N seconds. N may + be any non-negative, non-complex number." + (when (minusp seconds) (report-bad-arg seconds '(real 0 *))) + #-windows-target + (multiple-value-bind (secs nanos) + (nanoseconds seconds) + (%nanosleep secs nanos)) + #+windows-target + (%windows-sleep (round (* seconds 1000)))) + + +(defun %internal-run-time () + ;; Returns user and system times in internal-time-units as multiple values. + #-windows-target + (rlet ((usage :rusage)) + (%%rusage usage) + (let* ((user-seconds (pref usage :rusage.ru_utime.tv_sec)) + (system-seconds (pref usage :rusage.ru_stime.tv_sec)) + (user-micros (pref usage :rusage.ru_utime.tv_usec)) + (system-micros (pref usage :rusage.ru_stime.tv_usec))) + (values (+ (* user-seconds internal-time-units-per-second) + (round user-micros (floor 1000000 internal-time-units-per-second))) + (+ (* system-seconds internal-time-units-per-second) + (round system-micros (floor 1000000 internal-time-units-per-second)))))) + #+windows-target + (rlet ((start #>FILETIME) + (end #>FILETIME) + (kernel #>FILETIME) + (user #>FILETIME)) + (#_GetProcessTimes (#_GetCurrentProcess) start end kernel user) + (let* ((user-100ns (dpb (pref user #>FILETIME.dwHighDateTime) + (byte 32 32) + (pref user #>FILETIME.dwLowDateTime))) + (kernel-100ns (dpb (pref kernel #>FILETIME.dwHighDateTime) + (byte 32 32) + (pref kernel #>FILETIME.dwLowDateTime))) + (convert (floor 10000000 internal-time-units-per-second))) + (values (floor user-100ns convert) (floor kernel-100ns convert))))) + +(defun get-internal-run-time () + "Return the run time in the internal time format. (See + INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage." + (multiple-value-bind (user sys) (%internal-run-time) + (+ user sys))) + + + + + + Index: /branches/qres/ccl/lib/x86-backtrace.lisp =================================================================== --- /branches/qres/ccl/lib/x86-backtrace.lisp (revision 13564) +++ /branches/qres/ccl/lib/x86-backtrace.lisp (revision 13564) @@ -0,0 +1,460 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +;;; Returns two values: +;;; [nil, nil] if it can be reliably determined that function uses no registers at PC +;;; [mask, saved-location] if it can be reliably determined that the registers specified by "mask" +;;; were saved at "saved-location" in the function's stack frame +;;; [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them +;;; (perhaps because the "at-pc" argument wasn't specified. + + +(defun registers-used-by (function &optional at-pc) + (multiple-value-bind (mask stack-location rpc) + (%function-register-usage function) + (if (or (null mask) + (and at-pc rpc (<= at-pc rpc))) + (values nil nil) + (values (canonicalize-register-mask mask) (if (and at-pc rpc) stack-location))))) + +(defun canonicalize-register-mask (mask) + (dpb (ldb (byte 2 14) mask) (byte 2 2) (ldb (byte 2 11) mask))) + +(defun xcf-p (p) + (eql 0 (%fixnum-ref p target::lisp-frame.return-address))) + +(defun %current-xcf () + (do* ((q (%get-frame-ptr) (%%frame-backlink q))) + ((zerop q)) + (declare (fixnum q)) + (when (xcf-p q) (return q)))) + +;;; Try to determine the program counter value, relative to an xcf's nominal function. +(defun pc-from-xcf (xcf) + (let* ((nominal-function (%fixnum-ref xcf target::xcf.nominal-function)) + (containing-object (%fixnum-ref xcf target::xcf.containing-object))) + (when (typep nominal-function 'function) + (if (eq containing-object (function-to-function-vector nominal-function)) + (- (%fixnum-ref xcf target::xcf.relative-pc) + #+x8632-target x8632::fulltag-misc + #+x8664-target x8664::tag-function) + (let* ((tra (%fixnum-ref xcf target::xcf.ra0))) + (if (and #+x8664-target (= (lisptag tra) x8664::tag-tra) + #+x8632-target (= (fulltag tra) x8632::fulltag-tra) + (eq nominal-function (%return-address-function tra))) + (%return-address-offset tra))))))) + +(defun cfp-lfun (p) + (if (xcf-p p) + (values + (%fixnum-ref p target::xcf.nominal-function) + (pc-from-xcf p)) + (%cfp-lfun p))) + +;;; On PPC, some frames on the control stack are associated with catch +;;; frames rather than with function calls. The whole concept doesn't +;;; really apply here (e.g., nothing we encounter while walking frame +;;; pointer links belongs to a catch frame.) +(defun catch-csp-p (p context) + (declare (ignore p context))) + +(defun %raw-frame-ref (frame context idx bad) + (declare (fixnum frame idx)) + (let* ((base (parent-frame frame context)) + (raw-size (- base frame))) + (declare (fixnum base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (oldest-binding-frame-value context addr) + (%fixnum-ref addr))))) + bad))) + +(defun %raw-frame-set (frame context idx new) + (declare (fixnum frame idx)) + (let* ((base (parent-frame frame context)) + (raw-size (- base frame))) + (declare (fixnum base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (setf (oldest-binding-frame-value context addr) new) + (setf (%fixnum-ref addr) new)))))))) + +(defun %stack< (index1 index2 &optional context) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (vs-area (%fixnum-ref tcr target::tcr.vs-area))) + (and (%ptr-in-area-p index1 vs-area) + (%ptr-in-area-p index2 vs-area) + (< (the fixnum index1) (the fixnum index2))))) + + + + +(defun register-number->saved-register-index (regnum) + (ecase regnum + (#.x8664::save3 0) + (#.x8664::save2 1) + (#.x8664::save1 2) + (#.x8664::save0 3))) + + +(defun get-register-value (address last-catch index) + (if address + (%fixnum-ref address) + (uvref last-catch (+ index + #+x8632-target + x8632::catch-frame.db-link-cell + #+x8664-target + x8664::catch-frame.save-save3-cell)))) + +;;; Inverse of get-register-value + +(defun set-register-value (value address last-catch index) + (if address + (%fixnum-set address value) + (setf (uvref last-catch (+ index + #+x8632-target + x8632::catch-frame.db-link-cell + #+x8664-target + x8664::catch-frame.save-save3-cell)) + value))) + +(defun %find-register-argument-value (context cfp regval bad) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp (child-frame frame context)) + (first t)) + ((null frame)) + (if (xcf-p frame) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp)) + (return-from %find-register-argument-value + (encoded-gpr-lisp xp regval))) + (progn + (unless first + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (return-from %find-register-argument-value + (if where + (let ((offset (logcount (logandc2 mask (1- (ash 1 (1+ index))))))) + (raw-frame-ref frame context (+ where offset) bad)) + bad))))))) + (setq first nil)))) + (get-register-value nil last-catch index))) + +(defun %set-register-argument-value (context cfp regval new) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp (child-frame frame context)) + (first t)) + ((null frame)) + (if (xcf-p frame) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp)) + (return-from %set-register-argument-value + (setf (encoded-gpr-lisp xp regval) new))) + (progn + (unless first + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + + (return-from %set-register-argument-value + (raw-frame-set frame context where new))))))) + (setq first nil)))) + (set-register-value new nil last-catch index))) + +;;; Used for printing only. +(defun index->address (p) + (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0) (ash p target::fixnumshift))) + +(defun exception-frame-p (x) + (and x (xcf-p x))) + +;;; Function has failed a number-of-arguments check; return a list +;;; of the actual arguments. +;;; On x86-64, the kernel has finished the frame and pushed everything +;;; for us, so all that we need to do is to hide any inherited arguments. +(defun arg-check-call-arguments (fp function) + (when (xcf-p fp) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp)) + (let* ((numinh (ldb $lfbits-numinh (lfun-bits function))) + (nargs (- (xp-argument-count xp) numinh)) + (p (- (%fixnum-ref fp target::xcf.backptr) + (* target::node-size numinh)))) + (declare (fixnum numinh nargs p)) + (collect ((args)) + (dotimes (i nargs (args)) + (args (%fixnum-ref p (- target::node-size))) + (decf p))))))) + +(defun vsp-limits (frame context) + (let* ((parent (parent-frame frame context))) + (if (xcf-p frame) + (values (+ frame (ash target::xcf.size (- target::word-shift))) + parent) + (let* ((tra (%fixnum-ref frame target::lisp-frame.return-address))) + (values (+ frame 2 (if (eq tra (%get-kernel-global ret1valaddr)) 1 0)) + parent))))) + +(defun last-catch-since (fp context) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (catch (%catch-top tcr)) + (last-catch nil)) + (loop + (unless catch (return last-catch)) + (let ((catch-fp (uvref catch + #+x8632-target + x8632::catch-frame.ebp-cell + #+x8664-target + x8664::catch-frame.rbp-cell))) + (when (%stack< fp catch-fp context) (return last-catch)) + (setq last-catch catch + catch (next-catch catch)))))) + +(defun last-xcf-since (target-fp start-fp context) + (do* ((last-xcf nil) + (fp start-fp (parent-frame fp context))) + ((or (eql fp target-fp) + (null fp) + (%stack< target-fp fp)) last-xcf) + (if (xcf-p fp) (setq last-xcf fp)))) + +(defun match-local-name (cellno info pc) + (when info + (let* ((syms (%car info)) + (ptrs (%cdr info))) + (dotimes (i (length syms)) + (let ((j (%i+ i (%i+ i i )))) + (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77)) + (%i>= pc (uvref ptrs (%i+ j 1))) + (%i< pc (uvref ptrs (%i+ j 2))) + (return (aref syms i)))))))) + +(defun apply-in-frame (frame function arglist &optional context) + (setq function (coerce-to-function function)) + (let* ((parent (parent-frame frame context))) + (when parent + (if (xcf-p parent) + (error "Can't unwind to exception frame ~s" frame) + (setq frame parent)) + (if (or (null context) + (eq (bt.tcr context) (%current-tcr))) + (%apply-in-frame frame function arglist) + (let* ((process (tcr->process (bt.tcr context)))) + (if process + (process-interrupt process #'%apply-in-frame frame function arglist) + (error "Can't find process for backtrace context ~s" context))))))) + +(defun return-from-frame (frame &rest values) + (apply-in-frame frame #'values values nil)) + + +(defun last-tsp-before (target) + (declare (fixnum target)) + (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) + (%fixnum-ref tsp target::tsp-frame.backptr))) + ((zerop tsp) nil) + (declare (fixnum tsp)) + (when (> (the fixnum (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp + #+x8664-target x8664::tsp-frame.rbp)) + target) + (return tsp)))) + + + + +;;; We can't determine this reliably (yet). +(defun last-foreign-sp-before (target) + (declare (fixnum target)) + (do* ((cfp (%fixnum-ref (%current-tcr) target::tcr.foreign-sp) + (%fixnum-ref cfp target::csp-frame.backptr))) + ((zerop cfp)) + (declare (fixnum cfp)) + (let* ((rbp (%fixnum-ref cfp #+x8632-target x8632::csp-frame.ebp + #+x8664-target x8664::csp-frame.rbp))) + (declare (fixnum rbp)) + (if (> rbp target) + (return cfp) + (if (zerop rbp) + (return nil)))))) + + +(defun %tsp-frame-containing-progv-binding (db) + (declare (fixnum db)) + (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) next) + (next (%fixnum-ref tsp target::tsp-frame.backptr) + (%fixnum-ref tsp target::tsp-frame.backptr))) + () + (declare (fixnum tsp next)) + (let* ((rbp (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp + #+x8664-target x8664::tsp-frame.rbp))) + (declare (fixnum rbp)) + (if (zerop rbp) + (return (values nil nil)) + (if (and (> db tsp) + (< db next)) + (return (values tsp rbp))))))) + + + + + + +(defun last-binding-before (frame) + (declare (fixnum frame)) + (do* ((db (%current-db-link) (%fixnum-ref db 0)) + (tcr (%current-tcr)) + (vs-area (%fixnum-ref tcr target::tcr.vs-area)) + (vs-low (%fixnum-ref vs-area target::area.low)) + (vs-high (%fixnum-ref vs-area target::area.high))) + ((eql db 0) nil) + (declare (fixnum db vs-low vs-high)) + (if (and (> db vs-low) + (< db vs-high)) + (if (> db frame) + (return db)) + ;; db link points elsewhere; PROGV uses the temp stack + ;; to store an indefinite number of bindings. + (multiple-value-bind (tsp rbp) + (%tsp-frame-containing-progv-binding db) + (if tsp + (if (> rbp frame) + (return db) + ;; If the tsp frame is too young, we can skip + ;; all of the bindings it contains. The tsp + ;; frame contains two words of overhead, followed + ;; by a count of binding records in the frame, + ;; followed by the youngest of "count" binding + ;; records (which happens to be the value of + ;; "db".) Skip "count" binding records. + (dotimes (i (the fixnum (%fixnum-ref tsp target::dnode-size))) + (setq db (%fixnum-ref db 0)))) + ;; If the binding record wasn't on the temp stack and wasn't + ;; on the value stack, that probably means that things are + ;; seriously screwed up. This error will be almost + ;; meaningless to the user. + (error "binding record (#x~16,'0x/#x~16,'0x) not on temp or value stack" (index->address db) db)))))) + + + +(defun find-x8664-saved-nvrs (frame start-fp context) + (let* ((locations (make-array 16 :initial-element nil)) + (need (logior (ash 1 x8664::save0) + (ash 1 x8664::save1) + (ash 1 x8664::save2) + (ash 1 x8664::save3)))) + (declare (fixnum need) + (dynamic-extent locations)) + (do* ((parent frame child) + (child (child-frame parent context) (child-frame child context))) + ((or (= need 0) (eq child start-fp)) + (values (%svref locations x8664::save0) + (%svref locations x8664::save1) + (%svref locations x8664::save2) + (%svref locations x8664::save3))) + (multiple-value-bind (lfun pc) (cfp-lfun child) + (when (and lfun pc) + (multiple-value-bind (used where) (registers-used-by lfun pc) + (when (and used where (logtest used need)) + (locally (declare (fixnum used)) + (do* ((i x8664::save3 (1+ i))) + ((or (= i 16) (= used 0))) + (declare (type (mod 16) i)) + (when (logbitp i used) + (when (logbitp i need) + (setq need (logandc2 need (ash 1 i))) + (setf (%svref locations i) + (- (the fixnum (1- parent)) + (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i))))))))) + (setq used (logandc2 used (ash 1 i))))))))))))) + + + +(defun %apply-in-frame (frame function arglist) + (target-arch-case + (:x8632 (error "%apply-in-frame doesn't work for x8632 yet")) + (:x8664 + (let* ((target-catch (last-catch-since frame nil)) + (start-fp (if target-catch + (uvref target-catch x8664::catch-frame.rbp-cell) + (%get-frame-ptr))) + (target-xcf (last-xcf-since frame start-fp nil)) + (target-db-link (last-binding-before frame)) + (target-tsp (last-tsp-before frame)) + (target-foreign-sp (last-foreign-sp-before frame))) + (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc) + (find-x8664-saved-nvrs frame start-fp nil) + (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto + frame + target-catch + target-db-link + target-xcf + target-tsp + target-foreign-sp + (if save0-loc + (- save0-loc frame) + 0) + (if save1-loc + (- save1-loc frame) + 0) + (if save2-loc + (- save2-loc frame) + 0) + (if save3-loc + (- save3-loc frame) + 0) + (coerce-to-function function) + arglist + 0))) + (funcall thunk))))))) + + + Index: /branches/qres/ccl/lib/x86-watch.lisp =================================================================== --- /branches/qres/ccl/lib/x86-watch.lisp (revision 13564) +++ /branches/qres/ccl/lib/x86-watch.lisp (revision 13564) @@ -0,0 +1,87 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Return the effective address of a memory operand by using the +;;; register state in xp, or NIL if we can't figure it out. +;;; Needs to run inside a without-gcing form. +(defun x86-memory-operand-ea (xp op) + (let* ((seg (x86::x86-memory-operand-seg op)) + (disp (x86::x86-memory-operand-disp op)) + (base (x86::x86-memory-operand-base op)) + (index (x86::x86-memory-operand-index op)) + (scale (x86::x86-memory-operand-scale op))) + (cond + ((and base index (not seg)) + (let* ((base-re (x86::x86-register-operand-entry base)) + (index-re (x86::x86-register-operand-entry index)) + (base-num (x86::reg-entry-reg-num base-re)) + (index-num (x86::reg-entry-reg-num index-re)) + (base-val nil) + (index-val nil)) + (when (logtest (x86::reg-entry-reg-flags base-re) x86::+regrex+) + (incf base-num 8)) + (setq base-val (encoded-gpr-integer xp base-num)) + (when (logtest (x86::reg-entry-reg-flags index-re) x86::+regrex+) + (incf index-num 8)) + (setq index-val (encoded-gpr-integer xp index-num)) + (when scale + (setq index-val (ash index-val scale))) + (+ (or disp 0) base-val index-val)))))) + +;;; Try to emulate the disassembled instruction using the +;;; register state in xp. Return NIL if we couldn't do it. +;;; This will run with other threads suspended. +(defun x86-emulate-instruction (xp instruction) + (let* ((mnemonic (x86-di-mnemonic instruction)) + (op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when (and op0 op1 (not op2) + (typep op0 'x86::x86-register-operand) + (typep op1 'x86::x86-memory-operand)) + (without-gcing + (let* ((src-re (x86::x86-register-operand-entry op0)) + (src-num (x86::reg-entry-reg-num src-re)) + (src-val nil) + (ea (x86-memory-operand-ea xp op1))) + (when (logtest (x86::reg-entry-reg-flags src-re) x86::+regrex+) + (incf src-num 8)) + (setq src-val (encoded-gpr-integer xp src-num)) + (when ea + (with-macptrs ((p (%int-to-ptr ea))) + (cond + ((string= mnemonic "movb") + (setf (%get-signed-byte p) (ldb (byte 8 0) src-val))) + ((string= mnemonic "movw") + (setf (%get-signed-word p) (ldb (byte 16 0) src-val))) + ((string= mnemonic "movl") + (setf (%get-signed-long p) (ldb (byte 32 0) src-val))) + ((string= mnemonic "movq") + (setf (%%get-signed-longlong p 0) (ldb (byte 64 0) src-val))))))))))) + +(defun x86-can-emulate-instruction (instruction) + (let* ((mnemonic (x86-di-mnemonic instruction)) + (op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when (and op0 op1 (not op2) + (typep op0 'x86::x86-register-operand) + (typep op1 'x86::x86-memory-operand) + (member mnemonic '("movb" "movw" "movl" "movq") :test 'string=)) + (let* ((seg (x86::x86-memory-operand-seg op1)) + (base (x86::x86-memory-operand-base op1)) + (index (x86::x86-memory-operand-index op1))) + (and base index (not seg)))))) Index: /branches/qres/ccl/lib/x8632env.lisp =================================================================== --- /branches/qres/ccl/lib/x8632env.lisp (revision 13564) +++ /branches/qres/ccl/lib/x8632env.lisp (revision 13564) @@ -0,0 +1,71 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant $numx8632saveregs 0) +(defconstant $numx8632argregs 2) + + +(defconstant x8632-nonvolatile-registers-mask 0) + +(defconstant x8632-arg-registers-mask + (logior (ash 1 x8632::arg_z) + (ash 1 x8632::arg_y))) + +(defconstant x8632-temp-registers-mask + (logior (ash 1 x8632::temp0) + (ash 1 x8632::temp1))) + +(defconstant x8632-tagged-registers-mask + (logior x8632-temp-registers-mask + x8632-arg-registers-mask + x8632-nonvolatile-registers-mask)) + + + +(defconstant x8632-temp-node-regs + (make-mask x8632::temp0 + x8632::temp1 + x8632::arg_y + x8632::arg_z)) + +(defconstant x8632-nonvolatile-node-regs 0) + +(defconstant x8632-node-regs (logior x8632-temp-node-regs x8632-nonvolatile-node-regs)) + +(defconstant x8632-imm-regs (make-mask + x8632::imm0)) + +;;; Fine if we assume SSE support; not so hot when using x87 +(defconstant x8632-temp-fp-regs (make-mask x8632::fp0 + x8632::fp1 + x8632::fp2 + x8632::fp3 + x8632::fp4 + x8632::fp5 + x8632::fp6 + x8632::fp7)) + + + +(defconstant x8632-cr-fields (make-mask 0)) + +;;; hmm. +(defconstant $undo-x86-c-frame 16) + + +(ccl::provide "X8632ENV") Index: /branches/qres/ccl/lib/x8664env.lisp =================================================================== --- /branches/qres/ccl/lib/x8664env.lisp (revision 13564) +++ /branches/qres/ccl/lib/x8664env.lisp (revision 13564) @@ -0,0 +1,84 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant $numx8664saveregs 4) +(defconstant $numx8664argregs 3) + + +(defconstant x8664-nonvolatile-registers-mask + (logior (ash 1 x8664::save0) + (ash 1 x8664::save1) + (ash 1 x8664::save2) + (ash 1 x8664::save3))) + +(defconstant x8664-arg-registers-mask + (logior (ash 1 x8664::arg_z) + (ash 1 x8664::arg_y) + (ash 1 x8664::arg_x))) + +(defconstant x8664-temp-registers-mask + (logior (ash 1 x8664::temp0) + (ash 1 x8664::temp1) + (ash 1 x8664::temp2))) + + +(defconstant x8664-tagged-registers-mask + (logior x8664-temp-registers-mask + x8664-arg-registers-mask + x8664-nonvolatile-registers-mask)) + + +(defconstant x8664-temp-node-regs + (make-mask x8664::temp0 + x8664::temp1 + x8664::temp2 + x8664::arg_x + x8664::arg_y + x8664::arg_z)) + +(defconstant x8664-nonvolatile-node-regs + (make-mask x8664::save0 + x8664::save1 + x8664::save2 + x8664::save3)) + + +(defconstant x8664-node-regs (logior x8664-temp-node-regs x8664-nonvolatile-node-regs)) + +(defconstant x8664-imm-regs (make-mask + x8664::imm0 + x8664::imm1 + x8664::imm2)) + +(defconstant x8664-temp-fp-regs (make-mask x8664::fp0 + x8664::fp1 + x8664::fp2 + x8664::fp3 + x8664::fp4 + x8664::fp5 + x8664::fp6 + x8664::fp7)) + + + +(defconstant x8664-cr-fields (make-mask 0)) + +(defconstant $undo-x86-c-frame 16) + + +(ccl::provide "X8664ENV") Index: /branches/qres/ccl/lib/xref.lisp =================================================================== --- /branches/qres/ccl/lib/xref.lisp (revision 13564) +++ /branches/qres/ccl/lib/xref.lisp (revision 13564) @@ -0,0 +1,659 @@ +;;; -*- Mode: Lisp; Package: CCL; indent-tabs-mode: nil -*- +;;; +;;; Copyright (C) 2003 Oliver Markovic +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(*RECORD-XREF-INFO* + *LOAD-XREF-INFO* + XREF-ENTRY + XREF-ENTRY-NAME + XREF-ENTRY-TYPE + XREF-ENTRY-FULL-NAME + XREF-ENTRY-METHOD-QUALIFIERS + XREF-ENTRY-METHOD-SPECIALIZERS + XREF-ENTRY-P + XREF-ENTRY-EQUAL + DISCARD-ALL-XREF-INFO + GET-RELATION + MACROS-CALLED-BY + START-XREF + STOP-XREF + WHO-BINDS + WHO-CALLS + WHO-DIRECTLY-CALLS + WHO-INDIRECTLY-CALLS + WHO-REFERENCES + WHO-SETS + WHO-USES + WITH-XREF + XREF-DESCRIBE))) + +(defpackage "CROSS-REFERENCE" + (:use "CL") + (:nicknames "XREF") + (:import-from "CCL" + "*RECORD-XREF-INFO*" + "*LOAD-XREF-INFO*" + "XREF-ENTRY" + "XREF-ENTRY-NAME" + "XREF-ENTRY-TYPE" + "XREF-ENTRY-FULL-NAME" + "XREF-ENTRY-METHOD-QUALIFIERS" + "XREF-ENTRY-METHOD-SPECIALIZERS" + "XREF-ENTRY-P" + "XREF-ENTRY-EQUAL" + "DISCARD-ALL-XREF-INFO" + "GET-RELATION" + "MACROS-CALLED-BY" + "START-XREF" + "STOP-XREF" + "WHO-BINDS" + "WHO-CALLS" + "WHO-DIRECTLY-CALLS" + "WHO-INDIRECTLY-CALLS" + "WHO-REFERENCES" + "WHO-SETS" + "WHO-USES" + "WITH-XREF" + "XREF-DESCRIBE") + (:export "*RECORD-XREF-INFO*" + "*LOAD-XREF-INFO*" + "XREF-ENTRY" + "XREF-ENTRY-NAME" + "XREF-ENTRY-TYPE" + "XREF-ENTRY-FULL-NAME" + "XREF-ENTRY-METHOD-QUALIFIERS" + "XREF-ENTRY-METHOD-SPECIALIZERS" + "XREF-ENTRY-P" + "XREF-ENTRY-EQUAL" + "DISCARD-ALL-XREF-INFO" + "GET-RELATION" + "MACROS-CALLED-BY" + "START-XREF" + "STOP-XREF" + "WHO-BINDS" + "WHO-CALLS" + "WHO-DIRECTLY-CALLS" + "WHO-INDIRECTLY-CALLS" + "WHO-REFERENCES" + "WHO-SETS" + "WHO-USES" + "WITH-XREF" + "XREF-DESCRIBE")) + + +;; *RECORD-XREF-INFO* -- external +;; +;; Cross-referencing information will only be recorded if this flag +;; is set. It is usually set/unset by START-XREF/STOP-XREF +(defvar *record-xref-info* nil + "Flag indicating wether cross-referencing information should be recorded.") + +;; *LOAD-XREF-INFO* -- external +;; +;; FIXME: We don't save any information yet... +(defvar *load-xref-info* nil + "Flag indicating wether cross-referencing information should be loaded +from FASLs.") + + + +;; START-XREF -- external +;; +(defun start-xref () + "Start recording cross-referencing information while compiling." + (setf *record-xref-info* t) + (setf *load-xref-info* t) + t) + +;; STOP-XREF -- external +;; +(defun stop-xref () + "Stop recording cross-referencing information while compiling." + (setf *record-xref-info* nil) + (setf *load-xref-info* nil) + nil) + +;; WITH-XREF -- external +;; +(defmacro with-xref (&body body) + "Execute BODY with cross-referencing turned on." + (let ((return-value (gensym "RETURN-VALUE"))) + `(let ((*record-xref-info* t) + (*load-xref-info* t) + (,return-value nil)) + (setf ,return-value (progn ,@body)) + ,return-value))) + + +;; XREF-ENTRY -- external +;; +(defstruct (xref-entry + (:constructor %make-xref-entry) + (:print-function %print-xref-entry)) + name + type + (method-qualifiers nil) + (method-specializers nil)) + +;; %PRINT-XREF-ENTRY -- internal +;; +(defun %print-xref-entry (struct stream d) + (declare (ignore d)) + (if *print-readably* + (format stream "#S(xref::xref-entry :name '~A :type '~A :method-qualifiers ~A :method-specializers ~A)" + (xref-entry-name struct) + (xref-entry-type struct) + (xref-entry-method-qualifiers struct) + (xref-entry-method-specializers struct)) + (print-unreadable-object (struct stream :type t) + (format stream "~A ~A~@[ ~A~]~@[ ~A~]" + (xref-entry-name struct) + (xref-entry-type struct) + (xref-entry-method-qualifiers struct) + (xref-entry-method-specializers struct))))) + +;; MAKE-XREF-ENTRY -- internal +;; +;; Takes a simple input form and makes a XREF-ENTRY from it. The input is +;; assumed to be a function, macro or variable when a simple symbol is passed, +;; or a method when it is a cons. Since this needs to also handle the ouput +;; from CCL::CALLERS, there is additional hackery trying to do the right thing. +(defun make-xref-entry (input relation) + (etypecase input + (symbol + (let ((type (ecase relation + ((:direct-calls :indirect-calls) 'function) + ((:binds :sets :references) 'variable) + ((:macro-calls) 'macro)))) + (%make-xref-entry :name input :type type))) + (method + (let ((name (method-name input)) + (qualifiers (method-qualifiers input)) + (specializers (canonicalize-specializers (method-specializers input)))) + (%make-xref-entry :name name :type 'method + :method-qualifiers (unless (eql qualifiers t) qualifiers) + :method-specializers specializers))) + (cons + (case (car input) + ((ppc-lap-macro compiler-macro-function) + (%make-xref-entry :name (cadr input) :type (car input))) + ((:internal) + (make-xref-entry (car (last input)) relation)) + (t + (multiple-value-bind (type name specializers qualifiers) + (parse-definition-spec input) + (%make-xref-entry :name name :type type + :method-qualifiers (unless (eql qualifiers t) qualifiers) + :method-specializers specializers))))))) + +(defun parse-definition-spec (form) + (let ((type t) + name classes qualifiers) + (cond + ((consp form) + (cond ((eq (car form) 'setf) + (setq name form)) + (t + (when (eq (car form) :method) (pop form)) + (setq name (car form)) + (let* ((last (car (last (cdr form))))) + (cond ((and (listp last)(or (null last)(neq (car last) 'eql))) + (setq classes last) + (setq qualifiers (butlast (cdr form)))) + (t (setq classes (cdr form))))) + (cond ((null qualifiers) + (setq qualifiers t)) + ((equal qualifiers '(:primary)) + (setq qualifiers nil)))))) + (t (setq name form))) + (when (setf-function-name-p name) + (setq name (canonical-maybe-setf-name name))) + (when (not (or (symbolp name) + (setf-function-name-p name))) + (return-from parse-definition-spec)) + (when (consp qualifiers) + (mapc #'(lambda (q) + (when (listp q) + (return-from parse-definition-spec))) + qualifiers)) + (when classes + (mapc #'(lambda (c) + (when (not (and c (or (symbolp c)(and (consp c)(eq (car c) 'eql))))) + (return-from parse-definition-spec))) + classes)) + (when (or (consp classes)(consp qualifiers))(setq type 'method)) + (values type name classes qualifiers))) + +;; XREF-ENTRY-EQUAL -- external +;; +;; Simply compares all slots. +(defun xref-entry-equal (entry1 entry2) + (and (eql (xref-entry-name entry1) (xref-entry-name entry2)) + (eql (xref-entry-type entry1) (xref-entry-type entry2)) + (equal (xref-entry-method-qualifiers entry1) + (xref-entry-method-qualifiers entry2)) + (equal (xref-entry-method-specializers entry1) + (xref-entry-method-specializers entry2)))) + +;; XREF-ENTRY-FULL-NAME -- external +;; +(defun xref-entry-full-name (entry) + (if (eql (xref-entry-type entry) 'method) + `(:method ,(xref-entry-name entry) + ,@(xref-entry-method-qualifiers entry) + ,(xref-entry-method-specializers entry)) + (xref-entry-name entry))) + + +;; %DB-KEY-FROM-XREF-ENTRY -- internal +;; +;; This is mostly the inverse to MAKE-XREF-ENTRY, since it takes an entry +;; and returns either a symbol (for functions, macros and variables) or a +;; list in the form (METHOD-NAME QUALIFIERS (SPECIALIZERS)) for a method. +;; These are used as keys in the database hash-tables. +(defun %db-key-from-xref-entry (entry) + (if (eql (xref-entry-type entry) 'method) + `(,(xref-entry-name entry) + ,@(xref-entry-method-qualifiers entry) + ,(xref-entry-method-specializers entry)) + (xref-entry-name entry))) + +;; %SOURCE-FILE-FOR-XREF-ENTRY -- internal +;; +(defun %source-file-for-xref-entry (entry) + (multiple-value-bind (files name type specializers qualifiers) + (edit-definition-p (%db-key-from-xref-entry entry) + (if (eql (xref-entry-type entry) 'macro) + 'function + (xref-entry-type entry))) + (declare (ignore name type specializers qualifiers)) + (let ((filename (if (consp files) (cdar files) files))) + (when filename + (truename filename))))) + + +;; MAKE-XREF-DATABASE -- internal +;; +;; This returns a fresh cross-referencing "database". It's a simple association +;; list with two hash-tables per entry. The CAR hash holds the direct entries +;; e.g. KEY calls/references/etc VALUE, while the CDR holds inverse hash (KEY +;; is called/referenced/etc by VALUE. +(defun make-xref-database () + (list :binds (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :references (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :sets (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :direct-calls (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :indirect-calls (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :macro-calls (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)))) + +;; *XREF-DATABASE* -- internal +;; +;; The one and only cross-referencing database. +(defvar *xref-database* (make-xref-database)) + + +;; %XREF-TABLE -- internal +;; +;; Returns the appropriate table for a given relation. +(defun %xref-table (relation inversep) + (if inversep + (cdr (getf *xref-database* relation)) + (car (getf *xref-database* relation)))) + + +;; DISCARD-ALL-XREF-INFO -- external +;; +(defun discard-all-xref-info () + "Clear the cross-referencing database." + (setf *xref-database* (make-xref-database)) + t) + + +;; %ADD-XREF-ENTRY -- internal +;; +;; The compiler adds cross-referencing information by calling this +;; (see NX-RECORD-XREF-INFO). +(defun %add-xref-entry (relation name1 name2) + (when (and *record-xref-info* relation name1 name2) + (pushnew (make-xref-entry name2 relation) + (gethash name1 (%xref-table relation nil)) + :test #'xref-entry-equal) + (pushnew (make-xref-entry name1 relation) + (gethash name2 (%xref-table relation t)) + :test #'xref-entry-equal) + t)) + + + + +;; %DISCARD-XREF-INFO-FOR-FUNCTION -- internal +;; +;; This rather expensive operation removes all traces of a given function +;; from the cross-referencing database. It needs to be called whenever a +;; function gets redefined, so we don't pick up stale xref entries. +(defun %discard-xref-info-for-function (func) + ;; need to go through every possible relation + (dolist (relation '(:direct-calls :indirect-calls :macro-calls + :binds :references :sets)) + ;; get a list of the places to which the func points to... + (dolist (entry (gethash func (%xref-table relation nil))) + (let ((key (%db-key-from-xref-entry entry))) + ;; ... and remove it from there + (setf (gethash key (%xref-table relation t)) + (delete func (gethash key (%xref-table relation t)))))) + ;; the non-inverse case is easy + (remhash func (%xref-table relation nil)))) + + +;; GET-RELATION -- external +;; +;; FIXME: Implement filtering by files. +;; And what the heck should errorp do? +(defun get-relation (relation name1 name2 &key in-files in-functions exhaustive errorp) + "Returns a list of matches for RELATION between NAME1 and NAME2. Results can +be filtered by passing a list of files in IN-FILES or functions in IN-FUNCTIONS. +If EXHAUSTIVE is true, it will also look for callers for which no xref information +is present by looping through all defined functions in memory." + (when (and (eql name1 :wild) (eql name2 :wild)) + (error "Only one wildcard allowed in a cross-reference query")) + (ecase relation + ((:binds :references :sets :direct-calls :indirect-calls :macro-calls) + (let ((lookup-table (%xref-table relation nil)) + (inverse-lookup-table (%xref-table relation t))) + (let ((matches (if (eql name1 :wild) + (%do-wild-xref-lookup name2 inverse-lookup-table + in-files in-functions) + (if (eql name2 :wild) + (%do-wild-xref-lookup name1 lookup-table + in-files in-functions) + (%do-simple-xref-lookup name1 name2 lookup-table + in-files in-functions))))) + ;; search all lfuns if exhaustive is t + (when (and exhaustive (eql name1 :wild) (or (eql relation :direct-calls) + (eql relation :indirect-calls))) + (dolist (caller (callers name2)) + (pushnew (make-xref-entry caller relation) + matches + :test #'xref-entry-equal))) + matches))) + (:calls + (let ((direct-calls (get-relation :direct-calls name1 name2 + :in-files in-files :in-functions in-functions + :exhaustive exhaustive :errorp errorp)) + (indirect-calls (get-relation :indirect-calls name1 name2 + :in-files in-files :in-functions in-functions + :exhaustive exhaustive :errorp errorp)) + (macro-calls (get-relation :macro-calls name1 name2 + :in-files in-files :in-functions in-functions + :exhaustive exhaustive :errorp errorp))) + (if (or (eql name1 :wild) (eql name2 :wild)) + ;; need to weed out possible duplicates here + (let ((matches nil)) + (dolist (c direct-calls) (pushnew c matches)) + (dolist (c indirect-calls) (pushnew c matches)) + (dolist (c macro-calls) (pushnew c matches)) + matches) + (when (or direct-calls indirect-calls macro-calls) + name2)))) + (:uses + (let ((binds (get-relation :binds name1 name2 :in-files in-files + :in-functions in-functions :errorp errorp + :exhaustive exhaustive)) + (references (get-relation :binds name1 name2 :in-files in-files + :in-functions in-functions :errorp errorp + :exhaustive exhaustive)) + (sets (get-relation :sets name1 name2 :in-files in-files + :in-functions in-functions :errorp errorp + :exhaustive exhaustive))) + (if (or (eql name1 :wild) (eql name2 :wild)) + (concatenate 'list binds references sets) + (when (or binds references sets) + name2)))))) + +;; %DO-WILD-XREF-LOOKUP -- internal +;; +;; Does a wild lookup into the xref database and returns a list of matches. +;; +;; FIXME: implement filtering by files +(defun %do-wild-xref-lookup (name table in-files in-functions) + (declare (ignore in-files)) + (multiple-value-bind (value foundp) (gethash name table) + (declare (ignore foundp)) + (if in-functions + (remove-if (lambda (x) (not (find x in-functions))) value) + value))) + +;; %DO-SIMPLE-XREF-LOOKUP -- internal +;; +;; Does a simple lookup into the xref database and returns NAME2 if a relation +;; between NAME1 and NAME2 exists. +;; +;; FIXME: implement filtering by files +(defun %do-simple-xref-lookup (name1 name2 table in-files in-functions) + (declare (ignore in-files)) + (when (some (lambda (x) + (when in-functions + (find x in-functions)) + (eql x name2)) + (gethash name1 table)) + name2)) + + +(defun %print-xref-entries (entries stream verbose) + (dolist (entry entries) + (if (eql (xref-entry-type entry) 'method) + ;; print qualifiers and specializers if it's a method + (format stream "~5,5T~A ~@[~A ~]~A~%" + (xref-entry-name entry) + (xref-entry-method-qualifiers entry) + (xref-entry-method-specializers entry)) + (format stream "~5,5T~A~%" (xref-entry-name entry))) + ;; print extra information when verbose + (when verbose + (format stream "~5,5T Type: ~A~%" (xref-entry-type entry)) + (let ((file (%source-file-for-xref-entry entry))) + (format stream "~5,5T File: ~A~%~%" (if file file "not recorded")))))) + + +;; WHO-DIRECTLY-CALLS -- external +;; +(defun who-directly-calls (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints information about direct callers of NAME. If INVERSE is true, +it will print direct callees of NAME instead." + (let ((callers/callees (if inverse + (get-relation :direct-calls name :wild + :in-files in-files + :in-functions in-functions) + (get-relation :direct-calls :wild name + :in-files in-files + :in-functions in-functions + :exhaustive t)))) + (format stream "~%~T") + (if callers/callees + (progn + (format stream "~A ~:[is directly called by~;directly calls~]:~%" + name inverse) + (%print-xref-entries callers/callees stream verbose)) + (format stream "No direct ~:[callers~;callees~] of ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-INDIRECTLY-CALLS -- external +;; +;; FIXME: Implement this (we can't currently detect indirect calls). +(defun who-indirectly-calls (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints information about indirect callers of NAME. If INVERSE is true, +it will print indirect callees of NAME instead." + (let ((callers/callees (if inverse + (get-relation :indirect-calls name :wild + :in-files in-files + :in-functions in-functions) + (get-relation :indirect-calls :wild name + :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if callers/callees + (progn + (format stream "~A ~:[is indirectly called by~;indirectly calls~]:~%" + name inverse) + (%print-xref-entries callers/callees stream verbose)) + (format stream "No indirect ~:[callers~;callees~] of ~A were found in the database~%" + inverse name))) + (values)) + +;; MACROS-CALLED-BY -- external +;; +(defun macros-called-by (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints information about macros which get called by NAME. If INVERSE is true, +it will list all functions which macroexpand NAME instead." + (let ((callers/callees (if (not inverse) + (get-relation :macro-calls name :wild + :in-files in-files + :in-functions in-functions) + (get-relation :macro-calls :wild name + :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if callers/callees + (progn + (format stream "~A ~:[is macro called by~;macro calls~]:~%" + name (not inverse)) + (%print-xref-entries callers/callees stream verbose)) + (format stream "No macro ~:[callers~;callees~] of ~A were found in the database~%" + (not inverse) name))) + (values)) + +;; WHO-CALLS -- external +;; +(defun who-calls (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Shorthand for WHO-DIRECTLY-CALLS, WHO-INDIRECTLY-CALLS and +MACROS-CALLED-BY." + (who-directly-calls name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (who-indirectly-calls name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (macros-called-by name :inverse (not inverse) :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (values)) + + +;; WHO-BINDS -- external +;; +(defun who-binds (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints a list of functions which bind NAME. If INVERSE is true, it will +print a list of variables bound by NAME instead." + (let ((bindings (if inverse + (get-relation :binds name :wild :in-files in-files + :in-functions in-functions) + (get-relation :binds :wild name :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if bindings + (progn + (format stream "~A ~:[is bound by~;binds~]:" name inverse) + (%print-xref-entries bindings stream verbose)) + (format stream "No ~:[bindings of~;symbols bound by~] ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-REFERENCES -- external +;; +(defun who-references (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints a list of functions which reference NAME. If INVERSE is true, it will +print a list of variables referenced by NAME instead." + (let ((references (if inverse + (get-relation :references name :wild :in-files in-files + :in-functions in-functions) + (get-relation :references :wild name :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if references + (progn + (format stream "~A ~:[is referenced by~;references~]:~%" name inverse) + (%print-xref-entries references stream verbose)) + (format stream "No ~:[references to~;symbols referenced by~] ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-SETS -- external +;; +(defun who-sets (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints a list of functions which set NAME. If INVERSE is true, it will +print a list of variables set by NAME instead." + (let ((sets (if inverse + (get-relation :sets name :wild :in-files in-files + :in-functions in-functions) + (get-relation :sets :wild name :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if sets + (progn + (format stream "~A ~:[is set by~;sets~]:~%" name inverse) + (%print-xref-entries sets stream verbose)) + (format stream "No ~:[settings of~;symbols set by~] ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-USES -- external +;; +(defun who-uses (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Shorthand for WHO-BINDS, WHO-REFERENCES and WHO-SETS." + (who-binds name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + + (who-references name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + + (who-sets name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (values)) + + +;; XREF-DESCRIBE -- external +;; +(defun xref-describe (name &key verbose) + "Prints relevant cross-referencing information about NAME." + (if (fboundp name) + (progn + (who-calls name :stream *terminal-io* :verbose verbose) + (who-calls name :inverse t :stream *terminal-io* :verbose verbose) + (who-uses name :inverse t :stream *terminal-io* :verbose verbose)) + (who-uses name :stream *terminal-io* :verbose verbose)) + (values)) + + +;;; Hook into the Clozure CL compiler frontend, by pointing a couple +;;; of its variables at our functions. +(setq ccl::*nx-discard-xref-info-hook* #'%discard-xref-info-for-function) +(setq ccl::*nx-add-xref-entry-hook* #'%add-xref-entry) + +(provide :xref) Index: /branches/qres/ccl/library/.cvsignore =================================================================== --- /branches/qres/ccl/library/.cvsignore (revision 13564) +++ /branches/qres/ccl/library/.cvsignore (revision 13564) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/qres/ccl/library/chud-metering.lisp =================================================================== --- /branches/qres/ccl/library/chud-metering.lisp (revision 13564) +++ /branches/qres/ccl/library/chud-metering.lisp (revision 13564) @@ -0,0 +1,306 @@ +;;;-*-Mode: LISP; Package: (CHUD (:USE CL CCL)) -*- +;;; +;;; Copyright (C) 2005,2008,2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Some of this is based on work done by Dan Knapp and Hamilton Link +;;; (and possibly others.) + +;;; CHUD 4.4.3-5 claims to offer 64-bit support; however, the library +;;; which provides the API to control CHUD metering functions still +;;; seems to be 32-bit only. Conditionalization for x86-64 and +;;; for 64-bit targets is (so far) just an exercise. + +(defpackage "CHUD" + (:use "CL" "CCL") + (:export "METER" "*SHARK-CONFIG-FILE*")) + +(in-package "CHUD") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (progn + #-darwin-target + (error "This code is Darwin/MacOSX-specific."))) + + +(defparameter *shark-session-path* nil) + +(defloadvar *written-spatch-file* nil) + +(defparameter *shark-session-native-namestring* nil) + +(defparameter *shark-config-file* nil "Full pathname of .cfg file to use for profiling, or NIL.") + +(defun finder-open-file (namestring) + "Open the file named by NAMESTRING, as if it was double-clicked on +in the finder" + (run-program "/usr/bin/open" (list namestring) :output nil)) + +(defun ensure-shark-session-path () + (unless *shark-session-path* + (multiple-value-bind (second minute hour date month year) + (decode-universal-time (get-universal-time)) + (let* ((subdir (format nil "profiling-session-~A-~d_~d-~d-~d_~d.~d.~d" + (pathname-name + (car + ccl::*command-line-argument-list*)) + (ccl::getpid) + month + date + year + hour + minute + second)) + (dir (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list subdir)) :defaults nil)) + (native-name (ccl::native-untranslated-namestring dir))) + (ensure-directories-exist dir) + (setenv "SHARK_SEARCH_PATH_PATCH_FILES" native-name) + (setq *shark-session-native-namestring* + native-name + *shark-session-path* dir)))) + *shark-session-path*) + + + + +(defloadvar *shark-process* nil) +(defloadvar *sampling* nil) + +(defvar *debug-shark-process-output* nil) + + +(defun safe-shark-function-name (function) + (let* ((name (format nil "~s" function))) + (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1))) + +(defun print-shark-spatch-record (fn &optional (stream t)) + (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn) + (startaddr (+ (ccl::%address-of code-vector) + #+x8664-target 0 + #+ppc32-target target::misc-data-offset + #-ppc32-target 0)) + (endaddr (+ startaddr + #+x8664-target + (1+ (ash (1- (ccl::%function-code-words fn) + ) target::word-shift)) + #+ppc-target + (* 4 (- (uvsize code-vector) + #+ppc64-target 2 + #-ppc64-target 1))))) + ;; i hope all lisp sym characters are allowed... we'll see + (format stream "{~%~@ + ~a~@ + ~@?~@ + ~@?~@ + }~%" + (safe-shark-function-name fn) + #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x" + startaddr + #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x" + endaddr))) + +#+x8664-target +(ccl::defx86lapfunction dynamic-dnode ((x arg_z)) + (movq (% x) (% imm0)) + (ref-global x86::heap-start arg_y) + (subq (% arg_y) (% imm0)) + (shrq ($ x8664::dnode-shift) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +#+x8632-target +(ccl::defx8632lapfunction dynamic-dnode ((x arg_z)) + (movl (% x) (% imm0)) + (ref-global x86::heap-start arg_y) + (subl (% arg_y) (% imm0)) + (shrl ($ x8632::dnode-shift) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +#+x8664-target +(defun identify-functions-with-pure-code () + (ccl::freeze) + (ccl::collect ((functions)) + (block walk + (let* ((frozen-dnodes (ccl::frozen-space-dnodes))) + (ccl::%map-areas (lambda (o) + (when (>= (dynamic-dnode o) frozen-dnodes) + (return-from walk nil)) + (when (typep o 'ccl::function-vector) + (functions (ccl::function-vector-to-function o)))) + ccl::area-dynamic + ))) + (functions))) + +#+x8632-target +(defun identify-functions-with-pure-code () + (ccl::freeze) + (ccl::collect ((functions)) + (block walk + (let* ((frozen-dnodes (ccl::frozen-space-dnodes))) + (ccl::%map-areas (lambda (o) + (when (>= (dynamic-dnode o) frozen-dnodes) + (return-from walk nil)) + (when (typep o 'function) + (functions o))) + ccl::area-dynamic + ))) + (functions))) + +#+ppc-target +(defun identify-functions-with-pure-code () + (ccl::purify) + (multiple-value-bind (pure-low pure-high) + + (ccl::do-gc-areas (a) + (when (eql(ccl::%fixnum-ref a target::area.code) + ccl::area-readonly) + (return + (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift) + (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift))))) + (let* ((hash (make-hash-table :test #'eq))) + (ccl::%map-lfuns #'(lambda (f) + (let* ((code-vector (ccl:uvref f 0)) + (startaddr (+ (ccl::%address-of code-vector) + target::misc-data-offset))) + (when (and (>= startaddr pure-low) + (< startaddr pure-high)) + (push f (gethash code-vector hash)))))) + (let* ((n 0)) + (declare (fixnum n)) + (maphash #'(lambda (k v) + (declare (ignore k)) + (if (null (cdr v)) + (incf n))) + hash) + (let* ((functions ())) + (maphash #'(lambda (k v) + (declare (ignore k)) + (when (null (cdr v)) + (push (car v) functions))) + hash) + (sort functions + #'(lambda (x y) + (< (ccl::%address-of (uvref x 0) ) + (ccl::%address-of (uvref y 0)))))))))) + + + + +(defun generate-shark-spatch-file () + (let* ((functions (identify-functions-with-pure-code))) + (with-open-file (f (make-pathname + :host nil + :directory (pathname-directory + (ensure-shark-session-path)) + :name (format nil "~a_~D" + (pathname-name + (car + ccl::*command-line-argument-list*)) + (ccl::getpid)) + :type "spatch") + :direction :output + :if-exists :supersede) + (format f "!SHARK_SPATCH_BEGIN~%") + (dolist (fun functions) + (print-shark-spatch-record fun f)) + (format f "!SHARK_SPATCH_END~%")))) + +(defun terminate-shark-process () + (when *shark-process* + (signal-external-process *shark-process* #$SIGUSR2)) + (setq *shark-process* nil + *sampling* nil)) + +(defun toggle-sampling () + (if *shark-process* + (progn + (signal-external-process *shark-process* #$SIGUSR1) + (setq *sampling* (not *sampling*))) + (warn "No active shark procsss"))) + +(defun enable-sampling () + (unless *sampling* (toggle-sampling))) + +(defun disable-sampling () + (when *sampling* (toggle-sampling))) + +(defun ensure-shark-process (reset hook) + (when (or (null *shark-process*) reset) + (terminate-shark-process) + (when (or reset (not *written-spatch-file*)) + (generate-shark-spatch-file)) + (let* ((args (list "-b" "-1" "-a" (format nil "~d" (ccl::getpid)) + "-d" *shark-session-native-namestring*))) + (when *shark-config-file* + (push (ccl::native-untranslated-namestring *shark-config-file*) + args) + (push "-m" args)) + (setq *shark-process* + (run-program "/usr/bin/shark" + args + :output :stream + :status-hook hook + :wait nil)) + (let* ((output (external-process-output-stream *shark-process*))) + (do* ((line (read-line output nil nil) (read-line output nil nil))) + ((null line)) + (when *debug-shark-process-output* + (format t "~&~a" line)) + (when (search "ready." line :key #'char-downcase) + (sleep 1) + (return))))))) + +(defun display-shark-session-file (line) + (let* ((last-quote (position #\' line :from-end t)) + (first-quote (and last-quote (position #\' line :end (1- last-quote) :from-end t))) + (path (and first-quote (subseq line (1+ first-quote) last-quote)))) + (when path (finder-open-file path)))) + +(defun scan-shark-process-output (p) + (with-interrupts-enabled + (let* ((out (ccl::external-process-output p))) + (do* ((line (read-line out nil nil) (read-line out nil nil))) + ((null line)) + (when *debug-shark-process-output* + (format t "~&~a" line)) + (when (search "Created session file:" line) + (display-shark-session-file line) + (return)))))) + + + +(defmacro meter (form &key reset debug-output) + (let* ((hook (gensym)) + (block (gensym)) + (process (gensym))) + `(block ,block + (flet ((,hook (p) + (when (or (eq (external-process-status p) :exited) + (eq (external-process-status p) :signaled)) + (setq *shark-process* nil + *sampling* nil)))) + (let* ((*debug-shark-process-output* ,debug-output)) + (ensure-shark-process ,reset #',hook) + (unwind-protect + (progn + (enable-sampling) + ,form) + (disable-sampling) + (let* ((,process *shark-process*)) + (when ,process + (scan-shark-process-output ,process))))))))) + +;;; Try to clean up after ourselves when the lisp quits. +(pushnew 'terminate-shark-process ccl::*save-exit-functions*) Index: /branches/qres/ccl/library/chud-metering.txt =================================================================== --- /branches/qres/ccl/library/chud-metering.txt (revision 13564) +++ /branches/qres/ccl/library/chud-metering.txt (revision 13564) @@ -0,0 +1,157 @@ +Using Apple's CHUD metering tools from CCL +========================================== + +Prerequisites +------------- + +Apple's CHUD metering tools are available (as of this writing) from: + +. + +The CHUD tools are also generally bundled with Apple's XCode tools. +CBUD 4.5.0 (which seems to be bundled with XCode 3.0) seems to work +well with this interface; later versions may have problems. +Versions of CHUD as old as 4.1.1 may work with 32-bit PPC versions +of CCL; later versions (not sure exactly -what- versions) added +x86, ppc64, and x86-64 support. + +One way to tell whether any version of the CHUD tools is installed +is to try to invoke the "shark" command-line program (/usr/bin/shark) +from the shell: + +shell> shark --help + +and verifying that that prints a usage summary. + +CHUD consists of several components, including command-line programs, +GUI applications, kernel extensions, and "frameworks" (collections of +libraries, headers, and other resources which applications can use to +access functionality provided by the other components.) Past versions +of CCL/OpenMCL have used the CHUD framework libraries to control the +CHUD profiler. Even though the rest of CHUD is currently 64-bit aware, +the frameworks are unfortunately still only available as 32-bit libraries, +so the traditional way of controlling the profiling facility from OpenMCL +has only worked from DarwinPPC32 versions. + +Two of the CHUD component programs are of particular interest: + +1) The "Shark" application (often installed in +"/Developer/Applications/Performance Tools/Shark.app"), which provides +a graphical user interface for exploring and analyzing profiling results +and provides tools for creating "sampling configurations" (see below), +among other things. + +2) the "shark" program ("/usr/bin/shark"), which can be used to control +the CHUD profiling facility and to collect sampling data, which can then +be displayed and analyzed in Shark.app. + +The fact that these two (substantially different) programs have names that +differ only in alphabetic case may be confusing. The discussion below +tries to consistently distinguish between "the shark program" and "the +Shark application". + +Usage synopsis +-------------- + +? (defun fact (n) (if (zerop n) 1 (* n (fact (1- n))))) +FACT +? (require "CHUD-METERING") +"CHUD-METERING" +("CHUD-METERING") +? (chud:meter (null (fact 10000))) +NIL ; since that large number is not NULL + +and, a few seconds after the result is returned, a file whose +name is of the form "session_nnn.mshark" will open in Shark.app. + +The fist time that CHUD:METER is used in a lisp session, it'll do a +few things to prepare subsequent profiling sessions. Those things +include: + +1) creating a directory to store files that are related to using +the CHUD tools in this lisp session. This directory is created in +the user's home directory and has a name of the form: + +profiling-session--_-

-_.. + +where is the lisp's process id, is the name of +the lisp kernel (of all things ...), and the other values provide +a timestamp. + +2) does whatever needs to be done to ensure that currently-defined +lisp functions don't move around as the result of GC activity, then +writes a text file describing the names and addresses of those functions +to the profiling-session directory created above. (The naming conventions +for and format of that file are described in + + + +3) run the shark program ("/usr/bin/shark") and wait until it's ready to +receive signals that control its operation. + +This startup activity typically takes a few seconds; after it's been +completed, subsequent use of CHUD:METER doesn't involve that overhead. +(See the discussion of :RESET below.) + +After any startup activity is complete, CHUD:METER arranges to send +a "start profiling" signal to the running shark program, executes +the form, sends a "stop profiling" signal to the shark program, and +reads its diagnostic output, looking for the name of the ".mshark" +file it produces. If it's able to find this filename, it arranges +for "Shark.app" to open it + +Profiling "configurations". +-------------------------- + +By default, a shark profiling session will: +a) use "time based" sampling, to periodically interrupt the lisp + process and note the value of the program counter and at least + a few levels of call history. +b) do this sampling once every millisecond +c) run for up to 30 seconds, unless told to stop earlier. + +This is known as "the default configuration"; it's possible to use +items on the "Config" menu in the Shark application to create alternate +configurations which provide different kinds of profiling parameters +and to save these configurations in files for subsequent reuse. +(The set of things that CHUD knows how to monitor is large and interesting.) + +You use alternate profiling configurations (created and "exported" via +Shark.app) with CHUD:METER, but the interface is a little awkward. + +Reference +--------- + +CHUD:*SHARK-CONFIG-FILE* [Variable] + +When non-null, this should be the pathname of an alternate profiling +configuration file created by the "Config Editor" in Shark.app. + +(CHUD:METER form &key (reset nil) (debug-output nil)) [Macro] + +Executes FORM (an arbitrary lisp form) and returns whatever result(s) +it returns, with CHUD profiling enabled during the form's execution. +Tries to determine the name of the session file (*.mshark) to which +the shark program wrote profiling data and opens this file in the +Shark application. + +Arguments: + +debug-output - when non-nil, causes output generated by the shark program to + be echoed to *TERMINAL-IO*. For debugging. +reset - when non-nil, terminates any running instance of the + shark program created by previous invocations of CHUD:METER + in this lisp session, generates a new .spatch file + (describing the names and addresses of lisp functions), + and starts a new instance of the shark program; if + CHUD:*SHARK-CONFIG-FILE* is non-NIL when this new instance + is started, that instance is told to use the specified + config file for profiling (in lieu of the default profiling + configuration.) + +Acknowledgments +--------------- + +Both Dan Knapp and Hamilton Link have posted similar CHUD interfaces +to openmcl-devel in the past; Hamilton's also reported bugs in the +spatch mechanism to CHUD developers (and gotten those bugs fixed.) Index: /branches/qres/ccl/library/core-files.lisp =================================================================== --- /branches/qres/ccl/library/core-files.lisp (revision 13564) +++ /branches/qres/ccl/library/core-files.lisp (revision 13564) @@ -0,0 +1,1410 @@ +;;; +;;; Copyright (C) 2009-2010 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Functions to examine core files. + +(in-package :ccl) + +#+:linuxx8664-target +(progn + + +(defconstant $image-nsections 7) +(defconstant $image-data-offset-64 9) +(defconstant $image-header-size 16) + +(defconstant $image-sect-code 0) +(defconstant $image-sect-size 4) +(defconstant $image-sect-header-size 8) + +(export '(open-core close-core + core-heap-utilization map-core-areas + core-q core-l core-w core-b + core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p + core-uvtype core-uvtypep core-uvref core-uvsize + core-car core-cdr core-object-typecode-type + core-object-type-key core-type-string + copy-from-core core-list + core-keyword-package core-find-package core-find-symbol + core-package-names core-package-name + core-map-symbols + core-symbol-name core-symbol-value core-symbol-package core-symbol-plist + core-gethash core-hash-table-count + core-lfun-name core-lfun-bits core-nth-immediate + core-find-class + core-instance-class + core-instance-p + core-string= + core-all-processes core-process-name + core-find-process-for-id + core-print + core-print-call-history + )) + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + +;; The intended way to use these facilities is to open up a particular core file once, +;; and then repeatedly call functions to examine it. So for convenience, we keep the +;; core file in a global var, rather than making all user functions take an extra arg. +;; There is nothing intrinsic that would prevent having multiple core files open at once. + +(defvar *current-core* nil) + + +(eval-when (load eval #-BOOTSTRAPPED compile) + +(defstruct core-info + pathname + sections + ;; uses either stream or ivector, determined at runtime + streams + ivectors + ;; caches + symbol-ptrs + classes-hash-table-ptr + lfun-names-table-ptr + process-class + ) +) + +(defmethod print-object :around ((core core-info) (stream t)) + (let ((*print-array* nil) + (*print-simple-bit-vector* nil)) + (call-next-method))) + +(declaim (type (or null core-info) *current-core*) + (ftype (function () core-info) current-core) + (inline current-core)) + +(defun current-core () + (or *current-core* (require-type *current-core* 'core-info))) + +(defun close-core () + (let ((core *current-core*)) + (setq *current-core* nil) + (when core + (map nil #'close (core-info-streams core)) + (map nil #'unmap-ivector (core-info-ivectors core)) + t))) + +; +(defmacro area-loop (with ptrvar &body body) + (assert (eq with 'with)) + (let ((before (loop while (eq (car body) 'with) + nconc (list (pop body) (pop body) (pop body) (pop body))))) + `(loop ,@before + for ,ptrvar = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ) + then (core-q ,ptrvar target::area.succ) + until (eq (core-q area-ptr target::area.code) (ash area-void target::fixnum-shift)) + ,@body))) + +(def-accessor-macros %svref + %core-sect.start-addr + %core-sect.offset + %core-sect.end-addr + %core-sect.ivector + %core-sect.stream) + +(defun make-core-sect (&key start end offset ivector stream) + (vector start offset end ivector stream)) + + +(defvar *core-info-class* 'core-info) + +;; TODO: after load sections, check if highest heap address is a fixnum, and +;; arrange to use fixnum-only versions of the reading functions. +(defun open-core (pathname &key (image nil) (method :mmap) (core-info nil)) + (when *current-core* + (close-core)) + (let* ((sections (read-sections pathname)) + (core (require-type (or core-info (make-instance *core-info-class*)) 'core-info))) + (setf (core-info-pathname core) pathname) + (setf (core-info-sections core) sections) + (setf (core-info-symbol-ptrs core) nil) + (setf (core-info-classes-hash-table-ptr core) nil) + (setf (core-info-lfun-names-table-ptr core) nil) + (setf (core-info-process-class core) nil) + (setf (core-info-ivectors core) nil) + (setf (core-info-streams core) nil) + (ecase method + (:mmap (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8)))) + (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector) + (push mapped-vector (core-info-ivectors core)) + (loop for sect across sections + do (incf (%core-sect.offset sect) offset) + do (setf (%core-sect.ivector sect) vector))))) + (:stream (let ((stream (open pathname :element-type '(unsigned-byte 8) + :sharing :lock))) + (push stream (core-info-streams core)) + (loop for sect across sections do (setf (%core-sect.stream sect) stream))))) + (setq *current-core* core)) + ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core))) + ;; (error "Non-fixnum addresses not supported")) + (when (and image + (area-loop with area-ptr + thereis (and (eq (core-q area-ptr target::area.code) + (ash area-readonly target::fixnum-shift)) + (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)) + (not (core-section-for-address (core-q area-ptr target::area.low)))))) + ;; Have a missing readonly section, and an image file that might contain it. + (add-core-sections-from-image image)) + pathname) + +;; Kinda stupid to call external program for this... +(defun read-sections (pathname) + (flet ((split (line start end) + (loop while (setq start (position-if-not #'whitespacep line :start start :end end)) + as match = (cdr (assq (char line start) '((#\[ . #\]) (#\( . #\)) (#\< . #\>)))) + as next = (if match + (1+ (or (position match line :start (1+ start) :end end) + (error "Unmatched ~c at position ~s" (char line start) start))) + (or (position-if #'whitespacep line :start start :end end) end)) + collect (subseq line start next) + do (setq start next)))) + (let* ((file (native-translated-namestring pathname)) + (string (with-output-to-string (output) + #+readelf (ccl:run-program "readelf" `("--sections" "--wide" ,file) :output output) + #-readelf (ccl:run-program "objdump" `("-h" "-w" ,file) :output output))) + (header-pos (or #+readelf (position #\[ string) + #-readelf (search "Idx Name" string) + (error "Cannot parse: ~%~a" string))) + (sections (loop + for start = (1+ (position #\newline string :start header-pos)) then (1+ end) + for end = (or (position #\newline string :start start) (length string)) + while (and (< start end) (find (aref string start) " 123456789")) + nconc + (multiple-value-bind (name address filepos size) + #+readelf + (destructuring-bind (number name type address filepos size &rest flags) + (split string start end) + (declare (ignore flags)) + (assert (and (eql (char number 0) #\[) (eql (char number (1- (length number))) #\]))) + (setq number (read-from-string number :start 1 :end (1- (length number)))) + (when (eql number 0) + (shiftf size filepos address type)) + (values name address filepos size)) + #-readelf + (destructuring-bind (number name size address lma filepos &rest flags) + (split string start end) + (declare (ignore lma flags)) + (parse-integer number :radix 10) ;; error checking only + (values name address filepos size)) + (unless (or (equal name "") (eql (char name 0) #\.)) + (setq address (parse-integer address :radix 16)) + (setq filepos (parse-integer filepos :radix 16)) + (setq size (parse-integer size :radix 16)) + (unless (eql size 0) + (list (list address filepos size))))))) + (sections (sort sections #'< :key #'car));; sort by address + (sections (let ((last (car (last sections)))) ;; hack for loop below + (nconc sections (list (list (+ (car last) (caddr last) 1) 0 0))))) + (sections (loop + with cur-address = -1 + with cur-filepos = -1 + with cur-end = cur-address + for (address filepos size) in sections + unless (or (= (+ cur-filepos (- address cur-address)) filepos) + (= cur-address cur-end)) + collect (make-core-sect + :start cur-address + :end cur-end + :offset cur-filepos) + do (if (= (+ cur-filepos (- address cur-address)) filepos) + (setq cur-end (max (+ address size) cur-end)) + (progn + (assert (<= cur-end address));; no overlap. + (setq cur-address address cur-filepos filepos cur-end (+ address size))))))) + (coerce sections 'vector)))) + + +(defun add-core-sections-from-image (pathname) + (with-open-file (header-stream pathname :element-type '(signed-byte 32)) + (labels ((read-at (&optional pos) + (when pos (file-position header-stream pos)) + (read-byte header-stream)) + (readn (pos) (+ (logand #xFFFFFFFF (read-at pos)) (ash (read-at) 32)))) + (let* ((sig '(#x4F70656E #x4D434C49 #x6D616765 #x46696C65)) + (end (file-length header-stream)) + (page-mask (1- *host-page-size*)) + (header (+ end (/ (read-at (1- end)) 4)))) + (unless (progn + (file-position header-stream (- end 4)) + (loop repeat 3 as s in sig always (eql s (read-at)))) + (error "~s is not a ccl image file" pathname)) + (assert (and (integerp header) (< header end) (<= 0 header))) + (file-position header-stream header) + (assert (loop for s in sig always (eql s (read-at)))) + (let* ((nsections (read-at (+ header $image-nsections))) + (offset + #+64-bit-host (/ (+ (ash (read-at (+ header $image-data-offset-64)) 32) + (logand #xFFFFFFFF (read-at))) 4) + #-64-bit-host 0) + (sections (loop repeat nsections + for pos upfrom (+ header $image-header-size) by $image-sect-header-size + for epos = (* 4 (+ header $image-header-size + (* nsections $image-sect-header-size) + offset)) + then (+ fpos mem-size) + as fpos = (logandc2 (+ epos page-mask) page-mask) + as mem-size = (readn (+ pos $image-sect-size)) + when (eq (readn (+ pos $image-sect-code)) + (ash area-readonly target::fixnum-shift)) + collect (cons fpos mem-size))) + (new (area-loop with area-ptr + when (and (eq (core-q area-ptr target::area.code) + (ash area-readonly target::fixnum-shift)) + (< (core-q area-ptr target::area.low) + (core-q area-ptr target::area.active)) + (not (core-section-for-address (core-q area-ptr target::area.low)))) + collect (let* ((size (- (core-q area-ptr target::area.active) + (core-q area-ptr target::area.low))) + (matches (remove size sections :key 'cdr :test-not 'eql))) + + ;; **** should just do nothing if not found + (assert (eql (length matches) 1)) + (make-core-sect + :start (core-q area-ptr target::area.low) + :end (core-q area-ptr target::area.active) + :offset (caar matches))))) + (image-stream (open pathname :element-type '(unsigned-byte 8) :sharing :lock))) + (unwind-protect + (let ((core (current-core))) + (setf (core-info-sections core) + (sort (concatenate 'vector new (core-info-sections core)) + #'< :key (lambda (s) (%core-sect.start-addr s)))) + (push image-stream (core-info-streams core)) + (loop for s in new do (setf (%core-sect.stream s) image-stream)) + (setq image-stream nil)) + (when image-stream (close image-stream :abort t)))))))) + + +(declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq + core-stream-readb core-stream-readw core-stream-readl core-stream-readq)) +(declaim (ftype (function (t t) (unsigned-byte 8)) core-ivector-readb core-stream-readb) + (ftype (function (t t) (unsigned-byte 16)) core-ivector-readw core-stream-readw) + (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl) + (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq) + (ftype (function (simple-vector) fixnum) core-section-for-address)) + +(define-condition invalid-core-address (simple-error) + () + (:default-initargs :format-control "Unknown core address x~x")) + +(declaim (inline core-section-for-address)) +(defun core-section-for-address (address) + (loop with sections = (core-info-sections (current-core)) + with len fixnum = (length sections) + with low fixnum = -1 + with high fixnum = len + do (let ((half (the fixnum (ash (%i+ high low) -1)))) + (declare (fixnum half)) + (when (eq half low) + (return (and (%i<= 0 half) + (%i< half len) + (let ((sect (%svref sections half))) + (and (< address (%core-sect.end-addr (%svref sections half))) sect))))) + (let ((sect (%svref sections half))) + (if (%i<= (%core-sect.start-addr sect) address) + (setq low half) + (setq high half)))))) + +(defun core-heap-address-p (address) + (core-section-for-address address)) + + +(defun core-stream-readb (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (read-byte s)) + +(defun core-stream-readw (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (%i+ (core-stream-readb s nil) (%ilsl 8 (core-stream-readb s nil)))) + +(defun core-stream-readl (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (%i+ (core-stream-readw s nil) (%ilsl 16 (core-stream-readw s nil)))) + +(defun core-stream-readq (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (+ (core-stream-readl s nil) (ash (the fixnum (core-stream-readl s nil)) 32))) + +(defun core-ivector-readb (vec offset) + (declare (type (simple-array (unsigned-byte 8) (*)) vec) (fixnum offset) + (optimize (speed 3) (safety 0))) + (aref vec offset)) + +(defun core-ivector-readw (vec offset) + (declare (optimize (speed 3) (safety 0))) + (%i+ (core-ivector-readb vec offset) (%ilsl 8 (core-ivector-readb vec (+ offset 1))))) + +(defun core-ivector-readl (vec offset) + (declare (optimize (speed 3) (safety 0))) + (%i+ (core-ivector-readw vec offset) (%ilsl 16 (core-ivector-readw vec (+ offset 2))))) + +(defun core-ivector-readq (vec offset) + (declare (optimize (speed 3) (safety 0))) + (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (+ offset 4)) 32))) + + +(defun core-q (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) + (if ivector + (core-ivector-readq ivector pos) + (core-stream-readq (%core-sect.stream sect) pos)))) + + +(defun core-l (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) + (if ivector + (core-ivector-readl ivector pos) + (core-stream-readl (%core-sect.stream sect) pos)))) + +(defun core-w (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) + (if ivector + (core-ivector-readw ivector pos) + (core-stream-readw (%core-sect.stream sect) pos)))) + +(defun core-b (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) + (if ivector + (core-ivector-readb ivector pos) + (core-stream-readb (%core-sect.stream sect) pos)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; general utilities + +;; NIL is constant, assume is same in core as here. +(defun kernel-global-address (global) + (check-type global symbol) + (+ (target-nil-value) (target::%kernel-global global))) + +(defun nil-relative-symbol-address (sym) + (+ (target-nil-value) + #x20 ;;; dunno why + (* (or (position sym x86::*x86-nil-relative-symbols* :test #'eq) + (error "Not a nil-relative symbol ~s" sym)) + target::symbol.size) + (- target::fulltag-symbol target::fulltag-nil))) + +(defun core-area-name (code) + (or (heap-area-name code) + (and (integerp code) + (not (logtest code (1- (ash 1 target::fixnum-shift)))) + (heap-area-name (ash code (- target::fixnum-shift)))))) + +(defx86lapfunction %%raw-obj ((address arg_z)) + (unbox-fixnum address arg_z) + (single-value-return)) + +(declaim (inline uvheader-p uvheader-typecode uvheader-size)) + +(defun uvheader-p (header) + (let ((tag (logand header target::fulltagmask))) + (declare (fixnum tag)) + (and (<= target::fulltag-nodeheader-0 tag) + (<= tag target::fulltag-immheader-2) + (neq tag target::fulltag-odd-fixnum)))) + +(defun uvheader-typecode (header) + (the fixnum (logand #xFF header))) + +(defun uvheader-size (header) + (the fixnum (ash header (- target::num-subtag-bits)))) + +(defun uvheader-byte-size (header) + (x8664::x8664-misc-byte-count (uvheader-typecode header) (uvheader-size header))) + +(defun uvheader-type (header) + (let* ((typecode (uvheader-typecode header)) + (low4 (logand typecode target::fulltagmask)) + (high4 (ash typecode (- target::ntagbits)))) + (declare (type (unsigned-byte 8) typecode) + (type (unsigned-byte 4) low4 high4)) + (cond ((eql low4 x8664::fulltag-immheader-0) + (%svref *immheader-0-types* high4)) + ((eql low4 x8664::fulltag-immheader-1) + (%svref *immheader-1-types* high4)) + ((eql low4 x8664::fulltag-immheader-2) + (%svref *immheader-2-types* high4)) + ((eql low4 x8664::fulltag-nodeheader-0) + (%svref *nodeheader-0-types* high4)) + ((eql low4 x8664::fulltag-nodeheader-1) + (%svref *nodeheader-1-types* high4)) + (t 'bogus)))) + +(defun uvheader-type-typecode (symbol &aux pos) + (unless (eq symbol 'bogus) + (cond ((setq pos (position symbol *immheader-0-types*)) + (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-0)) + ((setq pos (position symbol *immheader-1-types*)) + (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-1)) + ((setq pos (position symbol *immheader-2-types*)) + (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-2)) + ((setq pos (position symbol *nodeheader-0-types*)) + (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-0)) + ((setq pos (position symbol *nodeheader-1-types*)) + (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-1))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Core heap + + +(defun core-heap-area-code (area) + (let ((code (heap-area-code area)) + (dynamic (ash (core-q (core-q (core-q (kernel-global-address 'all-areas)) + target::area.succ) + target::area.code) + (- target::fixnum-shift)))) + (if (or (fixnump area) + (eq dynamic area-dynamic) + ;; account for watched area having been inserted + (<= code area-watched)) + code + (1- code)))) + +(defun map-core-areas (function &key area) + (if (eq area :tenured) + (map-core-area (core-q (kernel-global-address 'tenured-area)) function) + (area-loop with area-ptr + with area = (cond ((or (eq area t) (eq area nil)) nil) + ((consp area) (mapcar #'core-heap-area-code area)) + (t (list (core-heap-area-code area)))) + as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift)) + do (when (and (<= area-readonly code) + (<= code area-dynamic) + (or (null area) (member code area)) + (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active))) + #+debug + (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)" + area-ptr (core-area-name code) + (core-q area-ptr target::area.low) + (core-q area-ptr target::area.active) + (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low)) + (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low))) + (map-core-area area-ptr function))))) + +(defun map-core-area (area-ptr fun) + (map-core-region (core-q area-ptr target::area.low) + (core-q area-ptr target::area.active) + fun)) + +(defun map-core-region (ptr end fun) + (loop + while (< ptr end) as header = (core-q ptr) + do (cond ((uvheader-p header) + (let ((subtag (uvheader-typecode header))) + (funcall fun + (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol) + ((eq subtag target::subtag-function) target::fulltag-function) + (t target::fulltag-misc))))) + (let* ((bytes (uvheader-byte-size header)) + (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size))) + (1- target::dnode-size)))) + (declare (fixnum bytes total)) + (incf ptr total))) + (t + (funcall fun (+ ptr target::fulltag-cons)) + (incf ptr target::cons.size))))) + + +(declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp)) + +(defun core-consp (ptr) + (eq (logand ptr target::fulltagmask) target::fulltag-cons)) + +(defun core-symbolp (ptr) + (eq (logand ptr target::fulltagmask) target::fulltag-symbol)) + +(defun core-functionp (ptr) + (eq (logand ptr target::fulltagmask) target::fulltag-function)) + +(defun core-listp (ptr) + (eq (logand ptr target::tagmask) target::tag-list)) + +(defun core-nullp (obj) + (eq (logand obj target::fulltagmask) target::fulltag-nil)) + +;; uvector utilities +(declaim (inline core-uvector-p core-uvheader core-uvtypecode core-uvtype)) + +(defun core-uvector-p (ptr) + (%i>= (logand ptr target::fulltagmask) target::fulltag-misc)) + +(defun core-uvheader (vec-ptr) + (core-q (logandc2 vec-ptr target::fulltagmask))) + +(defun core-uvtypecode (vec-ptr) + (uvheader-typecode (core-uvheader vec-ptr))) + +(defun core-uvtype (vec-ptr) + (uvheader-type (core-uvheader vec-ptr))) + +(defmacro core-uvtypep (vec-ptr type &aux temp) + (when (keywordp type) + (setq type (type-keyword-code type))) + (when (and (or (symbolp (setq temp type)) + (and (quoted-form-p type) + (symbolp (setq temp (cadr type))))) + (setq temp (find-symbol (symbol-name temp) :ccl)) + (setq temp (uvheader-type-typecode temp))) + (setq type temp)) + (when (constant-symbol-p type) + (setq temp (symbol-value type)) + (when (<= 0 temp #xFF) (setq type temp))) + `(let ((vec-ptr ,vec-ptr)) + (and (core-uvector-p vec-ptr) + (eq (core-uvtypecode vec-ptr) ,type)))) + +(defun core-uvref (vec-ptr index) + (let* ((header (core-uvheader vec-ptr)) + (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) + (typecode (uvheader-typecode header)) + (tag (%ilogand typecode target::fulltagmask)) + (len (uvheader-size header))) + (assert (< -1 index len)) + (cond ((or (eq tag target::fulltag-nodeheader-0) + (eq tag target::fulltag-nodeheader-1)) + (core-q addr (%ilsl target::word-shift index))) + ((eq tag target::ivector-class-64-bit) + (cond ((eq typecode target::subtag-double-float-vector) + (error "~s not implemented yet" 'target::subtag-double-float-vector)) + (t + (core-q addr (%ilsl target::word-shift index))))) + ((eq tag target::ivector-class-32-bit) + (cond ((eq typecode target::subtag-simple-base-string) + (%code-char (core-l addr (%ilsl 2 index)))) + ((eq typecode target::subtag-single-float-vector) + (error "~s not implemented yet" 'target::subtag-single-float-vector)) + (t (core-l addr (%ilsl 2 index))))) + ((eq typecode target::subtag-bit-vector) + (let ((byte (core-b addr (%iasr 3 (%i+ index 7))))) + (error "not implemented, for ~b" byte))) + ((>= typecode target::min-8-bit-ivector-subtag) + (core-b addr index)) + (t (core-w addr (%ilsl 1 index)))))) + +(defun core-uvsize (vec-ptr) + (uvheader-size (core-uvheader vec-ptr))) + +(defun core-car (obj) + (assert (core-listp obj)) + (core-q obj target::cons.car)) + +(defun core-cdr (obj) + (assert (core-listp obj)) + (core-q obj target::cons.cdr)) + +(defun core-object-typecode-type (obj) + (let ((fulltag (logand obj target::fulltagmask))) + (cond ((eq fulltag target::fulltag-cons) 'cons) + ((eq fulltag target::fulltag-nil) 'null) + ((eq (logand fulltag target::tagmask) target::tag-fixnum) 'fixnum) + ((and (or (eq fulltag target::fulltag-imm-0) + (eq fulltag target::fulltag-imm-1)) + (fixnump obj)) + ;; Assumes we're running on same architecture as core file. + (type-of (%%raw-obj obj))) + ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address) + ((eq fulltag target::fulltag-misc) + ;; (core-uvtype obj) + (handler-case (core-uvtype obj) (invalid-core-address () 'unmapped))) + ((eq fulltag target::fulltag-symbol) 'symbol) + ;; TODO: Could get hairier based on lfun-bits, but usually don't care. + ((eq fulltag target::fulltag-function) 'function) + (t (cerror "treat as ~*~s" "Invalid object tag at #x~x" obj 'bogus) + 'bogus)))) + +(defun core-object-type-key (obj) + ;; Returns either a symbol (for built-in types) or a pointer to type symbol or class. + ;; Whatever it returns must be suitable for use in an eql hash table; use core-type-string + ;; to get a printable rep. + (let ((type (core-object-typecode-type obj))) + (case type + (function (core-function-type obj)) + (internal-structure (core-istruct-type obj)) + (structure (core-struct-type obj)) + (instance (core-instance-type obj)) + (t type)))) + +(defun core-function-type (obj) + (and (core-uvtypep obj :function) + (let ((bits (core-lfun-bits obj))) + (declare (fixnum bits)) + (or (if (logbitp $lfbits-trampoline-bit bits) + (let* ((inner-fn (core-closure-function obj)) + (inner-bits (core-lfun-bits inner-fn))) + (if (neq inner-fn obj) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (unless (logbitp $lfbits-gfn-bit inner-bits) + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + (unless (logbitp $lfbits-gfn-bit bits) + (if (logbitp $lfbits-cm-bit bits) + 'combined-method + 'function)))) + (core-class-name + (core-uvref + (core-nth-immediate obj gf.instance.class-wrapper) + %wrapper-class)))))) + +(defun core-type-string (object-type) + (with-output-to-string (s) + (if (fixnump object-type) + (core-print object-type s) + (prin1 object-type s)))) + +(defun core-istruct-type (obj) + (and (core-uvtypep obj :istruct) + (core-car (core-uvref obj 0)))) + +(defun core-struct-type (obj) + (and (core-uvtypep obj :struct) + (core-uvref (core-car (core-uvref obj 0)) 1))) + +(defun core-instance-type (obj) + (and (core-uvtypep obj :instance) + (core-class-name (core-instance-class obj)))) + +(defun core-class-name (class) + (core-uvref (core-uvref class instance.slots) %class.name)) + +(defun core-object-type-and-size (obj) + (let ((fulltag (logand obj target::fulltagmask))) + (if (eq fulltag target::fulltag-cons) + (values 'cons target::dnode-size target::dnode-size) + (if (%i<= target::fulltag-misc fulltag) + (let* ((header (core-uvheader obj)) + (logsize (uvheader-byte-size header)) + ;; total including header and alignment. + (total (logandc2 (+ logsize target::node-size (1- target::dnode-size)) + (1- target::dnode-size)))) + (values (uvheader-type header) logsize total)))))) + +(defun core-heap-utilization (&key (stream *debug-io*) area unit (sort :size) classes (threshold 0.00005)) + (let* ((obj-hash (make-hash-table :shared nil)) + (slotv-hash (make-hash-table :shared nil)) + (all nil)) + (map-core-areas (lambda (obj &aux (hash obj-hash)) + (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj) + (when classes + (when (core-uvtypep obj :slot-vector) + (setq hash slotv-hash + obj (core-uvref obj slot-vector.instance))) + (setq type (core-object-type-key obj))) + (let ((a (or (gethash type hash) + (setf (gethash type hash) (list 0 0 0))))) + (incf (car a)) + (incf (cadr a) logsize) + (incf (caddr a) physsize)))) + :area area) + (maphash (lambda (type data) + (push (cons (core-type-string type) data) all)) + obj-hash) + (maphash (lambda (type data) + (push (cons (concatenate 'string (core-type-string type) " slot-vector") data) all)) + slotv-hash) + (report-heap-utilization all :stream stream :unit unit :sort sort :threshold threshold))) + + +(defstruct unresolved-address address) + +(defmethod print-object ((obj unresolved-address) stream) + (let* ((address (unresolved-address-address obj))) + (if (and (core-uvector-p address) + (not (handler-case (core-uvheader address) (invalid-core-address () nil)))) + (format stream "#" address) + (format stream "#" + (or (ignore-errors (core-type-string (core-object-type-key address))) + (core-object-typecode-type address)) + (and (core-uvector-p address) (core-uvsize address)) + address)))) + +(defun copy-from-core (obj &key (depth 1)) + (check-type depth (integer 0)) + (when (unresolved-address-p obj) + (setq obj (unresolved-address-address obj))) + (let ((fulltag (logand obj target::fulltagmask))) + (cond ((eq fulltag target::fulltag-nil) nil) + ((eq (logand fulltag target::tagmask) target::tag-fixnum) + (ash obj (- target::fixnum-shift))) + ((and (fixnump obj) + (or (eq fulltag target::fulltag-imm-0) + (eq fulltag target::fulltag-imm-1))) + (%%raw-obj obj)) + ((< (decf depth) 0) + (make-unresolved-address :address obj)) + ((and (%i<= target::fulltag-misc fulltag) + (handler-case (core-uvheader obj) (invalid-core-address nil))) + (or (and (core-uvtypep obj :package) + (find-package (core-package-name obj))) + (let ((v (%copy-uvector-from-core obj depth))) + (when (and (symbolp v) (<= depth 1)) + ;; Need to fix up the package slot else it's not useful + (let ((pp (%svref (symptr->symvector v) target::symbol.package-predicate-cell))) + (when (unresolved-address-p pp) + (setq pp (copy-from-core pp :depth 1))) + (when (and (consp pp) (unresolved-address-p (car pp))) + (let ((pkg (unresolved-address-address (car pp)))) + (when (and (core-uvtypep pkg :package) + (setq pkg (find-package (core-package-name pkg)))) + (setf (car pp) pkg)))) + (setf (%svref (symptr->symvector v) target::symbol.package-predicate-cell) pp)) + ;; ditto for pname + (let ((pp (%svref (symptr->symvector v) target::symbol.pname-cell))) + (when (unresolved-address-p pp) + (setf (%svref (symptr->symvector v) target::symbol.pname-cell) + (copy-from-core pp :depth 1))))) + v))) + ((eq fulltag target::fulltag-cons) + (cons (copy-from-core (core-car obj) :depth depth) + (copy-from-core (core-cdr obj) :depth depth))) + (t (make-unresolved-address :address obj))))) + +(defun %copy-uvector-from-core (vec-ptr depth) + (let* ((header (core-uvheader vec-ptr)) + (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) + (typecode (uvheader-typecode header)) + (tag (logand typecode target::fulltagmask)) + (len (uvheader-size header)) + (vec (%alloc-misc len typecode))) + (declare (type fixnum typecode tag len)) + (cond ((or (eq tag target::fulltag-nodeheader-0) + (eq tag target::fulltag-nodeheader-1)) + (when (eq typecode target::subtag-function) + ;; Don't bother copying the code for now + (let ((skip (core-l addr))) + (declare (fixnum skip)) + (assert (<= 0 skip len)) + (incf addr (ash skip target::word-shift)) + (decf len skip))) + (dotimes (i len) + (declare (fixnum i)) + (setf (%svref vec i) + (copy-from-core (core-q addr (%ilsl target::word-shift i)) :depth depth))) + (let ((ptrtag (logand vec-ptr target::fulltagmask))) + (cond ((eq ptrtag target::fulltag-symbol) + (%symvector->symptr vec)) + ((eq ptrtag target::fulltag-function) + (%function-vector-to-function vec)) + (t vec)))) + ((eq tag target::ivector-class-64-bit) + (cond ((eq typecode target::subtag-double-float-vector) + (warn "~s not implemented yet" 'target::subtag-double-float-vector) + (make-unresolved-address :address vec-ptr)) + (t + (dotimes (i len vec) + (setf (uvref vec i) (core-q addr (%ilsl target::word-shift i))))))) + ((eq tag target::ivector-class-32-bit) + (cond ((eq typecode target::subtag-simple-base-string) + (dotimes (i len vec) + (setf (uvref vec i) (%code-char (core-l addr (%ilsl 2 i)))))) + ((eq typecode target::subtag-single-float-vector) + (warn "~s not implemented yet" 'target::subtag-single-float-vector) + (make-unresolved-address :address vec-ptr)) + (t + (dotimes (i len vec) + (setf (uvref vec i) (core-l addr (%ilsl 2 i))))))) + ((eq typecode target::subtag-bit-vector) + (warn "bit vector not implemented yet") + (make-unresolved-address :address vec-ptr)) + ((>= typecode target::min-8-bit-ivector-subtag) + (dotimes (i len vec) + (setf (uvref vec i) (core-b addr i)))) + (t + (dotimes (i len vec) + (setf (uvref vec i) (core-w addr (%ilsl 1 i)))))))) + +(defun map-core-pointers (fn &key area) + (map-core-areas (lambda (obj) + (cond ((core-consp obj) + (funcall fn (core-car obj) obj 0) + (funcall fn (core-cdr obj) obj 1)) + (t + (let* ((header (core-uvheader obj)) + (subtag (logand header target::fulltagmask))) + (when (or (eq subtag target::fulltag-nodeheader-0) + (eq subtag target::fulltag-nodeheader-1)) + (let* ((typecode (uvheader-typecode header)) + (len (uvheader-size header)) + (addr (+ (logandc2 obj target::fulltagmask) target::node-size))) + (declare (fixnum typecode len)) + (when (eq typecode target::subtag-function) + (let ((skip (core-l addr))) + (declare (fixnum skip)) + (assert (<= 0 skip len)) + (incf addr (%ilsl target::word-shift skip)) + (decf len skip))) + (dotimes (i len) + (funcall fn (core-q addr (%ilsl target::word-shift i)) obj i)))))))) + :area area)) + +(defun core-find-tra-function (tra) + (assert (eq (logand tra target::tagmask) target::tag-tra)) + (map-core-areas (lambda (obj) + (when (core-uvtypep obj :function) + (let* ((addr (+ (logandc2 obj target::fulltagmask) target::node-size)) + (skip (core-l addr)) + (offset (- tra addr))) + (when (<= 0 offset (ash skip target::word-shift)) + (return-from core-find-tra-function (values obj (+ offset (- target::node-size + (logand obj target::fulltagmask))))))))))) + +(defun core-instance-class (obj) + (when (core-uvtypep obj :slot-vector) + (setq obj (core-uvref obj slot-vector.instance))) + (assert (core-uvtypep obj :instance)) + (core-uvref (core-uvref obj instance.class-wrapper) %wrapper-class)) + +(defun core-instance-p (obj class) + (and (core-uvtypep obj :instance) + (labels ((matchp (iclass) + (or (eql iclass class) + (loop for supers = (core-uvref (core-uvref iclass instance.slots) %class.local-supers) + then (core-cdr supers) + while (core-consp supers) + thereis (matchp (core-car supers)))))) + (matchp (core-instance-class obj))))) + + +(defun core-symptr (obj) + (if (core-nullp obj) + (nil-relative-symbol-address 'nil) + (when (core-uvtypep obj :symbol) + (let ((tag (logand obj target::fulltagmask))) + (unless (eq tag target::fulltag-symbol) + (incf obj (%i- target::fulltag-symbol tag)))) + obj))) + +(defun core-symbol-name (obj) + (when (setq obj (core-symptr obj)) + (copy-from-core (core-q obj target::symbol.pname) :depth 1))) + +(defun core-symbol-value (obj) + (when (setq obj (core-symptr obj)) + (core-q obj target::symbol.vcell))) + +(defun core-symbol-package (obj) + (when (setq obj (core-symptr obj)) + (let ((cell (core-q obj target::symbol.package-predicate))) + (if (core-consp cell) + (core-car cell) + cell)))) + +(defun core-symbol-plist (obj) + (when (setq obj (core-symptr obj)) + (core-cdr (core-q obj target::symbol.plist)))) + +(defun core-all-packages-ptr () + (core-symbol-value (nil-relative-symbol-address '%all-packages%))) + +(defun core-keyword-package () + (core-symbol-value (nil-relative-symbol-address '*keyword-package*))) + +(defun core-symbol-pointers () + (or (core-info-symbol-ptrs (current-core)) + (let ((vector (make-array 1000 :adjustable t :fill-pointer 0))) + (map-core-areas (lambda (obj) + (when (core-symbolp obj) + (vector-push-extend obj vector)))) + (setf (core-info-symbol-ptrs (current-core)) vector)))) + +(defun core-map-symbols (fun) + (loop for sym-ptr across (core-symbol-pointers) do (funcall fun sym-ptr))) + + +(defun core-string= (ptr string &aux (len (length string))) + (assert (core-uvtypep ptr :simple-string)) + (when (eq (core-uvsize ptr) len) + (loop for i from 0 below len + always (eql (core-uvref ptr i) (aref string i))))) + +(defun core-find-package (name &key error) + (when (integerp name) + (when (core-symbolp name) + (setq name (core-q name target::symbol.pname))) + (when (core-uvtypep name :simple-string) + (setq name (copy-from-core name :depth 1)))) + (setq name (string name)) + (or (loop for list-ptr = (core-all-packages-ptr) then (core-cdr list-ptr) + while (core-consp list-ptr) + as pkg-ptr = (core-car list-ptr) + when (loop for names-ptr = (core-uvref pkg-ptr pkg.names) then (core-cdr names-ptr) + while (core-consp names-ptr) + as name-ptr = (core-car names-ptr) + thereis (core-string-equal name-ptr name)) + do (return pkg-ptr)) + (and error (error "No package named ~s" name)))) + +(defun core-package-names (pkg-ptr) + (assert (core-uvtypep pkg-ptr :package)) + (copy-from-core (core-uvref pkg-ptr pkg.names) :depth 2)) + +(defun core-package-name (pkg-ptr) + (assert (core-uvtypep pkg-ptr :package)) + (copy-from-core (core-car (core-uvref pkg-ptr pkg.names)) :depth 1)) + +(defun core-find-symbol (name &optional package) + ;; Unlike cl:find-symbol, this doesn't look for inherited symbols, + ;; you have to get the package right. + (when (integerp name) + (when (core-symbolp name) + (when (null package) + (setq package (core-symbol-package name))) + (setq name (core-q name target::symbol.pname))) + (when (core-uvtypep name :simple-string) + (setq name (copy-from-core name :depth 1)))) + (when (and (null package) (non-nil-symbolp name)) + (setq package (symbol-package name))) + (when (null package) (error "Package is required")) + (let* ((symbol-name (string name)) + (name-len (length symbol-name)) + (pkg-ptr (if (and (integerp package) (core-uvtypep package :package)) + package + (core-find-package (if (packagep package) + (package-name package) + package) + :error t)))) + (multiple-value-bind (primary secondary) (hash-pname symbol-name name-len) + (flet ((findsym (htab-ptr) + (let* ((vec-ptr (core-car htab-ptr)) + (vlen (core-uvsize vec-ptr))) + (loop for idx = (fast-mod primary vlen) then (+ i secondary) + for i = idx then (if (>= idx vlen) (- idx vlen) idx) + as sym = (core-uvref vec-ptr i) + until (eql sym 0) + do (when (and (core-symbolp sym) + (core-string-equal (core-q sym target::symbol.pname) symbol-name)) + (return (if (eq sym (nil-relative-symbol-address 'nil)) + (target-nil-value) + sym))))))) + (or (findsym (core-uvref pkg-ptr pkg.itab)) + (findsym (core-uvref pkg-ptr pkg.etab))))))) + +(defun core-gethash (key-ptr hash-ptr) + (when (core-uvtypep hash-ptr :istruct) + (setq hash-ptr (core-uvref hash-ptr nhash.vector))) + (assert (core-uvtypep hash-ptr :hash-vector)) + (loop for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 + do (when (eq (core-uvref hash-ptr i) key-ptr) + (return (core-uvref hash-ptr (1+ i)))))) + +(defun core-hash-table-count (hash-ptr) + (when (core-uvtypep hash-ptr :istruct) + (setq hash-ptr (core-uvref hash-ptr nhash.vector))) + (assert (core-uvtypep hash-ptr :hash-vector)) + (loop with rehashing = (%fixnum-address-of (%slot-unbound-marker)) + with free = (%fixnum-address-of (%unbound-marker)) + for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 + count (let ((value (core-uvref hash-ptr (1+ i)))) + (when (eq value rehashing) + (error "This table is being rehashed")) + (neq value free)))) + +(defun core-classes-hash-table-ptr () + (or (core-info-classes-hash-table-ptr (current-core)) + (setf (core-info-classes-hash-table-ptr (current-core)) + (core-symbol-value (core-find-symbol '%find-classes%))))) + +(defun core-find-class (name) + (let* ((name-ptr (etypecase name + (integer + (assert (core-symbolp name)) + name) + (symbol (core-find-symbol name)))) + (hash-ptr (core-classes-hash-table-ptr)) + (cell (core-gethash name-ptr hash-ptr)) + (class (and cell (core-uvref cell class-cell-class)))) + (and class (core-uvtypep class :instance) class))) + +(defun core-lfun-names-table-ptr () + (or (core-info-lfun-names-table-ptr (current-core)) + (setf (core-info-lfun-names-table-ptr (current-core)) + (core-symbol-value (core-find-symbol '*lfun-names*))))) + +(defun core-nth-immediate (fn i) + (assert (core-uvtypep fn :function)) + (let ((addr (+ (logandc2 fn target::fulltagmask) target::node-size))) + (core-q addr (%ilsl target::word-shift (+ (core-l addr) i -1))))) + +(defun core-closure-function (fun) + (while (and (core-functionp fun) + (logbitp $lfbits-trampoline-bit (core-lfun-bits fun))) + (setq fun (core-nth-immediate fun 1)) + (when (core-uvtypep fun :simple-vector) + (setq fun (core-uvref fun 0))) + #+gz (assert (core-functionp fun))) + fun) + +(defun core-lfun-name (fn) + (assert (core-functionp fn)) + (flet ((lfun-name (fn) + (or (core-gethash fn (core-lfun-names-table-ptr)) + (let* ((lfbits (core-lfun-bits fn)) + (name (if (and (logbitp $lfbits-gfn-bit lfbits) + (not (logbitp $lfbits-method-bit lfbits))) + (core-uvref (core-nth-immediate fn gf.slots) sgf.name) + (unless (logbitp $lfbits-noname-bit lfbits) + (core-uvref fn (- (core-uvsize fn) 2)))))) + (and name + (not (eql name (%fixnum-address-of (%slot-unbound-marker)))) + (not (core-nullp name)) + name))))) + (or (lfun-name fn) + (let ((inner-fn (core-closure-function fn))) + (and (core-functionp inner-fn) + (not (eql inner-fn fn)) + (lfun-name inner-fn)))))) + +(defun core-list (ptr) + (let ((cars (loop while (core-consp ptr) + collect (core-car ptr) + do (setq ptr (core-cdr ptr))))) + (if (core-nullp ptr) + cars + (nconc cars ptr)))) + +(defun core-all-processes () + (let* ((sym (core-find-symbol 'all-processes)) + (closure (core-uvref sym target::symbol.fcell-cell)) + (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size)) + (imm-end (core-uvsize closure)) + (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx) + when (core-uvtypep imm :value-cell) return imm)) + (val (core-uvref vcell target::value-cell.value-cell)) + (processes (core-list val))) + processes)) + +(defun core-process-name (proc) + (assert (core-uvtypep proc :instance)) + (let ((slots (core-uvref proc ccl::instance.slots))) + (copy-from-core (core-uvref slots 1) :depth 1))) + +(defun core-process-tcr (proc) + (assert (core-uvtypep proc :instance)) + (let* ((slots (core-uvref proc ccl::instance.slots)) + (thread (core-uvref slots 2))) + (core-uvref thread ccl::lisp-thread.tcr))) + +(defun core-find-process-for-id (lwp) + (loop for proc in (core-all-processes) + when (eql lwp (core-q (core-process-tcr proc) target::tcr.native-thread-id)) + return proc)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun core-process-class () + (or (core-info-process-class (current-core)) + (setf (core-info-process-class (current-core)) + (core-find-class 'process)))) + +(defun core-print (obj &optional (stream t) depth) + ;; TODO: could dispatch on core-object-typecode-type... + (cond ((core-nullp obj) (format stream "NIL")) + ((core-symbolp obj) + (core-print-symbol obj stream)) + ((core-uvtypep obj :function) + (core-print-function obj stream)) + ((core-instance-p obj (core-process-class)) + (core-print-process obj stream)) + ((and depth (< (decf depth) 0)) + (format stream "x~x" obj)) + ((core-consp obj) + (loop for sep = "(" then " " + for i from 0 below (or *print-length* 100) + while (core-consp obj) + do (format stream sep) + do (core-print (core-car obj) stream depth) + do (setq obj (core-cdr obj))) + (unless (core-nullp obj) + (format stream " . ") + (core-print obj stream depth)) + (format stream ")")) + (t (format stream "#" + (or (ignore-errors (core-type-string (core-object-type-key obj))) + (core-object-typecode-type obj)) + obj)))) + +(defun core-print-symbol (sym stream) + (let ((package (core-symbol-package sym))) + (cond ((core-nullp package) + (format stream "#:")) + ((eq package (core-keyword-package)) + (format stream ":")) + (t (let ((pkgname (core-package-name package))) + (etypecase pkgname + (unresolved-address (format stream "@~x::" (unresolved-address-address pkgname))) + (string (unless (string-equal pkgname "COMMON-LISP") + (format stream "~a::" pkgname))))))) + (let ((symname (core-symbol-name sym))) + (etypecase symname + (unresolved-address (format stream "@~x" (unresolved-address-address symname))) + (string (format stream "~a" symname))))) + (values)) + +(defun core-lfun-bits (fun) + (let ((unsigned (core-uvref fun (1- (core-uvsize fun))))) + (ash (if (logbitp (1- (* target::node-size 8)) unsigned) + (logior (ash -1 (* target::node-size 8)) unsigned) + unsigned) + (- target::fixnum-shift)))) + + +(defun core-print-function (fun stream) + (let* ((lfbits (core-lfun-bits fun)) + (name (core-lfun-name fun))) + (format stream "#<") + (cond ((or (null name) (core-nullp name)) + (format stream "Anonymous function")) + ((logbitp $lfbits-method-bit lfbits) + (assert (core-uvtypep name :instance)) + (let* ((slot-vector (core-uvref name instance.slots)) + (method-qualifiers (core-uvref slot-vector %method.qualifiers)) + (method-specializers (core-uvref slot-vector %method.specializers)) + (method-name (core-uvref slot-vector %method.name))) + (format stream "Method-Function ") + (core-print method-name stream) + (format stream " ") + (unless (core-nullp method-qualifiers) + (if (core-nullp (core-cdr method-qualifiers)) + (core-print (core-car method-qualifiers) stream) + (core-print method-qualifiers stream)) + (format stream " ")) + ;; print specializer list but print names instead of classes. + (loop for sep = "(" then " " + while (core-consp method-specializers) + do (format stream sep) + do (let ((spec (core-car method-specializers))) + (if (core-uvtypep spec :instance) + (let ((slots (core-uvref spec instance.slots))) + ;; specializer is either a class or a ccl::eql-specializer + (if (eql (core-uvsize slots) 3) + (progn + (format stream "(EQL ") + (core-print (core-uvref slots 2) stream) + (format stream ")")) + (core-print (core-uvref slots %class.name) stream))) + (core-print spec stream))) + do (setq method-specializers (core-cdr method-specializers))) + (unless (core-nullp method-specializers) + (format stream " . ") + (core-print method-specializers stream)) + (format stream ")"))) + (t + (if (logbitp $lfbits-gfn-bit lfbits) + (format stream "Generic Function ") + (format stream "Function ")) + (core-print name stream))) + (format stream " x~x>" fun))) + +(defun core-print-process (proc stream) + (format stream "#<~a ~s LWP(~d) #x~x>" + (core-symbol-name (core-instance-type proc)) + (core-process-name proc) + (core-q (core-process-tcr proc) target::tcr.native-thread-id) + proc)) + +(defun dwim-core-frame-pointer (tcr &optional end) + (let* ((ret1valn (core-q (kernel-global-address 'ret1valaddr))) + (lexprs (list (core-q (kernel-global-address 'lexpr-return)) + (core-q (kernel-global-address 'lexpr-return1v)))) + (stack-area (core-q tcr target::tcr.vs-area)) + (fp (core-q stack-area target::area.high)) + (low (core-q stack-area target::area.low))) + (flet ((validp (pp) + (let ((tra (core-q pp target::lisp-frame.return-address))) + (when (eql tra ret1valn) + (setq tra (core-q pp target::lisp-frame.xtra))) + (or (eql (logand tra target::tagmask) target::tag-tra) + (eql tra 0) + (member tra lexprs))))) + (decf fp (* 2 target::node-size)) + (when (and end (<= low end fp)) + (setq low (- end 8))) + (loop while + (loop for pp downfrom (- fp target::node-size) above low by target::node-size + do (when (eql (core-q pp target::lisp-frame.backptr) fp) + (when (validp pp) + (return (setq fp pp)))))) + fp))) + +(defun core-stack-frame-values (tcr fp) + (let* ((bottom (core-q fp target::lisp-frame.backptr)) + (top (if (eql 0 (core-q fp target::lisp-frame.return-address)) + (+ fp target::xcf.size) + (+ fp (if (eql (core-q fp target::lisp-frame.return-address) + (core-q (kernel-global-address 'ret1valaddr))) + target::lisp-frame.size + target::lisp-frame.xtra)))) + (db-link (loop as db = (core-q tcr target::tcr.db-link) then (core-q db) + until (or (eql db 0) (>= db bottom)) + when (<= top db) return db))) + (loop for vsp from top below bottom by target::node-size + when (eql vsp db-link) + ;; The db-link will be followed by var and val, which we'll just collect normally + do (setq db-link (core-q db-link) vsp (+ vsp target::node-size)) + and collect `(:db-link ,db-link) + collect (core-q vsp)))) + +(defun core-print-call-history (process &key (stream t) origin detailed-p) + (flet ((fp-backlink (fp vs-end) + (let ((backlink (core-q fp target::lisp-frame.backptr))) + (when (or (eql backlink 0) + (<= vs-end backlink) + (<= vs-end (core-q backlink target::lisp-frame.backptr))) + (setq backlink vs-end)) + (assert (< fp backlink)) + backlink)) + (fp-tra (fp) + (let ((tra (core-q fp target::lisp-frame.return-address))) + (if (eql tra (core-q (kernel-global-address 'ret1valaddr))) + (core-q fp target::lisp-frame.xtra) + tra))) + (recover-fn (pc) + (when (and (eql (logand pc target::tagmask) target::tag-tra) + (eql (core-w pc) target::recover-fn-from-rip-word0) + (eql (core-b pc 2) target::recover-fn-from-rip-byte2)) + (+ pc target::recover-fn-from-rip-length + (- (core-l pc target::recover-fn-from-rip-disp-offset) + #x100000000))))) + (format stream "~&") + (core-print process stream) + (let* ((tcr (core-process-tcr process)) + (vs-area (core-q tcr target::tcr.vs-area)) + (vs-end (core-q vs-area target::area.high)) + (valence (core-q tcr target::tcr.valence)) + (fp (or origin + ;; TODO: find the registers in the core file! + (case valence + ;; TCR_STATE_LISP + (0 (let ((xp (core-q tcr target::tcr.suspend-context))) + (format stream "~&") + (if (eql xp 0) + (format stream "Unknown lisp context, guessing frame pointer:") + (core-print (core-q xp (* 10 target::node-size)) stream)) ;; r13 = fn + (if (eql xp 0) + (dwim-core-frame-pointer tcr) + ;; uc_mcontext.gregs[rbp] + (core-q xp (* 15 target::node-size))))) + ;; TCR_STATE_FOREIGN + (1 (format stream "~&In foreign code") + ;; the save-rbp seems to include some non-lisp frames sometimes, + ;; shave them down. + #+no (core-q tcr target::tcr.save-rbp) + (dwim-core-frame-pointer tcr (core-q tcr target::tcr.save-rbp))) + ;; TCR_STATE_EXCEPTION_WAIT + (2 (let ((xp (core-q tcr target::tcr.pending-exception-context))) + ;; regs start at index 5, in this order: + ;; arg_x temp1 ra0 save3 save2 fn save1 save0 arg_y arg_z + ;; rbp temp0 imm1 imm0 nargs rsp rip + (format stream " exception-wait") + (if (zerop xp) + (format stream "~&context unknown") + (let* ((fn (core-q xp (* 10 target::node-size))) + (sp (core-q xp (* 20 target::node-size))) + (ra (core-q sp))) + (if (and (core-functionp fn) + (and (<= fn ra) + (< ra (+ fn (* (core-uvsize fn) target::node-size))))) + (progn + (format stream "~&") + (core-print fn stream) + (format stream " + ~d" (- ra fn))) + (progn + (format stream "~&top of stack = x~x, r13 = " ra) + (core-print fn stream))))) + (unless (zerop xp) + (core-q xp (* 15 target::node-size)))))) + (error "Cannot find frame pointer")))) + (unless (<= (core-q vs-area target::area.low) fp vs-end) + (error "frame pointer x~x is not in stack area" fp)) + (loop while (< fp vs-end) for pc = (fp-tra fp) for fun = (recover-fn pc) + do (format stream "~&fp: x~x pc: x~x : " fp pc) + do (cond (fun + (core-print fun stream) + (format stream " + ~d " (- pc fun))) + ((eql pc 0) ;; exception frame + (let* ((nominal-function (core-q fp target::xcf.nominal-function)) + (obj (core-q fp target::xcf.containing-object))) + (when (core-functionp nominal-function) + (format stream "exception ") + (core-print nominal-function stream) + (format stream " + ~d" + (if (eq (- obj target::fulltag-misc) + (- nominal-function target::fulltag-function)) + (- (core-q fp target::xcf.relative-pc) target::tag-function) + (let ((pc (core-q fp target::xcf.ra0))) + (when (eql nominal-function (recover-fn pc)) + (- pc nominal-function)))))))) + ((eql pc (core-q (kernel-global-address 'lexpr-return))) + (format stream "lexpr return")) + ((eql pc (core-q (kernel-global-address 'lexpr-return1v))) + (format stream "lexpr1v return")) + (t + (if (eql (logand pc target::tagmask) target::tag-tra) + (format stream " # couldn't recover function") + (unless (core-nullp pc) + (format stream "bad frame!"))) + ;; can't trust backlink + (return))) + ;; TODO: print stack addressses + do (when detailed-p + (loop for val in (core-stack-frame-values tcr fp) + do (format stream "~& ") + do (if (integerp val) + (handler-case (core-print val stream) + (error () (format stream "#" val))) + (format stream "~a x~x" (car val) (cadr val))))) + do (setq fp (fp-backlink fp vs-end)))))) + + +) ; :x8664-target + Index: /branches/qres/ccl/library/cover.lisp =================================================================== --- /branches/qres/ccl/library/cover.lisp (revision 13564) +++ /branches/qres/ccl/library/cover.lisp (revision 13564) @@ -0,0 +1,856 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Code coverage reporting facility, originally inspired by SBCL's sb-cover API. + +(in-package :ccl) + +(export '(*compile-code-coverage* + report-coverage + reset-coverage + clear-coverage + save-coverage-in-file + restore-coverage-from-file + + save-coverage + restore-coverage + combine-coverage + read-coverage-from-file + write-coverage-to-file + + coverage-statistics + coverage-source-file + coverage-expressions-total + coverage-expressions-entered + coverage-expressions-covered + coverage-unreached-branches + coverage-code-forms-total + coverage-code-forms-covered + coverage-functions-total + coverage-functions-fully-covered + coverage-functions-partly-covered + coverage-functions-not-entered + + without-compiling-code-coverage)) + +(defconstant $not-executed-style 2) +(defconstant $totally-covered-style 5) +(defconstant $partially-covered-style 6) + +(defparameter *file-coverage* ()) +(defparameter *coverage-subnotes* (make-hash-table :test #'eq)) +(defparameter *emitted-code-notes* (make-hash-table :test #'eq)) +(defparameter *entry-code-notes* (make-hash-table :test #'eq)) + + +(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-")) + alist) + +;; Wrapper in case we ever want to do dwim on raw alists +(defun coverage-state-alist (coverage) + (etypecase coverage + (coverage-state (%coverage-state-alist coverage)))) + + +(defun file-coverage-file (entry) + (car entry)) + +(defun file-coverage-functions (entry) + (cadr entry)) + +(defun file-coverage-toplevel-functions (entry) + (cddr entry)) + +(defun coverage-subnotes (note) ;; reversed parent chain + (gethash note *coverage-subnotes*)) + +(defun emitted-code-note-p (note) + (gethash note *emitted-code-notes*)) + +(defun entry-code-note-p (note) + (gethash note *entry-code-notes*)) + +(defun map-function-coverage (lfun fn &optional refs) + (let ((refs (cons lfun refs))) + (declare (dynamic-extent refs)) + (lfunloop for imm in lfun + when (code-note-p imm) + do (funcall fn imm) + when (and (functionp imm) + (not (memq imm refs))) + do (map-function-coverage imm fn refs)))) + +(defun get-function-coverage (fn refs) + (let ((entry (function-entry-code-note fn)) + (refs (cons fn refs))) + (declare (dynamic-extent refs)) + (when entry + (assert (eq fn (gethash entry *entry-code-notes* fn))) + (setf (gethash entry *entry-code-notes*) fn)) + (nconc + (and entry (list fn)) + (lfunloop for imm in fn + when (code-note-p imm) + do (setf (gethash imm *emitted-code-notes*) t) + when (and (functionp imm) + (not (memq imm refs))) + nconc (get-function-coverage imm refs))))) + +(defun get-coverage () + (setq *file-coverage* nil) + (clrhash *coverage-subnotes*) + (clrhash *emitted-code-notes*) + (clrhash *entry-code-notes*) + (loop for data in *code-covered-functions* + when (consp data) + do (destructuring-bind (file . toplevel-functions) data + (push (list* file + ;; Duplicates are possible if you have multiple instances of + ;; (load-time-value (foo)) where (foo) returns an lfun. + ;; CL-PPCRE does that. + (delete-duplicates + (loop for fn across toplevel-functions + nconc (get-function-coverage fn nil))) + toplevel-functions) + *file-coverage*))) + ;; Now get subnotes, including un-emitted ones. + (loop for note being the hash-key of *emitted-code-notes* + do (loop for n = note then parent as parent = (code-note-parent-note n) + while parent + do (pushnew n (gethash parent *coverage-subnotes*)) + until (emitted-code-note-p parent)))) + +#+debug +(defun show-notes (note) + (when (functionp note) + (setq note (function-entry-code-note note))) + (labels ((show (note indent label) + (dotimes (i indent) (write-char #\space)) + (format t "~a ~a" label note) + (unless (emitted-code-note-p note) + (format t " [Not Emitted]")) + (when (entry-code-note-p note) + (format t " (Entry to ~s)" (entry-code-note-p note))) + (format t "~%") + (when (code-note-p note) + (loop with subindent = (+ indent 3) + for sub in (coverage-subnotes note) as i upfrom 1 + do (show sub subindent (format nil "~a~d." label i)))))) + (show note 0 ""))) + +(defun assoc-by-filename (path alist) + (let* ((true-path (probe-file path))) + (find-if #'(lambda (data) + (or (equalp (car data) path) + (and true-path (equalp (probe-file (car data)) true-path)))) + alist))) + +(defun covered-functions-for-file (path) + (cdr (assoc-by-filename path *code-covered-functions*))) + +(defun clear-coverage () + "Clear all files from the coverage database. The files will be re-entered +into the database when the FASL files (produced by compiling with +CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the +image." + (setq *code-covered-functions* nil)) + +(defun reset-function-coverage (lfun) + (map-function-coverage lfun #'(lambda (note) + (setf (code-note-code-coverage note) nil)))) + +(defun reset-coverage () + "Reset all coverage data back to the `Not executed` state." + (loop for data in *code-covered-functions* + do (typecase data + (cons ;; (source-file . functions) + (loop for fn across (cdr data) + do (reset-function-coverage fn))) + (function (reset-function-coverage data))))) + +;; Name used for consistency checking across file save/restore +(defun function-covered-name (fn) + (let ((name (function-name fn))) + (and (symbolp name) + (symbol-package name) + name))) + + +(defun coverage-mismatch (why &rest args) + ;; Throw to somebody who knows what file we're working on. + (throw 'coverage-mismatch (cons why args))) + +(defmacro with-coverage-mismatch-catch ((saved-file) &body body) + `(let ((file ,saved-file) + (err (catch 'coverage-mismatch ,@body nil))) + (when err + (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err))))) + + +;; (name . #(i1 i2 ...)) where in is either an index or (index . subfncoverage). +(defun save-function-coverage (fn &optional (refs ())) + (let ((refs (cons fn refs))) + (declare (dynamic-extent refs)) + (cons (function-covered-name fn) + (lfunloop for imm in fn as i upfrom 0 + when (and (code-note-p imm) + (code-note-code-coverage imm)) + collect i into list + when (and (functionp imm) (not (memq imm refs))) + collect (cons i (save-function-coverage imm refs)) into list + finally (return (and list (coerce list 'vector))))))) + +(defun copy-function-coverage (fn-data) + (cons (car fn-data) + (and (cdr fn-data) + (map 'vector #'(lambda (imm-data) + (if (consp imm-data) + (cons (car imm-data) + (copy-function-coverage (cdr imm-data))) + imm-data)) + (cdr fn-data))))) + +(defun restore-function-coverage (fn saved-fn-data &optional (refs ())) + (let* ((refs (cons fn refs)) + (saved-name (car saved-fn-data)) + (saved-imms (cdr saved-fn-data)) + (nimms (length saved-imms)) + (n 0)) + (declare (dynamic-extent refs)) + (unless (equalp saved-name (function-covered-name fn)) + (coverage-mismatch "had function ~s now have ~s" saved-name fn)) + (lfunloop for imm in fn as i upfrom 0 + when (code-note-p imm) + do (let* ((next (and (< n nimms) (aref saved-imms n)))) + (when (if (consp next) (<= (car next) i) (and next (< next i))) + (coverage-mismatch "in ~s" fn)) + (when (setf (code-note-code-coverage imm) + (and (eql next i) 'restored)) + (incf n))) + when (and (functionp imm) (not (memq imm refs))) + do (let* ((next (and (< n nimms) (aref saved-imms n)))) + (unless (and (consp next) (eql (car next) i)) + (coverage-mismatch "in ~s" fn)) + (restore-function-coverage imm (cdr next) refs) + (incf n))))) + + +(defun add-function-coverage (fn-data new-fn-data) + (let* ((fn-name (car fn-data)) + (imms (cdr fn-data)) + (new-fn-name (car new-fn-data)) + (new-imms (cdr new-fn-data))) + (flet ((kar (x) (if (consp x) (%car x) x))) + (declare (inline kar)) + (unless (equalp fn-name new-fn-name) + (coverage-mismatch "function ~s vs. ~s" fn-name new-fn-name)) + (when new-imms + (loop for new across new-imms + as old = (find (kar new) imms :key #'kar) + if (and (null old) (fixnump new)) + collect new into extras + else do (unless (eql old new) + (if (and (consp new) (consp old)) + (add-function-coverage (cdr old) (cdr new)) + (coverage-mismatch "in function ~s" fn-name))) + finally (when extras + (setf (cdr fn-data) + (sort (concatenate 'vector imms extras) #'< :key #'kar)))))) + fn-data)) + + +(defun save-coverage () + "Returns a snapshot of the current coverage state" + (make-coverage-state + :alist (loop for data in *code-covered-functions* + when (consp data) + collect (cons (car data) + (map 'vector #'save-function-coverage (cdr data)))))) + +(defun combine-coverage (coverage-states) + (let ((result nil)) + (map nil + (lambda (coverage-state) + (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state) + for result-fns = (cdr (assoc-by-filename saved-file result)) + do (with-coverage-mismatch-catch (saved-file) + (cond ((null result-fns) + (push (cons saved-file + (map 'vector #'copy-function-coverage saved-fns)) + result)) + ((not (eql (length result-fns) (length saved-fns))) + (coverage-mismatch "different function counts")) + (t + (loop for result-fn across result-fns + for saved-fn across saved-fns + do (add-function-coverage result-fn saved-fn))))))) + coverage-states) + (make-coverage-state :alist (nreverse result)))) + + +(defun restore-coverage (coverage-state) + "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE." + (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state) + for fns = (covered-functions-for-file saved-file) + do (with-coverage-mismatch-catch (saved-file) + (cond ((null fns) + (warn "Couldn't restore saved coverage for ~s, no matching file present" + saved-file)) + ((not (eql (length fns) (length saved-fns))) + (coverage-mismatch "had ~s functions, now have ~s" + (length saved-fns) (length fns))) + (t + (map nil #'restore-function-coverage fns saved-fns)))))) + +(defvar *loading-coverage*) + +(defun write-coverage-to-file (coverage pathname) + "Write the coverage state COVERAGE in the file designated by PATHNAME" + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (with-standard-io-syntax + (let ((*package* (pkg-arg "CCL"))) + (format stream "(in-package :ccl)~%~s~%" + `(setq *loading-coverage* ',(coverage-state-alist coverage))))) + (values))) + +(defun read-coverage-from-file (pathname) + " Return the coverage state saved in the file. Doesn't affect the current coverage state." + (let ((*package* (pkg-arg "CCL")) + (*loading-coverage* :none)) + (load pathname) + (when (eq *loading-coverage* :none) + (error "~s doesn't seem to be a saved coverage file" pathname)) + (make-coverage-state :alist *loading-coverage*))) + +(defun save-coverage-in-file (pathname) + "Save the current coverage state in the file designed by PATHNAME" + (write-coverage-to-file (save-coverage) pathname)) + +(defun restore-coverage-from-file (pathname) + "Set the current coverage state from the file designed by PATHNAME" + (restore-coverage (read-coverage-from-file pathname))) + +(defun common-coverage-directory () + (let* ((host :unknown) + (rev-dir ())) + (loop for data in *code-covered-functions* + when (consp data) + do (let ((file (probe-file (car data)))) + (when file + (cond ((eq host :unknown) + (setq host (pathname-host file) + rev-dir (reverse (pathname-directory file)))) + ((not (equalp host (pathname-host file))) + (return-from common-coverage-directory nil)) + (t + (let* ((path (pathname-directory file)) + (dir-len (length rev-dir)) + (len (length path))) + (if (< len dir-len) + (setq rev-dir (nthcdr (- dir-len len) rev-dir)) + (setq path (subseq path 0 dir-len))) + (loop for pp on (reverse path) until (equalp pp rev-dir) + do (pop rev-dir)))))))) + (unless (eq host :unknown) + (make-pathname :host host :directory (reverse rev-dir))))) + + +(defstruct (coverage-statistics (:conc-name "COVERAGE-")) + source-file + expressions-total + expressions-entered + expressions-covered + unreached-branches + code-forms-total + code-forms-covered + functions-total + functions-fully-covered + functions-partly-covered + functions-not-entered) + +(defun coverage-statistics () + (let* ((*file-coverage* nil) + (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) + (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) + (*entry-code-notes* (make-hash-table :test #'eq :shared nil))) + (get-coverage) + (loop for coverage in *file-coverage* + as stats = (make-coverage-statistics :source-file (file-coverage-file coverage)) + do (map nil (lambda (fn) + (let ((note (function-entry-code-note fn))) + (when note (precompute-note-coverage note)))) + (file-coverage-toplevel-functions coverage)) + do (destructuring-bind (total entered %entered covered %covered) + (count-covered-sexps coverage) + (declare (ignore %entered %covered)) + (setf (coverage-expressions-total stats) total) + (setf (coverage-expressions-entered stats) entered) + (setf (coverage-expressions-covered stats) covered)) + do (let ((count (count-unreached-branches coverage))) + (setf (coverage-unreached-branches stats) count)) + do (destructuring-bind (total covered %covered) (count-covered-aexps coverage) + (declare (ignore %covered)) + (setf (coverage-code-forms-total stats) total) + (setf (coverage-code-forms-covered stats) covered)) + do (destructuring-bind (total fully %fully partly %partly never %never) + (count-covered-entry-notes coverage) + (declare (ignore %fully %partly %never)) + (setf (coverage-functions-total stats) total) + (setf (coverage-functions-fully-covered stats) fully) + (setf (coverage-functions-partly-covered stats) partly) + (setf (coverage-functions-not-entered stats) never)) + collect stats))) + + +(defun report-coverage (output-file &key (external-format :default) (statistics t) (html t)) + "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE +and, in the same directory, one html file for each instrumented source file that has been +loaded in the current session. +The external format of the source files can be specified with the EXTERNAL-FORMAT parameter. +If :STATISTICS is non-nil, a CSV file is generated with a table. If +:STATISTICS is a filename, that file is used, else 'statistics.csv' is +written to the output directory. +" + (let* ((paths) + (directory (make-pathname :name nil :type nil :defaults output-file)) + (coverage-dir (common-coverage-directory)) + (*file-coverage* nil) + (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) + (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) + (*entry-code-notes* (make-hash-table :test #'eq :shared nil)) + (index-file (and html (merge-pathnames output-file "index.html"))) + (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) + (pathnamep statistics)) + (merge-pathnames statistics "statistics.csv") + "statistics.csv") + output-file)))) + (get-coverage) + (ensure-directories-exist directory) + (loop for coverage in *file-coverage* + as file = (or (probe-file (file-coverage-file coverage)) + (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage)) + nil)) + do (when file + (let* ((src-name (enough-namestring file coverage-dir)) + (html-name (substitute + #\_ #\: (substitute + #\_ #\. (substitute + #\_ #\/ (namestring-unquote src-name)))))) + (when html + (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory) + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (report-file-coverage index-file coverage stream external-format))) + (push (list* src-name html-name coverage) paths)))) + (when (null paths) + (error "No code coverage data available")) + (setq paths (sort paths #'(lambda (path1 path2) + (let* ((f1 (car path1)) + (f2 (car path2))) + (or (string< (directory-namestring f1) + (directory-namestring f2)) + (and (equal (pathname-directory f1) + (pathname-directory f2)) + (string< (file-namestring f1) + (file-namestring f2)))))))) + (if html + (with-open-file (html-stream index-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (if stats-file + (with-open-file (stats-stream stats-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (report-coverage-to-streams paths html-stream stats-stream)) + (report-coverage-to-streams paths html-stream nil))) + (if stats-file + (with-open-file (stats-stream stats-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (report-coverage-to-streams paths nil stats-stream)) + (error "One of :HTML or :STATISTICS must be non-nil"))) + (values index-file stats-file))) + +(defun report-coverage-to-streams (paths html-stream stats-stream) + (when html-stream (write-coverage-styles html-stream)) + (unless paths + (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?") + (when html-stream (format html-stream "

No code coverage data found.

~%")) + (when stats-stream (format stats-stream "No code coverage data found.~%")) + (return-from report-coverage-to-streams)) + (when html-stream (format html-stream "")) + (coverage-stats-head html-stream stats-stream) + (loop for prev = nil then src-name + for (src-name report-name . coverage) in paths + for even = nil then (not even) + do (when (or (null prev) + (not (equal (pathname-directory (pathname src-name)) + (pathname-directory (pathname prev))))) + (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name)))) + (when html-stream (format html-stream "~%" dir)) + (when stats-stream (format stats-stream "~a~%" dir)))) + do (coverage-stats-data html-stream stats-stream coverage even report-name src-name)) + (when html-stream (format html-stream "
~A
"))) + +(defun precompute-note-coverage (note &optional refs) + (when note + (let ((subnotes (coverage-subnotes note)) + (refs (cons note refs))) + (declare (dynamic-extent refs)) + (loop for sub in subnotes + when (member sub refs) + do (break "Circularity!!") + unless (member sub refs) + do (precompute-note-coverage sub refs)) + (when (and (or (not (emitted-code-note-p note)) + (code-note-code-coverage note)) + (loop for sub in subnotes + always (or (eq 'full (code-note-code-coverage sub)) + (entry-code-note-p sub)))) + (setf (code-note-code-coverage note) 'full))))) + + +(defun fill-with-text-style (coverage location-note styles) + (let ((style (case coverage + ((full) $totally-covered-style) + ((nil) $not-executed-style) + (t $partially-covered-style)))) + (fill styles style + :start (source-note-start-pos location-note) + :end (source-note-end-pos location-note)))) + +(defun update-text-styles (note styles) + (let ((source (code-note-source-note note))) + (when source + (fill-with-text-style (code-note-code-coverage note) source styles)) + (unless (and (emitted-code-note-p note) + (memq (code-note-code-coverage note) '(nil full)) + ;; If not a source note, descend in case have some subnotes + ;; that can be shown + source) + (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) + do (update-text-styles sub styles))))) + +(defun entry-note-unambiguous-source (entry-note) + ;; Return the nearest containing source note provided it can be done unambiguously. + (loop for n = entry-note then parent until (code-note-source-note n) + as parent = (code-note-parent-note n) + do (unless (and parent + (labels ((no-other-entry-subnotes (n refs) + (let ((subs (coverage-subnotes n)) + (refs (cons n refs))) + (declare (dynamic-extent refs)) + (loop for sub in subs + always (or (memq sub refs) + (eq sub entry-note) + (and (not (entry-code-note-p sub)) + (no-other-entry-subnotes sub refs))))))) + (no-other-entry-subnotes parent ()))) + (return nil)) + finally (return (code-note-source-note n)))) + +(defun colorize-source-note (note styles) + ;; Change coverage flag to 'full if all subforms are covered. + (precompute-note-coverage note) + ;; Now actually change text styles, from outside in. + ;; But first, a special kludge: + ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function " + ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner + ;; function got executed. However, suppose have a macro "(setq-fun foo (x) x)" that + ;; expanded into the above, there isn't a clear way to show the distinction between + ;; just referencing the inner fn and executing it. In practice, the colorization + ;; based on the inner function is more interesting -- consider for example DEFUN, + ;; nobody cares whether the defun form itself got executed. + ;; So when showing the colorization of an inner function, we usurp the whole nearest source + ;; form, provided it can be done unambiguously. + (let ((n (entry-note-unambiguous-source note))) + (when n + (fill-with-text-style (code-note-code-coverage note) n styles))) + (update-text-styles note styles)) + +(defun function-source-form-note (fn) + ;; Find the outermost source form containing the fn. + (loop with sn = nil + for n = (function-entry-code-note fn) then (code-note-parent-note n) + do (when (null n) (return nil)) + do (when (setq sn (code-note-source-note n)) + (loop for s = (source-note-source sn) while (source-note-p s) + do (setq sn s)) + (return sn)))) + + +(defun colorize-function (fn styles &optional refs) + (let* ((note (function-entry-code-note fn)) + (source (function-source-form-note fn)) + (refs (cons fn refs))) + (declare (dynamic-extent refs)) + ;; Colorize the body of the function + (when note + (colorize-source-note note styles)) + ;; And now any subfunction references + (lfunloop for imm in fn + when (and (functionp imm) + (not (memq imm refs)) + ;; Make sure this fn is in the source we're currently looking at. + ;; It might not be, if it is referenced via (load-time-value (foo)) + ;; where (foo) returns an lfun from some different source entirely. + ;; CL-PPCRE does that. + (or (null source) + (eq source (function-source-form-note imm)) + #+debug (progn + (warn "Ignoring ref to ~s from ~s" imm fn) + nil))) + do (colorize-function imm styles refs)))) + +(defun report-file-coverage (index-file coverage html-stream external-format) + "Print a code coverage report of FILE into the stream HTML-STREAM." + (format html-stream "") + (write-coverage-styles html-stream) + (format html-stream "") + (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format) + (let ((string (make-string (file-length s)))) + (read-sequence string s) + string))) + (styles (make-array (length source) + :initial-element 0 + :element-type '(unsigned-byte 2)))) + (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage)) + (print-file-coverage-report index-file html-stream coverage styles source) + (format html-stream ""))) + +(defun print-file-coverage-report (index-file html-stream coverage styles source) + (let ((*print-case* :downcase)) + (format html-stream "

Coverage report: ~a
~%

~%" + (native-translated-namestring (make-pathname :name (pathname-name index-file) + :type (pathname-type index-file))) + (file-coverage-file coverage)) + (format html-stream "") + (coverage-stats-head html-stream nil) + (coverage-stats-data html-stream nil coverage) + (format html-stream "
") + + (format html-stream "
Key
~%") + (format html-stream "
Fully covered - every single instruction executed
" $totally-covered-style) + (format html-stream "
Partly covered - entered but some subforms not executed
" $partially-covered-style) + (format html-stream "
Never entered - not a single instruction executed
" $not-executed-style) + (format html-stream "

~%") + + (flet ((line (line) + (unless (eql line 0) + (format html-stream "")) + (incf line) + (format html-stream "
~%
~A
 " line) + line)) + (loop with line = (line 0) with col = 0 + for last-style = nil then style + for char across source + for style across styles + do (unless (eq style last-style) + (when last-style + (format html-stream "")) + (format html-stream "" style)) + do (case char + ((#\Newline) + (setq style nil) + (setq col 0) + (setq line (line line))) + ((#\Space) + (incf col) + (write-string " " html-stream)) + ((#\Tab) + (dotimes (i (- 8 (mod col 8))) + (incf col) + (write-string " " html-stream))) + (t + (incf col) + (if (alphanumericp char) + (write-char char html-stream) + (format html-stream "&#~D;" (char-code char)))))) + (format html-stream "
")))) + + +(defun coverage-stats-head (html-stream stats-stream) + (when html-stream + (format html-stream "") + (format html-stream "Expressions") + (format html-stream "Branches") + (format html-stream "Code Forms") + (format html-stream "Functions") + (format html-stream "~{~A~}" + '("Source file" + ;; Expressions + "Total" "Entered" "% entered" "Fully covered" "% fully covered" + ;; Branches + "total unreached" + ;; Code forms + "Total" "Covered" "% covered" + ;; Functions + "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered"))) + (when stats-stream + (format stats-stream "~{~a~^,~}" + `("Source file" + "Expressions Total" "Expressions Entered" "% Expressions Entered" + "Unreached Branches" + "Code Forms Total" "Code Forms Covered" "% Code Forms Covered" + "Functions Total" "Functions Fully Covered" "% Functions Fully Covered" + "Functions Partly Covered" "% Functions Partly Covered" + "Functions Not Entered" "% Functions Not Entered")))) + +(defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name) + (when html-stream + (format html-stream "" evenp) + (if report-name + (format html-stream "~a" report-name src-name) + (format html-stream "~a" (file-coverage-file coverage)))) + (when stats-stream + (format stats-stream "~a," (file-coverage-file coverage))) + + (let ((exp-counts (count-covered-sexps coverage))) + (when html-stream + (format html-stream "~{~:[-~;~:*~a~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" exp-counts)) + (when stats-stream + (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) + + (let ((count (count-unreached-branches coverage))) + (when html-stream + (format html-stream "~:[-~;~:*~a~]" count)) + (when stats-stream + (format stats-stream "~:[~;~:*~a~]," count))) + + (let ((exp-counts (count-covered-aexps coverage))) + (when html-stream + (format html-stream "~{~:[-~;~:*~a~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" exp-counts)) + (when stats-stream + (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) + + (destructuring-bind (total . counts) (count-covered-entry-notes coverage) + (when html-stream + (format html-stream "~:[-~;~:*~a~]~{~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" total counts)) + (when stats-stream + (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts)))) + +(defun map-coverage-entry-notes (coverage fn) + (map nil #'(lambda (function) + (let ((note (function-entry-code-note function))) + (when (and note + ;; Ignore toplevel functions created by the compiler. + (or (code-note-source-note note) + (code-note-parent-note note))) + (funcall fn note)))) + (file-coverage-functions coverage))) + + +(defun count-covered-entry-notes (coverage) + (let ((fully 0) (partly 0) (never 0) (total 0)) + (map-coverage-entry-notes + coverage + #'(lambda (note) + (incf total) + (case (code-note-code-coverage note) + ((full) (incf fully)) + ((nil) (incf never)) + (t (incf partly))))) + (if (> total 0) + (list total + fully (* 100.0 (/ fully total)) + partly (* 100.0 (/ partly total)) + never (* 100.0 (/ never total))) + '(0 0 -- 0 -- 0 --)))) + +(defun count-covered-aexps (coverage) + (let ((covered 0) (total 0)) + (map-coverage-entry-notes + coverage + (lambda (note) + (labels ((rec (note) + (when (emitted-code-note-p note) + (incf total) + (when (code-note-code-coverage note) + (incf covered))) + (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) do (rec sub)))) + (rec note)))) + (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) + +(defun count-covered-sexps (coverage) + ;; Count the number of source expressions that have been entered (regardless + ;; of whether or not they are completely covered). + (let ((entered 0) (covered 0) (total 0)) + (map-coverage-entry-notes + coverage + (lambda (note) + (labels ((rec (note) + (when (code-note-source-note note) + #+debug (format t "~&~s" note) + (incf total) + (when (code-note-code-coverage note) + (incf entered) + (when (eq (code-note-code-coverage note) 'full) + (incf covered)))) + (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) do (rec sub)))) + (rec note)))) + (list total + entered (if (> total 0) (* 100.0d0 (/ entered total)) '--) + covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) + +(defun count-unreached-branches (coverage) + ;; Count the number of maximal unentered forms + (let ((count 0)) + (map-coverage-entry-notes + coverage + (lambda (note) + (labels ((rec (note parent) + (case (code-note-code-coverage note) + ((full) nil) + ((nil) (when parent (incf count))) + (t (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) do (rec sub note)))))) + (rec note nil)))) + count)) + +(defun write-coverage-styles (html-stream) + (format html-stream "" + $not-executed-style + $partially-covered-style + $totally-covered-style + )) Index: /branches/qres/ccl/library/darwinppc-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/darwinppc-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/darwinppc-syscalls.lisp (revision 13564) @@ -0,0 +1,298 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::exit 1 (:int) :void ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fork 2 () :void) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::read 3 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::write 4 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::wait4 7 (:unsigned-fullword :address :signed-fullword :address) :unsigned-fullword ) + ; 8 is old creat +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::link 9 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::unlink 10 (:address) :signed-fullword ) + ; 11 is obsolete execv +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chdir 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lchown 16 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpid 20 () :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getuid 24 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::accept 30 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpeername 31 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getsockname 32 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sync 36 () :unsigned-fullword ) + ; 38 is old stat +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::pipe 42 () :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getgid 47 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::socket 97 (:unsigned-fullword :unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::connect 98 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::bind 104 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::listen 106 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::gettimeofday 116 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::rename 128 (:address :address) :signed-fullword) + ; 129 is old truncate + ; 130 is old ftruncate +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::socketpair 135 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::rmdir 137 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mount 167 (:address :address :unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::stat 188 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fstat 189 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lstat 190 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lseek 199 (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::truncate 200 (:address :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-doubleword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::poll 230 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn + ; 17 is obsolete sbreak + ; 18 is old getfsstat + ; 19 is old lseek + ; 21 is obsolete mount + ; 22 is obsolete umount +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ptrace 26 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::access 33 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chflags 34 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchflags 35 () ) + ; 40 is old lstat +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getegid 43 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::profil 44 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ktrace 45 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigaction 46 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigprocmask 48 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getlogin 49 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setlogin 50 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::acct 51 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigpending 52 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigaltstack 53 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::reboot 55 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::revoke 56 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::symlink 57 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::execve 59 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::umask 60 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chroot 61 () ) + ; 62 is old fstat + ; 63 is unused + ; 64 is old getpagesize +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msync 65 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::vfork 66 () ) + ; 67 is obsolete vread + ; 68 is obsolete vwrite +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sbrk 69 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sstk 70 () ) + ; 71 is old mmap + ; 72 is obsolete vadvise +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::munmap 73 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mprotect 74 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::madvise 75 () ) + ; 76 is obsolete vhangup + ; 77 is obsolete vlimit +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mincore 78 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getgroups 79 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setgroups 80 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpgrp 81 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setpgid 82 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setitimer 83 () ) + ; 84 is old wait +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::swapon 85 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getitimer 86 () ) + ; 87 is old gethostname + ; 88 is old sethostname +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getdtablesize 89 () ) + + + ; 94 is obsolete setdopt +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setpriority 96 () ) + ; 99 is old accept +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpriority 100 () ) + ; 101 is old send + ; 102 is old recv +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigreturn 103 () ) + ; 107 is obsolete vtimes + ; 108 is old sigvec + ; 109 is old sigblock + ; 110 is old sigsetmask +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigsuspend 111 () ) + ; 112 is old sigstack + ; 113 is old recvmsg + ; 114 is old sendmsg + ; 115 is obsolete vtrace + ; 119 is obsolete resuba +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::readv 120 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::writev 121 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::settimeofday 122 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchown 123 () ) + ; 125 is old recvfrom + ; 126 is old setreuid + ; 127 is old setregid +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::flock 131 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mkfifo 132 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::utimes 138 () ) + ; 139 is unused +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::adjtime 140 () ) + ; 141 is old getpeername + ; 142 is old gethostid + ; 143 is old sethostid + ; 144 is old getrlimit + ; 145 is old setrlimit + ; 146 is old killpg +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setsid 147 () ) + ; 148 is obsolete setquota + ; 149 is obsolete quota + ; 150 is old getsockname + ; 151 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setprivexec 152 () ) + ; 153 is reserved + ; 154 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::nfssvc 155 () ) + ; 156 is old getdirentries +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::statfs 157 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fstatfs 158 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::unmount 159 () ) + ; 160 is obsolete async_daemon +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getfh 161 () ) + ; 162 is old getdomainname + ; 163 is old setdomainname + ; 164 is obsolete pcfs_mount +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::quotactl 165 () ) + ; 166 is obsolete exportfs + + ; 168 is obsolete ustat + ; 169 is unused +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::table 170 () ) + ; 171 is old wait_3 + ; 172 is obsolete rpause + ; 173 is unused + ; 174 is obsolete getdents +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::gc_control 175 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::add_profil 176 () ) + ; 177 is unused + ; 178 is unused + ; 179 is unused +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::kdebug_trace 180 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setegid 182 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::seteuid 183 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_bmapv 184 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_markv 185 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_segclean 186 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_segwait 187 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::pathconf 191 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fpathconf 192 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getrlimit 194 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setrlimit 195 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getdirentries 196 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mmap 197 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::__syscall 198 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::__sysctl 202 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mlock 203 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::munlock 204 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::undelete 205 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATsocket 206 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATgetmsg 207 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATputmsg 208 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPsndreq 209 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPsndrsp 210 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPgetreq 211 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPgetrsp 212 () ) + ; 213-215 are reserved for AppleTalk +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mkcomplex 216 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::statv 217 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lstatv 218 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fstatv 219 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getattrlist 220 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setattrlist 221 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getdirentriesattr 222 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::exchangedata 223 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::checkuseraccess 224 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::searchfs 225 () ) + + ; 226 - 230 are reserved for HFS expansion + ; 231 - 249 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::minherit 250 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semsys 251 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgsys 252 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmsys 253 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semctl 254 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semget 255 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semop 256 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semconfig 257 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgctl 258 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgget 259 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgsnd 260 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgrcv 261 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmat 262 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmctl 263 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmdt 264 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmget 265 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shm_open 266 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shm_unlink 267 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_open 268 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_close 269 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_unlink 270 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_wait 271 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_trywait 272 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_post 273 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_getvalue 274 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_init 275 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_destroy 276 () ) + ; 277 - 295 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::load_shared_file 296 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::reset_shared_file 297 () ) + ; 298 - 323 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mlockall 324 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::munlockall 325 () ) + ; 326 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::issetugid 327 () ) +) Index: /branches/qres/ccl/library/darwinx8632-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/darwinx8632-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/darwinx8632-syscalls.lisp (revision 13564) @@ -0,0 +1,296 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::exit 1 (:int) :void ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fork 2 () :void) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::read 3 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::write 4 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::wait4 7 (:unsigned-fullword :address :signed-fullword :address) :unsigned-fullword ) + ; 8 is old creat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::link 9 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::unlink 10 (:address) :signed-fullword ) + ; 11 is obsolete execv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chdir 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lchown 16 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpid 20 () :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getuid 24 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::accept 30 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpeername 31 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getsockname 32 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sync 36 () :unsigned-fullword ) + ; 38 is old stat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::pipe 42 () :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getgid 47 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::socket 97 (:unsigned-fullword :unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::connect 98 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::bind 104 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::listen 106 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::gettimeofday 116 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::rename 128 (:address :address) :signed-fullword) + ; 129 is old truncate + ; 130 is old ftruncate +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::socketpair 135 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::rmdir 137 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mount 167 (:address :address :unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::stat 188 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fstat 189 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lstat 190 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lseek 199 (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::truncate 200 (:address :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::poll 230 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn + ; 17 is obsolete sbreak + ; 18 is old getfsstat + ; 19 is old lseek + ; 21 is obsolete mount + ; 22 is obsolete umount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ptrace 26 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::access 33 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chflags 34 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchflags 35 () ) + ; 40 is old lstat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getegid 43 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::profil 44 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ktrace 45 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigaction 46 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigprocmask 48 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getlogin 49 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setlogin 50 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::acct 51 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigpending 52 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigaltstack 53 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::reboot 55 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::revoke 56 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::symlink 57 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::execve 59 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::umask 60 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chroot 61 () ) + ; 62 is old fstat + ; 63 is unused + ; 64 is old getpagesize +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msync 65 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::vfork 66 () ) + ; 67 is obsolete vread + ; 68 is obsolete vwrite +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sbrk 69 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sstk 70 () ) + ; 71 is old mmap + ; 72 is obsolete vadvise +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::munmap 73 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mprotect 74 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::madvise 75 () ) + ; 76 is obsolete vhangup + ; 77 is obsolete vlimit +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mincore 78 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getgroups 79 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setgroups 80 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpgrp 81 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setpgid 82 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setitimer 83 () ) + ; 84 is old wait +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::swapon 85 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getitimer 86 () ) + ; 87 is old gethostname + ; 88 is old sethostname +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getdtablesize 89 () ) + + + ; 94 is obsolete setdopt +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setpriority 96 () ) + ; 99 is old accept +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpriority 100 () ) + ; 101 is old send + ; 102 is old recv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigreturn 103 () ) + ; 107 is obsolete vtimes + ; 108 is old sigvec + ; 109 is old sigblock + ; 110 is old sigsetmask +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigsuspend 111 () ) + ; 112 is old sigstack + ; 113 is old recvmsg + ; 114 is old sendmsg + ; 115 is obsolete vtrace + ; 119 is obsolete resuba +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::readv 120 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::writev 121 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::settimeofday 122 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchown 123 () ) + ; 125 is old recvfrom + ; 126 is old setreuid + ; 127 is old setregid +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::flock 131 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mkfifo 132 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::utimes 138 () ) + ; 139 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::adjtime 140 () ) + ; 141 is old getpeername + ; 142 is old gethostid + ; 143 is old sethostid + ; 144 is old getrlimit + ; 145 is old setrlimit + ; 146 is old killpg +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setsid 147 () ) + ; 148 is obsolete setquota + ; 149 is obsolete quota + ; 150 is old getsockname + ; 151 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setprivexec 152 () ) + ; 153 is reserved + ; 154 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::nfssvc 155 () ) + ; 156 is old getdirentries +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::statfs 157 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fstatfs 158 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::unmount 159 () ) + ; 160 is obsolete async_daemon +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getfh 161 () ) + ; 162 is old getdomainname + ; 163 is old setdomainname + ; 164 is obsolete pcfs_mount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::quotactl 165 () ) + ; 166 is obsolete exportfs + + ; 168 is obsolete ustat + ; 169 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::table 170 () ) + ; 171 is old wait_3 + ; 172 is obsolete rpause + ; 173 is unused + ; 174 is obsolete getdents +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::gc_control 175 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::add_profil 176 () ) + ; 177 is unused + ; 178 is unused + ; 179 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::kdebug_trace 180 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setegid 182 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::seteuid 183 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_bmapv 184 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_markv 185 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_segclean 186 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_segwait 187 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::pathconf 191 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fpathconf 192 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getrlimit 194 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setrlimit 195 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getdirentries 196 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mmap 197 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::__syscall 198 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::__sysctl 202 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mlock 203 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::munlock 204 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::undelete 205 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATsocket 206 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATgetmsg 207 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATputmsg 208 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPsndreq 209 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPsndrsp 210 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPgetreq 211 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPgetrsp 212 () ) + ; 213-215 are reserved for AppleTalk +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mkcomplex 216 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::statv 217 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lstatv 218 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fstatv 219 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getattrlist 220 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setattrlist 221 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getdirentriesattr 222 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::exchangedata 223 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::checkuseraccess 224 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::searchfs 225 () ) + + ; 226 - 230 are reserved for HFS expansion + ; 231 - 249 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::minherit 250 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semsys 251 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgsys 252 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmsys 253 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semctl 254 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semget 255 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semop 256 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semconfig 257 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgctl 258 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgget 259 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgsnd 260 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgrcv 261 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmat 262 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmctl 263 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmdt 264 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmget 265 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shm_open 266 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shm_unlink 267 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_open 268 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_close 269 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_unlink 270 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_wait 271 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_trywait 272 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_post 273 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_getvalue 274 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_init 275 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_destroy 276 () ) + ; 277 - 295 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::load_shared_file 296 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::reset_shared_file 297 () ) + ; 298 - 323 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mlockall 324 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::munlockall 325 () ) + ; 326 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::issetugid 327 () ) +) + + Index: /branches/qres/ccl/library/darwinx8664-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/darwinx8664-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/darwinx8664-syscalls.lisp (revision 13564) @@ -0,0 +1,297 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL") + (defconstant darwinx8664-unix-syscall-mask #x2000000)) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::exit (logior darwinx8664-unix-syscall-mask 1) (:int) :void ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fork (logior darwinx8664-unix-syscall-mask 2) () :void) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::read (logior darwinx8664-unix-syscall-mask 3) (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::write (logior darwinx8664-unix-syscall-mask 4) (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::open (logior darwinx8664-unix-syscall-mask 5) (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::close (logior darwinx8664-unix-syscall-mask 6) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::wait4 (logior darwinx8664-unix-syscall-mask 7) (:unsigned-fullword :address :signed-fullword :address) :unsigned-fullword ) + ; 8 is old creat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::link (logior darwinx8664-unix-syscall-mask 9) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::unlink (logior darwinx8664-unix-syscall-mask 10) (:address) :signed-fullword ) + ; 11 is obsolete execv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chdir (logior darwinx8664-unix-syscall-mask 12) (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchdir (logior darwinx8664-unix-syscall-mask 13) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mknod (logior darwinx8664-unix-syscall-mask 14) (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chmod (logior darwinx8664-unix-syscall-mask 15) (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lchown (logior darwinx8664-unix-syscall-mask 16) (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpid (logior darwinx8664-unix-syscall-mask 20) () :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setuid (logior darwinx8664-unix-syscall-mask 23) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getuid (logior darwinx8664-unix-syscall-mask 24) () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::geteuid (logior darwinx8664-unix-syscall-mask 25) () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::recvmsg (logior darwinx8664-unix-syscall-mask 27) (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sendmsg (logior darwinx8664-unix-syscall-mask 28) (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::recvfrom (logior darwinx8664-unix-syscall-mask 29) (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::accept (logior darwinx8664-unix-syscall-mask 30) (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpeername (logior darwinx8664-unix-syscall-mask 31) (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getsockname (logior darwinx8664-unix-syscall-mask 32) (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::kill (logior darwinx8664-unix-syscall-mask 37) (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sync (logior darwinx8664-unix-syscall-mask 36) () :unsigned-fullword ) + ; 38 is old stat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getppid (logior darwinx8664-unix-syscall-mask 39) () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::dup (logior darwinx8664-unix-syscall-mask 41) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::pipe (logior darwinx8664-unix-syscall-mask 42) () :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getgid (logior darwinx8664-unix-syscall-mask 47) () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ioctl (logior darwinx8664-unix-syscall-mask 54) (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::dup2 (logior darwinx8664-unix-syscall-mask 90) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fcntl (logior darwinx8664-unix-syscall-mask 92) (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::select (logior darwinx8664-unix-syscall-mask 93) (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fsync (logior darwinx8664-unix-syscall-mask 95) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::socket (logior darwinx8664-unix-syscall-mask 97) (:unsigned-fullword :unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::connect (logior darwinx8664-unix-syscall-mask 98) (:unsigned-fullword :address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::bind (logior darwinx8664-unix-syscall-mask 104) (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setsockopt (logior darwinx8664-unix-syscall-mask 105) (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::listen (logior darwinx8664-unix-syscall-mask 106) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday (logior darwinx8664-unix-syscall-mask 116) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getrusage (logior darwinx8664-unix-syscall-mask 117) (:signed-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getsockopt (logior darwinx8664-unix-syscall-mask 118) (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchmod (logior darwinx8664-unix-syscall-mask 124) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::rename (logior darwinx8664-unix-syscall-mask 128) (:address :address) :signed-fullword) + ; 129 is old truncate + ; 130 is old ftruncate +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sendto (logior darwinx8664-unix-syscall-mask 133) (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shutdown (logior darwinx8664-unix-syscall-mask 134) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::socketpair (logior darwinx8664-unix-syscall-mask 135) (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mkdir (logior darwinx8664-unix-syscall-mask 136) (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::rmdir (logior darwinx8664-unix-syscall-mask 137) (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mount (logior darwinx8664-unix-syscall-mask 167) (:address :address :unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setgid (logior darwinx8664-unix-syscall-mask 181) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::stat (logior darwinx8664-unix-syscall-mask 188) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fstat (logior darwinx8664-unix-syscall-mask 189) (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lstat (logior darwinx8664-unix-syscall-mask 190) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lseek (logior darwinx8664-unix-syscall-mask 199) (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::truncate (logior darwinx8664-unix-syscall-mask 200) (:address :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ftruncate (logior darwinx8664-unix-syscall-mask 201) (:unsigned-fullword :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::poll (logior darwinx8664-unix-syscall-mask 230) ((:* (:struct :pollfd)) :int :int) :int) +#+notdefinedyet +(progn + ; 17 is obsolete sbreak + ; 18 is old getfsstat + ; 19 is old lseek + ; 21 is obsolete mount + ; 22 is obsolete umount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ptrace (logior darwinx8664-unix-syscall-mask 26) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::access (logior darwinx8664-unix-syscall-mask 33) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chflags (logior darwinx8664-unix-syscall-mask 34) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchflags (logior darwinx8664-unix-syscall-mask 35) () ) + ; 40 is old lstat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getegid (logior darwinx8664-unix-syscall-mask 43) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::profil (logior darwinx8664-unix-syscall-mask 44) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ktrace (logior darwinx8664-unix-syscall-mask 45) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigaction (logior darwinx8664-unix-syscall-mask 46) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask (logior darwinx8664-unix-syscall-mask 48) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getlogin (logior darwinx8664-unix-syscall-mask 49) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setlogin (logior darwinx8664-unix-syscall-mask 50) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::acct (logior darwinx8664-unix-syscall-mask 51) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigpending (logior darwinx8664-unix-syscall-mask 52) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack (logior darwinx8664-unix-syscall-mask 53) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::reboot (logior darwinx8664-unix-syscall-mask 55) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::revoke (logior darwinx8664-unix-syscall-mask 56) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::symlink (logior darwinx8664-unix-syscall-mask 57) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::readlink (logior darwinx8664-unix-syscall-mask 58) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::execve (logior darwinx8664-unix-syscall-mask 59) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::umask (logior darwinx8664-unix-syscall-mask 60) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chroot (logior darwinx8664-unix-syscall-mask 61) () ) + ; 62 is old fstat + ; 63 is unused + ; 64 is old getpagesize +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msync (logior darwinx8664-unix-syscall-mask 65) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::vfork (logior darwinx8664-unix-syscall-mask 66) () ) + ; 67 is obsolete vread + ; 68 is obsolete vwrite +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sbrk (logior darwinx8664-unix-syscall-mask 69) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sstk (logior darwinx8664-unix-syscall-mask 70) () ) + ; 71 is old mmap + ; 72 is obsolete vadvise +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::munmap (logior darwinx8664-unix-syscall-mask 73) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mprotect (logior darwinx8664-unix-syscall-mask 74) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::madvise (logior darwinx8664-unix-syscall-mask 75) () ) + ; 76 is obsolete vhangup + ; 77 is obsolete vlimit +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mincore (logior darwinx8664-unix-syscall-mask 78) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getgroups (logior darwinx8664-unix-syscall-mask 79) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setgroups (logior darwinx8664-unix-syscall-mask 80) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpgrp (logior darwinx8664-unix-syscall-mask 81) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setpgid (logior darwinx8664-unix-syscall-mask 82) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setitimer (logior darwinx8664-unix-syscall-mask 83) () ) + ; 84 is old wait +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::swapon (logior darwinx8664-unix-syscall-mask 85) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getitimer (logior darwinx8664-unix-syscall-mask 86) () ) + ; 87 is old gethostname + ; 88 is old sethostname +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getdtablesize (logior darwinx8664-unix-syscall-mask 89) () ) + + + ; 94 is obsolete setdopt +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setpriority (logior darwinx8664-unix-syscall-mask 96) () ) + ; 99 is old accept +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpriority (logior darwinx8664-unix-syscall-mask 100) () ) + ; 101 is old send + ; 102 is old recv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigreturn (logior darwinx8664-unix-syscall-mask 103) () ) + ; 107 is obsolete vtimes + ; 108 is old sigvec + ; 109 is old sigblock + ; 110 is old sigsetmask +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend (logior darwinx8664-unix-syscall-mask 111) () ) + ; 112 is old sigstack + ; 113 is old recvmsg + ; 114 is old sendmsg + ; 115 is obsolete vtrace + ; 119 is obsolete resuba +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::readv (logior darwinx8664-unix-syscall-mask 120) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::writev (logior darwinx8664-unix-syscall-mask 121) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::settimeofday (logior darwinx8664-unix-syscall-mask 122) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchown (logior darwinx8664-unix-syscall-mask 123) () ) + ; 125 is old recvfrom + ; 126 is old setreuid + ; 127 is old setregid +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::flock (logior darwinx8664-unix-syscall-mask 131) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mkfifo (logior darwinx8664-unix-syscall-mask 132) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::utimes (logior darwinx8664-unix-syscall-mask 138) () ) + ; 139 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::adjtime (logior darwinx8664-unix-syscall-mask 140) () ) + ; 141 is old getpeername + ; 142 is old gethostid + ; 143 is old sethostid + ; 144 is old getrlimit + ; 145 is old setrlimit + ; 146 is old killpg +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setsid (logior darwinx8664-unix-syscall-mask 147) () ) + ; 148 is obsolete setquota + ; 149 is obsolete quota + ; 150 is old getsockname + ; 151 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setprivexec (logior darwinx8664-unix-syscall-mask 152) () ) + ; 153 is reserved + ; 154 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::nfssvc (logior darwinx8664-unix-syscall-mask 155) () ) + ; 156 is old getdirentries +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::statfs (logior darwinx8664-unix-syscall-mask 157) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fstatfs (logior darwinx8664-unix-syscall-mask 158) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::unmount (logior darwinx8664-unix-syscall-mask 159) () ) + ; 160 is obsolete async_daemon +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getfh (logior darwinx8664-unix-syscall-mask 161) () ) + ; 162 is old getdomainname + ; 163 is old setdomainname + ; 164 is obsolete pcfs_mount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::quotactl (logior darwinx8664-unix-syscall-mask 165) () ) + ; 166 is obsolete exportfs + + ; 168 is obsolete ustat + ; 169 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::table (logior darwinx8664-unix-syscall-mask 170) () ) + ; 171 is old wait_3 + ; 172 is obsolete rpause + ; 173 is unused + ; 174 is obsolete getdents +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::gc_control (logior darwinx8664-unix-syscall-mask 175) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::add_profil (logior darwinx8664-unix-syscall-mask 176) () ) + ; 177 is unused + ; 178 is unused + ; 179 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::kdebug_trace (logior darwinx8664-unix-syscall-mask 180) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setegid (logior darwinx8664-unix-syscall-mask 182) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::seteuid (logior darwinx8664-unix-syscall-mask 183) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_bmapv (logior darwinx8664-unix-syscall-mask 184) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_markv (logior darwinx8664-unix-syscall-mask 185) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_segclean (logior darwinx8664-unix-syscall-mask 186) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_segwait (logior darwinx8664-unix-syscall-mask 187) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::pathconf (logior darwinx8664-unix-syscall-mask 191) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fpathconf (logior darwinx8664-unix-syscall-mask 192) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getrlimit (logior darwinx8664-unix-syscall-mask 194) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setrlimit (logior darwinx8664-unix-syscall-mask 195) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getdirentries (logior darwinx8664-unix-syscall-mask 196) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mmap (logior darwinx8664-unix-syscall-mask 197) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::__syscall (logior darwinx8664-unix-syscall-mask 198) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::__sysctl (logior darwinx8664-unix-syscall-mask 202) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mlock (logior darwinx8664-unix-syscall-mask 203) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::munlock (logior darwinx8664-unix-syscall-mask 204) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::undelete (logior darwinx8664-unix-syscall-mask 205) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATsocket (logior darwinx8664-unix-syscall-mask 206) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATgetmsg (logior darwinx8664-unix-syscall-mask 207) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATputmsg (logior darwinx8664-unix-syscall-mask 208) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPsndreq (logior darwinx8664-unix-syscall-mask 209) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPsndrsp (logior darwinx8664-unix-syscall-mask 210) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPgetreq (logior darwinx8664-unix-syscall-mask 211) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPgetrsp (logior darwinx8664-unix-syscall-mask 212) () ) + ; 213-215 are reserved for AppleTalk +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mkcomplex (logior darwinx8664-unix-syscall-mask 216) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::statv (logior darwinx8664-unix-syscall-mask 217) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lstatv (logior darwinx8664-unix-syscall-mask 218) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fstatv (logior darwinx8664-unix-syscall-mask 219) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getattrlist (logior darwinx8664-unix-syscall-mask 220) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setattrlist (logior darwinx8664-unix-syscall-mask 221) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getdirentriesattr (logior darwinx8664-unix-syscall-mask 222) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::exchangedata (logior darwinx8664-unix-syscall-mask 223) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::checkuseraccess (logior darwinx8664-unix-syscall-mask 224) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::searchfs (logior darwinx8664-unix-syscall-mask 225) () ) + + ; 226 - 230 are reserved for HFS expansion + ; 231 - 249 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::minherit (logior darwinx8664-unix-syscall-mask 250) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semsys (logior darwinx8664-unix-syscall-mask 251) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgsys (logior darwinx8664-unix-syscall-mask 252) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmsys (logior darwinx8664-unix-syscall-mask 253) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semctl (logior darwinx8664-unix-syscall-mask 254) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semget (logior darwinx8664-unix-syscall-mask 255) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semop (logior darwinx8664-unix-syscall-mask 256) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semconfig (logior darwinx8664-unix-syscall-mask 257) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgctl (logior darwinx8664-unix-syscall-mask 258) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgget (logior darwinx8664-unix-syscall-mask 259) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgsnd (logior darwinx8664-unix-syscall-mask 260) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgrcv (logior darwinx8664-unix-syscall-mask 261) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmat (logior darwinx8664-unix-syscall-mask 262) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmctl (logior darwinx8664-unix-syscall-mask 263) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmdt (logior darwinx8664-unix-syscall-mask 264) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmget (logior darwinx8664-unix-syscall-mask 265) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shm_open (logior darwinx8664-unix-syscall-mask 266) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shm_unlink (logior darwinx8664-unix-syscall-mask 267) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_open (logior darwinx8664-unix-syscall-mask 268) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_close (logior darwinx8664-unix-syscall-mask 269) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_unlink (logior darwinx8664-unix-syscall-mask 270) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_wait (logior darwinx8664-unix-syscall-mask 271) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_trywait (logior darwinx8664-unix-syscall-mask 272) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_post (logior darwinx8664-unix-syscall-mask 273) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_getvalue (logior darwinx8664-unix-syscall-mask 274) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_init (logior darwinx8664-unix-syscall-mask 275) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_destroy (logior darwinx8664-unix-syscall-mask 276) () ) + ; 277 - 295 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::load_shared_file (logior darwinx8664-unix-syscall-mask 296) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::reset_shared_file (logior darwinx8664-unix-syscall-mask 297) () ) + ; 298 - 323 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mlockall (logior darwinx8664-unix-syscall-mask 324) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::munlockall (logior darwinx8664-unix-syscall-mask 325) () ) + ; 326 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::issetugid (logior darwinx8664-unix-syscall-mask 327) () ) +) Index: /branches/qres/ccl/library/dominance.lisp =================================================================== --- /branches/qres/ccl/library/dominance.lisp (revision 13564) +++ /branches/qres/ccl/library/dominance.lisp (revision 13564) @@ -0,0 +1,518 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2010 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;(setq *print-array* nil) +;(setq *print-simple-bit-vector* nil) + +#+:linuxx8664-target +(progn + +(export '(idom-heap-utilization)) + +#| +(open-core "home:core.28209") +(idom-heap-utilization :unit nil :sort :size) +|# + +(defconstant half-fixnum-shift (ash (integer-length most-positive-fixnum) -1)) + +(defconstant half-fixnum-mask (1- (ash 1 half-fixnum-shift))) + +(defstruct (core-graph (:include core-info) (:conc-name "CG.") (:constructor %cons-cg)) + (heap-base 0 :type fixnum) + (heap-end 0 :type fixnum) + (stage nil) ;; indication of what has been computed and what hasn't, so can restart. + (head-p #.(make-array 0 :element-type 'bit) :type simple-bit-vector) + (ptrs-p #.(make-array 0 :element-type 'bit) :type simple-bit-vector) + ;; Nodes after eliminating single-entry and leaf objects + (nodes #() :type simple-vector) ;; map postorder-idx -> dnode + (revnodes #() :type simple-vector) ;; map dnode -> postorder-idx + (roots () :type list) + (predecessors #() :type simple-vector) ;; postorder-idx -> list of postorder indices of predecessors + (node-doms #() :type simple-vector) ;; postorder-idx of node -> postorder-idx of its immediate dominator + (idoms #() :type simple-vector) ;; sequence of postorder indices of immediate dominators + (revidoms #() :type simple-vector) ;; map dnode -> index in idoms + (logsizes #() :type simple-vector) ;; corresponding sequence of logical sizes (including all owned objects) + (physizes #() :type simple-vector) ;; corresponding sequence of physical sizes (including all owned objects) + ) + +(setq *core-info-class* 'core-graph) + +(defparameter *cg-stages* '(nil :objects :leaves :postorder :predecessors :idoms :idom-sizes t)) + +(defmethod cg-compute :before (stage &aux (cg (current-core))) + (assert (memq stage *cg-stages*)) + (check-type cg core-graph) + (when (eql (cg.heap-base cg) 0) + (let ((area-ptr (core-q (kernel-global-address 'tenured-area)))) + (setf (cg.heap-base cg) (core-q area-ptr target::area.low)) + (setf (cg.heap-end cg) (core-q area-ptr target::area.active)))) + ;; ensure have all the prereqs + (loop for undone = (cdr (memq (cg.stage cg) *cg-stages*)) + while (memq stage (cdr undone)) + do (format t "~&Computing ~a" (car undone)) + do (cg-compute (car undone)))) + +(defmethod cg-compute :after (stage &aux (cg (current-core))) + (setf (cg.stage cg) stage)) + +(defmethod cg-compute ((stage (eql t))) ;; before method does all the work + nil) + + +(declaim (inline core-node-p)) +(defun core-node-p (ptr) (or (core-consp ptr) (core-uvector-p ptr))) + +(declaim (inline dnode addr)) + +(defun dnode (base n) (the fixnum (ash (%i- n base) (- target::dnode-shift)))) + +(defun addr (base n) (%i+ base (ash (the fixnum n) target::dnode-shift))) + +(defun tagged-ptr (ptr) + (let ((header (core-q ptr))) + (cond ((uvheader-p header) + (let ((subtag (uvheader-typecode header))) + (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol) + ((eq subtag target::subtag-function) target::fulltag-function) + (t target::fulltag-misc)))) ) + (t + (+ ptr target::fulltag-cons))))) + +(defun core-physsize (obj) + ;; (assert (core-node-p obj)) + (if (core-consp obj) + target::dnode-size + (logandc2 (+ (uvheader-byte-size (core-uvheader obj)) target::node-size (1- target::dnode-size)) + (1- target::dnode-size)))) + +(defun core-object-sizes (obj) + (let ((fulltag (logand obj target::fulltagmask))) + (if (eq fulltag target::fulltag-cons) + (values target::dnode-size target::dnode-size) + (if (%i<= target::fulltag-misc fulltag) + (let* ((header (core-uvheader obj)) + (logsize (uvheader-byte-size header)) + ;; total including header and alignment. + (total (logandc2 (+ logsize target::node-size (1- target::dnode-size)) + (1- target::dnode-size)))) + (values logsize total)))))) + +(defun link-range (ptr) + (declare (fixnum ptr)) + (let* ((addr (logandc2 ptr target::fulltagmask)) + (header (core-q addr)) + (end addr)) + (declare (fixnum addr end)) + (if (uvheader-p header) + (let ((subtag (%ilogand header target::fulltagmask))) + (declare (fixnum subtag)) + (when (or (eq subtag target::fulltag-nodeheader-0) + (eq subtag target::fulltag-nodeheader-1)) + (incf addr target::node-size) + (setq end (+ addr (ash (uvheader-size header) target::word-shift))) + (when (eql (uvheader-typecode header) target::subtag-function) + (incf addr (ash (core-l addr) target::word-shift))))) + (setq end (+ addr target::dnode-size))) + (values addr end))) + +(defmethod cg-compute ((stage (eql :objects)) &aux (cg (current-core))) + "Compute incoming pointer counts" + (let* ((base (cg.heap-base cg)) + (high (cg.heap-end cg)) + (ndnodes (dnode base high)) + (ptrs (make-array ndnodes :element-type 'bit :initial-element 0)) + (head (make-array ndnodes :element-type 'bit :initial-element 0))) + (declare (fixnum base ndnodes) + (type simple-bit-vector ptrs head)) + (map-core-region base high + (lambda (obj) + (multiple-value-bind (start end) (link-range obj) + (loop for addr from start below end by target::node-size + as ptr = (core-q addr) + do (when (and (<= base ptr) (< ptr high) (core-node-p ptr)) + (let ((dnode (dnode base ptr))) + (setf (aref head dnode) (aref ptrs dnode)) + (setf (aref ptrs dnode) 1))))) + ;; Mark that have an object even if there are no refs to it. + (let ((dnode (dnode base obj))) + (when (eql (aref ptrs dnode) 0) + (setf (aref head dnode) 1))))) + ;; head = 0, ptrs = 0 -- not an object (internal dnode) + ;; head = 0, ptrs = 1 -- single-entry object (exactly one pointer to it) + ;; head = 1, ptrs = 0 -- root object (no pointers to it) + ;; head = 1, ptrs = 1 -- multiple-entry object + (setf (cg.head-p cg) head) + (setf (cg.ptrs-p cg) ptrs) + cg)) + +(defmethod cg-compute ((stage (eql :leaves)) &aux (cg (current-core))) + "Mark leaf nodes (nodes with no outgoing pointers)" + (let* ((base (cg.heap-base cg)) + (high (cg.heap-end cg)) + (ptrs (cg.ptrs-p cg)) + (head (cg.head-p cg))) + (declare (fixnum base high)) + (loop for dn upfrom 0 + for h bit across head + for p bit across ptrs + do (unless (and (eql h 0) (eql p 0)) + (unless (multiple-value-bind (start end) (link-range (addr base dn)) + (loop for addr from start below end by target::node-size + as val = (core-q addr) + thereis (and (<= base val) (< val high) (core-node-p val)))) + (setf (aref head dn) 0) + (setf (aref ptrs dn) 0)))) + ;; head = 0, ptrs = 0 -- not an object (internal dnode) or a leaf + ;; head = 0, ptrs = 1 -- single-entry object (exactly one pointer to it), not leaf + ;; head = 1, ptrs = 0 -- root object (no pointers to it), not leaf + ;; head = 1, ptrs = 1 -- multiple-entry object, not leaf + cg)) + +(defun collect-root-dnodes (cg) + (let ((head (cg.head-p cg)) + (ptrs (cg.ptrs-p cg))) + (loop for dn = (position 1 head) then (position 1 head :start (1+ dn)) while dn + when (eql (aref ptrs dn) 0) collect dn))) + +(defmethod cg-compute ((stage (eql :postorder)) &aux (cg (current-core))) + (let* ((roots (collect-root-dnodes cg)) + (head (cg.head-p cg)) + (ptrs (cg.ptrs-p cg)) + (halo-roots ()) + (n (count 1 head)) + (base (cg.heap-base cg)) + (high (cg.heap-end cg)) + (ndnodes (dnode base high)) + (seen (make-array ndnodes :element-type 'bit :initial-element 0)) + (nodes (make-array n)) + (node-count 0)) + (assert (< ndnodes (ash 1 half-fixnum-shift))) + (flet ((dfs (root-dn) + (setf (aref seen root-dn) 1) + (let ((path (multiple-value-bind (start end) (link-range (addr base root-dn)) + (list (list* start end root-dn))))) + (loop + (destructuring-bind (start end . pred-dn) (car path) + (incf (caar path) target::node-size) + (if (eql start end) + (progn + (when (eql (aref head pred-dn) 1) + (setf (aref nodes node-count) pred-dn) + (incf node-count)) + (setq path (cdr path)) + (when (null path) (return))) + (let ((next (core-q start))) + (when (and (<= base next) (< next high) (core-node-p next)) + (let ((next-dn (dnode base next))) + (if (eql (aref ptrs next-dn) 0) ;; root or leaf -- ignore leaf + (when (eql (aref head next-dn) 1) ;; previously assumed halo root + #+debug (warn "REASSIGNING HALO ROOT ~s -> ~d" (assq next-dn halo-roots) node-count) + (assert (eql (aref seen next-dn) 1)) + (setf (aref ptrs next-dn) 1) + ;; not actually a root after all. Shift the region containing + ;; nodes from previous handling of next-dn to the end, as if + ;; just walked it right now. + (destructuring-bind (start . end) (cdr (assq next-dn halo-roots)) + (shift-vector-region nodes start end node-count)) + (setq halo-roots (delete next-dn halo-roots :key 'car))) + ;; non-leaf non-root + (when (eq (aref seen next-dn) 0) + (setf (aref seen next-dn) 1) + (multiple-value-bind (start end) (link-range next) + (push (list* start end next-dn) path))))))))))))) + (map nil #'dfs roots) + ;; Map through "halo" roots + (loop until (eql (length nodes) node-count) + as circ = (loop for nd = (position 1 head) then (position 1 head :start (1+ nd)) while nd + when (eql (aref seen nd) 0) return nd) + do (when (null circ) + ;; Must have some cycles consisting of just single-entry nodes, since we caught all other ones + (setq circ (loop for nd = (position 1 ptrs) then (position 1 ptrs :start (1+ nd)) while nd + when (eql (aref seen nd) 0) return nd)) + #+debug (progn (format t "~&Breaking a SINGLE-NODE CYCLE at ") (core-print (tagged-ptr (addr (cg.heap-base cg) circ)))) + (setf (aref head circ) 1)) + do (let ((start node-count)) + #+debug (progn (format t "~&Breaking out a HALO ROOT at ") (core-print (tagged-ptr (addr (cg.heap-base cg) circ)))) + (dfs circ) + ;; This just makes it faster to find these in the dfs, it gets undone below. + (setf (aref ptrs circ) 0) + (push (list* circ start node-count) halo-roots)))) + (setq roots (nconc (mapcar (lambda (x &aux (dn (car x))) + (setf (aref ptrs dn) 1) + dn) + halo-roots) + roots)) + (setf (cg.roots cg) roots) + (setf (cg.nodes cg) nodes) + cg)) + +(defun shift-vector-region (vector start mid end) + ;; move the interval from START to MID to after the interval from MID to END. + (loop as n2 = (- end mid) as n1 = (- mid start) + while (and (> n2 0) (> n1 0)) + do (if (< n1 n2) + (loop for i from start below mid + do (rotatef (aref vector i) (aref vector (+ i n1))) + finally (setq start mid mid (+ mid n1))) + (loop for i from mid below end + do (rotatef (aref vector i) (aref vector (- i n1))) + finally (setq start (+ start n2)))))) + + +(declaim (inline make-rev-map)) + +(defun make-rev-map (arr &optional (fn 'identity)) + (let* ((n (length arr)) + (revarr (make-array n))) + (loop for i from 0 below n as dn = (funcall fn (aref arr i)) + do (setf (aref revarr i) (+ (ash i half-fixnum-shift) dn))) ;; [pidx ,, dn] + (sort revarr #'< :key (lambda (i.d) (logand i.d half-fixnum-mask))))) + +(defun index-for-dnode (revnodes dn) + (declare (type simple-vector revnodes) (fixnum dn) + (optimize (speed 3) (safety 0))) + (let ((low 0) + (high (length revnodes))) + (declare (fixnum low high) ) + (loop + (when (eq low high) (return nil)) + (let* ((half (ash (%i+ high low) -1)) + (val (%ilogand2 (%svref revnodes half) half-fixnum-mask))) + (declare (fixnum half val)) + (when (eq val dn) + (return (the fixnum (ash (the fixnum (%svref revnodes half)) (- half-fixnum-shift))))) + (if (< val dn) + (setq low (1+ half)) + (setq high half)))))) + +(defmacro do-pointers ((child-var addr) &body body) + (let ((path (gensym)) + (start (gensym)) + (end (gensym))) + ` (macrolet ((descend-pointers (child) + `(multiple-value-bind (start end) (link-range ,child) + (push (cons start end) ,',path)))) + (let ((,path nil)) + (descend-pointers ,addr) + (loop + (destructuring-bind (,start . ,end) (car ,path) + (incf (caar ,path) target::node-size) + (if (eq ,start ,end) + (unless (setq ,path (cdr ,path)) (return)) + (let ((,child-var (core-q ,start))) + (when (core-node-p ,child-var) + ,@body))))))))) + +(defmethod cg-compute ((stage (eql :predecessors)) &aux (cg (current-core))) + (let* ((base (cg.heap-base cg)) + (high (cg.heap-end cg)) + (roots (cg.roots cg)) + (head (cg.head-p cg)) + (ptrs (cg.ptrs-p cg)) + (nodes (cg.nodes cg)) ;; pidx -> dn + (n (length nodes)) + (revnodes (make-rev-map nodes)) ;; dn -> pidx + (predecessors (make-array (1+ n) :initial-element 0))) + (flet ((record-predecessor (dn pred-i) + (let* ((i (index-for-dnode revnodes dn)) + (old (aref predecessors i))) + (cond ((eql old 0) + (setf (aref predecessors i) (1+ pred-i))) + ((fixnump old) + (if (eql (logandc2 old half-fixnum-mask) 0) + (setf (aref predecessors i) (+ (ash old half-fixnum-shift) pred-i)) + ;; could do more here, but most cases are covered by the 2-elt optimization + (setf (aref predecessors i) + (list pred-i + (logand old half-fixnum-mask) (1- (ash old (- half-fixnum-shift))))))) + (t (setf (aref predecessors i) (cons pred-i old))))))) + (loop for dn across nodes as dn-idx upfrom 0 + do (ASSERT (eql dn-idx (index-for-dnode revnodes dn))) + do (do-pointers (next (addr base dn)) + (when (and (<= base next) (< next high)) + (let ((next-dn (dnode base next))) + (when (eq (aref ptrs next-dn) 1) ;; non-leaf + (if (eql (aref head next-dn) 1) ;; stop at head node + (record-predecessor next-dn dn-idx) + (descend-pointers next))))))) + ;; Pretend there is one single root node which is the predecessor of all our roots. + (loop for root-dn in roots do (record-predecessor root-dn n))) + (setf (cg.revnodes cg) revnodes) + (setf (cg.predecessors cg) predecessors) + cg)) + +(defun predecessor-list (predecessors i) + (let ((p (aref predecessors i))) + (cond ((eql p 0) '()) + ((fixnump p) + (let ((p1 (logand p half-fixnum-mask))) + (if (eql p p1) + (list (1- p1)) + (list p1 (1- (ash p (- half-fixnum-shift))))))) + (t p)))) + +;;; Ok, now on to compute dominance +;; immediate dominators per Cooper, Harvey, Kennedy. +(defmethod cg-compute ((stage (eql :idoms)) &aux (cg (current-core))) + (let* ((predecessors (cg.predecessors cg)) + (root-idx (1- (length predecessors))) + (doms (make-array (1+ root-idx) :initial-element nil))) + (flet ((intersect (i1 i2) + (when (and i1 i2) + (loop until (eq i1 i2) + do (loop while (< i1 i2) do (setq i1 (aref doms i1))) + do (loop while (< i2 i1) do (setq i2 (aref doms i2))))) + (or i1 i2)) + (preds (i) + (predecessor-list predecessors i))) + (declare (inline intersect preds)) + (setf (aref doms root-idx) root-idx) + (loop for changed = 0 + do (loop for i from (1- root-idx) downto 0 + do (let ((new-idom nil)) + (loop for p in (preds i) + do (when (aref doms p) (setq new-idom (intersect p new-idom)))) + (unless (eql new-idom (aref doms i)) + (setf (aref doms i) new-idom) + (incf changed)))) + DO (progn #+debug (format t "~&Finished loop, changed=~d~%" changed)) + while (> changed 0))) + (setf (cg.node-doms cg) doms) + (setf (cg.idoms cg) (sort (delete root-idx (remove-duplicates doms)) #'<)) + (let ((nodes (cg.nodes cg))) + (setf (cg.revidoms cg) (make-rev-map (cg.idoms cg) (lambda (ni) (aref nodes ni))))) + cg)) + +(defmethod cg-compute ((stage (eql :idom-sizes)) &aux (cg (current-core))) + (let* ((nodes (cg.nodes cg)) + (idom-nodes (cg.idoms cg)) + (idom-revnodes (cg.revidoms cg)) + (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0)) + (base (cg.heap-base cg)) + (high (cg.heap-end cg)) + (nidoms (length idom-nodes)) + (logsizes (make-array nidoms)) + (physizes (make-array nidoms))) + ;; Any object that's not an idom is only reachable by one idom, + ;; so don't need to reinit SEEN bits between iterations. + (setf (cg.idoms cg) idom-nodes) + (loop for i from 0 below nidoms as idom = (aref idom-nodes i) + do (let* ((dn (aref nodes idom)) + (addr (addr base dn)) + (ptr (tagged-ptr addr))) + (multiple-value-bind (logsize physsize) (core-object-sizes ptr) + (do-pointers (next addr) + (when (and (<= base next) (< next high)) + (let ((next-dn (dnode base next))) + (unless (or (index-for-dnode idom-revnodes next-dn) + (eql (aref seen next-dn) 1)) + (setf (aref seen next-dn) 1) + (multiple-value-bind (this-logsize this-physsize) (core-object-sizes next) + (incf logsize this-logsize) + (incf physsize this-physsize)) + (descend-pointers next))))) + (setf (aref logsizes i) logsize) + (setf (aref physizes i) physsize)))) + (setf (cg.logsizes cg) logsizes) + (setf (cg.physizes cg) physizes) + cg)) + +(defun idom-set-heap-range (area) + (check-type area (member :tenured :dynamic)) + (multiple-value-bind (base end) + (cond ((eq area :tenured) + (let ((area-ptr (core-q (kernel-global-address 'tenured-area)))) + (values (core-q area-ptr target::area.low) + (core-q area-ptr target::area.active)))) + ((eq area :dynamic) + (let* ((newest (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)) + (oldest (core-q (kernel-global-address 'tenured-area)))) + (assert (loop for this = newest then older as older = (core-q this target::area.succ) + until (eql this oldest) + always (eql (core-q this target::area.low) (core-q older target::area.active)))) + (values (core-q oldest target::area.low) + (core-q newest target::area.active))))) + (let ((cg (current-core))) + (unless (and (eq base (cg.heap-base cg)) + (eq end (cg.heap-end cg))) + (setf (cg.stage cg) nil) + (setf (cg.heap-base cg) base) + (setf (cg.heap-end cg) end))))) + + +(defun report-idom-heap-utilization (type-infos &key unit sort threshold) + (let ((data (loop for type being the hash-key of type-infos using (hash-value info) + collect (cons (core-type-string type) info)))) + (report-heap-utilization data :unit unit :sort sort :stream *standard-output* :threshold threshold))) + +(defun idom-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured)) + (idom-set-heap-range area) + (cg-compute t) + (loop with cg = (current-core) + with nodes = (cg.nodes cg) + with type-infos = (make-hash-table :test 'eql) + with base = (cg.heap-base cg) + for idx across (cg.idoms cg) + for logsz across (cg.logsizes cg) + for physz across (cg.physizes cg) + as type = (core-object-type-key (tagged-ptr (addr base (aref nodes idx)))) + as info = (or (gethash type type-infos) (setf (gethash type type-infos) (list 0 0 0))) + do (incf (car info)) + do (incf (cadr info) logsz) + do (incf (caddr info) physz) + finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold))) + +(defun idom-frontier-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured) (test nil)) + ;; Compute the heap utilization WITHIN selected idom trees, aggregated. + (idom-set-heap-range area) + (cg-compute :idoms) + (let* ((cg (current-core)) + (nodes (cg.nodes cg)) + (idom-nodes (cg.idoms cg)) + (idom-revnodes (cg.revidoms cg)) + (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0)) + (base (cg.heap-base cg)) + (high (cg.heap-end cg)) + (nidoms (length idom-nodes)) + (type-infos (make-hash-table :test 'eql))) + (flet ((record (ptr) + (multiple-value-bind (logsize physsize) (core-object-sizes ptr) + (let* ((type (core-object-type-key ptr)) + (info (or (gethash type type-infos) (setf (gethash type type-infos) (list 0 0 0))))) + (incf (car info)) + (incf (cadr info) logsize) + (incf (caddr info) physsize))))) + (loop for i from 0 below nidoms as idom = (aref idom-nodes i) + do (let* ((dn (aref nodes idom)) + (addr (addr base dn)) + (ptr (tagged-ptr addr))) + (when (or (null test) (funcall test ptr)) + ;; Ok, idom of interest. Walk its subgraph + (record ptr) + (do-pointers (next addr) + (when (and (<= base next) (< next high)) + (let ((next-dn (dnode base next))) + (unless (or (index-for-dnode idom-revnodes next-dn) + (eql (aref seen next-dn) 1)) + (setf (aref seen next-dn) 1) + (record next) + (descend-pointers next))))))) + finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold))))) + +) Index: /branches/qres/ccl/library/elf.lisp =================================================================== --- /branches/qres/ccl/library/elf.lisp (revision 13564) +++ /branches/qres/ccl/library/elf.lisp (revision 13564) @@ -0,0 +1,421 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :elf)) + + + +;;; String tables: used both for symbol names and for section names. +(defstruct elf-string-table + (hash (make-hash-table :test #'equal)) + (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t))) + +;;; Collect info about Elf symbols. +(defstruct elf-symbol-table + (strings (make-elf-string-table)) + data ; foreign pointer + nsyms + ) + +;;; Wrapper around libelf's "elf" pointer +(defstruct elf-object + libelf-pointer + fd + pathname + ) + + +;;; Is libelf thread-safe ? Who knows, there's no +;;; documentation ... +(defun libelf-error-string (&optional (errnum -1)) + (let* ((p (#_elf_errmsg errnum))) + (if (%null-ptr-p p) + (format nil "ELF error ~d" errnum) + (%get-cstring p)))) + +(defloadvar *checked-libelf-version* nil) + +(defun check-libelf-version () + (or *checked-libelf-version* + (progn + (open-shared-library "libelf.so") + (let* ((version (#_elf_version #$EV_CURRENT))) + (if (eql #$EV_NONE version) + (error "ELF library initialization failed: ~a" (libelf-error-string))) + (setq *checked-libelf-version* version))))) + + +;;; Prepate to create an ELF object file at PATHNAME, overwriting +;;; whatever might have been there. +(defun create-elf-object (pathname) + (let* ((namestring (native-translated-namestring pathname)) + (fd (ccl::fd-open namestring + (logior #$O_RDWR #$O_CREAT #$O_TRUNC) + #o755))) + (if (< fd 0) + (signal-file-error fd pathname) + (progn + (check-libelf-version) + (let* ((ptr (#_elf_begin fd #$ELF_C_WRITE +null-ptr+))) + (if (%null-ptr-p ptr) + (error "Can't initialize libelf object for ~s: ~a" + pathname (libelf-error-string)) + (make-elf-object :libelf-pointer (assert-pointer-type ptr :lf) + :fd fd + :pathname pathname))))))) + +(defun elf-end (object) + (#_elf_end (elf-object-libelf-pointer object)) + (setf (elf-object-libelf-pointer object) nil + (elf-object-fd object) nil)) + +(defun new-elf-file-header (object format type machine) + (let* ((ehdr (#+64-bit-target #_elf64_newehdr #+32-bit-target #_elf32_newehdr (elf-object-libelf-pointer object)))) + (if (%null-ptr-p ehdr) + (error "Can't create ELF file header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (progn + (setf (paref (pref ehdr + #+64-bit-target :lf64_hdr.e_ident + #+32-bit-target :lf32_hdr.e_ident) (:* :unsigned-char) #$EI_DATA) format + (pref ehdr + #+64-bit-target :lf64_hdr.e_machine + #+32-bit-target :lf32_hdr.e_machine) machine + (pref ehdr + #+64-bit-target :lf64_hdr.e_type + #+32-bit-target :lf32_hdr.e_type) type + (pref ehdr + #+64-bit-target :lf64_hdr.e_version + #+32-bit-target :lf32_hdr.e_version) *checked-libelf-version*) + (assert-pointer-type ehdr + #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr))))) + +(defun new-elf-program-header (object &optional (count 1)) + (let* ((phdr (#+64-bit-target #_elf64_newphdr #+32-bit-target #_elf32_newphdr (elf-object-libelf-pointer object) count))) + (if (%null-ptr-p phdr) + (error "Can't create ELF program header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type phdr + #+64-bit-target :lf64_

hdr + #+32-bit-target :lf32_

hdr)))) + +(defun new-elf-section (object) + (let* ((scn (#_elf_newscn (elf-object-libelf-pointer object)))) + (if (%null-ptr-p scn) + (error "Can' create ELF section for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type scn :lf_cn)))) + +(defun elf-section-header-for-section (object section) + (let* ((shdr (#+64-bit-target #_elf64_getshdr #+32-bit-target #_elf32_getshdr section))) + (if (%null-ptr-p shdr) + (error "Can' obtain ELF section header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type shdr + #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)))) + +(defun elf-data-pointer-for-section (object section) + (let* ((data (#_elf_newdata section))) + (if (%null-ptr-p data) + (error "Can' obtain ELF data pointer for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type data :lf_ata)))) + + +(defun elf-register-string (string table) + (let* ((hash (elf-string-table-hash table)) + (s (elf-string-table-string table))) + (when (gethash string hash) + (format t "~& duplicate: ~s" string)) + (or (gethash string hash) + (setf (gethash string hash) + (let* ((n (length s))) + (dotimes (i (length string) (progn (vector-push-extend 0 s) n)) + (let* ((code (char-code (char string i)))) + (declare (type (mod #x110000) code)) + (if (> code 255) + (vector-push-extend (char-code #\sub) s) + (vector-push-extend code s))))))))) + + +(defun elf-lisp-function-name (f) + (let* ((name (format nil "~s" f))) + (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1))) + +#+x8664-target +(defx86lapfunction dynamic-dnode ((x arg_z)) + (movq (% x) (% imm0)) + (ref-global x86::heap-start arg_y) + (subq (% arg_y) (% imm0)) + (shrq ($ x8664::dnode-shift) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +#+x8632-target +(defx8632lapfunction dynamic-dnode ((x arg_z)) + (movl (% x) (% imm0)) + (ref-global x86::heap-start arg_y) + (subl (% arg_y) (% imm0)) + (shrl ($ x8632::dnode-shift) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defun collect-elf-static-functions () + (collect ((functions)) + (freeze) + (block walk + (let* ((frozen-dnodes (frozen-space-dnodes))) + (%map-areas (lambda (o) + (when (>= (dynamic-dnode o) frozen-dnodes) + (return-from walk nil)) + (when (typep o + #+x8664-target 'function-vector + #-x8664-target 'function) + (functions (function-vector-to-function o)))) + ccl::area-dynamic + ))) + (functions))) + +(defun register-elf-functions (section-number) + (let* ((functions (collect-elf-static-functions)) + (n (length functions)) + (data (#_calloc (1+ n) (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym))) + (string-table (make-elf-string-table))) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (p (%inc-ptr data + (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym)) + (progn (%incf-ptr p + (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym)) + p)) + (f (pop functions) (pop functions))) + ((= i n) + (make-elf-symbol-table :strings string-table :data data :nsyms n)) + (declare (fixnum n)) + (setf (pref p + #+64-bit-target :lf64_ym.st_name + #+32-bit-target :lf32_ym.st_name) + (elf-register-string (elf-lisp-function-name f) string-table) + (pref p + #+64-bit-target :lf64_ym.st_info + #+32-bit-target :lf32_ym.st_info) + (logior (ash #$STB_GLOBAL 4) #$STT_FUNC) + (pref p + #+64-bit-target :lf64_ym.st_shndx + #+32-bit-target :lf32_ym.st_shndx) section-number + (pref p + #+64-bit-target :lf64_ym.st_value + #+32-bit-target :lf32_ym.st_value) (%address-of f) + (pref p + #+64-bit-target :lf64_ym.st_size + #+32-bit-target :lf32_ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift)))))) + +(defun elf-section-index (section) + (#_elf_ndxscn section)) + +(defun elf-set-shstrab-section (object scn) + #+freebsd-target + (#_elf_setshstrndx (elf-object-libelf-pointer object) (elf-section-index scn)) + #-freebsd-target + (declare (ignore object scn))) + + +(defun elf-init-section-data-from-string-table (object section string-table) + (let* ((strings-data (elf-data-pointer-for-section object section)) + (s (elf-string-table-string string-table)) + (bytes (array-data-and-offset s)) + (n (length s)) + (buf (#_malloc n))) + (%copy-ivector-to-ptr bytes 0 buf 0 n) + (setf (pref strings-data :lf_ata.d_align) 1 + (pref strings-data :lf_ata.d_off) 0 + (pref strings-data :lf_ata.d_type) #$ELF_T_BYTE + (pref strings-data :lf_ata.d_version) #$EV_CURRENT + (pref strings-data :lf_ata.d_size) n + (pref strings-data :lf_ata.d_buf) buf) + n)) + +(defun elf-init-symbol-section-from-symbol-table (object section symbols) + (let* ((symbols-data (elf-data-pointer-for-section object section)) + (buf (elf-symbol-table-data symbols)) + (nsyms (elf-symbol-table-nsyms symbols) ) + (n (* (1+ nsyms) (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym)))) + (setf (pref symbols-data :lf_ata.d_align) 8 + (pref symbols-data :lf_ata.d_off) 0 + (pref symbols-data :lf_ata.d_type) #$ELF_T_SYM + (pref symbols-data :lf_ata.d_version) #$EV_CURRENT + (pref symbols-data :lf_ata.d_size) n + (pref symbols-data :lf_ata.d_buf) buf) + nsyms)) + +(defun elf-make-empty-data-for-section (object section &optional (size 0)) + (let* ((data (elf-data-pointer-for-section object section)) + (buf +null-ptr+)) + (setf (pref data :lf_ata.d_align) 0 + (pref data :lf_ata.d_off) 0 + (pref data :lf_ata.d_type) #$ELF_T_BYTE + (pref data :lf_ata.d_version) #$EV_CURRENT + (pref data :lf_ata.d_size) size + (pref data :lf_ata.d_buf) buf) + 0)) + + +(defun elf-flag-phdr (object cmd flags) + (#_elf_flagphdr (elf-object-libelf-pointer object) cmd flags)) + +(defun elf-update (object cmd) + (let* ((size (#_elf_update (elf-object-libelf-pointer object) cmd))) + (if (< size 0) + (error "elf_update failed for for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + size))) + +(defun fixup-lisp-section-offset (fd eof sectnum) + (fd-lseek fd 0 #$SEEK_SET) + (rlet ((fhdr #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr) + (shdr #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + (fd-read fd fhdr (record-length #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + (let* ((pos (+ (pref fhdr #+64-bit-target :lf64_hdr.e_shoff + #+32-bit-target :lf32_hdr.e_shoff) + (* sectnum (pref fhdr #+64-bit-target :lf64_hdr.e_shentsize + #+32-bit-target :lf32_hdr.e_shentsize))))) + (fd-lseek fd pos #$SEEK_SET) + (fd-read fd shdr (record-length #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + ;; On 64-bit platforms, the section data precedes the image + ;; header; on 32-bit platforms, the image header and image + ;; section table precede the image data for the first (static) + ;; section. With alignment, the header/section headers are + ;; one 4K page, and the static section size is 8K ... + (setf (pref shdr #+64-bit-target :lf64_hdr.sh_offset + #+32-bit-target :lf32_hdr.sh_offset) + (+ #+32-bit-target #x1000 #+64-bit-target 0 #x2000 (logandc2 (+ eof 4095) 4095))) + (setf (pref shdr #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) + #$SHT_PROGBITS) + (fd-lseek fd pos #$SEEK_SET) + (fd-write fd shdr (record-length #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + t))) + +(defun write-elf-symbols-to-file (pathname) + (let* ((object (create-elf-object pathname)) + (file-header (new-elf-file-header object + #+little-endian-target #$ELFDATA2LSB + #+big-endian-target #$ELFDATA2MSB + #$ET_DYN + #+x8664-target #$EM_X86_64 + #+x8632-target #$EM_386 + #+ppc32-target #$EM_PPC + #+ppc64-target #$EM_PPC64 + )) + (program-header (new-elf-program-header object)) + (lisp-section (new-elf-section object)) + (symbols-section (new-elf-section object)) + (strings-section (new-elf-section object)) + (shstrtab-section (new-elf-section object)) + (section-names (make-elf-string-table)) + (lisp-section-index (elf-section-index lisp-section)) + (symbols (register-elf-functions lisp-section-index)) + (lisp-section-header (elf-section-header-for-section object lisp-section)) + (symbols-section-header (elf-section-header-for-section object symbols-section)) + (strings-section-header (elf-section-header-for-section object strings-section)) + (shstrtab-section-header (elf-section-header-for-section object shstrtab-section))) + + (setf (pref file-header #+64-bit-target :lf64_hdr.e_shstrndx + #+32-bit-target :lf32_hdr.e_shstrndx) (elf-section-index shstrtab-section)) + (setf (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".lisp" section-names) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_NOBITS + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_flags + #+32-bit-target :lf32_hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_addr + #+32-bit-target :lf32_hdr.sh_addr) (ash (%get-kernel-global heap-start) target::fixnumshift) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_size + #+32-bit-target :lf32_hdr.sh_size) (ash (frozen-space-dnodes) target::dnode-shift) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_offset + #+32-bit-target :lf32_hdr.sh_offset) 0 + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_addralign + #+32-bit-target :lf32_hdr.sh_addralign) 1) + (setf (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".symtab" section-names) + (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_SYMTAB + (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_entsize + #+32-bit-target :lf32_hdr.sh_entsize) (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym) + (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_link + #+32-bit-target :lf32_hdr.sh_link) (elf-section-index strings-section)) + (setf (pref strings-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".strtab" section-names) + (pref strings-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_STRTAB + (pref strings-section-header #+64-bit-target :lf64_hdr.sh_flags + #+32-bit-target :lf32_hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC)) + (setf (pref shstrtab-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".shstrtab" section-names) + (pref shstrtab-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_STRTAB + (pref shstrtab-section-header #+64-bit-target :lf64_hdr.sh_flags + #+32-bit-target :lf32_hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC)) + (elf-make-empty-data-for-section object lisp-section (ash (frozen-space-dnodes) target::dnode-shift)) + (elf-init-section-data-from-string-table object strings-section (elf-symbol-table-strings symbols)) + (elf-init-section-data-from-string-table object shstrtab-section section-names) + (elf-init-symbol-section-from-symbol-table object symbols-section symbols) + ;; Prepare in-memory data structures. + (elf-update object #$ELF_C_NULL) + ;; Fix up the program header. + (setf (pref program-header + #+64-bit-target :lf64_

hdr.p_type + #+32-bit-target :lf32_

hdr.p_type) #$PT_PHDR + (pref program-header #+64-bit-target :lf64_

hdr.p_offset + #+32-bit-target :lf32_

hdr.p_offset) + (pref file-header + #+64-bit-target :lf64_hdr.e_phoff + #+32-bit-target :lf32_hdr.e_phoff) + (pref program-header + #+64-bit-target :lf64_

hdr.p_filesz + #+32-bit-target :lf32_

hdr.p_filesz) + (#+64-bit-target #_elf64_fsize #+32-bit-target #_elf32_fsize #$ELF_T_PHDR 1 #$EV_CURRENT)) + ;; Mark the program header as being dirty. + (elf-flag-phdr object #$ELF_C_SET #$ELF_F_DIRTY) + (let* ((eof (elf-update object #$ELF_C_WRITE)) + (fd (elf-object-fd object))) + (elf-end object) + (fixup-lisp-section-offset fd eof lisp-section-index) + (fd-close fd)) + pathname)) + + + + Index: /branches/qres/ccl/library/hash-cons.lisp =================================================================== --- /branches/qres/ccl/library/hash-cons.lisp (revision 13564) +++ /branches/qres/ccl/library/hash-cons.lisp (revision 13564) @@ -0,0 +1,498 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Low-level support for hash-consing. + +(in-package "CCL") + +(defpackage "OPENMCL-HONS" + (:use "CL") + (:nicknames "HONS") + (:export "HONS-INDEX-USED-P" "HONS-SPACE-DELETED-MARKER" + "HONS-SPACE-FREE-MARKER" + "HONS-SPACE-SIZE" "HONSP" "HONS-FROM-INDEX" + "HONS-SPACE-REF-CAR" "HONS-SPACE-REF-CDR" + "HONS-SPACE-CONS" "DELETED-HONS-COUNT" "INVALID-HONS-INDEX" + "INVALID-HONS-INDEX-INDEX")) + + +;;; At this level. the API is basically: +;;; +;;; +;;; (OPENMCL-HONS:HONS-SPACE-DELETED-MARKER) [MACRO] +;;; Returns another constant value used to indicate a +;;; "deleted" cell in a HONS hash table; the CAR and CDR of +;;; a pair are set to this value by the GC if the HONS which +;;; addresses that pair becomes garbage. This value is used +;;; in Clozure CL to denote unbound slots in STANDARD-INSTANCEs, +;;; so setting a slot in a standard-instance to this value +;;; is roughly equivalent to calling SLOT-MAKUNBOUND. This +;;; value prints as #. +;;; +;;; (OPENMCL-HONS:HONS-SPACE-FREE-MARKER) [MACRO] +;;; Returns another constant value used to indicate a +;;; "free" cell in a HONS hash table; the CAR and CDR of +;;; a pair are initially set to this value by the GC if the HONS which +;;; addresses that pair becomes garbage. This value is used +;;; in Clozure CL to denote unbound special variabls +;;; setting a special variable to this value +;;; is roughly equivalent to calling MAKUNBOUND. This +;;; value prints as #. + +;;; (OPENCL-HONS:HONS-SPACE-SIZE) +;;; Returns a non-negative integer denoting the number of +;;; statically allocated pairs reserved for hash consing. +;;; +;;; OPENMCL-HONS:HONS-SPACE-SIZE can be used with SETF, to specify a +;;; new size in pairs. The new size should be a non-negative +;;; fixnum. If the new size is less than the current size, +;;; any references to HONSes whose index is between the +;;; current and new size will be set to NIL. +;;; Otherwise, any newly allocated pairs will have their CAR and CDR both +;;; set to the value returned by (OPENMCL-HONS:HONS-SPACE-FREE). +;;; +;;; (OPENMCL-HONS:HONSP ) +;;; If is a CONS and is allocated within hons-space, +;;; returns the index of the pair addressed by (e.g., +;;; the return value will be a non-negative integer less than +;;; (OPENMCL-HONS:HONS-SPACE-SIZE). If is not a CONS or is not +;;; allocated within hons-space, returns NIL. +;;; +;;; (OPENCL-HONS:HONS-FROM-INDEX ) If is a non-negative +;;; integer less than (OPENMCL-HONS:HONS-SPACE-SIZE), returns a +;;; CONS-typed pointer to the th pair in hons-space. (If +;;; is a HONS, then (EQ (OPENMCL-HONS:HONS-FROM-INDEX +;;; (OPENMCL-HONS:HONSP )) ) is true). Signals an error +;;; of type OPENMCL-HONS:INVALID-HONS-INDEX if is a fixnum but +;;; not a valid index. Signals a TYPE-ERROR if is not a fixum. +;;; +;;; (OPENMCL-HONS:HONS-SPACE-REF-CAR ) +;;; (OPENMCL-HONS:HONS-SPACE-REF-CDR ) +;;; Semantically equivalent to (CAR (OPENMCL-HONS:HONS-FROM-INDEX )) and +;;; (CDR (OPENMCL-HONS:HONS-FROM-INDEX )), respectively. (May not be +;;; implemented in a way that actually calls OPENMCL-HONS:HONS-FROM-INDEX.) +;;; +;;; (OPENMCL-HONS:HONS-SPACE-CONS ) +;;; Equivalent to: +;;; (let* ((x (OPENMCL-HONS:HONS-FROM-INDEX ))) +;;; (setf (car x) +;;; (cdr x) ) +;;; x) +;;; +;;; (OPENMCL-HONS:HONS-INDEX-USED-P ) +;;; If is a valid index, returns a Lisp boolean indicating +;;; whether or not +;;; (a) OPENMCL-HONS:HONS-FROM-INDEX has been called on it +;;; and (b) the GC has not marked the index as being deleted +;;; are both true. + +;;; (OPENMCL-HONS:DELETED-HONS-COUNT) +;;; Returns the total number of pairs in hons space that the GC has deleted +;;; (because they were unreachable); a "deleted" pair has its CAR and CDR +;;; set to the value of (OPENMCL-HONS:HONS-DELETED-MARKER), but (since these +;;; things are statically allocated) the space that the pair occupied remains +;;; part of hons space. +;;; Information about the number of deleted pairs may help to guide hashing +;;; algorithms, but it's not yet clear whether this global count is that +;;; useful; it may be replaced or extended in the future. + + +(define-condition openmcl-hons:invalid-hons-index () + ((index :initarg :index :reader openmcl-hons:invalid-hons-index-index)) + (:report (lambda (c s) + (format s "Invalid HONS index ~s ." + (openmcl-hons:invalid-hons-index-index c))))) + + +(defmacro openmcl-hons:hons-space-deleted-marker () + "Returns the value used to indicate deleted HONS cells." + (%slot-unbound-marker)) + +(defmacro openmcl-hons:hons-space-free-marker () + "Returns the value used to indicate free HONS cells." + (%unbound-marker)) + +(defun (setf openmcl-hons:hons-space-size) (npairs) + "Argument NPAIRS should be a non-negative fixnum. Tries to grow or + shrink the static hons area so that it contains NPAIRS pairs. + NPAIRS may be rounded to the next multiple of the machine word size. + Returns the number of pairs in the HONS space after it's made the + (possibly unsuccessful) attempt. (Attempts to increase HONS space + size may fail if insufficient address space is available.) + If NPAIRS is less than the current hons space size, any \"dangling\" + references to HONS cells in the deleted region will be set to NIL." + (check-type npairs (integer 0 #.(- (1+ target::most-positive-fixnum) + target::nbits-in-word))) + (set-hons-space-size npairs)) + +#+ppc-target +(defppclapfunction set-hons-space-size ((npairs arg_z)) + (check-nargs 1) + (mflr loc-pc) + #+ppc32-target + (bla .SPgetu32) + #+ppc64-target + (bla .SPgetu64) + (mtlr loc-pc) + (mr imm1 imm0) + (li imm0 arch::gc-trap-function-set-hons-area-size) + (trlgei allocptr 0) + #+ppc32-target + (ba .SPmakeu32) + #+ppc64-target + (ba .SPmakeu64)) + + +#+x8664-target +(defx86lapfunction set-hons-space-size ((npairs arg_z)) + (check-nargs 1) + (save-simple-frame) + (call-subprim .SPgetu64) + (movq (% imm0) (% imm1)) + (movq ($ arch::gc-trap-function-set-hons-area-size) (% imm0)) + (uuo-gc-trap) + (restore-simple-frame) + (jmp-subprim .SPmakeu64)) + +(defun openmcl-hons:hons-space-size () + "Returns the current size of the static hons area." + (%fixnum-ref-natural (%get-kernel-global 'tenured-area) + target::area.static-dnodes)) + +#+ppc-target +(defppclapfunction openmcl-hons:honsp ((thing arg_z)) + "If THING is a CONS cell allocated in the hons area, return an integer + which denotes that cell's index in hons space - an integer between + 0 (inclusive) and the hons-space size (exclusive). Otherwise, return + NIL." + (check-nargs 1) + (extract-fulltag imm2 thing) + (ref-global imm0 tenured-area) + (cmpri cr2 imm2 target::fulltag-cons) + (ldr imm1 target::area.static-dnodes imm0) + (ldr imm0 target::area.low imm0) + (slri imm1 imm1 (1+ target::word-shift)) + (bne cr2 @no) + (add imm1 imm0 imm1) + (cmpr cr0 thing imm0) + (cmpr cr1 thing imm1) + (blt cr0 @no) + (bgt cr1 @no) + (subi arg_z arg_z target::fulltag-cons) + (sub arg_z arg_z imm0) + (srri arg_z arg_z 1) + (blr) + @no + (li arg_z nil) + (blr)) + +#+x8664-target +(defx86lapfunction openmcl-hons:honsp ((thing arg_z)) + "If THING is a CONS cell allocated in the hons area, return an integer + which denotes that cell's index in hons space - an integer between + 0 (inclusive) and the hons-space size (exclusive). Otherwise, return + NIL." + (check-nargs 1) + (extract-fulltag thing imm1) + (ref-global tenured-area imm0) + (cmpb ($ target::fulltag-cons) (% imm1.b)) + (movq (@ target::area.static-dnodes (% imm0)) (% imm1)) + (movq (@ target::area.low (% imm0)) (% imm0)) + (jne @no) + (shr ($ (1+ target::word-shift)) (% imm1)) + (add (% imm0) (% imm1)) + (rcmpq (% thing) (% imm0)) + (jb @no) + (rcmpq (% thing) (% imm1)) + (jae @no) + (subq ($ target::fulltag-cons) (% arg_z)) + (subq (% imm0) (% arg_z)) + (shr ($ 1) (% arg_z)) + (single-value-return) + @no + (movq ($ nil) (% arg_z)) + (single-value-return)) + +#+ppc-target +(defppclapfunction openmcl-hons:hons-from-index ((index arg_z)) + "If INDEX is a fixnum between 0 (inclusive) and the current hons space size + (exclusive), return a statically allocated CONS cell. Otherwise, signal + an error." + (check-nargs 1) + (extract-lisptag imm0 index) + (cmpri cr0 index 0) + (cmpri cr1 imm0 target::tag-fixnum) + (ref-global imm0 tenured-area) + (unbox-fixnum imm1 arg_z) + (ldr imm2 target::area.static-dnodes imm0) + (bne cr1 @bad) + (cmpr cr2 imm1 imm2) + (blt cr0 @bad) + (ldr imm2 target::area.static-used imm0) + (ldr imm0 target::area.low imm0) + (bge cr2 @bad) + (add arg_z index index) + (add arg_z imm0 arg_z) + (la arg_z target::fulltag-cons arg_z) + (sub imm0 arg_z imm0) + (set-bit-at-index imm2 imm0) + (blr) + @bad + (save-lisp-context) + (load-constant arg_x openmcl-hons:invalid-hons-index) + (load-constant arg_y :index) + (set-nargs 3) + (load-constant fname error) + (bla .SPjmpsym) + (ba .SPpopj)) + +#+x8664-target +(defx86lapfunction openmcl-hons:hons-from-index ((index arg_z)) + "If INDEX is a fixnum between 0 (inclusive) and the current hons space size + (exclusive), return a statically allocated CONS cell. Otherwise, signal + an error." + (check-nargs 1) + (testb ($ x8664::fixnummask) (%b index)) + (ref-global tenured-area temp0) + (jne @bad) + (unbox-fixnum index imm1) + (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0))) + (jae @bad) + (shl ($ 1) (% index)) + (movq (% index) (% imm0)) + (addq (@ target::area.low (% temp0)) (% index)) + (addq ($ target::fulltag-cons) (% arg_z)) + (movq (@ target::area.static-used (% temp0)) (% temp0)) + (movq (% imm1) (% imm0)) + (andl ($ 63) (% imm0)) + (xorb ($ 63) (%b imm0)) + (shrq ($ 6) (% imm1)) + (lock) + (btsq (% imm0) (@ (% temp0) (% imm1) 8)) + (single-value-return) + @bad + (save-simple-frame) + (load-constant openmcl-hons:invalid-hons-index arg_x) + (load-constant :index arg_y) + (call-symbol error 3) + (restore-simple-frame) + (single-value-return)) + + + +#+ppc-target +(defppclapfunction openmcl-hons:hons-index-used-p ((index arg_z)) + "If INDEX is a fixnum between 0 (inclusive) and the current hons space size + (exclusive), return a boolean indicating whether the pair is used. + Otherwise, signal an error." + (check-nargs 1) + (extract-lisptag imm0 index) + (cmpri cr0 index 0) + (cmpri cr1 imm0 target::tag-fixnum) + (ref-global imm0 tenured-area) + (unbox-fixnum imm1 arg_z) + (ldr imm2 target::area.static-dnodes imm0) + (bne cr1 @bad) + (cmpr cr2 imm1 imm2) + (blt cr0 @bad) + (ldr imm2 target::area.static-used imm0) + (ldr imm0 target::area.low imm0) + (bge cr2 @bad) + (add imm0 index index) + (test-bit-at-index imm2 imm0) + (li arg_z nil) + (beqlr) + (li arg_z t) + (blr) + @bad + (save-lisp-context) + (load-constant arg_x openmcl-hons:invalid-hons-index) + (load-constant arg_y :index) + (set-nargs 3) + (load-constant fname error) + (bla .SPjmpsym) + (ba .SPpopj)) + +#+x8664-target +(defx86lapfunction openmcl-hons:hons-index-used-p ((index arg_z)) + "If INDEX is a fixnum between 0 (inclusive) and the current hons space size + (exclusive), return a boolean indicating whether the pair is used. + Otherwise, signal an error." + (check-nargs 1) + (testb ($ x8664::fixnummask) (%b index)) + (ref-global tenured-area temp0) + (jne @bad) + (unbox-fixnum index imm1) + (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0))) + (jae @bad) + (movq (@ target::area.static-used (% temp0)) (% temp0)) + (movq (% imm1) (% imm0)) + (andl ($ 63) (% imm0)) + (xorb ($ 63) (%b imm0)) + (shrq ($ 6) (% imm1)) + (btq (% imm0) (@ (% temp0) (% imm1) 8)) + (movl ($ x8664::t-value) (%l imm0)) + (leaq (@ (- x8664::t-offset) (% imm0)) (% arg_z)) + (cmovbl (%l imm0) (%l arg_z)) + (single-value-return) + @bad + (save-simple-frame) + (load-constant openmcl-hons:invalid-hons-index arg_x) + (load-constant :index arg_y) + (call-symbol error 3) + (restore-simple-frame) + (single-value-return)) + + +#+ppc-target +(defppclapfunction openmcl-hons:hons-space-ref-car ((index arg_z)) + "If INDEX is in bounds (non-negative and less than the current hons-space size), + return the CAR of the pair at that index. The return value could be any + lisp object, or (HONS-SPACE-DELETED-MARKER). + If INDEX is not in bounds, an error is signaled." + (check-nargs 1) + (extract-lisptag imm0 index) + (cmpri cr0 index 0) + (cmpri cr1 imm0 target::tag-fixnum) + (ref-global imm0 tenured-area) + (unbox-fixnum imm1 arg_z) + (ldr imm2 target::area.static-dnodes imm0) + (bne cr1 @bad) + (cmpr cr2 imm1 imm2) + (blt cr0 @bad) + (ldr imm0 target::area.low imm0) + (bge cr2 @bad) + (add arg_z index index) + (add imm0 imm0 arg_z) + (ldr arg_z (+ target::cons.car target::fulltag-cons) imm0) + (blr) + @bad + (save-lisp-context) + (load-constant arg_x openmcl-hons:invalid-hons-index) + (load-constant arg_y :index) + (set-nargs 3) + (load-constant fname error) + (bla .SPjmpsym) + (ba .SPpopj)) + +#+x8664-target +(defx86lapfunction openmcl-hons:hons-space-ref-car ((index arg_z)) + "If INDEX is in bounds (non-negative and less than the current hons-space size), + return the CAR of the pair at that index. The return value could be any + lisp object, or (HONS-SPACE-DELETED-MARKER). + If INDEX is not in bounds, an error is signaled." + (check-nargs 1) + (testb ($ x8664::fixnummask) (%b index)) + (ref-global tenured-area temp0) + (jne @bad) + (unbox-fixnum index imm1) + (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0))) + (jae @bad) + (shlq ($ 1) (% index)) + (addq (@ target::area.low (% temp0)) (% arg_z)) + (movq (@ (+ target::cons.car target::fulltag-cons) (% arg_z)) (% arg_z)) + (single-value-return) + @bad + (save-simple-frame) + (load-constant openmcl-hons:invalid-hons-index arg_x) + (load-constant :index arg_y) + (call-symbol error 3) + (restore-simple-frame) + (single-value-return)) + +#+ppc-target +(defppclapfunction openmcl-hons:hons-space-ref-cdr ((index arg_z)) + "If INDEX is in bounds (non-negative and less than the current hons-space size), + return the CAR of the pair at that index. The return value could be any + lisp object, or either (HONS-SPACE-FREE-MARKER) or (HONS-SPACE-DELETED-MARKER). + If INDEX is not in bounds, an error is signaled." + (check-nargs 1) + (extract-lisptag imm0 index) + (cmpri cr0 index 0) + (cmpri cr1 imm0 target::tag-fixnum) + (ref-global imm0 tenured-area) + (unbox-fixnum imm1 arg_z) + (ldr imm2 target::area.static-dnodes imm0) + (bne cr1 @bad) + (cmpr cr2 imm1 imm2) + (blt cr0 @bad) + (ldr imm0 target::area.low imm0) + (bge cr2 @bad) + (add arg_z index index) + (add imm0 imm0 arg_z) + (ldr arg_z (+ target::cons.cdr target::fulltag-cons) imm0) + (blr) + @bad + (save-lisp-context) + (load-constant arg_x openmcl-hons:invalid-hons-index) + (load-constant arg_y :index) + (set-nargs 3) + (load-constant fname error) + (bla .SPjmpsym) + (ba .SPpopj)) + +#+x8664-target +(defx86lapfunction openmcl-hons:hons-space-ref-cdr ((index arg_z)) + "If INDEX is in bounds (non-negative and less than the current hons-space size), + return the CDR of the pair at that index. The return value could be any + lisp object, or (HONS-SPACE-DELETED-MARKER). + If INDEX is not in bounds, an error is signaled." + (check-nargs 1) + (testb ($ x8664::fixnummask) (%b index)) + (ref-global tenured-area temp0) + (jne @bad) + (unbox-fixnum index imm1) + (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0))) + (jae @bad) + (shlq ($ 1) (% index)) + (addq (@ target::area.low (% temp0)) (% arg_z)) + (movq (@ (+ target::cons.cdr target::fulltag-cons) (% arg_z)) (% arg_z)) + (single-value-return) + @bad + (save-simple-frame) + (load-constant openmcl-hons:invalid-hons-index arg_x) + (load-constant :index arg_y) + (call-symbol error 3) + (restore-simple-frame) + (single-value-return)) + + + + +(defun openmcl-hons:hons-space-cons (index new-car new-cdr) + "Return a CONS cell with the specified NEW-CAR and NEW-CDR, + allocated at the INDEXth pair in hons space." + (let* ((hons (openmcl-hons:hons-from-index index))) + (setf (car hons) new-car + (cdr hons) new-cdr) + hons)) + +;;; We might have multiple (logical) tables in hons space, and +;;; would probably like to know how many pairs had been deleted +;;; from each table. (How to express that to the GC in some +;;; way that would allow it to efficiently track this is an +;;; open question.) For now, the GC just maintains a global +;;; count of static pairs that it's deleted. +(defun openmcl-hons:deleted-hons-count () + "Returns the total number of pairs in hons space that have + been deleted by the GC." + (%get-kernel-global 'deleted-static-pairs)) + +(defun (setf openmcl-hons:deleted-hons-count) (new) + (check-type new (and fixnum unsigned-byte)) + (%set-kernel-global 'deleted-static-pairs new)) + +(provide "HASH-CONS") Index: /branches/qres/ccl/library/intel-io.lisp =================================================================== --- /branches/qres/ccl/library/intel-io.lisp (revision 13564) +++ /branches/qres/ccl/library/intel-io.lisp (revision 13564) @@ -0,0 +1,182 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2010 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Some primitives for accessing Intel I/O ports from CCL. +;;; Note that port access requires special privileges which +;;; the OS may or may not provide (and generally only provides +;;; to root/privileged users if it does provide them.) +;;; Port addresses must be unsigned 16-bit integers. +;;; Values written via '%outb', '%outw', and '%outl' must be +;;; unsigned 8-bit 16-bit or 32-bit integers +;;; +;;; (%inb port) - read an unsigned 8-bit byte from the specified I/O port +;;; (%inw port) - 16-bit +;;; (%inl port) - 32-bit +;;; (%outb val port) - write an unsigned 8-bit value to the specified I/O port +;;; (%outw val port) - write an unsigned 16-bit value to the specified I/O port +;;; (%outl val port) - write an unsigned 32-bit value to the specified I/O port + + +#+x8632-target +(progn +(defx8632lapfunction %inb ((port arg_z)) + (mark-as-imm temp1) + (unbox-fixnum port edx) + (:byte #xec) ;inb (%dx),%al + (mark-as-node temp1) + (movzbl (% al) (% eax)) + (box-fixnum eax arg_z) + (single-value-return)) + + +(defx8632lapfunction %inw ((port arg_z)) + (mark-as-imm temp1) + (unbox-fixnum port edx) + (:byte #x66) (:byte #xed) ;inw (%dx),%ax + (mark-as-node temp1) + (movzwl (% ax) (% eax)) + (box-fixnum eax arg_z) + (single-value-return)) + +(defx8632lapfunction %inl ((port arg_z)) + (mark-as-imm temp1) + (unbox-fixnum port edx) + (:byte #xed) ;inl (%dx),%eax + (mark-as-node temp1) + (jmp-subprim .SPmakeu32)) + + +(defx8632lapfunction %outb ((val arg_y) (port arg_z)) + (unbox-fixnum val eax) + (mark-as-imm temp1) + (unbox-fixnum port edx) + (:byte #xee) ;outb %al,(%dx) + (mark-as-node temp1) + (mov (% val) (% arg_z)) + (single-value-return)) + + +(defx8632lapfunction %outw ((val arg_y) (port arg_z)) + (unbox-fixnum val eax) + (mark-as-imm temp1) + (unbox-fixnum port edx) + (:byte #x66) (:byte #xef) ;outw %ax,(%dx) + (mark-as-node temp1) + (mov (% val) (% arg_z)) + (single-value-return)) + + +(defx8632lapfunction %outl ((val arg_y) (port arg_z)) + (save-simple-frame) + (pushl (% port)) + (movl (% val) (% arg_z)) + (call-subprim .SPgetu32) + (popl (% temp0)) + (mark-as-imm temp1) + (unbox-fixnum temp0 edx) + (:byte #xef) ;outl %eax,(%dx) + (mark-as-node temp1) + (restore-simple-frame) + (single-value-return)) +) + +#+x8664-target +(progn +(defx86lapfunction %inb ((port arg_z)) + (unbox-fixnum port rdx) + (:byte #xec) ;inb (%dx),%al + (movzbl (% al) (% eax)) + (box-fixnum rax arg_z) + (single-value-return)) + + +(defx86lapfunction %inw ((port arg_z)) + (unbox-fixnum port rdx) + (:byte #x66) (:byte #xed) ;inw (%dx),%ax + (movzwl (% ax) (% eax)) + (box-fixnum rax arg_z) + (single-value-return)) + +(defx86lapfunction %inl ((port arg_z)) + (unbox-fixnum port rdx) + (:byte #xed) ;inl (%dx),%eax + (box-fixnum rax arg_z) + (single-value-return)) + + +(defx86lapfunction %outb ((val arg_y) (port arg_z)) + (unbox-fixnum val rax) + (unbox-fixnum port rdx) + (:byte #xee) ;outb %al,(%dx) + (movq (% val) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %outw ((val arg_y) (port arg_z)) + (unbox-fixnum val rax) + (unbox-fixnum port rdx) + (:byte #x66) (:byte #xef) ;outw %ax,(%dx) + (mov (% val) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %outl ((val arg_y) (port arg_z)) + (unbox-fixnum val imm0) + (unbox-fixnum port rdx) + (:byte #xef) ;outl %eax,(%dx) + (mov (% val) (% arg_z)) + (single-value-return)) +) + + +;;; Linux provides two primitives which allow a process running as +;;; a privileged user to execute I/O instructions. + +;;; #_ioperm can be used to gain/renounce access to a range if I/O +;;; ports; all ports in that range must be below #x4000. +;;; #_iopl can be used to set the calling process's privilege level +;;; to a value between 0 and 3; 0 being the level at which user code +;;; usually runs and 3 being the most privileged level. + +#+(and linux-target x86-target) +(progn +(defun ioperm (enable-p first-port last-port) + (check-type first-port (integer 0 (#x400))) + (check-type last-port (integer 0 (#x400))) + (unless (<= first-port last-port) + (error "First port ~d must be <= last port ~d." first-port last-port)) + (or (eql 0 + (external-call "ioperm" + :unsigned-long first-port + :unsigned-long (1+ (- last-port first-port)) + :int (if enable-p 1 0) + :int)) + (error "Error ~aing port access: ~a." + (if enable-p "enabl" "disabl") + (%strerror (%get-errno))))) + +(defun iopl (level) + (check-type level (integer 0 3)) + (or (eql 0 (external-call "iopl" :int level :int)) + (error "Can't set I/O privilege level to ~d: ~a." + level + (%strerror (%get-errno))))) +) + +;;; Other OSes may provide similar functionality. + Index: /branches/qres/ccl/library/jp-encode.lisp =================================================================== --- /branches/qres/ccl/library/jp-encode.lisp (revision 13564) +++ /branches/qres/ccl/library/jp-encode.lisp (revision 13564) @@ -0,0 +1,17945 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;;; helper functions +(defvar *eucjp-to-ucs-hash* (make-hash-table)) +(defvar *ucs-to-eucjp-hash* (make-hash-table)) +(defvar *cp932-to-ucs-hash* (make-hash-table)) +(defvar *ucs-to-cp932-hash* (make-hash-table)) + +(let* ((cp932-only '((#xFC4B #x9ED1) + (#xFC4A #x9E19) + (#xFC49 #xFA2D) + (#xFC48 #x9D6B) + (#xFC47 #x9D70) + (#xFC46 #x9C00) + (#xFC45 #x9BBB) + (#xFC44 #x9BB1) + (#xFC43 #x9B8F) + (#xFC42 #x9B72) + (#xFC41 #x9B75) + (#xFC40 #x9ADC) + (#xFBFC #x9AD9) + (#xFBFB #x9A4E) + (#xFBFA #x999E) + (#xFBF9 #xFA2C) + (#xFBF8 #x9927) + (#xFBF7 #xFA2B) + (#xFBF6 #xFA2A) + (#xFBF5 #x9865) + (#xFBF4 #x9857) + (#xFBF3 #x9755) + (#xFBF2 #x9751) + (#xFBF1 #x974F) + (#xFBF0 #x974D) + (#xFBEF #x9743) + (#xFBEE #x973B) + (#xFBED #x9733) + (#xFBEC #x96AF) + (#xFBEB #x969D) + (#xFBEA #xFA29) + (#xFBE9 #xF9DC) + (#xFBE8 #x9592) + (#xFBE7 #x9448) + (#xFBE6 #x9445) + (#xFBE5 #x9431) + (#xFBE4 #x93F8) + (#xFBE3 #x93DE) + (#xFBE2 #x93C6) + (#xFBE1 #x93A4) + (#xFBE0 #x9357) + (#xFBDF #x9370) + (#xFBDE #x9302) + (#xFBDD #x931D) + (#xFBDC #x92FF) + (#xFBDB #x931E) + (#xFBDA #xFA28) + (#xFBD9 #x92FB) + (#xFBD8 #x9321) + (#xFBD7 #x9325) + (#xFBD6 #x92D3) + (#xFBD5 #x92E0) + (#xFBD4 #x92D5) + (#xFBD3 #xFA27) + (#xFBD2 #x92D0) + (#xFBD1 #x92D9) + (#xFBD0 #x92D7) + (#xFBCF #x92E7) + (#xFBCE #x9278) + (#xFBCD #x9277) + (#xFBCC #x92A7) + (#xFBCB #x9267) + (#xFBCA #x9239) + (#xFBC9 #x9251) + (#xFBC8 #x9259) + (#xFBC7 #x924E) + (#xFBC6 #x923C) + (#xFBC5 #x9240) + (#xFBC4 #x923A) + (#xFBC3 #x920A) + (#xFBC2 #x9210) + (#xFBC1 #x9206) + (#xFBC0 #x91E5) + (#xFBBF #x91E4) + (#xFBBE #x91EE) + (#xFBBD #x91ED) + (#xFBBC #x91DE) + (#xFBBB #x91D7) + (#xFBBA #x91DA) + (#xFBB9 #x9127) + (#xFBB8 #x9115) + (#xFBB7 #xFA26) + (#xFBB6 #x90DE) + (#xFBB5 #x9067) + (#xFBB4 #xFA25) + (#xFBB3 #xFA24) + (#xFBB2 #x8ECF) + (#xFBB1 #xFA23) + (#xFBB0 #x8D76) + (#xFBAF #x8D12) + (#xFBAE #x8CF4) + (#xFBAD #x8CF0) + (#xFBAC #x8B7F) + (#xFBAB #x8B53) + (#xFBAA #x8AF6) + (#xFBA9 #xFA22) + (#xFBA8 #x8ADF) + (#xFBA7 #x8ABE) + (#xFBA6 #x8AA7) + (#xFBA5 #x8A79) + (#xFBA4 #x8A37) + (#xFBA3 #x8A12) + (#xFBA2 #x88F5) + (#xFBA1 #x8807) + (#xFBA0 #xFA21) + (#xFB9F #xFA20) + (#xFB9E #x85B0) + (#xFB9D #xFA1F) + (#xFB9C #x856B) + (#xFB9B #x8559) + (#xFB9A #x8553) + (#xFB99 #x84B4) + (#xFB98 #x8448) + (#xFB97 #x83F6) + (#xFB96 #x83C7) + (#xFB95 #x837F) + (#xFB94 #x8362) + (#xFB93 #x8301) + (#xFB92 #xFA1E) + (#xFB91 #x7FA1) + (#xFB90 #x7F47) + (#xFB8F #x7E52) + (#xFB8E #x7DD6) + (#xFB8D #x7DA0) + (#xFB8C #x7DB7) + (#xFB8B #x7D5C) + (#xFB8A #x7D48) + (#xFB89 #xFA1D) + (#xFB88 #x7B9E) + (#xFB87 #x7AEB) + (#xFB86 #xFA1C) + (#xFB85 #x7AE7) + (#xFB84 #x7AD1) + (#xFB83 #x799B) + (#xFB82 #xFA1B) + (#xFB81 #x7994) + (#xFB80 #xFA1A) + (#xFB7E #xFA19) + (#xFB7D #xFA18) + (#xFB7C #x7930) + (#xFB7B #x787A) + (#xFB7A #x7864) + (#xFB79 #x784E) + (#xFB78 #x7821) + (#xFB77 #x52AF) + (#xFB76 #x7746) + (#xFB75 #xFA17) + (#xFB74 #x76A6) + (#xFB73 #x769B) + (#xFB72 #x769E) + (#xFB71 #x769C) + (#xFB70 #x7682) + (#xFB6F #x756F) + (#xFB6E #x7501) + (#xFB6D #x749F) + (#xFB6C #x7489) + (#xFB6B #x7462) + (#xFB6A #x742E) + (#xFB69 #x7429) + (#xFB68 #x742A) + (#xFB67 #x7426) + (#xFB66 #x73F5) + (#xFB65 #x7407) + (#xFB64 #x73D2) + (#xFB63 #x73E3) + (#xFB62 #x73D6) + (#xFB61 #x73C9) + (#xFB60 #x73BD) + (#xFB5F #x7377) + (#xFB5E #xFA16) + (#xFB5D #x7324) + (#xFB5C #x72BE) + (#xFB5B #x72B1) + (#xFB5A #x71FE) + (#xFB59 #x71C1) + (#xFB58 #xFA15) + (#xFB57 #x7147) + (#xFB56 #x7146) + (#xFB55 #x715C) + (#xFB54 #x7104) + (#xFB53 #x710F) + (#xFB52 #x70AB) + (#xFB51 #x7085) + (#xFB50 #x7028) + (#xFB4F #x7007) + (#xFB4E #x7005) + (#xFB4D #x6FF5) + (#xFB4C #x6FB5) + (#xFB4B #x6F88) + (#xFB4A #x6EBF) + (#xFB49 #x6E3C) + (#xFB48 #x6E27) + (#xFB47 #x6E5C) + (#xFB46 #x6E39) + (#xFB45 #x6DFC) + (#xFB44 #x6DF2) + (#xFB43 #x6DF8) + (#xFB42 #x6DCF) + (#xFB41 #x6DAC) + (#xFB40 #x6D96) + (#xFAFC #x6D6F) + (#xFAFB #x6D87) + (#xFAFA #x6D04) + (#xFAF9 #x6CDA) + (#xFAF8 #x6C6F) + (#xFAF7 #x6C86) + (#xFAF6 #x6C5C) + (#xFAF5 #x6C3F) + (#xFAF4 #x6BD6) + (#xFAF3 #x6AE4) + (#xFAF2 #x6AE2) + (#xFAF1 #x6A7E) + (#xFAF0 #x6A73) + (#xFAEF #x6A46) + (#xFAEE #x6A6B) + (#xFAED #x6A30) + (#xFAEC #x69E2) + (#xFAEB #x6998) + (#xFAEA #xFA14) + (#xFAE9 #x6968) + (#xFAE8 #xFA13) + (#xFAE7 #x68CF) + (#xFAE6 #x6844) + (#xFAE5 #x6801) + (#xFAE4 #x67C0) + (#xFAE3 #x6852) + (#xFAE2 #x67BB) + (#xFAE1 #x6766) + (#xFAE0 #xF929) + (#xFADF #x670E) + (#xFADE #x66FA) + (#xFADD #x66BF) + (#xFADC #x66B2) + (#xFADB #x66A0) + (#xFADA #x6699) + (#xFAD9 #x6673) + (#xFAD8 #xFA12) + (#xFAD7 #x6659) + (#xFAD6 #x6657) + (#xFAD5 #x6665) + (#xFAD4 #x6624) + (#xFAD3 #x661E) + (#xFAD2 #x662E) + (#xFAD1 #x6609) + (#xFAD0 #x663B) + (#xFACF #x6615) + (#xFACE #x6600) + (#xFACD #x654E) + (#xFACC #x64CE) + (#xFACB #x649D) + (#xFACA #x6460) + (#xFAC9 #x63F5) + (#xFAC8 #x62A6) + (#xFAC7 #x6213) + (#xFAC6 #x6198) + (#xFAC5 #x6130) + (#xFAC4 #x6137) + (#xFAC3 #x6111) + (#xFAC2 #x60F2) + (#xFAC1 #x6120) + (#xFAC0 #x60D5) + (#xFABF #x60DE) + (#xFABE #x608A) + (#xFABD #x6085) + (#xFABC #x605D) + (#xFABB #x5FDE) + (#xFABA #x5FB7) + (#xFAB9 #x5F67) + (#xFAB8 #x5F34) + (#xFAB7 #x5F21) + (#xFAB6 #x5DD0) + (#xFAB5 #x5DB9) + (#xFAB4 #x5DB8) + (#xFAB3 #x5D6D) + (#xFAB2 #x5D42) + (#xFAB1 #xFA11) + (#xFAB0 #x5D53) + (#xFAAF #x5D27) + (#xFAAE #x5CF5) + (#xFAAD #x5CBA) + (#xFAAC #x5CA6) + (#xFAAB #x5C1E) + (#xFAAA #x5BEC) + (#xFAA9 #x5BD8) + (#xFAA8 #x752F) + (#xFAA7 #x5BC0) + (#xFAA6 #x5B56) + (#xFAA5 #x59BA) + (#xFAA4 #x59A4) + (#xFAA3 #x5963) + (#xFAA2 #x595D) + (#xFAA1 #x595B) + (#xFAA0 #x5953) + (#xFA9F #x590B) + (#xFA9E #x58B2) + (#xFA9D #x589E) + (#xFA9C #xFA10) + (#xFA9B #xFA0F) + (#xFA9A #x57C7) + (#xFA99 #x57C8) + (#xFA98 #x57AC) + (#xFA97 #x5765) + (#xFA96 #x5759) + (#xFA95 #x5586) + (#xFA94 #x54FF) + (#xFA93 #x54A9) + (#xFA92 #x548A) + (#xFA91 #x549C) + (#xFA90 #xFA0E) + (#xFA8F #x53DD) + (#xFA8E #x53B2) + (#xFA8D #x5393) + (#xFA8C #x5372) + (#xFA8B #x5324) + (#xFA8A #x5307) + (#xFA89 #x5300) + (#xFA88 #x52DB) + (#xFA87 #x52C0) + (#xFA86 #x52A6) + (#xFA85 #x529C) + (#xFA84 #x5215) + (#xFA83 #x51EC) + (#xFA82 #x51BE) + (#xFA81 #x519D) + (#xFA80 #x5164) + (#xFA7E #x514A) + (#xFA7D #x50D8) + (#xFA7C #x50F4) + (#xFA7B #x5094) + (#xFA7A #x5042) + (#xFA79 #x5070) + (#xFA78 #x5046) + (#xFA77 #x501E) + (#xFA76 #x4FFF) + (#xFA75 #x5022) + (#xFA74 #x5040) + (#xFA73 #x4FCD) + (#xFA72 #x4F94) + (#xFA71 #x4F9A) + (#xFA70 #x4F8A) + (#xFA6F #x4F92) + (#xFA6E #x4F56) + (#xFA6D #x4F39) + (#xFA6C #x4F03) + (#xFA6B #x4F00) + (#xFA6A #x4EFC) + (#xFA69 #x4EE1) + (#xFA68 #x4E28) + (#xFA67 #x5F45) + (#xFA66 #x66FB) + (#xFA65 #x92F9) + (#xFA64 #x68C8) + (#xFA63 #x6631) + (#xFA62 #x70BB) + (#xFA61 #x4FC9) + (#xFA60 #x84DC) + (#xFA5F #x9288) + (#xFA5E #x9348) + (#xFA5D #x891C) + (#xFA5C #x7E8A) + (#xFA5B #x2235) + (#xFA5A #x2121) + (#xFA59 #x2116) + (#xFA58 #x3231) + (#xFA57 #xFF02) + (#xFA56 #xFF07) + (#xFA55 #xFFE4) + (#xFA54 #xFFE2) + (#xFA53 #x2169) + (#xFA52 #x2168) + (#xFA51 #x2167) + (#xFA50 #x2166) + (#xFA4F #x2165) + (#xFA4E #x2164) + (#xFA4D #x2163) + (#xFA4C #x2162) + (#xFA4B #x2161) + (#xFA4A #x2160) + (#xFA49 #x2179) + (#xFA48 #x2178) + (#xFA47 #x2177) + (#xFA46 #x2176) + (#xFA45 #x2175) + (#xFA44 #x2174) + (#xFA43 #x2173) + (#xFA42 #x2172) + (#xFA41 #x2171) + (#xFA40 #x2170) + (#xF9FC #xE757) + (#xF9FB #xE756) + (#xF9FA #xE755) + (#xF9F9 #xE754) + (#xF9F8 #xE753) + (#xF9F7 #xE752) + (#xF9F6 #xE751) + (#xF9F5 #xE750) + (#xF9F4 #xE74F) + (#xF9F3 #xE74E) + (#xF9F2 #xE74D) + (#xF9F1 #xE74C) + (#xF9F0 #xE74B) + (#xF9EF #xE74A) + (#xF9EE #xE749) + (#xF9ED #xE748) + (#xF9EC #xE747) + (#xF9EB #xE746) + (#xF9EA #xE745) + (#xF9E9 #xE744) + (#xF9E8 #xE743) + (#xF9E7 #xE742) + (#xF9E6 #xE741) + (#xF9E5 #xE740) + (#xF9E4 #xE73F) + (#xF9E3 #xE73E) + (#xF9E2 #xE73D) + (#xF9E1 #xE73C) + (#xF9E0 #xE73B) + (#xF9DF #xE73A) + (#xF9DE #xE739) + (#xF9DD #xE738) + (#xF9DC #xE737) + (#xF9DB #xE736) + (#xF9DA #xE735) + (#xF9D9 #xE734) + (#xF9D8 #xE733) + (#xF9D7 #xE732) + (#xF9D6 #xE731) + (#xF9D5 #xE730) + (#xF9D4 #xE72F) + (#xF9D3 #xE72E) + (#xF9D2 #xE72D) + (#xF9D1 #xE72C) + (#xF9D0 #xE72B) + (#xF9CF #xE72A) + (#xF9CE #xE729) + (#xF9CD #xE728) + (#xF9CC #xE727) + (#xF9CB #xE726) + (#xF9CA #xE725) + (#xF9C9 #xE724) + (#xF9C8 #xE723) + (#xF9C7 #xE722) + (#xF9C6 #xE721) + (#xF9C5 #xE720) + (#xF9C4 #xE71F) + (#xF9C3 #xE71E) + (#xF9C2 #xE71D) + (#xF9C1 #xE71C) + (#xF9C0 #xE71B) + (#xF9BF #xE71A) + (#xF9BE #xE719) + (#xF9BD #xE718) + (#xF9BC #xE717) + (#xF9BB #xE716) + (#xF9BA #xE715) + (#xF9B9 #xE714) + (#xF9B8 #xE713) + (#xF9B7 #xE712) + (#xF9B6 #xE711) + (#xF9B5 #xE710) + (#xF9B4 #xE70F) + (#xF9B3 #xE70E) + (#xF9B2 #xE70D) + (#xF9B1 #xE70C) + (#xF9B0 #xE70B) + (#xF9AF #xE70A) + (#xF9AE #xE709) + (#xF9AD #xE708) + (#xF9AC #xE707) + (#xF9AB #xE706) + (#xF9AA #xE705) + (#xF9A9 #xE704) + (#xF9A8 #xE703) + (#xF9A7 #xE702) + (#xF9A6 #xE701) + (#xF9A5 #xE700) + (#xF9A4 #xE6FF) + (#xF9A3 #xE6FE) + (#xF9A2 #xE6FD) + (#xF9A1 #xE6FC) + (#xF9A0 #xE6FB) + (#xF99F #xE6FA) + (#xF99E #xE6F9) + (#xF99D #xE6F8) + (#xF99C #xE6F7) + (#xF99B #xE6F6) + (#xF99A #xE6F5) + (#xF999 #xE6F4) + (#xF998 #xE6F3) + (#xF997 #xE6F2) + (#xF996 #xE6F1) + (#xF995 #xE6F0) + (#xF994 #xE6EF) + (#xF993 #xE6EE) + (#xF992 #xE6ED) + (#xF991 #xE6EC) + (#xF990 #xE6EB) + (#xF98F #xE6EA) + (#xF98E #xE6E9) + (#xF98D #xE6E8) + (#xF98C #xE6E7) + (#xF98B #xE6E6) + (#xF98A #xE6E5) + (#xF989 #xE6E4) + (#xF988 #xE6E3) + (#xF987 #xE6E2) + (#xF986 #xE6E1) + (#xF985 #xE6E0) + (#xF984 #xE6DF) + (#xF983 #xE6DE) + (#xF982 #xE6DD) + (#xF981 #xE6DC) + (#xF980 #xE6DB) + (#xF97E #xE6DA) + (#xF97D #xE6D9) + (#xF97C #xE6D8) + (#xF97B #xE6D7) + (#xF97A #xE6D6) + (#xF979 #xE6D5) + (#xF978 #xE6D4) + (#xF977 #xE6D3) + (#xF976 #xE6D2) + (#xF975 #xE6D1) + (#xF974 #xE6D0) + (#xF973 #xE6CF) + (#xF972 #xE6CE) + (#xF971 #xE6CD) + (#xF970 #xE6CC) + (#xF96F #xE6CB) + (#xF96E #xE6CA) + (#xF96D #xE6C9) + (#xF96C #xE6C8) + (#xF96B #xE6C7) + (#xF96A #xE6C6) + (#xF969 #xE6C5) + (#xF968 #xE6C4) + (#xF967 #xE6C3) + (#xF966 #xE6C2) + (#xF965 #xE6C1) + (#xF964 #xE6C0) + (#xF963 #xE6BF) + (#xF962 #xE6BE) + (#xF961 #xE6BD) + (#xF960 #xE6BC) + (#xF95F #xE6BB) + (#xF95E #xE6BA) + (#xF95D #xE6B9) + (#xF95C #xE6B8) + (#xF95B #xE6B7) + (#xF95A #xE6B6) + (#xF959 #xE6B5) + (#xF958 #xE6B4) + (#xF957 #xE6B3) + (#xF956 #xE6B2) + (#xF955 #xE6B1) + (#xF954 #xE6B0) + (#xF953 #xE6AF) + (#xF952 #xE6AE) + (#xF951 #xE6AD) + (#xF950 #xE6AC) + (#xF94F #xE6AB) + (#xF94E #xE6AA) + (#xF94D #xE6A9) + (#xF94C #xE6A8) + (#xF94B #xE6A7) + (#xF94A #xE6A6) + (#xF949 #xE6A5) + (#xF948 #xE6A4) + (#xF947 #xE6A3) + (#xF946 #xE6A2) + (#xF945 #xE6A1) + (#xF944 #xE6A0) + (#xF943 #xE69F) + (#xF942 #xE69E) + (#xF941 #xE69D) + (#xF940 #xE69C) + (#xF8FC #xE69B) + (#xF8FB #xE69A) + (#xF8FA #xE699) + (#xF8F9 #xE698) + (#xF8F8 #xE697) + (#xF8F7 #xE696) + (#xF8F6 #xE695) + (#xF8F5 #xE694) + (#xF8F4 #xE693) + (#xF8F3 #xE692) + (#xF8F2 #xE691) + (#xF8F1 #xE690) + (#xF8F0 #xE68F) + (#xF8EF #xE68E) + (#xF8EE #xE68D) + (#xF8ED #xE68C) + (#xF8EC #xE68B) + (#xF8EB #xE68A) + (#xF8EA #xE689) + (#xF8E9 #xE688) + (#xF8E8 #xE687) + (#xF8E7 #xE686) + (#xF8E6 #xE685) + (#xF8E5 #xE684) + (#xF8E4 #xE683) + (#xF8E3 #xE682) + (#xF8E2 #xE681) + (#xF8E1 #xE680) + (#xF8E0 #xE67F) + (#xF8DF #xE67E) + (#xF8DE #xE67D) + (#xF8DD #xE67C) + (#xF8DC #xE67B) + (#xF8DB #xE67A) + (#xF8DA #xE679) + (#xF8D9 #xE678) + (#xF8D8 #xE677) + (#xF8D7 #xE676) + (#xF8D6 #xE675) + (#xF8D5 #xE674) + (#xF8D4 #xE673) + (#xF8D3 #xE672) + (#xF8D2 #xE671) + (#xF8D1 #xE670) + (#xF8D0 #xE66F) + (#xF8CF #xE66E) + (#xF8CE #xE66D) + (#xF8CD #xE66C) + (#xF8CC #xE66B) + (#xF8CB #xE66A) + (#xF8CA #xE669) + (#xF8C9 #xE668) + (#xF8C8 #xE667) + (#xF8C7 #xE666) + (#xF8C6 #xE665) + (#xF8C5 #xE664) + (#xF8C4 #xE663) + (#xF8C3 #xE662) + (#xF8C2 #xE661) + (#xF8C1 #xE660) + (#xF8C0 #xE65F) + (#xF8BF #xE65E) + (#xF8BE #xE65D) + (#xF8BD #xE65C) + (#xF8BC #xE65B) + (#xF8BB #xE65A) + (#xF8BA #xE659) + (#xF8B9 #xE658) + (#xF8B8 #xE657) + (#xF8B7 #xE656) + (#xF8B6 #xE655) + (#xF8B5 #xE654) + (#xF8B4 #xE653) + (#xF8B3 #xE652) + (#xF8B2 #xE651) + (#xF8B1 #xE650) + (#xF8B0 #xE64F) + (#xF8AF #xE64E) + (#xF8AE #xE64D) + (#xF8AD #xE64C) + (#xF8AC #xE64B) + (#xF8AB #xE64A) + (#xF8AA #xE649) + (#xF8A9 #xE648) + (#xF8A8 #xE647) + (#xF8A7 #xE646) + (#xF8A6 #xE645) + (#xF8A5 #xE644) + (#xF8A4 #xE643) + (#xF8A3 #xE642) + (#xF8A2 #xE641) + (#xF8A1 #xE640) + (#xF8A0 #xE63F) + (#xF89F #xE63E) + (#xF89E #xE63D) + (#xF89D #xE63C) + (#xF89C #xE63B) + (#xF89B #xE63A) + (#xF89A #xE639) + (#xF899 #xE638) + (#xF898 #xE637) + (#xF897 #xE636) + (#xF896 #xE635) + (#xF895 #xE634) + (#xF894 #xE633) + (#xF893 #xE632) + (#xF892 #xE631) + (#xF891 #xE630) + (#xF890 #xE62F) + (#xF88F #xE62E) + (#xF88E #xE62D) + (#xF88D #xE62C) + (#xF88C #xE62B) + (#xF88B #xE62A) + (#xF88A #xE629) + (#xF889 #xE628) + (#xF888 #xE627) + (#xF887 #xE626) + (#xF886 #xE625) + (#xF885 #xE624) + (#xF884 #xE623) + (#xF883 #xE622) + (#xF882 #xE621) + (#xF881 #xE620) + (#xF880 #xE61F) + (#xF87E #xE61E) + (#xF87D #xE61D) + (#xF87C #xE61C) + (#xF87B #xE61B) + (#xF87A #xE61A) + (#xF879 #xE619) + (#xF878 #xE618) + (#xF877 #xE617) + (#xF876 #xE616) + (#xF875 #xE615) + (#xF874 #xE614) + (#xF873 #xE613) + (#xF872 #xE612) + (#xF871 #xE611) + (#xF870 #xE610) + (#xF86F #xE60F) + (#xF86E #xE60E) + (#xF86D #xE60D) + (#xF86C #xE60C) + (#xF86B #xE60B) + (#xF86A #xE60A) + (#xF869 #xE609) + (#xF868 #xE608) + (#xF867 #xE607) + (#xF866 #xE606) + (#xF865 #xE605) + (#xF864 #xE604) + (#xF863 #xE603) + (#xF862 #xE602) + (#xF861 #xE601) + (#xF860 #xE600) + (#xF85F #xE5FF) + (#xF85E #xE5FE) + (#xF85D #xE5FD) + (#xF85C #xE5FC) + (#xF85B #xE5FB) + (#xF85A #xE5FA) + (#xF859 #xE5F9) + (#xF858 #xE5F8) + (#xF857 #xE5F7) + (#xF856 #xE5F6) + (#xF855 #xE5F5) + (#xF854 #xE5F4) + (#xF853 #xE5F3) + (#xF852 #xE5F2) + (#xF851 #xE5F1) + (#xF850 #xE5F0) + (#xF84F #xE5EF) + (#xF84E #xE5EE) + (#xF84D #xE5ED) + (#xF84C #xE5EC) + (#xF84B #xE5EB) + (#xF84A #xE5EA) + (#xF849 #xE5E9) + (#xF848 #xE5E8) + (#xF847 #xE5E7) + (#xF846 #xE5E6) + (#xF845 #xE5E5) + (#xF844 #xE5E4) + (#xF843 #xE5E3) + (#xF842 #xE5E2) + (#xF841 #xE5E1) + (#xF840 #xE5E0) + (#xF7FC #xE5DF) + (#xF7FB #xE5DE) + (#xF7FA #xE5DD) + (#xF7F9 #xE5DC) + (#xF7F8 #xE5DB) + (#xF7F7 #xE5DA) + (#xF7F6 #xE5D9) + (#xF7F5 #xE5D8) + (#xF7F4 #xE5D7) + (#xF7F3 #xE5D6) + (#xF7F2 #xE5D5) + (#xF7F1 #xE5D4) + (#xF7F0 #xE5D3) + (#xF7EF #xE5D2) + (#xF7EE #xE5D1) + (#xF7ED #xE5D0) + (#xF7EC #xE5CF) + (#xF7EB #xE5CE) + (#xF7EA #xE5CD) + (#xF7E9 #xE5CC) + (#xF7E8 #xE5CB) + (#xF7E7 #xE5CA) + (#xF7E6 #xE5C9) + (#xF7E5 #xE5C8) + (#xF7E4 #xE5C7) + (#xF7E3 #xE5C6) + (#xF7E2 #xE5C5) + (#xF7E1 #xE5C4) + (#xF7E0 #xE5C3) + (#xF7DF #xE5C2) + (#xF7DE #xE5C1) + (#xF7DD #xE5C0) + (#xF7DC #xE5BF) + (#xF7DB #xE5BE) + (#xF7DA #xE5BD) + (#xF7D9 #xE5BC) + (#xF7D8 #xE5BB) + (#xF7D7 #xE5BA) + (#xF7D6 #xE5B9) + (#xF7D5 #xE5B8) + (#xF7D4 #xE5B7) + (#xF7D3 #xE5B6) + (#xF7D2 #xE5B5) + (#xF7D1 #xE5B4) + (#xF7D0 #xE5B3) + (#xF7CF #xE5B2) + (#xF7CE #xE5B1) + (#xF7CD #xE5B0) + (#xF7CC #xE5AF) + (#xF7CB #xE5AE) + (#xF7CA #xE5AD) + (#xF7C9 #xE5AC) + (#xF7C8 #xE5AB) + (#xF7C7 #xE5AA) + (#xF7C6 #xE5A9) + (#xF7C5 #xE5A8) + (#xF7C4 #xE5A7) + (#xF7C3 #xE5A6) + (#xF7C2 #xE5A5) + (#xF7C1 #xE5A4) + (#xF7C0 #xE5A3) + (#xF7BF #xE5A2) + (#xF7BE #xE5A1) + (#xF7BD #xE5A0) + (#xF7BC #xE59F) + (#xF7BB #xE59E) + (#xF7BA #xE59D) + (#xF7B9 #xE59C) + (#xF7B8 #xE59B) + (#xF7B7 #xE59A) + (#xF7B6 #xE599) + (#xF7B5 #xE598) + (#xF7B4 #xE597) + (#xF7B3 #xE596) + (#xF7B2 #xE595) + (#xF7B1 #xE594) + (#xF7B0 #xE593) + (#xF7AF #xE592) + (#xF7AE #xE591) + (#xF7AD #xE590) + (#xF7AC #xE58F) + (#xF7AB #xE58E) + (#xF7AA #xE58D) + (#xF7A9 #xE58C) + (#xF7A8 #xE58B) + (#xF7A7 #xE58A) + (#xF7A6 #xE589) + (#xF7A5 #xE588) + (#xF7A4 #xE587) + (#xF7A3 #xE586) + (#xF7A2 #xE585) + (#xF7A1 #xE584) + (#xF7A0 #xE583) + (#xF79F #xE582) + (#xF79E #xE581) + (#xF79D #xE580) + (#xF79C #xE57F) + (#xF79B #xE57E) + (#xF79A #xE57D) + (#xF799 #xE57C) + (#xF798 #xE57B) + (#xF797 #xE57A) + (#xF796 #xE579) + (#xF795 #xE578) + (#xF794 #xE577) + (#xF793 #xE576) + (#xF792 #xE575) + (#xF791 #xE574) + (#xF790 #xE573) + (#xF78F #xE572) + (#xF78E #xE571) + (#xF78D #xE570) + (#xF78C #xE56F) + (#xF78B #xE56E) + (#xF78A #xE56D) + (#xF789 #xE56C) + (#xF788 #xE56B) + (#xF787 #xE56A) + (#xF786 #xE569) + (#xF785 #xE568) + (#xF784 #xE567) + (#xF783 #xE566) + (#xF782 #xE565) + (#xF781 #xE564) + (#xF780 #xE563) + (#xF77E #xE562) + (#xF77D #xE561) + (#xF77C #xE560) + (#xF77B #xE55F) + (#xF77A #xE55E) + (#xF779 #xE55D) + (#xF778 #xE55C) + (#xF777 #xE55B) + (#xF776 #xE55A) + (#xF775 #xE559) + (#xF774 #xE558) + (#xF773 #xE557) + (#xF772 #xE556) + (#xF771 #xE555) + (#xF770 #xE554) + (#xF76F #xE553) + (#xF76E #xE552) + (#xF76D #xE551) + (#xF76C #xE550) + (#xF76B #xE54F) + (#xF76A #xE54E) + (#xF769 #xE54D) + (#xF768 #xE54C) + (#xF767 #xE54B) + (#xF766 #xE54A) + (#xF765 #xE549) + (#xF764 #xE548) + (#xF763 #xE547) + (#xF762 #xE546) + (#xF761 #xE545) + (#xF760 #xE544) + (#xF75F #xE543) + (#xF75E #xE542) + (#xF75D #xE541) + (#xF75C #xE540) + (#xF75B #xE53F) + (#xF75A #xE53E) + (#xF759 #xE53D) + (#xF758 #xE53C) + (#xF757 #xE53B) + (#xF756 #xE53A) + (#xF755 #xE539) + (#xF754 #xE538) + (#xF753 #xE537) + (#xF752 #xE536) + (#xF751 #xE535) + (#xF750 #xE534) + (#xF74F #xE533) + (#xF74E #xE532) + (#xF74D #xE531) + (#xF74C #xE530) + (#xF74B #xE52F) + (#xF74A #xE52E) + (#xF749 #xE52D) + (#xF748 #xE52C) + (#xF747 #xE52B) + (#xF746 #xE52A) + (#xF745 #xE529) + (#xF744 #xE528) + (#xF743 #xE527) + (#xF742 #xE526) + (#xF741 #xE525) + (#xF740 #xE524) + (#xF6FC #xE523) + (#xF6FB #xE522) + (#xF6FA #xE521) + (#xF6F9 #xE520) + (#xF6F8 #xE51F) + (#xF6F7 #xE51E) + (#xF6F6 #xE51D) + (#xF6F5 #xE51C) + (#xF6F4 #xE51B) + (#xF6F3 #xE51A) + (#xF6F2 #xE519) + (#xF6F1 #xE518) + (#xF6F0 #xE517) + (#xF6EF #xE516) + (#xF6EE #xE515) + (#xF6ED #xE514) + (#xF6EC #xE513) + (#xF6EB #xE512) + (#xF6EA #xE511) + (#xF6E9 #xE510) + (#xF6E8 #xE50F) + (#xF6E7 #xE50E) + (#xF6E6 #xE50D) + (#xF6E5 #xE50C) + (#xF6E4 #xE50B) + (#xF6E3 #xE50A) + (#xF6E2 #xE509) + (#xF6E1 #xE508) + (#xF6E0 #xE507) + (#xF6DF #xE506) + (#xF6DE #xE505) + (#xF6DD #xE504) + (#xF6DC #xE503) + (#xF6DB #xE502) + (#xF6DA #xE501) + (#xF6D9 #xE500) + (#xF6D8 #xE4FF) + (#xF6D7 #xE4FE) + (#xF6D6 #xE4FD) + (#xF6D5 #xE4FC) + (#xF6D4 #xE4FB) + (#xF6D3 #xE4FA) + (#xF6D2 #xE4F9) + (#xF6D1 #xE4F8) + (#xF6D0 #xE4F7) + (#xF6CF #xE4F6) + (#xF6CE #xE4F5) + (#xF6CD #xE4F4) + (#xF6CC #xE4F3) + (#xF6CB #xE4F2) + (#xF6CA #xE4F1) + (#xF6C9 #xE4F0) + (#xF6C8 #xE4EF) + (#xF6C7 #xE4EE) + (#xF6C6 #xE4ED) + (#xF6C5 #xE4EC) + (#xF6C4 #xE4EB) + (#xF6C3 #xE4EA) + (#xF6C2 #xE4E9) + (#xF6C1 #xE4E8) + (#xF6C0 #xE4E7) + (#xF6BF #xE4E6) + (#xF6BE #xE4E5) + (#xF6BD #xE4E4) + (#xF6BC #xE4E3) + (#xF6BB #xE4E2) + (#xF6BA #xE4E1) + (#xF6B9 #xE4E0) + (#xF6B8 #xE4DF) + (#xF6B7 #xE4DE) + (#xF6B6 #xE4DD) + (#xF6B5 #xE4DC) + (#xF6B4 #xE4DB) + (#xF6B3 #xE4DA) + (#xF6B2 #xE4D9) + (#xF6B1 #xE4D8) + (#xF6B0 #xE4D7) + (#xF6AF #xE4D6) + (#xF6AE #xE4D5) + (#xF6AD #xE4D4) + (#xF6AC #xE4D3) + (#xF6AB #xE4D2) + (#xF6AA #xE4D1) + (#xF6A9 #xE4D0) + (#xF6A8 #xE4CF) + (#xF6A7 #xE4CE) + (#xF6A6 #xE4CD) + (#xF6A5 #xE4CC) + (#xF6A4 #xE4CB) + (#xF6A3 #xE4CA) + (#xF6A2 #xE4C9) + (#xF6A1 #xE4C8) + (#xF6A0 #xE4C7) + (#xF69F #xE4C6) + (#xF69E #xE4C5) + (#xF69D #xE4C4) + (#xF69C #xE4C3) + (#xF69B #xE4C2) + (#xF69A #xE4C1) + (#xF699 #xE4C0) + (#xF698 #xE4BF) + (#xF697 #xE4BE) + (#xF696 #xE4BD) + (#xF695 #xE4BC) + (#xF694 #xE4BB) + (#xF693 #xE4BA) + (#xF692 #xE4B9) + (#xF691 #xE4B8) + (#xF690 #xE4B7) + (#xF68F #xE4B6) + (#xF68E #xE4B5) + (#xF68D #xE4B4) + (#xF68C #xE4B3) + (#xF68B #xE4B2) + (#xF68A #xE4B1) + (#xF689 #xE4B0) + (#xF688 #xE4AF) + (#xF687 #xE4AE) + (#xF686 #xE4AD) + (#xF685 #xE4AC) + (#xF684 #xE4AB) + (#xF683 #xE4AA) + (#xF682 #xE4A9) + (#xF681 #xE4A8) + (#xF680 #xE4A7) + (#xF67E #xE4A6) + (#xF67D #xE4A5) + (#xF67C #xE4A4) + (#xF67B #xE4A3) + (#xF67A #xE4A2) + (#xF679 #xE4A1) + (#xF678 #xE4A0) + (#xF677 #xE49F) + (#xF676 #xE49E) + (#xF675 #xE49D) + (#xF674 #xE49C) + (#xF673 #xE49B) + (#xF672 #xE49A) + (#xF671 #xE499) + (#xF670 #xE498) + (#xF66F #xE497) + (#xF66E #xE496) + (#xF66D #xE495) + (#xF66C #xE494) + (#xF66B #xE493) + (#xF66A #xE492) + (#xF669 #xE491) + (#xF668 #xE490) + (#xF667 #xE48F) + (#xF666 #xE48E) + (#xF665 #xE48D) + (#xF664 #xE48C) + (#xF663 #xE48B) + (#xF662 #xE48A) + (#xF661 #xE489) + (#xF660 #xE488) + (#xF65F #xE487) + (#xF65E #xE486) + (#xF65D #xE485) + (#xF65C #xE484) + (#xF65B #xE483) + (#xF65A #xE482) + (#xF659 #xE481) + (#xF658 #xE480) + (#xF657 #xE47F) + (#xF656 #xE47E) + (#xF655 #xE47D) + (#xF654 #xE47C) + (#xF653 #xE47B) + (#xF652 #xE47A) + (#xF651 #xE479) + (#xF650 #xE478) + (#xF64F #xE477) + (#xF64E #xE476) + (#xF64D #xE475) + (#xF64C #xE474) + (#xF64B #xE473) + (#xF64A #xE472) + (#xF649 #xE471) + (#xF648 #xE470) + (#xF647 #xE46F) + (#xF646 #xE46E) + (#xF645 #xE46D) + (#xF644 #xE46C) + (#xF643 #xE46B) + (#xF642 #xE46A) + (#xF641 #xE469) + (#xF640 #xE468) + (#xF5FC #xE467) + (#xF5FB #xE466) + (#xF5FA #xE465) + (#xF5F9 #xE464) + (#xF5F8 #xE463) + (#xF5F7 #xE462) + (#xF5F6 #xE461) + (#xF5F5 #xE460) + (#xF5F4 #xE45F) + (#xF5F3 #xE45E) + (#xF5F2 #xE45D) + (#xF5F1 #xE45C) + (#xF5F0 #xE45B) + (#xF5EF #xE45A) + (#xF5EE #xE459) + (#xF5ED #xE458) + (#xF5EC #xE457) + (#xF5EB #xE456) + (#xF5EA #xE455) + (#xF5E9 #xE454) + (#xF5E8 #xE453) + (#xF5E7 #xE452) + (#xF5E6 #xE451) + (#xF5E5 #xE450) + (#xF5E4 #xE44F) + (#xF5E3 #xE44E) + (#xF5E2 #xE44D) + (#xF5E1 #xE44C) + (#xF5E0 #xE44B) + (#xF5DF #xE44A) + (#xF5DE #xE449) + (#xF5DD #xE448) + (#xF5DC #xE447) + (#xF5DB #xE446) + (#xF5DA #xE445) + (#xF5D9 #xE444) + (#xF5D8 #xE443) + (#xF5D7 #xE442) + (#xF5D6 #xE441) + (#xF5D5 #xE440) + (#xF5D4 #xE43F) + (#xF5D3 #xE43E) + (#xF5D2 #xE43D) + (#xF5D1 #xE43C) + (#xF5D0 #xE43B) + (#xF5CF #xE43A) + (#xF5CE #xE439) + (#xF5CD #xE438) + (#xF5CC #xE437) + (#xF5CB #xE436) + (#xF5CA #xE435) + (#xF5C9 #xE434) + (#xF5C8 #xE433) + (#xF5C7 #xE432) + (#xF5C6 #xE431) + (#xF5C5 #xE430) + (#xF5C4 #xE42F) + (#xF5C3 #xE42E) + (#xF5C2 #xE42D) + (#xF5C1 #xE42C) + (#xF5C0 #xE42B) + (#xF5BF #xE42A) + (#xF5BE #xE429) + (#xF5BD #xE428) + (#xF5BC #xE427) + (#xF5BB #xE426) + (#xF5BA #xE425) + (#xF5B9 #xE424) + (#xF5B8 #xE423) + (#xF5B7 #xE422) + (#xF5B6 #xE421) + (#xF5B5 #xE420) + (#xF5B4 #xE41F) + (#xF5B3 #xE41E) + (#xF5B2 #xE41D) + (#xF5B1 #xE41C) + (#xF5B0 #xE41B) + (#xF5AF #xE41A) + (#xF5AE #xE419) + (#xF5AD #xE418) + (#xF5AC #xE417) + (#xF5AB #xE416) + (#xF5AA #xE415) + (#xF5A9 #xE414) + (#xF5A8 #xE413) + (#xF5A7 #xE412) + (#xF5A6 #xE411) + (#xF5A5 #xE410) + (#xF5A4 #xE40F) + (#xF5A3 #xE40E) + (#xF5A2 #xE40D) + (#xF5A1 #xE40C) + (#xF5A0 #xE40B) + (#xF59F #xE40A) + (#xF59E #xE409) + (#xF59D #xE408) + (#xF59C #xE407) + (#xF59B #xE406) + (#xF59A #xE405) + (#xF599 #xE404) + (#xF598 #xE403) + (#xF597 #xE402) + (#xF596 #xE401) + (#xF595 #xE400) + (#xF594 #xE3FF) + (#xF593 #xE3FE) + (#xF592 #xE3FD) + (#xF591 #xE3FC) + (#xF590 #xE3FB) + (#xF58F #xE3FA) + (#xF58E #xE3F9) + (#xF58D #xE3F8) + (#xF58C #xE3F7) + (#xF58B #xE3F6) + (#xF58A #xE3F5) + (#xF589 #xE3F4) + (#xF588 #xE3F3) + (#xF587 #xE3F2) + (#xF586 #xE3F1) + (#xF585 #xE3F0) + (#xF584 #xE3EF) + (#xF583 #xE3EE) + (#xF582 #xE3ED) + (#xF581 #xE3EC) + (#xF580 #xE3EB) + (#xF57E #xE3EA) + (#xF57D #xE3E9) + (#xF57C #xE3E8) + (#xF57B #xE3E7) + (#xF57A #xE3E6) + (#xF579 #xE3E5) + (#xF578 #xE3E4) + (#xF577 #xE3E3) + (#xF576 #xE3E2) + (#xF575 #xE3E1) + (#xF574 #xE3E0) + (#xF573 #xE3DF) + (#xF572 #xE3DE) + (#xF571 #xE3DD) + (#xF570 #xE3DC) + (#xF56F #xE3DB) + (#xF56E #xE3DA) + (#xF56D #xE3D9) + (#xF56C #xE3D8) + (#xF56B #xE3D7) + (#xF56A #xE3D6) + (#xF569 #xE3D5) + (#xF568 #xE3D4) + (#xF567 #xE3D3) + (#xF566 #xE3D2) + (#xF565 #xE3D1) + (#xF564 #xE3D0) + (#xF563 #xE3CF) + (#xF562 #xE3CE) + (#xF561 #xE3CD) + (#xF560 #xE3CC) + (#xF55F #xE3CB) + (#xF55E #xE3CA) + (#xF55D #xE3C9) + (#xF55C #xE3C8) + (#xF55B #xE3C7) + (#xF55A #xE3C6) + (#xF559 #xE3C5) + (#xF558 #xE3C4) + (#xF557 #xE3C3) + (#xF556 #xE3C2) + (#xF555 #xE3C1) + (#xF554 #xE3C0) + (#xF553 #xE3BF) + (#xF552 #xE3BE) + (#xF551 #xE3BD) + (#xF550 #xE3BC) + (#xF54F #xE3BB) + (#xF54E #xE3BA) + (#xF54D #xE3B9) + (#xF54C #xE3B8) + (#xF54B #xE3B7) + (#xF54A #xE3B6) + (#xF549 #xE3B5) + (#xF548 #xE3B4) + (#xF547 #xE3B3) + (#xF546 #xE3B2) + (#xF545 #xE3B1) + (#xF544 #xE3B0) + (#xF543 #xE3AF) + (#xF542 #xE3AE) + (#xF541 #xE3AD) + (#xF540 #xE3AC) + (#xF4FC #xE3AB) + (#xF4FB #xE3AA) + (#xF4FA #xE3A9) + (#xF4F9 #xE3A8) + (#xF4F8 #xE3A7) + (#xF4F7 #xE3A6) + (#xF4F6 #xE3A5) + (#xF4F5 #xE3A4) + (#xF4F4 #xE3A3) + (#xF4F3 #xE3A2) + (#xF4F2 #xE3A1) + (#xF4F1 #xE3A0) + (#xF4F0 #xE39F) + (#xF4EF #xE39E) + (#xF4EE #xE39D) + (#xF4ED #xE39C) + (#xF4EC #xE39B) + (#xF4EB #xE39A) + (#xF4EA #xE399) + (#xF4E9 #xE398) + (#xF4E8 #xE397) + (#xF4E7 #xE396) + (#xF4E6 #xE395) + (#xF4E5 #xE394) + (#xF4E4 #xE393) + (#xF4E3 #xE392) + (#xF4E2 #xE391) + (#xF4E1 #xE390) + (#xF4E0 #xE38F) + (#xF4DF #xE38E) + (#xF4DE #xE38D) + (#xF4DD #xE38C) + (#xF4DC #xE38B) + (#xF4DB #xE38A) + (#xF4DA #xE389) + (#xF4D9 #xE388) + (#xF4D8 #xE387) + (#xF4D7 #xE386) + (#xF4D6 #xE385) + (#xF4D5 #xE384) + (#xF4D4 #xE383) + (#xF4D3 #xE382) + (#xF4D2 #xE381) + (#xF4D1 #xE380) + (#xF4D0 #xE37F) + (#xF4CF #xE37E) + (#xF4CE #xE37D) + (#xF4CD #xE37C) + (#xF4CC #xE37B) + (#xF4CB #xE37A) + (#xF4CA #xE379) + (#xF4C9 #xE378) + (#xF4C8 #xE377) + (#xF4C7 #xE376) + (#xF4C6 #xE375) + (#xF4C5 #xE374) + (#xF4C4 #xE373) + (#xF4C3 #xE372) + (#xF4C2 #xE371) + (#xF4C1 #xE370) + (#xF4C0 #xE36F) + (#xF4BF #xE36E) + (#xF4BE #xE36D) + (#xF4BD #xE36C) + (#xF4BC #xE36B) + (#xF4BB #xE36A) + (#xF4BA #xE369) + (#xF4B9 #xE368) + (#xF4B8 #xE367) + (#xF4B7 #xE366) + (#xF4B6 #xE365) + (#xF4B5 #xE364) + (#xF4B4 #xE363) + (#xF4B3 #xE362) + (#xF4B2 #xE361) + (#xF4B1 #xE360) + (#xF4B0 #xE35F) + (#xF4AF #xE35E) + (#xF4AE #xE35D) + (#xF4AD #xE35C) + (#xF4AC #xE35B) + (#xF4AB #xE35A) + (#xF4AA #xE359) + (#xF4A9 #xE358) + (#xF4A8 #xE357) + (#xF4A7 #xE356) + (#xF4A6 #xE355) + (#xF4A5 #xE354) + (#xF4A4 #xE353) + (#xF4A3 #xE352) + (#xF4A2 #xE351) + (#xF4A1 #xE350) + (#xF4A0 #xE34F) + (#xF49F #xE34E) + (#xF49E #xE34D) + (#xF49D #xE34C) + (#xF49C #xE34B) + (#xF49B #xE34A) + (#xF49A #xE349) + (#xF499 #xE348) + (#xF498 #xE347) + (#xF497 #xE346) + (#xF496 #xE345) + (#xF495 #xE344) + (#xF494 #xE343) + (#xF493 #xE342) + (#xF492 #xE341) + (#xF491 #xE340) + (#xF490 #xE33F) + (#xF48F #xE33E) + (#xF48E #xE33D) + (#xF48D #xE33C) + (#xF48C #xE33B) + (#xF48B #xE33A) + (#xF48A #xE339) + (#xF489 #xE338) + (#xF488 #xE337) + (#xF487 #xE336) + (#xF486 #xE335) + (#xF485 #xE334) + (#xF484 #xE333) + (#xF483 #xE332) + (#xF482 #xE331) + (#xF481 #xE330) + (#xF480 #xE32F) + (#xF47E #xE32E) + (#xF47D #xE32D) + (#xF47C #xE32C) + (#xF47B #xE32B) + (#xF47A #xE32A) + (#xF479 #xE329) + (#xF478 #xE328) + (#xF477 #xE327) + (#xF476 #xE326) + (#xF475 #xE325) + (#xF474 #xE324) + (#xF473 #xE323) + (#xF472 #xE322) + (#xF471 #xE321) + (#xF470 #xE320) + (#xF46F #xE31F) + (#xF46E #xE31E) + (#xF46D #xE31D) + (#xF46C #xE31C) + (#xF46B #xE31B) + (#xF46A #xE31A) + (#xF469 #xE319) + (#xF468 #xE318) + (#xF467 #xE317) + (#xF466 #xE316) + (#xF465 #xE315) + (#xF464 #xE314) + (#xF463 #xE313) + (#xF462 #xE312) + (#xF461 #xE311) + (#xF460 #xE310) + (#xF45F #xE30F) + (#xF45E #xE30E) + (#xF45D #xE30D) + (#xF45C #xE30C) + (#xF45B #xE30B) + (#xF45A #xE30A) + (#xF459 #xE309) + (#xF458 #xE308) + (#xF457 #xE307) + (#xF456 #xE306) + (#xF455 #xE305) + (#xF454 #xE304) + (#xF453 #xE303) + (#xF452 #xE302) + (#xF451 #xE301) + (#xF450 #xE300) + (#xF44F #xE2FF) + (#xF44E #xE2FE) + (#xF44D #xE2FD) + (#xF44C #xE2FC) + (#xF44B #xE2FB) + (#xF44A #xE2FA) + (#xF449 #xE2F9) + (#xF448 #xE2F8) + (#xF447 #xE2F7) + (#xF446 #xE2F6) + (#xF445 #xE2F5) + (#xF444 #xE2F4) + (#xF443 #xE2F3) + (#xF442 #xE2F2) + (#xF441 #xE2F1) + (#xF440 #xE2F0) + (#xF3FC #xE2EF) + (#xF3FB #xE2EE) + (#xF3FA #xE2ED) + (#xF3F9 #xE2EC) + (#xF3F8 #xE2EB) + (#xF3F7 #xE2EA) + (#xF3F6 #xE2E9) + (#xF3F5 #xE2E8) + (#xF3F4 #xE2E7) + (#xF3F3 #xE2E6) + (#xF3F2 #xE2E5) + (#xF3F1 #xE2E4) + (#xF3F0 #xE2E3) + (#xF3EF #xE2E2) + (#xF3EE #xE2E1) + (#xF3ED #xE2E0) + (#xF3EC #xE2DF) + (#xF3EB #xE2DE) + (#xF3EA #xE2DD) + (#xF3E9 #xE2DC) + (#xF3E8 #xE2DB) + (#xF3E7 #xE2DA) + (#xF3E6 #xE2D9) + (#xF3E5 #xE2D8) + (#xF3E4 #xE2D7) + (#xF3E3 #xE2D6) + (#xF3E2 #xE2D5) + (#xF3E1 #xE2D4) + (#xF3E0 #xE2D3) + (#xF3DF #xE2D2) + (#xF3DE #xE2D1) + (#xF3DD #xE2D0) + (#xF3DC #xE2CF) + (#xF3DB #xE2CE) + (#xF3DA #xE2CD) + (#xF3D9 #xE2CC) + (#xF3D8 #xE2CB) + (#xF3D7 #xE2CA) + (#xF3D6 #xE2C9) + (#xF3D5 #xE2C8) + (#xF3D4 #xE2C7) + (#xF3D3 #xE2C6) + (#xF3D2 #xE2C5) + (#xF3D1 #xE2C4) + (#xF3D0 #xE2C3) + (#xF3CF #xE2C2) + (#xF3CE #xE2C1) + (#xF3CD #xE2C0) + (#xF3CC #xE2BF) + (#xF3CB #xE2BE) + (#xF3CA #xE2BD) + (#xF3C9 #xE2BC) + (#xF3C8 #xE2BB) + (#xF3C7 #xE2BA) + (#xF3C6 #xE2B9) + (#xF3C5 #xE2B8) + (#xF3C4 #xE2B7) + (#xF3C3 #xE2B6) + (#xF3C2 #xE2B5) + (#xF3C1 #xE2B4) + (#xF3C0 #xE2B3) + (#xF3BF #xE2B2) + (#xF3BE #xE2B1) + (#xF3BD #xE2B0) + (#xF3BC #xE2AF) + (#xF3BB #xE2AE) + (#xF3BA #xE2AD) + (#xF3B9 #xE2AC) + (#xF3B8 #xE2AB) + (#xF3B7 #xE2AA) + (#xF3B6 #xE2A9) + (#xF3B5 #xE2A8) + (#xF3B4 #xE2A7) + (#xF3B3 #xE2A6) + (#xF3B2 #xE2A5) + (#xF3B1 #xE2A4) + (#xF3B0 #xE2A3) + (#xF3AF #xE2A2) + (#xF3AE #xE2A1) + (#xF3AD #xE2A0) + (#xF3AC #xE29F) + (#xF3AB #xE29E) + (#xF3AA #xE29D) + (#xF3A9 #xE29C) + (#xF3A8 #xE29B) + (#xF3A7 #xE29A) + (#xF3A6 #xE299) + (#xF3A5 #xE298) + (#xF3A4 #xE297) + (#xF3A3 #xE296) + (#xF3A2 #xE295) + (#xF3A1 #xE294) + (#xF3A0 #xE293) + (#xF39F #xE292) + (#xF39E #xE291) + (#xF39D #xE290) + (#xF39C #xE28F) + (#xF39B #xE28E) + (#xF39A #xE28D) + (#xF399 #xE28C) + (#xF398 #xE28B) + (#xF397 #xE28A) + (#xF396 #xE289) + (#xF395 #xE288) + (#xF394 #xE287) + (#xF393 #xE286) + (#xF392 #xE285) + (#xF391 #xE284) + (#xF390 #xE283) + (#xF38F #xE282) + (#xF38E #xE281) + (#xF38D #xE280) + (#xF38C #xE27F) + (#xF38B #xE27E) + (#xF38A #xE27D) + (#xF389 #xE27C) + (#xF388 #xE27B) + (#xF387 #xE27A) + (#xF386 #xE279) + (#xF385 #xE278) + (#xF384 #xE277) + (#xF383 #xE276) + (#xF382 #xE275) + (#xF381 #xE274) + (#xF380 #xE273) + (#xF37E #xE272) + (#xF37D #xE271) + (#xF37C #xE270) + (#xF37B #xE26F) + (#xF37A #xE26E) + (#xF379 #xE26D) + (#xF378 #xE26C) + (#xF377 #xE26B) + (#xF376 #xE26A) + (#xF375 #xE269) + (#xF374 #xE268) + (#xF373 #xE267) + (#xF372 #xE266) + (#xF371 #xE265) + (#xF370 #xE264) + (#xF36F #xE263) + (#xF36E #xE262) + (#xF36D #xE261) + (#xF36C #xE260) + (#xF36B #xE25F) + (#xF36A #xE25E) + (#xF369 #xE25D) + (#xF368 #xE25C) + (#xF367 #xE25B) + (#xF366 #xE25A) + (#xF365 #xE259) + (#xF364 #xE258) + (#xF363 #xE257) + (#xF362 #xE256) + (#xF361 #xE255) + (#xF360 #xE254) + (#xF35F #xE253) + (#xF35E #xE252) + (#xF35D #xE251) + (#xF35C #xE250) + (#xF35B #xE24F) + (#xF35A #xE24E) + (#xF359 #xE24D) + (#xF358 #xE24C) + (#xF357 #xE24B) + (#xF356 #xE24A) + (#xF355 #xE249) + (#xF354 #xE248) + (#xF353 #xE247) + (#xF352 #xE246) + (#xF351 #xE245) + (#xF350 #xE244) + (#xF34F #xE243) + (#xF34E #xE242) + (#xF34D #xE241) + (#xF34C #xE240) + (#xF34B #xE23F) + (#xF34A #xE23E) + (#xF349 #xE23D) + (#xF348 #xE23C) + (#xF347 #xE23B) + (#xF346 #xE23A) + (#xF345 #xE239) + (#xF344 #xE238) + (#xF343 #xE237) + (#xF342 #xE236) + (#xF341 #xE235) + (#xF340 #xE234) + (#xF2FC #xE233) + (#xF2FB #xE232) + (#xF2FA #xE231) + (#xF2F9 #xE230) + (#xF2F8 #xE22F) + (#xF2F7 #xE22E) + (#xF2F6 #xE22D) + (#xF2F5 #xE22C) + (#xF2F4 #xE22B) + (#xF2F3 #xE22A) + (#xF2F2 #xE229) + (#xF2F1 #xE228) + (#xF2F0 #xE227) + (#xF2EF #xE226) + (#xF2EE #xE225) + (#xF2ED #xE224) + (#xF2EC #xE223) + (#xF2EB #xE222) + (#xF2EA #xE221) + (#xF2E9 #xE220) + (#xF2E8 #xE21F) + (#xF2E7 #xE21E) + (#xF2E6 #xE21D) + (#xF2E5 #xE21C) + (#xF2E4 #xE21B) + (#xF2E3 #xE21A) + (#xF2E2 #xE219) + (#xF2E1 #xE218) + (#xF2E0 #xE217) + (#xF2DF #xE216) + (#xF2DE #xE215) + (#xF2DD #xE214) + (#xF2DC #xE213) + (#xF2DB #xE212) + (#xF2DA #xE211) + (#xF2D9 #xE210) + (#xF2D8 #xE20F) + (#xF2D7 #xE20E) + (#xF2D6 #xE20D) + (#xF2D5 #xE20C) + (#xF2D4 #xE20B) + (#xF2D3 #xE20A) + (#xF2D2 #xE209) + (#xF2D1 #xE208) + (#xF2D0 #xE207) + (#xF2CF #xE206) + (#xF2CE #xE205) + (#xF2CD #xE204) + (#xF2CC #xE203) + (#xF2CB #xE202) + (#xF2CA #xE201) + (#xF2C9 #xE200) + (#xF2C8 #xE1FF) + (#xF2C7 #xE1FE) + (#xF2C6 #xE1FD) + (#xF2C5 #xE1FC) + (#xF2C4 #xE1FB) + (#xF2C3 #xE1FA) + (#xF2C2 #xE1F9) + (#xF2C1 #xE1F8) + (#xF2C0 #xE1F7) + (#xF2BF #xE1F6) + (#xF2BE #xE1F5) + (#xF2BD #xE1F4) + (#xF2BC #xE1F3) + (#xF2BB #xE1F2) + (#xF2BA #xE1F1) + (#xF2B9 #xE1F0) + (#xF2B8 #xE1EF) + (#xF2B7 #xE1EE) + (#xF2B6 #xE1ED) + (#xF2B5 #xE1EC) + (#xF2B4 #xE1EB) + (#xF2B3 #xE1EA) + (#xF2B2 #xE1E9) + (#xF2B1 #xE1E8) + (#xF2B0 #xE1E7) + (#xF2AF #xE1E6) + (#xF2AE #xE1E5) + (#xF2AD #xE1E4) + (#xF2AC #xE1E3) + (#xF2AB #xE1E2) + (#xF2AA #xE1E1) + (#xF2A9 #xE1E0) + (#xF2A8 #xE1DF) + (#xF2A7 #xE1DE) + (#xF2A6 #xE1DD) + (#xF2A5 #xE1DC) + (#xF2A4 #xE1DB) + (#xF2A3 #xE1DA) + (#xF2A2 #xE1D9) + (#xF2A1 #xE1D8) + (#xF2A0 #xE1D7) + (#xF29F #xE1D6) + (#xF29E #xE1D5) + (#xF29D #xE1D4) + (#xF29C #xE1D3) + (#xF29B #xE1D2) + (#xF29A #xE1D1) + (#xF299 #xE1D0) + (#xF298 #xE1CF) + (#xF297 #xE1CE) + (#xF296 #xE1CD) + (#xF295 #xE1CC) + (#xF294 #xE1CB) + (#xF293 #xE1CA) + (#xF292 #xE1C9) + (#xF291 #xE1C8) + (#xF290 #xE1C7) + (#xF28F #xE1C6) + (#xF28E #xE1C5) + (#xF28D #xE1C4) + (#xF28C #xE1C3) + (#xF28B #xE1C2) + (#xF28A #xE1C1) + (#xF289 #xE1C0) + (#xF288 #xE1BF) + (#xF287 #xE1BE) + (#xF286 #xE1BD) + (#xF285 #xE1BC) + (#xF284 #xE1BB) + (#xF283 #xE1BA) + (#xF282 #xE1B9) + (#xF281 #xE1B8) + (#xF280 #xE1B7) + (#xF27E #xE1B6) + (#xF27D #xE1B5) + (#xF27C #xE1B4) + (#xF27B #xE1B3) + (#xF27A #xE1B2) + (#xF279 #xE1B1) + (#xF278 #xE1B0) + (#xF277 #xE1AF) + (#xF276 #xE1AE) + (#xF275 #xE1AD) + (#xF274 #xE1AC) + (#xF273 #xE1AB) + (#xF272 #xE1AA) + (#xF271 #xE1A9) + (#xF270 #xE1A8) + (#xF26F #xE1A7) + (#xF26E #xE1A6) + (#xF26D #xE1A5) + (#xF26C #xE1A4) + (#xF26B #xE1A3) + (#xF26A #xE1A2) + (#xF269 #xE1A1) + (#xF268 #xE1A0) + (#xF267 #xE19F) + (#xF266 #xE19E) + (#xF265 #xE19D) + (#xF264 #xE19C) + (#xF263 #xE19B) + (#xF262 #xE19A) + (#xF261 #xE199) + (#xF260 #xE198) + (#xF25F #xE197) + (#xF25E #xE196) + (#xF25D #xE195) + (#xF25C #xE194) + (#xF25B #xE193) + (#xF25A #xE192) + (#xF259 #xE191) + (#xF258 #xE190) + (#xF257 #xE18F) + (#xF256 #xE18E) + (#xF255 #xE18D) + (#xF254 #xE18C) + (#xF253 #xE18B) + (#xF252 #xE18A) + (#xF251 #xE189) + (#xF250 #xE188) + (#xF24F #xE187) + (#xF24E #xE186) + (#xF24D #xE185) + (#xF24C #xE184) + (#xF24B #xE183) + (#xF24A #xE182) + (#xF249 #xE181) + (#xF248 #xE180) + (#xF247 #xE17F) + (#xF246 #xE17E) + (#xF245 #xE17D) + (#xF244 #xE17C) + (#xF243 #xE17B) + (#xF242 #xE17A) + (#xF241 #xE179) + (#xF240 #xE178) + (#xF1FC #xE177) + (#xF1FB #xE176) + (#xF1FA #xE175) + (#xF1F9 #xE174) + (#xF1F8 #xE173) + (#xF1F7 #xE172) + (#xF1F6 #xE171) + (#xF1F5 #xE170) + (#xF1F4 #xE16F) + (#xF1F3 #xE16E) + (#xF1F2 #xE16D) + (#xF1F1 #xE16C) + (#xF1F0 #xE16B) + (#xF1EF #xE16A) + (#xF1EE #xE169) + (#xF1ED #xE168) + (#xF1EC #xE167) + (#xF1EB #xE166) + (#xF1EA #xE165) + (#xF1E9 #xE164) + (#xF1E8 #xE163) + (#xF1E7 #xE162) + (#xF1E6 #xE161) + (#xF1E5 #xE160) + (#xF1E4 #xE15F) + (#xF1E3 #xE15E) + (#xF1E2 #xE15D) + (#xF1E1 #xE15C) + (#xF1E0 #xE15B) + (#xF1DF #xE15A) + (#xF1DE #xE159) + (#xF1DD #xE158) + (#xF1DC #xE157) + (#xF1DB #xE156) + (#xF1DA #xE155) + (#xF1D9 #xE154) + (#xF1D8 #xE153) + (#xF1D7 #xE152) + (#xF1D6 #xE151) + (#xF1D5 #xE150) + (#xF1D4 #xE14F) + (#xF1D3 #xE14E) + (#xF1D2 #xE14D) + (#xF1D1 #xE14C) + (#xF1D0 #xE14B) + (#xF1CF #xE14A) + (#xF1CE #xE149) + (#xF1CD #xE148) + (#xF1CC #xE147) + (#xF1CB #xE146) + (#xF1CA #xE145) + (#xF1C9 #xE144) + (#xF1C8 #xE143) + (#xF1C7 #xE142) + (#xF1C6 #xE141) + (#xF1C5 #xE140) + (#xF1C4 #xE13F) + (#xF1C3 #xE13E) + (#xF1C2 #xE13D) + (#xF1C1 #xE13C) + (#xF1C0 #xE13B) + (#xF1BF #xE13A) + (#xF1BE #xE139) + (#xF1BD #xE138) + (#xF1BC #xE137) + (#xF1BB #xE136) + (#xF1BA #xE135) + (#xF1B9 #xE134) + (#xF1B8 #xE133) + (#xF1B7 #xE132) + (#xF1B6 #xE131) + (#xF1B5 #xE130) + (#xF1B4 #xE12F) + (#xF1B3 #xE12E) + (#xF1B2 #xE12D) + (#xF1B1 #xE12C) + (#xF1B0 #xE12B) + (#xF1AF #xE12A) + (#xF1AE #xE129) + (#xF1AD #xE128) + (#xF1AC #xE127) + (#xF1AB #xE126) + (#xF1AA #xE125) + (#xF1A9 #xE124) + (#xF1A8 #xE123) + (#xF1A7 #xE122) + (#xF1A6 #xE121) + (#xF1A5 #xE120) + (#xF1A4 #xE11F) + (#xF1A3 #xE11E) + (#xF1A2 #xE11D) + (#xF1A1 #xE11C) + (#xF1A0 #xE11B) + (#xF19F #xE11A) + (#xF19E #xE119) + (#xF19D #xE118) + (#xF19C #xE117) + (#xF19B #xE116) + (#xF19A #xE115) + (#xF199 #xE114) + (#xF198 #xE113) + (#xF197 #xE112) + (#xF196 #xE111) + (#xF195 #xE110) + (#xF194 #xE10F) + (#xF193 #xE10E) + (#xF192 #xE10D) + (#xF191 #xE10C) + (#xF190 #xE10B) + (#xF18F #xE10A) + (#xF18E #xE109) + (#xF18D #xE108) + (#xF18C #xE107) + (#xF18B #xE106) + (#xF18A #xE105) + (#xF189 #xE104) + (#xF188 #xE103) + (#xF187 #xE102) + (#xF186 #xE101) + (#xF185 #xE100) + (#xF184 #xE0FF) + (#xF183 #xE0FE) + (#xF182 #xE0FD) + (#xF181 #xE0FC) + (#xF180 #xE0FB) + (#xF17E #xE0FA) + (#xF17D #xE0F9) + (#xF17C #xE0F8) + (#xF17B #xE0F7) + (#xF17A #xE0F6) + (#xF179 #xE0F5) + (#xF178 #xE0F4) + (#xF177 #xE0F3) + (#xF176 #xE0F2) + (#xF175 #xE0F1) + (#xF174 #xE0F0) + (#xF173 #xE0EF) + (#xF172 #xE0EE) + (#xF171 #xE0ED) + (#xF170 #xE0EC) + (#xF16F #xE0EB) + (#xF16E #xE0EA) + (#xF16D #xE0E9) + (#xF16C #xE0E8) + (#xF16B #xE0E7) + (#xF16A #xE0E6) + (#xF169 #xE0E5) + (#xF168 #xE0E4) + (#xF167 #xE0E3) + (#xF166 #xE0E2) + (#xF165 #xE0E1) + (#xF164 #xE0E0) + (#xF163 #xE0DF) + (#xF162 #xE0DE) + (#xF161 #xE0DD) + (#xF160 #xE0DC) + (#xF15F #xE0DB) + (#xF15E #xE0DA) + (#xF15D #xE0D9) + (#xF15C #xE0D8) + (#xF15B #xE0D7) + (#xF15A #xE0D6) + (#xF159 #xE0D5) + (#xF158 #xE0D4) + (#xF157 #xE0D3) + (#xF156 #xE0D2) + (#xF155 #xE0D1) + (#xF154 #xE0D0) + (#xF153 #xE0CF) + (#xF152 #xE0CE) + (#xF151 #xE0CD) + (#xF150 #xE0CC) + (#xF14F #xE0CB) + (#xF14E #xE0CA) + (#xF14D #xE0C9) + (#xF14C #xE0C8) + (#xF14B #xE0C7) + (#xF14A #xE0C6) + (#xF149 #xE0C5) + (#xF148 #xE0C4) + (#xF147 #xE0C3) + (#xF146 #xE0C2) + (#xF145 #xE0C1) + (#xF144 #xE0C0) + (#xF143 #xE0BF) + (#xF142 #xE0BE) + (#xF141 #xE0BD) + (#xF140 #xE0BC) + (#xF0FC #xE0BB) + (#xF0FB #xE0BA) + (#xF0FA #xE0B9) + (#xF0F9 #xE0B8) + (#xF0F8 #xE0B7) + (#xF0F7 #xE0B6) + (#xF0F6 #xE0B5) + (#xF0F5 #xE0B4) + (#xF0F4 #xE0B3) + (#xF0F3 #xE0B2) + (#xF0F2 #xE0B1) + (#xF0F1 #xE0B0) + (#xF0F0 #xE0AF) + (#xF0EF #xE0AE) + (#xF0EE #xE0AD) + (#xF0ED #xE0AC) + (#xF0EC #xE0AB) + (#xF0EB #xE0AA) + (#xF0EA #xE0A9) + (#xF0E9 #xE0A8) + (#xF0E8 #xE0A7) + (#xF0E7 #xE0A6) + (#xF0E6 #xE0A5) + (#xF0E5 #xE0A4) + (#xF0E4 #xE0A3) + (#xF0E3 #xE0A2) + (#xF0E2 #xE0A1) + (#xF0E1 #xE0A0) + (#xF0E0 #xE09F) + (#xF0DF #xE09E) + (#xF0DE #xE09D) + (#xF0DD #xE09C) + (#xF0DC #xE09B) + (#xF0DB #xE09A) + (#xF0DA #xE099) + (#xF0D9 #xE098) + (#xF0D8 #xE097) + (#xF0D7 #xE096) + (#xF0D6 #xE095) + (#xF0D5 #xE094) + (#xF0D4 #xE093) + (#xF0D3 #xE092) + (#xF0D2 #xE091) + (#xF0D1 #xE090) + (#xF0D0 #xE08F) + (#xF0CF #xE08E) + (#xF0CE #xE08D) + (#xF0CD #xE08C) + (#xF0CC #xE08B) + (#xF0CB #xE08A) + (#xF0CA #xE089) + (#xF0C9 #xE088) + (#xF0C8 #xE087) + (#xF0C7 #xE086) + (#xF0C6 #xE085) + (#xF0C5 #xE084) + (#xF0C4 #xE083) + (#xF0C3 #xE082) + (#xF0C2 #xE081) + (#xF0C1 #xE080) + (#xF0C0 #xE07F) + (#xF0BF #xE07E) + (#xF0BE #xE07D) + (#xF0BD #xE07C) + (#xF0BC #xE07B) + (#xF0BB #xE07A) + (#xF0BA #xE079) + (#xF0B9 #xE078) + (#xF0B8 #xE077) + (#xF0B7 #xE076) + (#xF0B6 #xE075) + (#xF0B5 #xE074) + (#xF0B4 #xE073) + (#xF0B3 #xE072) + (#xF0B2 #xE071) + (#xF0B1 #xE070) + (#xF0B0 #xE06F) + (#xF0AF #xE06E) + (#xF0AE #xE06D) + (#xF0AD #xE06C) + (#xF0AC #xE06B) + (#xF0AB #xE06A) + (#xF0AA #xE069) + (#xF0A9 #xE068) + (#xF0A8 #xE067) + (#xF0A7 #xE066) + (#xF0A6 #xE065) + (#xF0A5 #xE064) + (#xF0A4 #xE063) + (#xF0A3 #xE062) + (#xF0A2 #xE061) + (#xF0A1 #xE060) + (#xF0A0 #xE05F) + (#xF09F #xE05E) + (#xF09E #xE05D) + (#xF09D #xE05C) + (#xF09C #xE05B) + (#xF09B #xE05A) + (#xF09A #xE059) + (#xF099 #xE058) + (#xF098 #xE057) + (#xF097 #xE056) + (#xF096 #xE055) + (#xF095 #xE054) + (#xF094 #xE053) + (#xF093 #xE052) + (#xF092 #xE051) + (#xF091 #xE050) + (#xF090 #xE04F) + (#xF08F #xE04E) + (#xF08E #xE04D) + (#xF08D #xE04C) + (#xF08C #xE04B) + (#xF08B #xE04A) + (#xF08A #xE049) + (#xF089 #xE048) + (#xF088 #xE047) + (#xF087 #xE046) + (#xF086 #xE045) + (#xF085 #xE044) + (#xF084 #xE043) + (#xF083 #xE042) + (#xF082 #xE041) + (#xF081 #xE040) + (#xF080 #xE03F) + (#xF07E #xE03E) + (#xF07D #xE03D) + (#xF07C #xE03C) + (#xF07B #xE03B) + (#xF07A #xE03A) + (#xF079 #xE039) + (#xF078 #xE038) + (#xF077 #xE037) + (#xF076 #xE036) + (#xF075 #xE035) + (#xF074 #xE034) + (#xF073 #xE033) + (#xF072 #xE032) + (#xF071 #xE031) + (#xF070 #xE030) + (#xF06F #xE02F) + (#xF06E #xE02E) + (#xF06D #xE02D) + (#xF06C #xE02C) + (#xF06B #xE02B) + (#xF06A #xE02A) + (#xF069 #xE029) + (#xF068 #xE028) + (#xF067 #xE027) + (#xF066 #xE026) + (#xF065 #xE025) + (#xF064 #xE024) + (#xF063 #xE023) + (#xF062 #xE022) + (#xF061 #xE021) + (#xF060 #xE020) + (#xF05F #xE01F) + (#xF05E #xE01E) + (#xF05D #xE01D) + (#xF05C #xE01C) + (#xF05B #xE01B) + (#xF05A #xE01A) + (#xF059 #xE019) + (#xF058 #xE018) + (#xF057 #xE017) + (#xF056 #xE016) + (#xF055 #xE015) + (#xF054 #xE014) + (#xF053 #xE013) + (#xF052 #xE012) + (#xF051 #xE011) + (#xF050 #xE010) + (#xF04F #xE00F) + (#xF04E #xE00E) + (#xF04D #xE00D) + (#xF04C #xE00C) + (#xF04B #xE00B) + (#xF04A #xE00A) + (#xF049 #xE009) + (#xF048 #xE008) + (#xF047 #xE007) + (#xF046 #xE006) + (#xF045 #xE005) + (#xF044 #xE004) + (#xF043 #xE003) + (#xF042 #xE002) + (#xF041 #xE001) + (#xF040 #xE000) + (#xEEFC #xFF02) + (#xEEFB #xFF07) + (#xEEFA #xFFE4) + (#xEEF9 #xFFE2) + (#xEEF8 #x2179) + (#xEEF7 #x2178) + (#xEEF6 #x2177) + (#xEEF5 #x2176) + (#xEEF4 #x2175) + (#xEEF3 #x2174) + (#xEEF2 #x2173) + (#xEEF1 #x2172) + (#xEEF0 #x2171) + (#xEEEF #x2170) + (#xEEEC #x9ED1) + (#xEEEB #x9E19) + (#xEEEA #xFA2D) + (#xEEE9 #x9D6B) + (#xEEE8 #x9D70) + (#xEEE7 #x9C00) + (#xEEE6 #x9BBB) + (#xEEE5 #x9BB1) + (#xEEE4 #x9B8F) + (#xEEE3 #x9B72) + (#xEEE2 #x9B75) + (#xEEE1 #x9ADC) + (#xEEE0 #x9AD9) + (#xEEDF #x9A4E) + (#xEEDE #x999E) + (#xEEDD #xFA2C) + (#xEEDC #x9927) + (#xEEDB #xFA2B) + (#xEEDA #xFA2A) + (#xEED9 #x9865) + (#xEED8 #x9857) + (#xEED7 #x9755) + (#xEED6 #x9751) + (#xEED5 #x974F) + (#xEED4 #x974D) + (#xEED3 #x9743) + (#xEED2 #x973B) + (#xEED1 #x9733) + (#xEED0 #x96AF) + (#xEECF #x969D) + (#xEECE #xFA29) + (#xEECD #xF9DC) + (#xEECC #x9592) + (#xEECB #x9448) + (#xEECA #x9445) + (#xEEC9 #x9431) + (#xEEC8 #x93F8) + (#xEEC7 #x93DE) + (#xEEC6 #x93C6) + (#xEEC5 #x93A4) + (#xEEC4 #x9357) + (#xEEC3 #x9370) + (#xEEC2 #x9302) + (#xEEC1 #x931D) + (#xEEC0 #x92FF) + (#xEEBF #x931E) + (#xEEBE #xFA28) + (#xEEBD #x92FB) + (#xEEBC #x9321) + (#xEEBB #x9325) + (#xEEBA #x92D3) + (#xEEB9 #x92E0) + (#xEEB8 #x92D5) + (#xEEB7 #xFA27) + (#xEEB6 #x92D0) + (#xEEB5 #x92D9) + (#xEEB4 #x92D7) + (#xEEB3 #x92E7) + (#xEEB2 #x9278) + (#xEEB1 #x9277) + (#xEEB0 #x92A7) + (#xEEAF #x9267) + (#xEEAE #x9239) + (#xEEAD #x9251) + (#xEEAC #x9259) + (#xEEAB #x924E) + (#xEEAA #x923C) + (#xEEA9 #x9240) + (#xEEA8 #x923A) + (#xEEA7 #x920A) + (#xEEA6 #x9210) + (#xEEA5 #x9206) + (#xEEA4 #x91E5) + (#xEEA3 #x91E4) + (#xEEA2 #x91EE) + (#xEEA1 #x91ED) + (#xEEA0 #x91DE) + (#xEE9F #x91D7) + (#xEE9E #x91DA) + (#xEE9D #x9127) + (#xEE9C #x9115) + (#xEE9B #xFA26) + (#xEE9A #x90DE) + (#xEE99 #x9067) + (#xEE98 #xFA25) + (#xEE97 #xFA24) + (#xEE96 #x8ECF) + (#xEE95 #xFA23) + (#xEE94 #x8D76) + (#xEE93 #x8D12) + (#xEE92 #x8CF4) + (#xEE91 #x8CF0) + (#xEE90 #x8B7F) + (#xEE8F #x8B53) + (#xEE8E #x8AF6) + (#xEE8D #xFA22) + (#xEE8C #x8ADF) + (#xEE8B #x8ABE) + (#xEE8A #x8AA7) + (#xEE89 #x8A79) + (#xEE88 #x8A37) + (#xEE87 #x8A12) + (#xEE86 #x88F5) + (#xEE85 #x8807) + (#xEE84 #xFA21) + (#xEE83 #xFA20) + (#xEE82 #x85B0) + (#xEE81 #xFA1F) + (#xEE80 #x856B) + (#xEE7E #x8559) + (#xEE7D #x8553) + (#xEE7C #x84B4) + (#xEE7B #x8448) + (#xEE7A #x83F6) + (#xEE79 #x83C7) + (#xEE78 #x837F) + (#xEE77 #x8362) + (#xEE76 #x8301) + (#xEE75 #xFA1E) + (#xEE74 #x7FA1) + (#xEE73 #x7F47) + (#xEE72 #x7E52) + (#xEE71 #x7DD6) + (#xEE70 #x7DA0) + (#xEE6F #x7DB7) + (#xEE6E #x7D5C) + (#xEE6D #x7D48) + (#xEE6C #xFA1D) + (#xEE6B #x7B9E) + (#xEE6A #x7AEB) + (#xEE69 #xFA1C) + (#xEE68 #x7AE7) + (#xEE67 #x7AD1) + (#xEE66 #x799B) + (#xEE65 #xFA1B) + (#xEE64 #x7994) + (#xEE63 #xFA1A) + (#xEE62 #xFA19) + (#xEE61 #xFA18) + (#xEE60 #x7930) + (#xEE5F #x787A) + (#xEE5E #x7864) + (#xEE5D #x784E) + (#xEE5C #x7821) + (#xEE5B #x52AF) + (#xEE5A #x7746) + (#xEE59 #xFA17) + (#xEE58 #x76A6) + (#xEE57 #x769B) + (#xEE56 #x769E) + (#xEE55 #x769C) + (#xEE54 #x7682) + (#xEE53 #x756F) + (#xEE52 #x7501) + (#xEE51 #x749F) + (#xEE50 #x7489) + (#xEE4F #x7462) + (#xEE4E #x742E) + (#xEE4D #x7429) + (#xEE4C #x742A) + (#xEE4B #x7426) + (#xEE4A #x73F5) + (#xEE49 #x7407) + (#xEE48 #x73D2) + (#xEE47 #x73E3) + (#xEE46 #x73D6) + (#xEE45 #x73C9) + (#xEE44 #x73BD) + (#xEE43 #x7377) + (#xEE42 #xFA16) + (#xEE41 #x7324) + (#xEE40 #x72BE) + (#xEDFC #x72B1) + (#xEDFB #x71FE) + (#xEDFA #x71C1) + (#xEDF9 #xFA15) + (#xEDF8 #x7147) + (#xEDF7 #x7146) + (#xEDF6 #x715C) + (#xEDF5 #x7104) + (#xEDF4 #x710F) + (#xEDF3 #x70AB) + (#xEDF2 #x7085) + (#xEDF1 #x7028) + (#xEDF0 #x7007) + (#xEDEF #x7005) + (#xEDEE #x6FF5) + (#xEDED #x6FB5) + (#xEDEC #x6F88) + (#xEDEB #x6EBF) + (#xEDEA #x6E3C) + (#xEDE9 #x6E27) + (#xEDE8 #x6E5C) + (#xEDE7 #x6E39) + (#xEDE6 #x6DFC) + (#xEDE5 #x6DF2) + (#xEDE4 #x6DF8) + (#xEDE3 #x6DCF) + (#xEDE2 #x6DAC) + (#xEDE1 #x6D96) + (#xEDE0 #x6D6F) + (#xEDDF #x6D87) + (#xEDDE #x6D04) + (#xEDDD #x6CDA) + (#xEDDC #x6C6F) + (#xEDDB #x6C86) + (#xEDDA #x6C5C) + (#xEDD9 #x6C3F) + (#xEDD8 #x6BD6) + (#xEDD7 #x6AE4) + (#xEDD6 #x6AE2) + (#xEDD5 #x6A7E) + (#xEDD4 #x6A73) + (#xEDD3 #x6A46) + (#xEDD2 #x6A6B) + (#xEDD1 #x6A30) + (#xEDD0 #x69E2) + (#xEDCF #x6998) + (#xEDCE #xFA14) + (#xEDCD #x6968) + (#xEDCC #xFA13) + (#xEDCB #x68CF) + (#xEDCA #x6844) + (#xEDC9 #x6801) + (#xEDC8 #x67C0) + (#xEDC7 #x6852) + (#xEDC6 #x67BB) + (#xEDC5 #x6766) + (#xEDC4 #xF929) + (#xEDC3 #x670E) + (#xEDC2 #x66FA) + (#xEDC1 #x66BF) + (#xEDC0 #x66B2) + (#xEDBF #x66A0) + (#xEDBE #x6699) + (#xEDBD #x6673) + (#xEDBC #xFA12) + (#xEDBB #x6659) + (#xEDBA #x6657) + (#xEDB9 #x6665) + (#xEDB8 #x6624) + (#xEDB7 #x661E) + (#xEDB6 #x662E) + (#xEDB5 #x6609) + (#xEDB4 #x663B) + (#xEDB3 #x6615) + (#xEDB2 #x6600) + (#xEDB1 #x654E) + (#xEDB0 #x64CE) + (#xEDAF #x649D) + (#xEDAE #x6460) + (#xEDAD #x63F5) + (#xEDAC #x62A6) + (#xEDAB #x6213) + (#xEDAA #x6198) + (#xEDA9 #x6130) + (#xEDA8 #x6137) + (#xEDA7 #x6111) + (#xEDA6 #x60F2) + (#xEDA5 #x6120) + (#xEDA4 #x60D5) + (#xEDA3 #x60DE) + (#xEDA2 #x608A) + (#xEDA1 #x6085) + (#xEDA0 #x605D) + (#xED9F #x5FDE) + (#xED9E #x5FB7) + (#xED9D #x5F67) + (#xED9C #x5F34) + (#xED9B #x5F21) + (#xED9A #x5DD0) + (#xED99 #x5DB9) + (#xED98 #x5DB8) + (#xED97 #x5D6D) + (#xED96 #x5D42) + (#xED95 #xFA11) + (#xED94 #x5D53) + (#xED93 #x5D27) + (#xED92 #x5CF5) + (#xED91 #x5CBA) + (#xED90 #x5CA6) + (#xED8F #x5C1E) + (#xED8E #x5BEC) + (#xED8D #x5BD8) + (#xED8C #x752F) + (#xED8B #x5BC0) + (#xED8A #x5B56) + (#xED89 #x59BA) + (#xED88 #x59A4) + (#xED87 #x5963) + (#xED86 #x595D) + (#xED85 #x595B) + (#xED84 #x5953) + (#xED83 #x590B) + (#xED82 #x58B2) + (#xED81 #x589E) + (#xED80 #xFA10) + (#xED7E #xFA0F) + (#xED7D #x57C7) + (#xED7C #x57C8) + (#xED7B #x57AC) + (#xED7A #x5765) + (#xED79 #x5759) + (#xED78 #x5586) + (#xED77 #x54FF) + (#xED76 #x54A9) + (#xED75 #x548A) + (#xED74 #x549C) + (#xED73 #xFA0E) + (#xED72 #x53DD) + (#xED71 #x53B2) + (#xED70 #x5393) + (#xED6F #x5372) + (#xED6E #x5324) + (#xED6D #x5307) + (#xED6C #x5300) + (#xED6B #x52DB) + (#xED6A #x52C0) + (#xED69 #x52A6) + (#xED68 #x529C) + (#xED67 #x5215) + (#xED66 #x51EC) + (#xED65 #x51BE) + (#xED64 #x519D) + (#xED63 #x5164) + (#xED62 #x514A) + (#xED61 #x50D8) + (#xED60 #x50F4) + (#xED5F #x5094) + (#xED5E #x5042) + (#xED5D #x5070) + (#xED5C #x5046) + (#xED5B #x501E) + (#xED5A #x4FFF) + (#xED59 #x5022) + (#xED58 #x5040) + (#xED57 #x4FCD) + (#xED56 #x4F94) + (#xED55 #x4F9A) + (#xED54 #x4F8A) + (#xED53 #x4F92) + (#xED52 #x4F56) + (#xED51 #x4F39) + (#xED50 #x4F03) + (#xED4F #x4F00) + (#xED4E #x4EFC) + (#xED4D #x4EE1) + (#xED4C #x4E28) + (#xED4B #x5F45) + (#xED4A #x66FB) + (#xED49 #x92F9) + (#xED48 #x68C8) + (#xED47 #x6631) + (#xED46 #x70BB) + (#xED45 #x4FC9) + (#xED44 #x84DC) + (#xED43 #x9288) + (#xED42 #x9348) + (#xED41 #x891C) + (#xED40 #x7E8A) + (#xEA9E #x9FA0) + (#xEA40 #x9D5D) + (#xE99E #x9AF7) + (#xE940 #x9871) + (#xE89E #x965E) + (#xE840 #x9319) + (#xE79E #x8FF8) + (#xE740 #x8E47) + (#xE69E #x8B6B) + (#xE640 #x8966) + (#xE59E #x8759) + (#xE540 #x8541) + (#xE49E #x82D9) + (#xE440 #x968B) + (#xE39E #x7F3A) + (#xE340 #x7D02) + (#xE29E #x7B50) + (#xE240 #x78E7) + (#xE19E #x7670) + (#xE140 #x74E0) + (#xE09E #x71FC) + (#xE040 #x6F3E) + (#x9F9E #x6CBE) + (#x9F40 #x6A97) + (#x9E9E #x68CD) + (#x9E40 #x66C4) + (#x9D9E #x64BC) + (#x9D40 #x621E) + (#x9C9E #x609A) + (#x9C40 #x5ED6) + (#x9B9E #x5C53) + (#x9B40 #x5978) + (#x9A9E #x5709) + (#x9A40 #x54AB) + (#x999E #x8FA8) + (#x9940 #x50C9) + (#x9840 #x84EE) + (#x979E #x7483) + (#x9740 #x8AED) + (#x969E #x6E80) + (#x9640 #x6CD5) + (#x959E #x670D) + (#x9540 #x9F3B) + (#x949E #x9EA6) + (#x9440 #x5982) + (#x939E #x5230) + (#x9340 #x90B8) + (#x929E #x5BF5) + (#x9240 #x53E9) + (#x919E #x618E) + (#x9140 #x7E4A) + (#x909E #x88FE) + (#x9040 #x62ED) + (#x8F9E #x511F) + (#x8F40 #x5B97) + (#x8E9E #x6642) + (#x8E40 #x5BDF) + (#x8D9E #x8FBC) + (#x8D40 #x540E) + (#x8C9E #x6372) + (#x8C40 #x6398) + (#x8B9E #x4EAC) + (#x8B40 #x6A5F) + (#x8A9E #x8431) + (#x8A40 #x9B41) + (#x899E #x5FDC) + (#x8940 #x9662) + (#x879C #x222A) + (#x879B #x2229) + (#x879A #x2235) + (#x8799 #x22BF) + (#x8798 #x221F) + (#x8797 #x2220) + (#x8796 #x22A5) + (#x8795 #x221A) + (#x8794 #x2211) + (#x8793 #x222E) + (#x8792 #x222B) + (#x8791 #x2261) + (#x8790 #x2252) + (#x878F #x337C) + (#x878E #x337D) + (#x878D #x337E) + (#x878C #x3239) + (#x878B #x3232) + (#x878A #x3231) + (#x8789 #x32A8) + (#x8788 #x32A7) + (#x8787 #x32A6) + (#x8786 #x32A5) + (#x8785 #x32A4) + (#x8784 #x2121) + (#x8783 #x33CD) + (#x8782 #x2116) + (#x8781 #x301F) + (#x8780 #x301D) + (#x877E #x337B) + (#x8775 #x33A1) + (#x8774 #x33C4) + (#x8773 #x338F) + (#x8772 #x338E) + (#x8771 #x339E) + (#x8770 #x339D) + (#x876F #x339C) + (#x876E #x333B) + (#x876D #x334A) + (#x876C #x332B) + (#x876B #x3323) + (#x876A #x3326) + (#x8769 #x330D) + (#x8768 #x3357) + (#x8767 #x3351) + (#x8766 #x3336) + (#x8765 #x3303) + (#x8764 #x3327) + (#x8763 #x3318) + (#x8762 #x334D) + (#x8761 #x3322) + (#x8760 #x3314) + (#x875F #x3349) + (#x875D #x2169) + (#x875C #x2168) + (#x875B #x2167) + (#x875A #x2166) + (#x8759 #x2165) + (#x8758 #x2164) + (#x8757 #x2163) + (#x8756 #x2162) + (#x8755 #x2161) + (#x8754 #x2160) + (#x8753 #x2473) + (#x8752 #x2472) + (#x8751 #x2471) + (#x8750 #x2470) + (#x874F #x246F) + (#x874E #x246E) + (#x874D #x246D) + (#x874C #x246C) + (#x874B #x246B) + (#x874A #x246A) + (#x8749 #x2469) + (#x8748 #x2468) + (#x8747 #x2467) + (#x8746 #x2466) + (#x8745 #x2465) + (#x8744 #x2464) + (#x8743 #x2463) + (#x8742 #x2462) + (#x8741 #x2461) + (#x8740 #x2460) + (#x8440 #x410) + (#x8340 #x30A1) + (#x819E #x25C7) + (#x8140 #x3000) + )) + (eucjp-only '((#xFEFE #xE3AB) + (#xFEFD #xE3AA) + (#xFEFC #xE3A9) + (#xFEFB #xE3A8) + (#xFEFA #xE3A7) + (#xFEF9 #xE3A6) + (#xFEF8 #xE3A5) + (#xFEF7 #xE3A4) + (#xFEF6 #xE3A3) + (#xFEF5 #xE3A2) + (#xFEF4 #xE3A1) + (#xFEF3 #xE3A0) + (#xFEF2 #xE39F) + (#xFEF1 #xE39E) + (#xFEF0 #xE39D) + (#xFEEF #xE39C) + (#xFEEE #xE39B) + (#xFEED #xE39A) + (#xFEEC #xE399) + (#xFEEB #xE398) + (#xFEEA #xE397) + (#xFEE9 #xE396) + (#xFEE8 #xE395) + (#xFEE7 #xE394) + (#xFEE6 #xE393) + (#xFEE5 #xE392) + (#xFEE4 #xE391) + (#xFEE3 #xE390) + (#xFEE2 #xE38F) + (#xFEE1 #xE38E) + (#xFEE0 #xE38D) + (#xFEDF #xE38C) + (#xFEDE #xE38B) + (#xFEDD #xE38A) + (#xFEDC #xE389) + (#xFEDB #xE388) + (#xFEDA #xE387) + (#xFED9 #xE386) + (#xFED8 #xE385) + (#xFED7 #xE384) + (#xFED6 #xE383) + (#xFED5 #xE382) + (#xFED4 #xE381) + (#xFED3 #xE380) + (#xFED2 #xE37F) + (#xFED1 #xE37E) + (#xFED0 #xE37D) + (#xFECF #xE37C) + (#xFECE #xE37B) + (#xFECD #xE37A) + (#xFECC #xE379) + (#xFECB #xE378) + (#xFECA #xE377) + (#xFEC9 #xE376) + (#xFEC8 #xE375) + (#xFEC7 #xE374) + (#xFEC6 #xE373) + (#xFEC5 #xE372) + (#xFEC4 #xE371) + (#xFEC3 #xE370) + (#xFEC2 #xE36F) + (#xFEC1 #xE36E) + (#xFEC0 #xE36D) + (#xFEBF #xE36C) + (#xFEBE #xE36B) + (#xFEBD #xE36A) + (#xFEBC #xE369) + (#xFEBB #xE368) + (#xFEBA #xE367) + (#xFEB9 #xE366) + (#xFEB8 #xE365) + (#xFEB7 #xE364) + (#xFEB6 #xE363) + (#xFEB5 #xE362) + (#xFEB4 #xE361) + (#xFEB3 #xE360) + (#xFEB2 #xE35F) + (#xFEB1 #xE35E) + (#xFEB0 #xE35D) + (#xFEAF #xE35C) + (#xFEAE #xE35B) + (#xFEAD #xE35A) + (#xFEAC #xE359) + (#xFEAB #xE358) + (#xFEAA #xE357) + (#xFEA9 #xE356) + (#xFEA8 #xE355) + (#xFEA7 #xE354) + (#xFEA6 #xE353) + (#xFEA5 #xE352) + (#xFEA4 #xE351) + (#xFEA3 #xE350) + (#xFEA2 #xE34F) + (#xFEA1 #xE34E) + (#xFDFE #xE34D) + (#xFDFD #xE34C) + (#xFDFC #xE34B) + (#xFDFB #xE34A) + (#xFDFA #xE349) + (#xFDF9 #xE348) + (#xFDF8 #xE347) + (#xFDF7 #xE346) + (#xFDF6 #xE345) + (#xFDF5 #xE344) + (#xFDF4 #xE343) + (#xFDF3 #xE342) + (#xFDF2 #xE341) + (#xFDF1 #xE340) + (#xFDF0 #xE33F) + (#xFDEF #xE33E) + (#xFDEE #xE33D) + (#xFDED #xE33C) + (#xFDEC #xE33B) + (#xFDEB #xE33A) + (#xFDEA #xE339) + (#xFDE9 #xE338) + (#xFDE8 #xE337) + (#xFDE7 #xE336) + (#xFDE6 #xE335) + (#xFDE5 #xE334) + (#xFDE4 #xE333) + (#xFDE3 #xE332) + (#xFDE2 #xE331) + (#xFDE1 #xE330) + (#xFDE0 #xE32F) + (#xFDDF #xE32E) + (#xFDDE #xE32D) + (#xFDDD #xE32C) + (#xFDDC #xE32B) + (#xFDDB #xE32A) + (#xFDDA #xE329) + (#xFDD9 #xE328) + (#xFDD8 #xE327) + (#xFDD7 #xE326) + (#xFDD6 #xE325) + (#xFDD5 #xE324) + (#xFDD4 #xE323) + (#xFDD3 #xE322) + (#xFDD2 #xE321) + (#xFDD1 #xE320) + (#xFDD0 #xE31F) + (#xFDCF #xE31E) + (#xFDCE #xE31D) + (#xFDCD #xE31C) + (#xFDCC #xE31B) + (#xFDCB #xE31A) + (#xFDCA #xE319) + (#xFDC9 #xE318) + (#xFDC8 #xE317) + (#xFDC7 #xE316) + (#xFDC6 #xE315) + (#xFDC5 #xE314) + (#xFDC4 #xE313) + (#xFDC3 #xE312) + (#xFDC2 #xE311) + (#xFDC1 #xE310) + (#xFDC0 #xE30F) + (#xFDBF #xE30E) + (#xFDBE #xE30D) + (#xFDBD #xE30C) + (#xFDBC #xE30B) + (#xFDBB #xE30A) + (#xFDBA #xE309) + (#xFDB9 #xE308) + (#xFDB8 #xE307) + (#xFDB7 #xE306) + (#xFDB6 #xE305) + (#xFDB5 #xE304) + (#xFDB4 #xE303) + (#xFDB3 #xE302) + (#xFDB2 #xE301) + (#xFDB1 #xE300) + (#xFDB0 #xE2FF) + (#xFDAF #xE2FE) + (#xFDAE #xE2FD) + (#xFDAD #xE2FC) + (#xFDAC #xE2FB) + (#xFDAB #xE2FA) + (#xFDAA #xE2F9) + (#xFDA9 #xE2F8) + (#xFDA8 #xE2F7) + (#xFDA7 #xE2F6) + (#xFDA6 #xE2F5) + (#xFDA5 #xE2F4) + (#xFDA4 #xE2F3) + (#xFDA3 #xE2F2) + (#xFDA2 #xE2F1) + (#xFDA1 #xE2F0) + (#xFCFE #xE2EF) + (#xFCFD #xE2EE) + (#xFCFC #xE2ED) + (#xFCFB #xE2EC) + (#xFCFA #xE2EB) + (#xFCF9 #xE2EA) + (#xFCF8 #xE2E9) + (#xFCF7 #xE2E8) + (#xFCF6 #xE2E7) + (#xFCF5 #xE2E6) + (#xFCF4 #xE2E5) + (#xFCF3 #xE2E4) + (#xFCF2 #xE2E3) + (#xFCF1 #xE2E2) + (#xFCF0 #xE2E1) + (#xFCEF #xE2E0) + (#xFCEE #xE2DF) + (#xFCED #xE2DE) + (#xFCEC #xE2DD) + (#xFCEB #xE2DC) + (#xFCEA #xE2DB) + (#xFCE9 #xE2DA) + (#xFCE8 #xE2D9) + (#xFCE7 #xE2D8) + (#xFCE6 #xE2D7) + (#xFCE5 #xE2D6) + (#xFCE4 #xE2D5) + (#xFCE3 #xE2D4) + (#xFCE2 #xE2D3) + (#xFCE1 #xE2D2) + (#xFCE0 #xE2D1) + (#xFCDF #xE2D0) + (#xFCDE #xE2CF) + (#xFCDD #xE2CE) + (#xFCDC #xE2CD) + (#xFCDB #xE2CC) + (#xFCDA #xE2CB) + (#xFCD9 #xE2CA) + (#xFCD8 #xE2C9) + (#xFCD7 #xE2C8) + (#xFCD6 #xE2C7) + (#xFCD5 #xE2C6) + (#xFCD4 #xE2C5) + (#xFCD3 #xE2C4) + (#xFCD2 #xE2C3) + (#xFCD1 #xE2C2) + (#xFCD0 #xE2C1) + (#xFCCF #xE2C0) + (#xFCCE #xE2BF) + (#xFCCD #xE2BE) + (#xFCCC #xE2BD) + (#xFCCB #xE2BC) + (#xFCCA #xE2BB) + (#xFCC9 #xE2BA) + (#xFCC8 #xE2B9) + (#xFCC7 #xE2B8) + (#xFCC6 #xE2B7) + (#xFCC5 #xE2B6) + (#xFCC4 #xE2B5) + (#xFCC3 #xE2B4) + (#xFCC2 #xE2B3) + (#xFCC1 #xE2B2) + (#xFCC0 #xE2B1) + (#xFCBF #xE2B0) + (#xFCBE #xE2AF) + (#xFCBD #xE2AE) + (#xFCBC #xE2AD) + (#xFCBB #xE2AC) + (#xFCBA #xE2AB) + (#xFCB9 #xE2AA) + (#xFCB8 #xE2A9) + (#xFCB7 #xE2A8) + (#xFCB6 #xE2A7) + (#xFCB5 #xE2A6) + (#xFCB4 #xE2A5) + (#xFCB3 #xE2A4) + (#xFCB2 #xE2A3) + (#xFCB1 #xE2A2) + (#xFCB0 #xE2A1) + (#xFCAF #xE2A0) + (#xFCAE #xE29F) + (#xFCAD #xE29E) + (#xFCAC #xE29D) + (#xFCAB #xE29C) + (#xFCAA #xE29B) + (#xFCA9 #xE29A) + (#xFCA8 #xE299) + (#xFCA7 #xE298) + (#xFCA6 #xE297) + (#xFCA5 #xE296) + (#xFCA4 #xE295) + (#xFCA3 #xE294) + (#xFCA2 #xE293) + (#xFCA1 #xE292) + (#xFBFE #xE291) + (#xFBFD #xE290) + (#xFBFC #xE28F) + (#xFBFB #xE28E) + (#xFBFA #xE28D) + (#xFBF9 #xE28C) + (#xFBF8 #xE28B) + (#xFBF7 #xE28A) + (#xFBF6 #xE289) + (#xFBF5 #xE288) + (#xFBF4 #xE287) + (#xFBF3 #xE286) + (#xFBF2 #xE285) + (#xFBF1 #xE284) + (#xFBF0 #xE283) + (#xFBEF #xE282) + (#xFBEE #xE281) + (#xFBED #xE280) + (#xFBEC #xE27F) + (#xFBEB #xE27E) + (#xFBEA #xE27D) + (#xFBE9 #xE27C) + (#xFBE8 #xE27B) + (#xFBE7 #xE27A) + (#xFBE6 #xE279) + (#xFBE5 #xE278) + (#xFBE4 #xE277) + (#xFBE3 #xE276) + (#xFBE2 #xE275) + (#xFBE1 #xE274) + (#xFBE0 #xE273) + (#xFBDF #xE272) + (#xFBDE #xE271) + (#xFBDD #xE270) + (#xFBDC #xE26F) + (#xFBDB #xE26E) + (#xFBDA #xE26D) + (#xFBD9 #xE26C) + (#xFBD8 #xE26B) + (#xFBD7 #xE26A) + (#xFBD6 #xE269) + (#xFBD5 #xE268) + (#xFBD4 #xE267) + (#xFBD3 #xE266) + (#xFBD2 #xE265) + (#xFBD1 #xE264) + (#xFBD0 #xE263) + (#xFBCF #xE262) + (#xFBCE #xE261) + (#xFBCD #xE260) + (#xFBCC #xE25F) + (#xFBCB #xE25E) + (#xFBCA #xE25D) + (#xFBC9 #xE25C) + (#xFBC8 #xE25B) + (#xFBC7 #xE25A) + (#xFBC6 #xE259) + (#xFBC5 #xE258) + (#xFBC4 #xE257) + (#xFBC3 #xE256) + (#xFBC2 #xE255) + (#xFBC1 #xE254) + (#xFBC0 #xE253) + (#xFBBF #xE252) + (#xFBBE #xE251) + (#xFBBD #xE250) + (#xFBBC #xE24F) + (#xFBBB #xE24E) + (#xFBBA #xE24D) + (#xFBB9 #xE24C) + (#xFBB8 #xE24B) + (#xFBB7 #xE24A) + (#xFBB6 #xE249) + (#xFBB5 #xE248) + (#xFBB4 #xE247) + (#xFBB3 #xE246) + (#xFBB2 #xE245) + (#xFBB1 #xE244) + (#xFBB0 #xE243) + (#xFBAF #xE242) + (#xFBAE #xE241) + (#xFBAD #xE240) + (#xFBAC #xE23F) + (#xFBAB #xE23E) + (#xFBAA #xE23D) + (#xFBA9 #xE23C) + (#xFBA8 #xE23B) + (#xFBA7 #xE23A) + (#xFBA6 #xE239) + (#xFBA5 #xE238) + (#xFBA4 #xE237) + (#xFBA3 #xE236) + (#xFBA2 #xE235) + (#xFBA1 #xE234) + (#xFAFE #xE233) + (#xFAFD #xE232) + (#xFAFC #xE231) + (#xFAFB #xE230) + (#xFAFA #xE22F) + (#xFAF9 #xE22E) + (#xFAF8 #xE22D) + (#xFAF7 #xE22C) + (#xFAF6 #xE22B) + (#xFAF5 #xE22A) + (#xFAF4 #xE229) + (#xFAF3 #xE228) + (#xFAF2 #xE227) + (#xFAF1 #xE226) + (#xFAF0 #xE225) + (#xFAEF #xE224) + (#xFAEE #xE223) + (#xFAED #xE222) + (#xFAEC #xE221) + (#xFAEB #xE220) + (#xFAEA #xE21F) + (#xFAE9 #xE21E) + (#xFAE8 #xE21D) + (#xFAE7 #xE21C) + (#xFAE6 #xE21B) + (#xFAE5 #xE21A) + (#xFAE4 #xE219) + (#xFAE3 #xE218) + (#xFAE2 #xE217) + (#xFAE1 #xE216) + (#xFAE0 #xE215) + (#xFADF #xE214) + (#xFADE #xE213) + (#xFADD #xE212) + (#xFADC #xE211) + (#xFADB #xE210) + (#xFADA #xE20F) + (#xFAD9 #xE20E) + (#xFAD8 #xE20D) + (#xFAD7 #xE20C) + (#xFAD6 #xE20B) + (#xFAD5 #xE20A) + (#xFAD4 #xE209) + (#xFAD3 #xE208) + (#xFAD2 #xE207) + (#xFAD1 #xE206) + (#xFAD0 #xE205) + (#xFACF #xE204) + (#xFACE #xE203) + (#xFACD #xE202) + (#xFACC #xE201) + (#xFACB #xE200) + (#xFACA #xE1FF) + (#xFAC9 #xE1FE) + (#xFAC8 #xE1FD) + (#xFAC7 #xE1FC) + (#xFAC6 #xE1FB) + (#xFAC5 #xE1FA) + (#xFAC4 #xE1F9) + (#xFAC3 #xE1F8) + (#xFAC2 #xE1F7) + (#xFAC1 #xE1F6) + (#xFAC0 #xE1F5) + (#xFABF #xE1F4) + (#xFABE #xE1F3) + (#xFABD #xE1F2) + (#xFABC #xE1F1) + (#xFABB #xE1F0) + (#xFABA #xE1EF) + (#xFAB9 #xE1EE) + (#xFAB8 #xE1ED) + (#xFAB7 #xE1EC) + (#xFAB6 #xE1EB) + (#xFAB5 #xE1EA) + (#xFAB4 #xE1E9) + (#xFAB3 #xE1E8) + (#xFAB2 #xE1E7) + (#xFAB1 #xE1E6) + (#xFAB0 #xE1E5) + (#xFAAF #xE1E4) + (#xFAAE #xE1E3) + (#xFAAD #xE1E2) + (#xFAAC #xE1E1) + (#xFAAB #xE1E0) + (#xFAAA #xE1DF) + (#xFAA9 #xE1DE) + (#xFAA8 #xE1DD) + (#xFAA7 #xE1DC) + (#xFAA6 #xE1DB) + (#xFAA5 #xE1DA) + (#xFAA4 #xE1D9) + (#xFAA3 #xE1D8) + (#xFAA2 #xE1D7) + (#xFAA1 #xE1D6) + (#xF9FE #xE1D5) + (#xF9FD #xE1D4) + (#xF9FC #xE1D3) + (#xF9FB #xE1D2) + (#xF9FA #xE1D1) + (#xF9F9 #xE1D0) + (#xF9F8 #xE1CF) + (#xF9F7 #xE1CE) + (#xF9F6 #xE1CD) + (#xF9F5 #xE1CC) + (#xF9F4 #xE1CB) + (#xF9F3 #xE1CA) + (#xF9F2 #xE1C9) + (#xF9F1 #xE1C8) + (#xF9F0 #xE1C7) + (#xF9EF #xE1C6) + (#xF9EE #xE1C5) + (#xF9ED #xE1C4) + (#xF9EC #xE1C3) + (#xF9EB #xE1C2) + (#xF9EA #xE1C1) + (#xF9E9 #xE1C0) + (#xF9E8 #xE1BF) + (#xF9E7 #xE1BE) + (#xF9E6 #xE1BD) + (#xF9E5 #xE1BC) + (#xF9E4 #xE1BB) + (#xF9E3 #xE1BA) + (#xF9E2 #xE1B9) + (#xF9E1 #xE1B8) + (#xF9E0 #xE1B7) + (#xF9DF #xE1B6) + (#xF9DE #xE1B5) + (#xF9DD #xE1B4) + (#xF9DC #xE1B3) + (#xF9DB #xE1B2) + (#xF9DA #xE1B1) + (#xF9D9 #xE1B0) + (#xF9D8 #xE1AF) + (#xF9D7 #xE1AE) + (#xF9D6 #xE1AD) + (#xF9D5 #xE1AC) + (#xF9D4 #xE1AB) + (#xF9D3 #xE1AA) + (#xF9D2 #xE1A9) + (#xF9D1 #xE1A8) + (#xF9D0 #xE1A7) + (#xF9CF #xE1A6) + (#xF9CE #xE1A5) + (#xF9CD #xE1A4) + (#xF9CC #xE1A3) + (#xF9CB #xE1A2) + (#xF9CA #xE1A1) + (#xF9C9 #xE1A0) + (#xF9C8 #xE19F) + (#xF9C7 #xE19E) + (#xF9C6 #xE19D) + (#xF9C5 #xE19C) + (#xF9C4 #xE19B) + (#xF9C3 #xE19A) + (#xF9C2 #xE199) + (#xF9C1 #xE198) + (#xF9C0 #xE197) + (#xF9BF #xE196) + (#xF9BE #xE195) + (#xF9BD #xE194) + (#xF9BC #xE193) + (#xF9BB #xE192) + (#xF9BA #xE191) + (#xF9B9 #xE190) + (#xF9B8 #xE18F) + (#xF9B7 #xE18E) + (#xF9B6 #xE18D) + (#xF9B5 #xE18C) + (#xF9B4 #xE18B) + (#xF9B3 #xE18A) + (#xF9B2 #xE189) + (#xF9B1 #xE188) + (#xF9B0 #xE187) + (#xF9AF #xE186) + (#xF9AE #xE185) + (#xF9AD #xE184) + (#xF9AC #xE183) + (#xF9AB #xE182) + (#xF9AA #xE181) + (#xF9A9 #xE180) + (#xF9A8 #xE17F) + (#xF9A7 #xE17E) + (#xF9A6 #xE17D) + (#xF9A5 #xE17C) + (#xF9A4 #xE17B) + (#xF9A3 #xE17A) + (#xF9A2 #xE179) + (#xF9A1 #xE178) + (#xF8FE #xE177) + (#xF8FD #xE176) + (#xF8FC #xE175) + (#xF8FB #xE174) + (#xF8FA #xE173) + (#xF8F9 #xE172) + (#xF8F8 #xE171) + (#xF8F7 #xE170) + (#xF8F6 #xE16F) + (#xF8F5 #xE16E) + (#xF8F4 #xE16D) + (#xF8F3 #xE16C) + (#xF8F2 #xE16B) + (#xF8F1 #xE16A) + (#xF8F0 #xE169) + (#xF8EF #xE168) + (#xF8EE #xE167) + (#xF8ED #xE166) + (#xF8EC #xE165) + (#xF8EB #xE164) + (#xF8EA #xE163) + (#xF8E9 #xE162) + (#xF8E8 #xE161) + (#xF8E7 #xE160) + (#xF8E6 #xE15F) + (#xF8E5 #xE15E) + (#xF8E4 #xE15D) + (#xF8E3 #xE15C) + (#xF8E2 #xE15B) + (#xF8E1 #xE15A) + (#xF8E0 #xE159) + (#xF8DF #xE158) + (#xF8DE #xE157) + (#xF8DD #xE156) + (#xF8DC #xE155) + (#xF8DB #xE154) + (#xF8DA #xE153) + (#xF8D9 #xE152) + (#xF8D8 #xE151) + (#xF8D7 #xE150) + (#xF8D6 #xE14F) + (#xF8D5 #xE14E) + (#xF8D4 #xE14D) + (#xF8D3 #xE14C) + (#xF8D2 #xE14B) + (#xF8D1 #xE14A) + (#xF8D0 #xE149) + (#xF8CF #xE148) + (#xF8CE #xE147) + (#xF8CD #xE146) + (#xF8CC #xE145) + (#xF8CB #xE144) + (#xF8CA #xE143) + (#xF8C9 #xE142) + (#xF8C8 #xE141) + (#xF8C7 #xE140) + (#xF8C6 #xE13F) + (#xF8C5 #xE13E) + (#xF8C4 #xE13D) + (#xF8C3 #xE13C) + (#xF8C2 #xE13B) + (#xF8C1 #xE13A) + (#xF8C0 #xE139) + (#xF8BF #xE138) + (#xF8BE #xE137) + (#xF8BD #xE136) + (#xF8BC #xE135) + (#xF8BB #xE134) + (#xF8BA #xE133) + (#xF8B9 #xE132) + (#xF8B8 #xE131) + (#xF8B7 #xE130) + (#xF8B6 #xE12F) + (#xF8B5 #xE12E) + (#xF8B4 #xE12D) + (#xF8B3 #xE12C) + (#xF8B2 #xE12B) + (#xF8B1 #xE12A) + (#xF8B0 #xE129) + (#xF8AF #xE128) + (#xF8AE #xE127) + (#xF8AD #xE126) + (#xF8AC #xE125) + (#xF8AB #xE124) + (#xF8AA #xE123) + (#xF8A9 #xE122) + (#xF8A8 #xE121) + (#xF8A7 #xE120) + (#xF8A6 #xE11F) + (#xF8A5 #xE11E) + (#xF8A4 #xE11D) + (#xF8A3 #xE11C) + (#xF8A2 #xE11B) + (#xF8A1 #xE11A) + (#xF7FE #xE119) + (#xF7FD #xE118) + (#xF7FC #xE117) + (#xF7FB #xE116) + (#xF7FA #xE115) + (#xF7F9 #xE114) + (#xF7F8 #xE113) + (#xF7F7 #xE112) + (#xF7F6 #xE111) + (#xF7F5 #xE110) + (#xF7F4 #xE10F) + (#xF7F3 #xE10E) + (#xF7F2 #xE10D) + (#xF7F1 #xE10C) + (#xF7F0 #xE10B) + (#xF7EF #xE10A) + (#xF7EE #xE109) + (#xF7ED #xE108) + (#xF7EC #xE107) + (#xF7EB #xE106) + (#xF7EA #xE105) + (#xF7E9 #xE104) + (#xF7E8 #xE103) + (#xF7E7 #xE102) + (#xF7E6 #xE101) + (#xF7E5 #xE100) + (#xF7E4 #xE0FF) + (#xF7E3 #xE0FE) + (#xF7E2 #xE0FD) + (#xF7E1 #xE0FC) + (#xF7E0 #xE0FB) + (#xF7DF #xE0FA) + (#xF7DE #xE0F9) + (#xF7DD #xE0F8) + (#xF7DC #xE0F7) + (#xF7DB #xE0F6) + (#xF7DA #xE0F5) + (#xF7D9 #xE0F4) + (#xF7D8 #xE0F3) + (#xF7D7 #xE0F2) + (#xF7D6 #xE0F1) + (#xF7D5 #xE0F0) + (#xF7D4 #xE0EF) + (#xF7D3 #xE0EE) + (#xF7D2 #xE0ED) + (#xF7D1 #xE0EC) + (#xF7D0 #xE0EB) + (#xF7CF #xE0EA) + (#xF7CE #xE0E9) + (#xF7CD #xE0E8) + (#xF7CC #xE0E7) + (#xF7CB #xE0E6) + (#xF7CA #xE0E5) + (#xF7C9 #xE0E4) + (#xF7C8 #xE0E3) + (#xF7C7 #xE0E2) + (#xF7C6 #xE0E1) + (#xF7C5 #xE0E0) + (#xF7C4 #xE0DF) + (#xF7C3 #xE0DE) + (#xF7C2 #xE0DD) + (#xF7C1 #xE0DC) + (#xF7C0 #xE0DB) + (#xF7BF #xE0DA) + (#xF7BE #xE0D9) + (#xF7BD #xE0D8) + (#xF7BC #xE0D7) + (#xF7BB #xE0D6) + (#xF7BA #xE0D5) + (#xF7B9 #xE0D4) + (#xF7B8 #xE0D3) + (#xF7B7 #xE0D2) + (#xF7B6 #xE0D1) + (#xF7B5 #xE0D0) + (#xF7B4 #xE0CF) + (#xF7B3 #xE0CE) + (#xF7B2 #xE0CD) + (#xF7B1 #xE0CC) + (#xF7B0 #xE0CB) + (#xF7AF #xE0CA) + (#xF7AE #xE0C9) + (#xF7AD #xE0C8) + (#xF7AC #xE0C7) + (#xF7AB #xE0C6) + (#xF7AA #xE0C5) + (#xF7A9 #xE0C4) + (#xF7A8 #xE0C3) + (#xF7A7 #xE0C2) + (#xF7A6 #xE0C1) + (#xF7A5 #xE0C0) + (#xF7A4 #xE0BF) + (#xF7A3 #xE0BE) + (#xF7A2 #xE0BD) + (#xF7A1 #xE0BC) + (#xF6FE #xE0BB) + (#xF6FD #xE0BA) + (#xF6FC #xE0B9) + (#xF6FB #xE0B8) + (#xF6FA #xE0B7) + (#xF6F9 #xE0B6) + (#xF6F8 #xE0B5) + (#xF6F7 #xE0B4) + (#xF6F6 #xE0B3) + (#xF6F5 #xE0B2) + (#xF6F4 #xE0B1) + (#xF6F3 #xE0B0) + (#xF6F2 #xE0AF) + (#xF6F1 #xE0AE) + (#xF6F0 #xE0AD) + (#xF6EF #xE0AC) + (#xF6EE #xE0AB) + (#xF6ED #xE0AA) + (#xF6EC #xE0A9) + (#xF6EB #xE0A8) + (#xF6EA #xE0A7) + (#xF6E9 #xE0A6) + (#xF6E8 #xE0A5) + (#xF6E7 #xE0A4) + (#xF6E6 #xE0A3) + (#xF6E5 #xE0A2) + (#xF6E4 #xE0A1) + (#xF6E3 #xE0A0) + (#xF6E2 #xE09F) + (#xF6E1 #xE09E) + (#xF6E0 #xE09D) + (#xF6DF #xE09C) + (#xF6DE #xE09B) + (#xF6DD #xE09A) + (#xF6DC #xE099) + (#xF6DB #xE098) + (#xF6DA #xE097) + (#xF6D9 #xE096) + (#xF6D8 #xE095) + (#xF6D7 #xE094) + (#xF6D6 #xE093) + (#xF6D5 #xE092) + (#xF6D4 #xE091) + (#xF6D3 #xE090) + (#xF6D2 #xE08F) + (#xF6D1 #xE08E) + (#xF6D0 #xE08D) + (#xF6CF #xE08C) + (#xF6CE #xE08B) + (#xF6CD #xE08A) + (#xF6CC #xE089) + (#xF6CB #xE088) + (#xF6CA #xE087) + (#xF6C9 #xE086) + (#xF6C8 #xE085) + (#xF6C7 #xE084) + (#xF6C6 #xE083) + (#xF6C5 #xE082) + (#xF6C4 #xE081) + (#xF6C3 #xE080) + (#xF6C2 #xE07F) + (#xF6C1 #xE07E) + (#xF6C0 #xE07D) + (#xF6BF #xE07C) + (#xF6BE #xE07B) + (#xF6BD #xE07A) + (#xF6BC #xE079) + (#xF6BB #xE078) + (#xF6BA #xE077) + (#xF6B9 #xE076) + (#xF6B8 #xE075) + (#xF6B7 #xE074) + (#xF6B6 #xE073) + (#xF6B5 #xE072) + (#xF6B4 #xE071) + (#xF6B3 #xE070) + (#xF6B2 #xE06F) + (#xF6B1 #xE06E) + (#xF6B0 #xE06D) + (#xF6AF #xE06C) + (#xF6AE #xE06B) + (#xF6AD #xE06A) + (#xF6AC #xE069) + (#xF6AB #xE068) + (#xF6AA #xE067) + (#xF6A9 #xE066) + (#xF6A8 #xE065) + (#xF6A7 #xE064) + (#xF6A6 #xE063) + (#xF6A5 #xE062) + (#xF6A4 #xE061) + (#xF6A3 #xE060) + (#xF6A2 #xE05F) + (#xF6A1 #xE05E) + (#xF5FE #xE05D) + (#xF5FD #xE05C) + (#xF5FC #xE05B) + (#xF5FB #xE05A) + (#xF5FA #xE059) + (#xF5F9 #xE058) + (#xF5F8 #xE057) + (#xF5F7 #xE056) + (#xF5F6 #xE055) + (#xF5F5 #xE054) + (#xF5F4 #xE053) + (#xF5F3 #xE052) + (#xF5F2 #xE051) + (#xF5F1 #xE050) + (#xF5F0 #xE04F) + (#xF5EF #xE04E) + (#xF5EE #xE04D) + (#xF5ED #xE04C) + (#xF5EC #xE04B) + (#xF5EB #xE04A) + (#xF5EA #xE049) + (#xF5E9 #xE048) + (#xF5E8 #xE047) + (#xF5E7 #xE046) + (#xF5E6 #xE045) + (#xF5E5 #xE044) + (#xF5E4 #xE043) + (#xF5E3 #xE042) + (#xF5E2 #xE041) + (#xF5E1 #xE040) + (#xF5E0 #xE03F) + (#xF5DF #xE03E) + (#xF5DE #xE03D) + (#xF5DD #xE03C) + (#xF5DC #xE03B) + (#xF5DB #xE03A) + (#xF5DA #xE039) + (#xF5D9 #xE038) + (#xF5D8 #xE037) + (#xF5D7 #xE036) + (#xF5D6 #xE035) + (#xF5D5 #xE034) + (#xF5D4 #xE033) + (#xF5D3 #xE032) + (#xF5D2 #xE031) + (#xF5D1 #xE030) + (#xF5D0 #xE02F) + (#xF5CF #xE02E) + (#xF5CE #xE02D) + (#xF5CD #xE02C) + (#xF5CC #xE02B) + (#xF5CB #xE02A) + (#xF5CA #xE029) + (#xF5C9 #xE028) + (#xF5C8 #xE027) + (#xF5C7 #xE026) + (#xF5C6 #xE025) + (#xF5C5 #xE024) + (#xF5C4 #xE023) + (#xF5C3 #xE022) + (#xF5C2 #xE021) + (#xF5C1 #xE020) + (#xF5C0 #xE01F) + (#xF5BF #xE01E) + (#xF5BE #xE01D) + (#xF5BD #xE01C) + (#xF5BC #xE01B) + (#xF5BB #xE01A) + (#xF5BA #xE019) + (#xF5B9 #xE018) + (#xF5B8 #xE017) + (#xF5B7 #xE016) + (#xF5B6 #xE015) + (#xF5B5 #xE014) + (#xF5B4 #xE013) + (#xF5B3 #xE012) + (#xF5B2 #xE011) + (#xF5B1 #xE010) + (#xF5B0 #xE00F) + (#xF5AF #xE00E) + (#xF5AE #xE00D) + (#xF5AD #xE00C) + (#xF5AC #xE00B) + (#xF5AB #xE00A) + (#xF5AA #xE009) + (#xF5A9 #xE008) + (#xF5A8 #xE007) + (#xF5A7 #xE006) + (#xF5A6 #xE005) + (#xF5A5 #xE004) + (#xF5A4 #xE003) + (#xF5A3 #xE002) + (#xF5A2 #xE001) + (#xF5A1 #xE000) + )) + (eucjp '((#x8FA2AF #x2D8) + (#x8FA2B0 #x2C7) + (#x8FA2B1 #xB8) + (#x8FA2B2 #x2D9) + (#x8FA2B3 #x2DD) + (#x8FA2B4 #xAF) + (#x8FA2B5 #x2DB) + (#x8FA2B6 #x2DA) + (#x8FA2B7 #xFF5E) + (#x8FA2B8 #x384) + (#x8FA2B9 #x385) + (#x8FA2C2 #xA1) + (#x8FA2C3 #xA6) + (#x8FA2C4 #xBF) + (#x8FA2EB #xBA) + (#x8FA2EC #xAA) + (#x8FA2ED #xA9) + (#x8FA2EE #xAE) + (#x8FA2EF #x2122) + (#x8FA2F0 #xA4) + (#x8FA2F1 #x2116) + (#x8FA6E1 #x386) + (#x8FA6E2 #x388) + (#x8FA6E3 #x389) + (#x8FA6E4 #x38A) + (#x8FA6E5 #x3AA) + (#x8FA6E7 #x38C) + (#x8FA6E9 #x38E) + (#x8FA6EA #x3AB) + (#x8FA6EC #x38F) + (#x8FA6F1 #x3AC) + (#x8FA6F2 #x3AD) + (#x8FA6F3 #x3AE) + (#x8FA6F4 #x3AF) + (#x8FA6F5 #x3CA) + (#x8FA6F6 #x390) + (#x8FA6F7 #x3CC) + (#x8FA6F8 #x3C2) + (#x8FA6F9 #x3CD) + (#x8FA6FA #x3CB) + (#x8FA6FB #x3B0) + (#x8FA6FC #x3CE) + (#x8FA7C2 #x402) + (#x8FA7C3 #x403) + (#x8FA7C4 #x404) + (#x8FA7C5 #x405) + (#x8FA7C6 #x406) + (#x8FA7C7 #x407) + (#x8FA7C8 #x408) + (#x8FA7C9 #x409) + (#x8FA7CA #x40A) + (#x8FA7CB #x40B) + (#x8FA7CC #x40C) + (#x8FA7CD #x40E) + (#x8FA7CE #x40F) + (#x8FA7F2 #x452) + (#x8FA7F3 #x453) + (#x8FA7F4 #x454) + (#x8FA7F5 #x455) + (#x8FA7F6 #x456) + (#x8FA7F7 #x457) + (#x8FA7F8 #x458) + (#x8FA7F9 #x459) + (#x8FA7FA #x45A) + (#x8FA7FB #x45B) + (#x8FA7FC #x45C) + (#x8FA7FD #x45E) + (#x8FA7FE #x45F) + (#x8FA9A1 #xC6) + (#x8FA9A2 #x110) + (#x8FA9A4 #x126) + (#x8FA9A6 #x132) + (#x8FA9A8 #x141) + (#x8FA9A9 #x13F) + (#x8FA9AB #x14A) + (#x8FA9AC #xD8) + (#x8FA9AD #x152) + (#x8FA9AF #x166) + (#x8FA9B0 #xDE) + (#x8FA9C1 #xE6) + (#x8FA9C2 #x111) + (#x8FA9C3 #xF0) + (#x8FA9C4 #x127) + (#x8FA9C5 #x131) + (#x8FA9C6 #x133) + (#x8FA9C7 #x138) + (#x8FA9C8 #x142) + (#x8FA9C9 #x140) + (#x8FA9CA #x149) + (#x8FA9CB #x14B) + (#x8FA9CC #xF8) + (#x8FA9CD #x153) + (#x8FA9CE #xDF) + (#x8FA9CF #x167) + (#x8FA9D0 #xFE) + (#x8FAAA1 #xC1) + (#x8FAAA2 #xC0) + (#x8FAAA3 #xC4) + (#x8FAAA4 #xC2) + (#x8FAAA5 #x102) + (#x8FAAA6 #x1CD) + (#x8FAAA7 #x100) + (#x8FAAA8 #x104) + (#x8FAAA9 #xC5) + (#x8FAAAA #xC3) + (#x8FAAAB #x106) + (#x8FAAAC #x108) + (#x8FAAAD #x10C) + (#x8FAAAE #xC7) + (#x8FAAAF #x10A) + (#x8FAAB0 #x10E) + (#x8FAAB1 #xC9) + (#x8FAAB2 #xC8) + (#x8FAAB3 #xCB) + (#x8FAAB4 #xCA) + (#x8FAAB5 #x11A) + (#x8FAAB6 #x116) + (#x8FAAB7 #x112) + (#x8FAAB8 #x118) + (#x8FAABA #x11C) + (#x8FAABB #x11E) + (#x8FAABC #x122) + (#x8FAABD #x120) + (#x8FAABE #x124) + (#x8FAABF #xCD) + (#x8FAAC0 #xCC) + (#x8FAAC1 #xCF) + (#x8FAAC2 #xCE) + (#x8FAAC3 #x1CF) + (#x8FAAC4 #x130) + (#x8FAAC5 #x12A) + (#x8FAAC6 #x12E) + (#x8FAAC7 #x128) + (#x8FAAC8 #x134) + (#x8FAAC9 #x136) + (#x8FAACA #x139) + (#x8FAACB #x13D) + (#x8FAACC #x13B) + (#x8FAACD #x143) + (#x8FAACE #x147) + (#x8FAACF #x145) + (#x8FAAD0 #xD1) + (#x8FAAD1 #xD3) + (#x8FAAD2 #xD2) + (#x8FAAD3 #xD6) + (#x8FAAD4 #xD4) + (#x8FAAD5 #x1D1) + (#x8FAAD6 #x150) + (#x8FAAD7 #x14C) + (#x8FAAD8 #xD5) + (#x8FAAD9 #x154) + (#x8FAADA #x158) + (#x8FAADB #x156) + (#x8FAADC #x15A) + (#x8FAADD #x15C) + (#x8FAADE #x160) + (#x8FAADF #x15E) + (#x8FAAE0 #x164) + (#x8FAAE1 #x162) + (#x8FAAE2 #xDA) + (#x8FAAE3 #xD9) + (#x8FAAE4 #xDC) + (#x8FAAE5 #xDB) + (#x8FAAE6 #x16C) + (#x8FAAE7 #x1D3) + (#x8FAAE8 #x170) + (#x8FAAE9 #x16A) + (#x8FAAEA #x172) + (#x8FAAEB #x16E) + (#x8FAAEC #x168) + (#x8FAAED #x1D7) + (#x8FAAEE #x1DB) + (#x8FAAEF #x1D9) + (#x8FAAF0 #x1D5) + (#x8FAAF1 #x174) + (#x8FAAF2 #xDD) + (#x8FAAF3 #x178) + (#x8FAAF4 #x176) + (#x8FAAF5 #x179) + (#x8FAAF6 #x17D) + (#x8FAAF7 #x17B) + (#x8FABA1 #xE1) + (#x8FABA2 #xE0) + (#x8FABA3 #xE4) + (#x8FABA4 #xE2) + (#x8FABA5 #x103) + (#x8FABA6 #x1CE) + (#x8FABA7 #x101) + (#x8FABA8 #x105) + (#x8FABA9 #xE5) + (#x8FABAA #xE3) + (#x8FABAB #x107) + (#x8FABAC #x109) + (#x8FABAD #x10D) + (#x8FABAE #xE7) + (#x8FABAF #x10B) + (#x8FABB0 #x10F) + (#x8FABB1 #xE9) + (#x8FABB2 #xE8) + (#x8FABB3 #xEB) + (#x8FABB4 #xEA) + (#x8FABB5 #x11B) + (#x8FABB6 #x117) + (#x8FABB7 #x113) + (#x8FABB8 #x119) + (#x8FABB9 #x1F5) + (#x8FABBA #x11D) + (#x8FABBB #x11F) + (#x8FABBD #x121) + (#x8FABBE #x125) + (#x8FABBF #xED) + (#x8FABC0 #xEC) + (#x8FABC1 #xEF) + (#x8FABC2 #xEE) + (#x8FABC3 #x1D0) + (#x8FABC5 #x12B) + (#x8FABC6 #x12F) + (#x8FABC7 #x129) + (#x8FABC8 #x135) + (#x8FABC9 #x137) + (#x8FABCA #x13A) + (#x8FABCB #x13E) + (#x8FABCC #x13C) + (#x8FABCD #x144) + (#x8FABCE #x148) + (#x8FABCF #x146) + (#x8FABD0 #xF1) + (#x8FABD1 #xF3) + (#x8FABD2 #xF2) + (#x8FABD3 #xF6) + (#x8FABD4 #xF4) + (#x8FABD5 #x1D2) + (#x8FABD6 #x151) + (#x8FABD7 #x14D) + (#x8FABD8 #xF5) + (#x8FABD9 #x155) + (#x8FABDA #x159) + (#x8FABDB #x157) + (#x8FABDC #x15B) + (#x8FABDD #x15D) + (#x8FABDE #x161) + (#x8FABDF #x15F) + (#x8FABE0 #x165) + (#x8FABE1 #x163) + (#x8FABE2 #xFA) + (#x8FABE3 #xF9) + (#x8FABE4 #xFC) + (#x8FABE5 #xFB) + (#x8FABE6 #x16D) + (#x8FABE7 #x1D4) + (#x8FABE8 #x171) + (#x8FABE9 #x16B) + (#x8FABEA #x173) + (#x8FABEB #x16F) + (#x8FABEC #x169) + (#x8FABED #x1D8) + (#x8FABEE #x1DC) + (#x8FABEF #x1DA) + (#x8FABF0 #x1D6) + (#x8FABF1 #x175) + (#x8FABF2 #xFD) + (#x8FABF3 #xFF) + (#x8FABF4 #x177) + (#x8FABF5 #x17A) + (#x8FABF6 #x17E) + (#x8FABF7 #x17C) + (#x8FB0A1 #x4E02) + (#x8FB0A2 #x4E04) + (#x8FB0A3 #x4E05) + (#x8FB0A4 #x4E0C) + (#x8FB0A5 #x4E12) + (#x8FB0A6 #x4E1F) + (#x8FB0A7 #x4E23) + (#x8FB0A8 #x4E24) + (#x8FB0A9 #x4E28) + (#x8FB0AA #x4E2B) + (#x8FB0AB #x4E2E) + (#x8FB0AC #x4E2F) + (#x8FB0AD #x4E30) + (#x8FB0AE #x4E35) + (#x8FB0AF #x4E40) + (#x8FB0B0 #x4E41) + (#x8FB0B1 #x4E44) + (#x8FB0B2 #x4E47) + (#x8FB0B3 #x4E51) + (#x8FB0B4 #x4E5A) + (#x8FB0B5 #x4E5C) + (#x8FB0B6 #x4E63) + (#x8FB0B7 #x4E68) + (#x8FB0B8 #x4E69) + (#x8FB0B9 #x4E74) + (#x8FB0BA #x4E75) + (#x8FB0BB #x4E79) + (#x8FB0BC #x4E7F) + (#x8FB0BD #x4E8D) + (#x8FB0BE #x4E96) + (#x8FB0BF #x4E97) + (#x8FB0C0 #x4E9D) + (#x8FB0C1 #x4EAF) + (#x8FB0C2 #x4EB9) + (#x8FB0C3 #x4EC3) + (#x8FB0C4 #x4ED0) + (#x8FB0C5 #x4EDA) + (#x8FB0C6 #x4EDB) + (#x8FB0C7 #x4EE0) + (#x8FB0C8 #x4EE1) + (#x8FB0C9 #x4EE2) + (#x8FB0CA #x4EE8) + (#x8FB0CB #x4EEF) + (#x8FB0CC #x4EF1) + (#x8FB0CD #x4EF3) + (#x8FB0CE #x4EF5) + (#x8FB0CF #x4EFD) + (#x8FB0D0 #x4EFE) + (#x8FB0D1 #x4EFF) + (#x8FB0D2 #x4F00) + (#x8FB0D3 #x4F02) + (#x8FB0D4 #x4F03) + (#x8FB0D5 #x4F08) + (#x8FB0D6 #x4F0B) + (#x8FB0D7 #x4F0C) + (#x8FB0D8 #x4F12) + (#x8FB0D9 #x4F15) + (#x8FB0DA #x4F16) + (#x8FB0DB #x4F17) + (#x8FB0DC #x4F19) + (#x8FB0DD #x4F2E) + (#x8FB0DE #x4F31) + (#x8FB0DF #x4F60) + (#x8FB0E0 #x4F33) + (#x8FB0E1 #x4F35) + (#x8FB0E2 #x4F37) + (#x8FB0E3 #x4F39) + (#x8FB0E4 #x4F3B) + (#x8FB0E5 #x4F3E) + (#x8FB0E6 #x4F40) + (#x8FB0E7 #x4F42) + (#x8FB0E8 #x4F48) + (#x8FB0E9 #x4F49) + (#x8FB0EA #x4F4B) + (#x8FB0EB #x4F4C) + (#x8FB0EC #x4F52) + (#x8FB0ED #x4F54) + (#x8FB0EE #x4F56) + (#x8FB0EF #x4F58) + (#x8FB0F0 #x4F5F) + (#x8FB0F1 #x4F63) + (#x8FB0F2 #x4F6A) + (#x8FB0F3 #x4F6C) + (#x8FB0F4 #x4F6E) + (#x8FB0F5 #x4F71) + (#x8FB0F6 #x4F77) + (#x8FB0F7 #x4F78) + (#x8FB0F8 #x4F79) + (#x8FB0F9 #x4F7A) + (#x8FB0FA #x4F7D) + (#x8FB0FB #x4F7E) + (#x8FB0FC #x4F81) + (#x8FB0FD #x4F82) + (#x8FB0FE #x4F84) + (#x8FB1A1 #x4F85) + (#x8FB1A2 #x4F89) + (#x8FB1A3 #x4F8A) + (#x8FB1A4 #x4F8C) + (#x8FB1A5 #x4F8E) + (#x8FB1A6 #x4F90) + (#x8FB1A7 #x4F92) + (#x8FB1A8 #x4F93) + (#x8FB1A9 #x4F94) + (#x8FB1AA #x4F97) + (#x8FB1AB #x4F99) + (#x8FB1AC #x4F9A) + (#x8FB1AD #x4F9E) + (#x8FB1AE #x4F9F) + (#x8FB1AF #x4FB2) + (#x8FB1B0 #x4FB7) + (#x8FB1B1 #x4FB9) + (#x8FB1B2 #x4FBB) + (#x8FB1B3 #x4FBC) + (#x8FB1B4 #x4FBD) + (#x8FB1B5 #x4FBE) + (#x8FB1B6 #x4FC0) + (#x8FB1B7 #x4FC1) + (#x8FB1B8 #x4FC5) + (#x8FB1B9 #x4FC6) + (#x8FB1BA #x4FC8) + (#x8FB1BB #x4FC9) + (#x8FB1BC #x4FCB) + (#x8FB1BD #x4FCC) + (#x8FB1BE #x4FCD) + (#x8FB1BF #x4FCF) + (#x8FB1C0 #x4FD2) + (#x8FB1C1 #x4FDC) + (#x8FB1C2 #x4FE0) + (#x8FB1C3 #x4FE2) + (#x8FB1C4 #x4FF0) + (#x8FB1C5 #x4FF2) + (#x8FB1C6 #x4FFC) + (#x8FB1C7 #x4FFD) + (#x8FB1C8 #x4FFF) + (#x8FB1C9 #x5000) + (#x8FB1CA #x5001) + (#x8FB1CB #x5004) + (#x8FB1CC #x5007) + (#x8FB1CD #x500A) + (#x8FB1CE #x500C) + (#x8FB1CF #x500E) + (#x8FB1D0 #x5010) + (#x8FB1D1 #x5013) + (#x8FB1D2 #x5017) + (#x8FB1D3 #x5018) + (#x8FB1D4 #x501B) + (#x8FB1D5 #x501C) + (#x8FB1D6 #x501D) + (#x8FB1D7 #x501E) + (#x8FB1D8 #x5022) + (#x8FB1D9 #x5027) + (#x8FB1DA #x502E) + (#x8FB1DB #x5030) + (#x8FB1DC #x5032) + (#x8FB1DD #x5033) + (#x8FB1DE #x5035) + (#x8FB1DF #x5040) + (#x8FB1E0 #x5041) + (#x8FB1E1 #x5042) + (#x8FB1E2 #x5045) + (#x8FB1E3 #x5046) + (#x8FB1E4 #x504A) + (#x8FB1E5 #x504C) + (#x8FB1E6 #x504E) + (#x8FB1E7 #x5051) + (#x8FB1E8 #x5052) + (#x8FB1E9 #x5053) + (#x8FB1EA #x5057) + (#x8FB1EB #x5059) + (#x8FB1EC #x505F) + (#x8FB1ED #x5060) + (#x8FB1EE #x5062) + (#x8FB1EF #x5063) + (#x8FB1F0 #x5066) + (#x8FB1F1 #x5067) + (#x8FB1F2 #x506A) + (#x8FB1F3 #x506D) + (#x8FB1F4 #x5070) + (#x8FB1F5 #x5071) + (#x8FB1F6 #x503B) + (#x8FB1F7 #x5081) + (#x8FB1F8 #x5083) + (#x8FB1F9 #x5084) + (#x8FB1FA #x5086) + (#x8FB1FB #x508A) + (#x8FB1FC #x508E) + (#x8FB1FD #x508F) + (#x8FB1FE #x5090) + (#x8FB2A1 #x5092) + (#x8FB2A2 #x5093) + (#x8FB2A3 #x5094) + (#x8FB2A4 #x5096) + (#x8FB2A5 #x509B) + (#x8FB2A6 #x509C) + (#x8FB2A7 #x509E) + (#x8FB2A8 #x509F) + (#x8FB2A9 #x50A0) + (#x8FB2AA #x50A1) + (#x8FB2AB #x50A2) + (#x8FB2AC #x50AA) + (#x8FB2AD #x50AF) + (#x8FB2AE #x50B0) + (#x8FB2AF #x50B9) + (#x8FB2B0 #x50BA) + (#x8FB2B1 #x50BD) + (#x8FB2B2 #x50C0) + (#x8FB2B3 #x50C3) + (#x8FB2B4 #x50C4) + (#x8FB2B5 #x50C7) + (#x8FB2B6 #x50CC) + (#x8FB2B7 #x50CE) + (#x8FB2B8 #x50D0) + (#x8FB2B9 #x50D3) + (#x8FB2BA #x50D4) + (#x8FB2BB #x50D8) + (#x8FB2BC #x50DC) + (#x8FB2BD #x50DD) + (#x8FB2BE #x50DF) + (#x8FB2BF #x50E2) + (#x8FB2C0 #x50E4) + (#x8FB2C1 #x50E6) + (#x8FB2C2 #x50E8) + (#x8FB2C3 #x50E9) + (#x8FB2C4 #x50EF) + (#x8FB2C5 #x50F1) + (#x8FB2C6 #x50F6) + (#x8FB2C7 #x50FA) + (#x8FB2C8 #x50FE) + (#x8FB2C9 #x5103) + (#x8FB2CA #x5106) + (#x8FB2CB #x5107) + (#x8FB2CC #x5108) + (#x8FB2CD #x510B) + (#x8FB2CE #x510C) + (#x8FB2CF #x510D) + (#x8FB2D0 #x510E) + (#x8FB2D1 #x50F2) + (#x8FB2D2 #x5110) + (#x8FB2D3 #x5117) + (#x8FB2D4 #x5119) + (#x8FB2D5 #x511B) + (#x8FB2D6 #x511C) + (#x8FB2D7 #x511D) + (#x8FB2D8 #x511E) + (#x8FB2D9 #x5123) + (#x8FB2DA #x5127) + (#x8FB2DB #x5128) + (#x8FB2DC #x512C) + (#x8FB2DD #x512D) + (#x8FB2DE #x512F) + (#x8FB2DF #x5131) + (#x8FB2E0 #x5133) + (#x8FB2E1 #x5134) + (#x8FB2E2 #x5135) + (#x8FB2E3 #x5138) + (#x8FB2E4 #x5139) + (#x8FB2E5 #x5142) + (#x8FB2E6 #x514A) + (#x8FB2E7 #x514F) + (#x8FB2E8 #x5153) + (#x8FB2E9 #x5155) + (#x8FB2EA #x5157) + (#x8FB2EB #x5158) + (#x8FB2EC #x515F) + (#x8FB2ED #x5164) + (#x8FB2EE #x5166) + (#x8FB2EF #x517E) + (#x8FB2F0 #x5183) + (#x8FB2F1 #x5184) + (#x8FB2F2 #x518B) + (#x8FB2F3 #x518E) + (#x8FB2F4 #x5198) + (#x8FB2F5 #x519D) + (#x8FB2F6 #x51A1) + (#x8FB2F7 #x51A3) + (#x8FB2F8 #x51AD) + (#x8FB2F9 #x51B8) + (#x8FB2FA #x51BA) + (#x8FB2FB #x51BC) + (#x8FB2FC #x51BE) + (#x8FB2FD #x51BF) + (#x8FB2FE #x51C2) + (#x8FB3A1 #x51C8) + (#x8FB3A2 #x51CF) + (#x8FB3A3 #x51D1) + (#x8FB3A4 #x51D2) + (#x8FB3A5 #x51D3) + (#x8FB3A6 #x51D5) + (#x8FB3A7 #x51D8) + (#x8FB3A8 #x51DE) + (#x8FB3A9 #x51E2) + (#x8FB3AA #x51E5) + (#x8FB3AB #x51EE) + (#x8FB3AC #x51F2) + (#x8FB3AD #x51F3) + (#x8FB3AE #x51F4) + (#x8FB3AF #x51F7) + (#x8FB3B0 #x5201) + (#x8FB3B1 #x5202) + (#x8FB3B2 #x5205) + (#x8FB3B3 #x5212) + (#x8FB3B4 #x5213) + (#x8FB3B5 #x5215) + (#x8FB3B6 #x5216) + (#x8FB3B7 #x5218) + (#x8FB3B8 #x5222) + (#x8FB3B9 #x5228) + (#x8FB3BA #x5231) + (#x8FB3BB #x5232) + (#x8FB3BC #x5235) + (#x8FB3BD #x523C) + (#x8FB3BE #x5245) + (#x8FB3BF #x5249) + (#x8FB3C0 #x5255) + (#x8FB3C1 #x5257) + (#x8FB3C2 #x5258) + (#x8FB3C3 #x525A) + (#x8FB3C4 #x525C) + (#x8FB3C5 #x525F) + (#x8FB3C6 #x5260) + (#x8FB3C7 #x5261) + (#x8FB3C8 #x5266) + (#x8FB3C9 #x526E) + (#x8FB3CA #x5277) + (#x8FB3CB #x5278) + (#x8FB3CC #x5279) + (#x8FB3CD #x5280) + (#x8FB3CE #x5282) + (#x8FB3CF #x5285) + (#x8FB3D0 #x528A) + (#x8FB3D1 #x528C) + (#x8FB3D2 #x5293) + (#x8FB3D3 #x5295) + (#x8FB3D4 #x5296) + (#x8FB3D5 #x5297) + (#x8FB3D6 #x5298) + (#x8FB3D7 #x529A) + (#x8FB3D8 #x529C) + (#x8FB3D9 #x52A4) + (#x8FB3DA #x52A5) + (#x8FB3DB #x52A6) + (#x8FB3DC #x52A7) + (#x8FB3DD #x52AF) + (#x8FB3DE #x52B0) + (#x8FB3DF #x52B6) + (#x8FB3E0 #x52B7) + (#x8FB3E1 #x52B8) + (#x8FB3E2 #x52BA) + (#x8FB3E3 #x52BB) + (#x8FB3E4 #x52BD) + (#x8FB3E5 #x52C0) + (#x8FB3E6 #x52C4) + (#x8FB3E7 #x52C6) + (#x8FB3E8 #x52C8) + (#x8FB3E9 #x52CC) + (#x8FB3EA #x52CF) + (#x8FB3EB #x52D1) + (#x8FB3EC #x52D4) + (#x8FB3ED #x52D6) + (#x8FB3EE #x52DB) + (#x8FB3EF #x52DC) + (#x8FB3F0 #x52E1) + (#x8FB3F1 #x52E5) + (#x8FB3F2 #x52E8) + (#x8FB3F3 #x52E9) + (#x8FB3F4 #x52EA) + (#x8FB3F5 #x52EC) + (#x8FB3F6 #x52F0) + (#x8FB3F7 #x52F1) + (#x8FB3F8 #x52F4) + (#x8FB3F9 #x52F6) + (#x8FB3FA #x52F7) + (#x8FB3FB #x5300) + (#x8FB3FC #x5303) + (#x8FB3FD #x530A) + (#x8FB3FE #x530B) + (#x8FB4A1 #x530C) + (#x8FB4A2 #x5311) + (#x8FB4A3 #x5313) + (#x8FB4A4 #x5318) + (#x8FB4A5 #x531B) + (#x8FB4A6 #x531C) + (#x8FB4A7 #x531E) + (#x8FB4A8 #x531F) + (#x8FB4A9 #x5325) + (#x8FB4AA #x5327) + (#x8FB4AB #x5328) + (#x8FB4AC #x5329) + (#x8FB4AD #x532B) + (#x8FB4AE #x532C) + (#x8FB4AF #x532D) + (#x8FB4B0 #x5330) + (#x8FB4B1 #x5332) + (#x8FB4B2 #x5335) + (#x8FB4B3 #x533C) + (#x8FB4B4 #x533D) + (#x8FB4B5 #x533E) + (#x8FB4B6 #x5342) + (#x8FB4B7 #x534C) + (#x8FB4B8 #x534B) + (#x8FB4B9 #x5359) + (#x8FB4BA #x535B) + (#x8FB4BB #x5361) + (#x8FB4BC #x5363) + (#x8FB4BD #x5365) + (#x8FB4BE #x536C) + (#x8FB4BF #x536D) + (#x8FB4C0 #x5372) + (#x8FB4C1 #x5379) + (#x8FB4C2 #x537E) + (#x8FB4C3 #x5383) + (#x8FB4C4 #x5387) + (#x8FB4C5 #x5388) + (#x8FB4C6 #x538E) + (#x8FB4C7 #x5393) + (#x8FB4C8 #x5394) + (#x8FB4C9 #x5399) + (#x8FB4CA #x539D) + (#x8FB4CB #x53A1) + (#x8FB4CC #x53A4) + (#x8FB4CD #x53AA) + (#x8FB4CE #x53AB) + (#x8FB4CF #x53AF) + (#x8FB4D0 #x53B2) + (#x8FB4D1 #x53B4) + (#x8FB4D2 #x53B5) + (#x8FB4D3 #x53B7) + (#x8FB4D4 #x53B8) + (#x8FB4D5 #x53BA) + (#x8FB4D6 #x53BD) + (#x8FB4D7 #x53C0) + (#x8FB4D8 #x53C5) + (#x8FB4D9 #x53CF) + (#x8FB4DA #x53D2) + (#x8FB4DB #x53D3) + (#x8FB4DC #x53D5) + (#x8FB4DD #x53DA) + (#x8FB4DE #x53DD) + (#x8FB4DF #x53DE) + (#x8FB4E0 #x53E0) + (#x8FB4E1 #x53E6) + (#x8FB4E2 #x53E7) + (#x8FB4E3 #x53F5) + (#x8FB4E4 #x5402) + (#x8FB4E5 #x5413) + (#x8FB4E6 #x541A) + (#x8FB4E7 #x5421) + (#x8FB4E8 #x5427) + (#x8FB4E9 #x5428) + (#x8FB4EA #x542A) + (#x8FB4EB #x542F) + (#x8FB4EC #x5431) + (#x8FB4ED #x5434) + (#x8FB4EE #x5435) + (#x8FB4EF #x5443) + (#x8FB4F0 #x5444) + (#x8FB4F1 #x5447) + (#x8FB4F2 #x544D) + (#x8FB4F3 #x544F) + (#x8FB4F4 #x545E) + (#x8FB4F5 #x5462) + (#x8FB4F6 #x5464) + (#x8FB4F7 #x5466) + (#x8FB4F8 #x5467) + (#x8FB4F9 #x5469) + (#x8FB4FA #x546B) + (#x8FB4FB #x546D) + (#x8FB4FC #x546E) + (#x8FB4FD #x5474) + (#x8FB4FE #x547F) + (#x8FB5A1 #x5481) + (#x8FB5A2 #x5483) + (#x8FB5A3 #x5485) + (#x8FB5A4 #x5488) + (#x8FB5A5 #x5489) + (#x8FB5A6 #x548D) + (#x8FB5A7 #x5491) + (#x8FB5A8 #x5495) + (#x8FB5A9 #x5496) + (#x8FB5AA #x549C) + (#x8FB5AB #x549F) + (#x8FB5AC #x54A1) + (#x8FB5AD #x54A6) + (#x8FB5AE #x54A7) + (#x8FB5AF #x54A9) + (#x8FB5B0 #x54AA) + (#x8FB5B1 #x54AD) + (#x8FB5B2 #x54AE) + (#x8FB5B3 #x54B1) + (#x8FB5B4 #x54B7) + (#x8FB5B5 #x54B9) + (#x8FB5B6 #x54BA) + (#x8FB5B7 #x54BB) + (#x8FB5B8 #x54BF) + (#x8FB5B9 #x54C6) + (#x8FB5BA #x54CA) + (#x8FB5BB #x54CD) + (#x8FB5BC #x54CE) + (#x8FB5BD #x54E0) + (#x8FB5BE #x54EA) + (#x8FB5BF #x54EC) + (#x8FB5C0 #x54EF) + (#x8FB5C1 #x54F6) + (#x8FB5C2 #x54FC) + (#x8FB5C3 #x54FE) + (#x8FB5C4 #x54FF) + (#x8FB5C5 #x5500) + (#x8FB5C6 #x5501) + (#x8FB5C7 #x5505) + (#x8FB5C8 #x5508) + (#x8FB5C9 #x5509) + (#x8FB5CA #x550C) + (#x8FB5CB #x550D) + (#x8FB5CC #x550E) + (#x8FB5CD #x5515) + (#x8FB5CE #x552A) + (#x8FB5CF #x552B) + (#x8FB5D0 #x5532) + (#x8FB5D1 #x5535) + (#x8FB5D2 #x5536) + (#x8FB5D3 #x553B) + (#x8FB5D4 #x553C) + (#x8FB5D5 #x553D) + (#x8FB5D6 #x5541) + (#x8FB5D7 #x5547) + (#x8FB5D8 #x5549) + (#x8FB5D9 #x554A) + (#x8FB5DA #x554D) + (#x8FB5DB #x5550) + (#x8FB5DC #x5551) + (#x8FB5DD #x5558) + (#x8FB5DE #x555A) + (#x8FB5DF #x555B) + (#x8FB5E0 #x555E) + (#x8FB5E1 #x5560) + (#x8FB5E2 #x5561) + (#x8FB5E3 #x5564) + (#x8FB5E4 #x5566) + (#x8FB5E5 #x557F) + (#x8FB5E6 #x5581) + (#x8FB5E7 #x5582) + (#x8FB5E8 #x5586) + (#x8FB5E9 #x5588) + (#x8FB5EA #x558E) + (#x8FB5EB #x558F) + (#x8FB5EC #x5591) + (#x8FB5ED #x5592) + (#x8FB5EE #x5593) + (#x8FB5EF #x5594) + (#x8FB5F0 #x5597) + (#x8FB5F1 #x55A3) + (#x8FB5F2 #x55A4) + (#x8FB5F3 #x55AD) + (#x8FB5F4 #x55B2) + (#x8FB5F5 #x55BF) + (#x8FB5F6 #x55C1) + (#x8FB5F7 #x55C3) + (#x8FB5F8 #x55C6) + (#x8FB5F9 #x55C9) + (#x8FB5FA #x55CB) + (#x8FB5FB #x55CC) + (#x8FB5FC #x55CE) + (#x8FB5FD #x55D1) + (#x8FB5FE #x55D2) + (#x8FB6A1 #x55D3) + (#x8FB6A2 #x55D7) + (#x8FB6A3 #x55D8) + (#x8FB6A4 #x55DB) + (#x8FB6A5 #x55DE) + (#x8FB6A6 #x55E2) + (#x8FB6A7 #x55E9) + (#x8FB6A8 #x55F6) + (#x8FB6A9 #x55FF) + (#x8FB6AA #x5605) + (#x8FB6AB #x5608) + (#x8FB6AC #x560A) + (#x8FB6AD #x560D) + (#x8FB6AE #x560E) + (#x8FB6AF #x560F) + (#x8FB6B0 #x5610) + (#x8FB6B1 #x5611) + (#x8FB6B2 #x5612) + (#x8FB6B3 #x5619) + (#x8FB6B4 #x562C) + (#x8FB6B5 #x5630) + (#x8FB6B6 #x5633) + (#x8FB6B7 #x5635) + (#x8FB6B8 #x5637) + (#x8FB6B9 #x5639) + (#x8FB6BA #x563B) + (#x8FB6BB #x563C) + (#x8FB6BC #x563D) + (#x8FB6BD #x563F) + (#x8FB6BE #x5640) + (#x8FB6BF #x5641) + (#x8FB6C0 #x5643) + (#x8FB6C1 #x5644) + (#x8FB6C2 #x5646) + (#x8FB6C3 #x5649) + (#x8FB6C4 #x564B) + (#x8FB6C5 #x564D) + (#x8FB6C6 #x564F) + (#x8FB6C7 #x5654) + (#x8FB6C8 #x565E) + (#x8FB6C9 #x5660) + (#x8FB6CA #x5661) + (#x8FB6CB #x5662) + (#x8FB6CC #x5663) + (#x8FB6CD #x5666) + (#x8FB6CE #x5669) + (#x8FB6CF #x566D) + (#x8FB6D0 #x566F) + (#x8FB6D1 #x5671) + (#x8FB6D2 #x5672) + (#x8FB6D3 #x5675) + (#x8FB6D4 #x5684) + (#x8FB6D5 #x5685) + (#x8FB6D6 #x5688) + (#x8FB6D7 #x568B) + (#x8FB6D8 #x568C) + (#x8FB6D9 #x5695) + (#x8FB6DA #x5699) + (#x8FB6DB #x569A) + (#x8FB6DC #x569D) + (#x8FB6DD #x569E) + (#x8FB6DE #x569F) + (#x8FB6DF #x56A6) + (#x8FB6E0 #x56A7) + (#x8FB6E1 #x56A8) + (#x8FB6E2 #x56A9) + (#x8FB6E3 #x56AB) + (#x8FB6E4 #x56AC) + (#x8FB6E5 #x56AD) + (#x8FB6E6 #x56B1) + (#x8FB6E7 #x56B3) + (#x8FB6E8 #x56B7) + (#x8FB6E9 #x56BE) + (#x8FB6EA #x56C5) + (#x8FB6EB #x56C9) + (#x8FB6EC #x56CA) + (#x8FB6ED #x56CB) + (#x8FB6EE #x56CF) + (#x8FB6EF #x56D0) + (#x8FB6F0 #x56CC) + (#x8FB6F1 #x56CD) + (#x8FB6F2 #x56D9) + (#x8FB6F3 #x56DC) + (#x8FB6F4 #x56DD) + (#x8FB6F5 #x56DF) + (#x8FB6F6 #x56E1) + (#x8FB6F7 #x56E4) + (#x8FB6F8 #x56E5) + (#x8FB6F9 #x56E6) + (#x8FB6FA #x56E7) + (#x8FB6FB #x56E8) + (#x8FB6FC #x56F1) + (#x8FB6FD #x56EB) + (#x8FB6FE #x56ED) + (#x8FB7A1 #x56F6) + (#x8FB7A2 #x56F7) + (#x8FB7A3 #x5701) + (#x8FB7A4 #x5702) + (#x8FB7A5 #x5707) + (#x8FB7A6 #x570A) + (#x8FB7A7 #x570C) + (#x8FB7A8 #x5711) + (#x8FB7A9 #x5715) + (#x8FB7AA #x571A) + (#x8FB7AB #x571B) + (#x8FB7AC #x571D) + (#x8FB7AD #x5720) + (#x8FB7AE #x5722) + (#x8FB7AF #x5723) + (#x8FB7B0 #x5724) + (#x8FB7B1 #x5725) + (#x8FB7B2 #x5729) + (#x8FB7B3 #x572A) + (#x8FB7B4 #x572C) + (#x8FB7B5 #x572E) + (#x8FB7B6 #x572F) + (#x8FB7B7 #x5733) + (#x8FB7B8 #x5734) + (#x8FB7B9 #x573D) + (#x8FB7BA #x573E) + (#x8FB7BB #x573F) + (#x8FB7BC #x5745) + (#x8FB7BD #x5746) + (#x8FB7BE #x574C) + (#x8FB7BF #x574D) + (#x8FB7C0 #x5752) + (#x8FB7C1 #x5762) + (#x8FB7C2 #x5765) + (#x8FB7C3 #x5767) + (#x8FB7C4 #x5768) + (#x8FB7C5 #x576B) + (#x8FB7C6 #x576D) + (#x8FB7C7 #x576E) + (#x8FB7C8 #x576F) + (#x8FB7C9 #x5770) + (#x8FB7CA #x5771) + (#x8FB7CB #x5773) + (#x8FB7CC #x5774) + (#x8FB7CD #x5775) + (#x8FB7CE #x5777) + (#x8FB7CF #x5779) + (#x8FB7D0 #x577A) + (#x8FB7D1 #x577B) + (#x8FB7D2 #x577C) + (#x8FB7D3 #x577E) + (#x8FB7D4 #x5781) + (#x8FB7D5 #x5783) + (#x8FB7D6 #x578C) + (#x8FB7D7 #x5794) + (#x8FB7D8 #x5797) + (#x8FB7D9 #x5799) + (#x8FB7DA #x579A) + (#x8FB7DB #x579C) + (#x8FB7DC #x579D) + (#x8FB7DD #x579E) + (#x8FB7DE #x579F) + (#x8FB7DF #x57A1) + (#x8FB7E0 #x5795) + (#x8FB7E1 #x57A7) + (#x8FB7E2 #x57A8) + (#x8FB7E3 #x57A9) + (#x8FB7E4 #x57AC) + (#x8FB7E5 #x57B8) + (#x8FB7E6 #x57BD) + (#x8FB7E7 #x57C7) + (#x8FB7E8 #x57C8) + (#x8FB7E9 #x57CC) + (#x8FB7EA #x57CF) + (#x8FB7EB #x57D5) + (#x8FB7EC #x57DD) + (#x8FB7ED #x57DE) + (#x8FB7EE #x57E4) + (#x8FB7EF #x57E6) + (#x8FB7F0 #x57E7) + (#x8FB7F1 #x57E9) + (#x8FB7F2 #x57ED) + (#x8FB7F3 #x57F0) + (#x8FB7F4 #x57F5) + (#x8FB7F5 #x57F6) + (#x8FB7F6 #x57F8) + (#x8FB7F7 #x57FD) + (#x8FB7F8 #x57FE) + (#x8FB7F9 #x57FF) + (#x8FB7FA #x5803) + (#x8FB7FB #x5804) + (#x8FB7FC #x5808) + (#x8FB7FD #x5809) + (#x8FB7FE #x57E1) + (#x8FB8A1 #x580C) + (#x8FB8A2 #x580D) + (#x8FB8A3 #x581B) + (#x8FB8A4 #x581E) + (#x8FB8A5 #x581F) + (#x8FB8A6 #x5820) + (#x8FB8A7 #x5826) + (#x8FB8A8 #x5827) + (#x8FB8A9 #x582D) + (#x8FB8AA #x5832) + (#x8FB8AB #x5839) + (#x8FB8AC #x583F) + (#x8FB8AD #x5849) + (#x8FB8AE #x584C) + (#x8FB8AF #x584D) + (#x8FB8B0 #x584F) + (#x8FB8B1 #x5850) + (#x8FB8B2 #x5855) + (#x8FB8B3 #x585F) + (#x8FB8B4 #x5861) + (#x8FB8B5 #x5864) + (#x8FB8B6 #x5867) + (#x8FB8B7 #x5868) + (#x8FB8B8 #x5878) + (#x8FB8B9 #x587C) + (#x8FB8BA #x587F) + (#x8FB8BB #x5880) + (#x8FB8BC #x5881) + (#x8FB8BD #x5887) + (#x8FB8BE #x5888) + (#x8FB8BF #x5889) + (#x8FB8C0 #x588A) + (#x8FB8C1 #x588C) + (#x8FB8C2 #x588D) + (#x8FB8C3 #x588F) + (#x8FB8C4 #x5890) + (#x8FB8C5 #x5894) + (#x8FB8C6 #x5896) + (#x8FB8C7 #x589D) + (#x8FB8C8 #x58A0) + (#x8FB8C9 #x58A1) + (#x8FB8CA #x58A2) + (#x8FB8CB #x58A6) + (#x8FB8CC #x58A9) + (#x8FB8CD #x58B1) + (#x8FB8CE #x58B2) + (#x8FB8CF #x58C4) + (#x8FB8D0 #x58BC) + (#x8FB8D1 #x58C2) + (#x8FB8D2 #x58C8) + (#x8FB8D3 #x58CD) + (#x8FB8D4 #x58CE) + (#x8FB8D5 #x58D0) + (#x8FB8D6 #x58D2) + (#x8FB8D7 #x58D4) + (#x8FB8D8 #x58D6) + (#x8FB8D9 #x58DA) + (#x8FB8DA #x58DD) + (#x8FB8DB #x58E1) + (#x8FB8DC #x58E2) + (#x8FB8DD #x58E9) + (#x8FB8DE #x58F3) + (#x8FB8DF #x5905) + (#x8FB8E0 #x5906) + (#x8FB8E1 #x590B) + (#x8FB8E2 #x590C) + (#x8FB8E3 #x5912) + (#x8FB8E4 #x5913) + (#x8FB8E5 #x5914) + (#x8FB8E6 #x8641) + (#x8FB8E7 #x591D) + (#x8FB8E8 #x5921) + (#x8FB8E9 #x5923) + (#x8FB8EA #x5924) + (#x8FB8EB #x5928) + (#x8FB8EC #x592F) + (#x8FB8ED #x5930) + (#x8FB8EE #x5933) + (#x8FB8EF #x5935) + (#x8FB8F0 #x5936) + (#x8FB8F1 #x593F) + (#x8FB8F2 #x5943) + (#x8FB8F3 #x5946) + (#x8FB8F4 #x5952) + (#x8FB8F5 #x5953) + (#x8FB8F6 #x5959) + (#x8FB8F7 #x595B) + (#x8FB8F8 #x595D) + (#x8FB8F9 #x595E) + (#x8FB8FA #x595F) + (#x8FB8FB #x5961) + (#x8FB8FC #x5963) + (#x8FB8FD #x596B) + (#x8FB8FE #x596D) + (#x8FB9A1 #x596F) + (#x8FB9A2 #x5972) + (#x8FB9A3 #x5975) + (#x8FB9A4 #x5976) + (#x8FB9A5 #x5979) + (#x8FB9A6 #x597B) + (#x8FB9A7 #x597C) + (#x8FB9A8 #x598B) + (#x8FB9A9 #x598C) + (#x8FB9AA #x598E) + (#x8FB9AB #x5992) + (#x8FB9AC #x5995) + (#x8FB9AD #x5997) + (#x8FB9AE #x599F) + (#x8FB9AF #x59A4) + (#x8FB9B0 #x59A7) + (#x8FB9B1 #x59AD) + (#x8FB9B2 #x59AE) + (#x8FB9B3 #x59AF) + (#x8FB9B4 #x59B0) + (#x8FB9B5 #x59B3) + (#x8FB9B6 #x59B7) + (#x8FB9B7 #x59BA) + (#x8FB9B8 #x59BC) + (#x8FB9B9 #x59C1) + (#x8FB9BA #x59C3) + (#x8FB9BB #x59C4) + (#x8FB9BC #x59C8) + (#x8FB9BD #x59CA) + (#x8FB9BE #x59CD) + (#x8FB9BF #x59D2) + (#x8FB9C0 #x59DD) + (#x8FB9C1 #x59DE) + (#x8FB9C2 #x59DF) + (#x8FB9C3 #x59E3) + (#x8FB9C4 #x59E4) + (#x8FB9C5 #x59E7) + (#x8FB9C6 #x59EE) + (#x8FB9C7 #x59EF) + (#x8FB9C8 #x59F1) + (#x8FB9C9 #x59F2) + (#x8FB9CA #x59F4) + (#x8FB9CB #x59F7) + (#x8FB9CC #x5A00) + (#x8FB9CD #x5A04) + (#x8FB9CE #x5A0C) + (#x8FB9CF #x5A0D) + (#x8FB9D0 #x5A0E) + (#x8FB9D1 #x5A12) + (#x8FB9D2 #x5A13) + (#x8FB9D3 #x5A1E) + (#x8FB9D4 #x5A23) + (#x8FB9D5 #x5A24) + (#x8FB9D6 #x5A27) + (#x8FB9D7 #x5A28) + (#x8FB9D8 #x5A2A) + (#x8FB9D9 #x5A2D) + (#x8FB9DA #x5A30) + (#x8FB9DB #x5A44) + (#x8FB9DC #x5A45) + (#x8FB9DD #x5A47) + (#x8FB9DE #x5A48) + (#x8FB9DF #x5A4C) + (#x8FB9E0 #x5A50) + (#x8FB9E1 #x5A55) + (#x8FB9E2 #x5A5E) + (#x8FB9E3 #x5A63) + (#x8FB9E4 #x5A65) + (#x8FB9E5 #x5A67) + (#x8FB9E6 #x5A6D) + (#x8FB9E7 #x5A77) + (#x8FB9E8 #x5A7A) + (#x8FB9E9 #x5A7B) + (#x8FB9EA #x5A7E) + (#x8FB9EB #x5A8B) + (#x8FB9EC #x5A90) + (#x8FB9ED #x5A93) + (#x8FB9EE #x5A96) + (#x8FB9EF #x5A99) + (#x8FB9F0 #x5A9C) + (#x8FB9F1 #x5A9E) + (#x8FB9F2 #x5A9F) + (#x8FB9F3 #x5AA0) + (#x8FB9F4 #x5AA2) + (#x8FB9F5 #x5AA7) + (#x8FB9F6 #x5AAC) + (#x8FB9F7 #x5AB1) + (#x8FB9F8 #x5AB2) + (#x8FB9F9 #x5AB3) + (#x8FB9FA #x5AB5) + (#x8FB9FB #x5AB8) + (#x8FB9FC #x5ABA) + (#x8FB9FD #x5ABB) + (#x8FB9FE #x5ABF) + (#x8FBAA1 #x5AC4) + (#x8FBAA2 #x5AC6) + (#x8FBAA3 #x5AC8) + (#x8FBAA4 #x5ACF) + (#x8FBAA5 #x5ADA) + (#x8FBAA6 #x5ADC) + (#x8FBAA7 #x5AE0) + (#x8FBAA8 #x5AE5) + (#x8FBAA9 #x5AEA) + (#x8FBAAA #x5AEE) + (#x8FBAAB #x5AF5) + (#x8FBAAC #x5AF6) + (#x8FBAAD #x5AFD) + (#x8FBAAE #x5B00) + (#x8FBAAF #x5B01) + (#x8FBAB0 #x5B08) + (#x8FBAB1 #x5B17) + (#x8FBAB2 #x5B34) + (#x8FBAB3 #x5B19) + (#x8FBAB4 #x5B1B) + (#x8FBAB5 #x5B1D) + (#x8FBAB6 #x5B21) + (#x8FBAB7 #x5B25) + (#x8FBAB8 #x5B2D) + (#x8FBAB9 #x5B38) + (#x8FBABA #x5B41) + (#x8FBABB #x5B4B) + (#x8FBABC #x5B4C) + (#x8FBABD #x5B52) + (#x8FBABE #x5B56) + (#x8FBABF #x5B5E) + (#x8FBAC0 #x5B68) + (#x8FBAC1 #x5B6E) + (#x8FBAC2 #x5B6F) + (#x8FBAC3 #x5B7C) + (#x8FBAC4 #x5B7D) + (#x8FBAC5 #x5B7E) + (#x8FBAC6 #x5B7F) + (#x8FBAC7 #x5B81) + (#x8FBAC8 #x5B84) + (#x8FBAC9 #x5B86) + (#x8FBACA #x5B8A) + (#x8FBACB #x5B8E) + (#x8FBACC #x5B90) + (#x8FBACD #x5B91) + (#x8FBACE #x5B93) + (#x8FBACF #x5B94) + (#x8FBAD0 #x5B96) + (#x8FBAD1 #x5BA8) + (#x8FBAD2 #x5BA9) + (#x8FBAD3 #x5BAC) + (#x8FBAD4 #x5BAD) + (#x8FBAD5 #x5BAF) + (#x8FBAD6 #x5BB1) + (#x8FBAD7 #x5BB2) + (#x8FBAD8 #x5BB7) + (#x8FBAD9 #x5BBA) + (#x8FBADA #x5BBC) + (#x8FBADB #x5BC0) + (#x8FBADC #x5BC1) + (#x8FBADD #x5BCD) + (#x8FBADE #x5BCF) + (#x8FBADF #x5BD6) + (#x8FBAE0 #x5BD7) + (#x8FBAE1 #x5BD8) + (#x8FBAE2 #x5BD9) + (#x8FBAE3 #x5BDA) + (#x8FBAE4 #x5BE0) + (#x8FBAE5 #x5BEF) + (#x8FBAE6 #x5BF1) + (#x8FBAE7 #x5BF4) + (#x8FBAE8 #x5BFD) + (#x8FBAE9 #x5C0C) + (#x8FBAEA #x5C17) + (#x8FBAEB #x5C1E) + (#x8FBAEC #x5C1F) + (#x8FBAED #x5C23) + (#x8FBAEE #x5C26) + (#x8FBAEF #x5C29) + (#x8FBAF0 #x5C2B) + (#x8FBAF1 #x5C2C) + (#x8FBAF2 #x5C2E) + (#x8FBAF3 #x5C30) + (#x8FBAF4 #x5C32) + (#x8FBAF5 #x5C35) + (#x8FBAF6 #x5C36) + (#x8FBAF7 #x5C59) + (#x8FBAF8 #x5C5A) + (#x8FBAF9 #x5C5C) + (#x8FBAFA #x5C62) + (#x8FBAFB #x5C63) + (#x8FBAFC #x5C67) + (#x8FBAFD #x5C68) + (#x8FBAFE #x5C69) + (#x8FBBA1 #x5C6D) + (#x8FBBA2 #x5C70) + (#x8FBBA3 #x5C74) + (#x8FBBA4 #x5C75) + (#x8FBBA5 #x5C7A) + (#x8FBBA6 #x5C7B) + (#x8FBBA7 #x5C7C) + (#x8FBBA8 #x5C7D) + (#x8FBBA9 #x5C87) + (#x8FBBAA #x5C88) + (#x8FBBAB #x5C8A) + (#x8FBBAC #x5C8F) + (#x8FBBAD #x5C92) + (#x8FBBAE #x5C9D) + (#x8FBBAF #x5C9F) + (#x8FBBB0 #x5CA0) + (#x8FBBB1 #x5CA2) + (#x8FBBB2 #x5CA3) + (#x8FBBB3 #x5CA6) + (#x8FBBB4 #x5CAA) + (#x8FBBB5 #x5CB2) + (#x8FBBB6 #x5CB4) + (#x8FBBB7 #x5CB5) + (#x8FBBB8 #x5CBA) + (#x8FBBB9 #x5CC9) + (#x8FBBBA #x5CCB) + (#x8FBBBB #x5CD2) + (#x8FBBBC #x5CDD) + (#x8FBBBD #x5CD7) + (#x8FBBBE #x5CEE) + (#x8FBBBF #x5CF1) + (#x8FBBC0 #x5CF2) + (#x8FBBC1 #x5CF4) + (#x8FBBC2 #x5D01) + (#x8FBBC3 #x5D06) + (#x8FBBC4 #x5D0D) + (#x8FBBC5 #x5D12) + (#x8FBBC6 #x5D2B) + (#x8FBBC7 #x5D23) + (#x8FBBC8 #x5D24) + (#x8FBBC9 #x5D26) + (#x8FBBCA #x5D27) + (#x8FBBCB #x5D31) + (#x8FBBCC #x5D34) + (#x8FBBCD #x5D39) + (#x8FBBCE #x5D3D) + (#x8FBBCF #x5D3F) + (#x8FBBD0 #x5D42) + (#x8FBBD1 #x5D43) + (#x8FBBD2 #x5D46) + (#x8FBBD3 #x5D48) + (#x8FBBD4 #x5D55) + (#x8FBBD5 #x5D51) + (#x8FBBD6 #x5D59) + (#x8FBBD7 #x5D4A) + (#x8FBBD8 #x5D5F) + (#x8FBBD9 #x5D60) + (#x8FBBDA #x5D61) + (#x8FBBDB #x5D62) + (#x8FBBDC #x5D64) + (#x8FBBDD #x5D6A) + (#x8FBBDE #x5D6D) + (#x8FBBDF #x5D70) + (#x8FBBE0 #x5D79) + (#x8FBBE1 #x5D7A) + (#x8FBBE2 #x5D7E) + (#x8FBBE3 #x5D7F) + (#x8FBBE4 #x5D81) + (#x8FBBE5 #x5D83) + (#x8FBBE6 #x5D88) + (#x8FBBE7 #x5D8A) + (#x8FBBE8 #x5D92) + (#x8FBBE9 #x5D93) + (#x8FBBEA #x5D94) + (#x8FBBEB #x5D95) + (#x8FBBEC #x5D99) + (#x8FBBED #x5D9B) + (#x8FBBEE #x5D9F) + (#x8FBBEF #x5DA0) + (#x8FBBF0 #x5DA7) + (#x8FBBF1 #x5DAB) + (#x8FBBF2 #x5DB0) + (#x8FBBF3 #x5DB4) + (#x8FBBF4 #x5DB8) + (#x8FBBF5 #x5DB9) + (#x8FBBF6 #x5DC3) + (#x8FBBF7 #x5DC7) + (#x8FBBF8 #x5DCB) + (#x8FBBF9 #x5DD0) + (#x8FBBFA #x5DCE) + (#x8FBBFB #x5DD8) + (#x8FBBFC #x5DD9) + (#x8FBBFD #x5DE0) + (#x8FBBFE #x5DE4) + (#x8FBCA1 #x5DE9) + (#x8FBCA2 #x5DF8) + (#x8FBCA3 #x5DF9) + (#x8FBCA4 #x5E00) + (#x8FBCA5 #x5E07) + (#x8FBCA6 #x5E0D) + (#x8FBCA7 #x5E12) + (#x8FBCA8 #x5E14) + (#x8FBCA9 #x5E15) + (#x8FBCAA #x5E18) + (#x8FBCAB #x5E1F) + (#x8FBCAC #x5E20) + (#x8FBCAD #x5E2E) + (#x8FBCAE #x5E28) + (#x8FBCAF #x5E32) + (#x8FBCB0 #x5E35) + (#x8FBCB1 #x5E3E) + (#x8FBCB2 #x5E4B) + (#x8FBCB3 #x5E50) + (#x8FBCB4 #x5E49) + (#x8FBCB5 #x5E51) + (#x8FBCB6 #x5E56) + (#x8FBCB7 #x5E58) + (#x8FBCB8 #x5E5B) + (#x8FBCB9 #x5E5C) + (#x8FBCBA #x5E5E) + (#x8FBCBB #x5E68) + (#x8FBCBC #x5E6A) + (#x8FBCBD #x5E6B) + (#x8FBCBE #x5E6C) + (#x8FBCBF #x5E6D) + (#x8FBCC0 #x5E6E) + (#x8FBCC1 #x5E70) + (#x8FBCC2 #x5E80) + (#x8FBCC3 #x5E8B) + (#x8FBCC4 #x5E8E) + (#x8FBCC5 #x5EA2) + (#x8FBCC6 #x5EA4) + (#x8FBCC7 #x5EA5) + (#x8FBCC8 #x5EA8) + (#x8FBCC9 #x5EAA) + (#x8FBCCA #x5EAC) + (#x8FBCCB #x5EB1) + (#x8FBCCC #x5EB3) + (#x8FBCCD #x5EBD) + (#x8FBCCE #x5EBE) + (#x8FBCCF #x5EBF) + (#x8FBCD0 #x5EC6) + (#x8FBCD1 #x5ECC) + (#x8FBCD2 #x5ECB) + (#x8FBCD3 #x5ECE) + (#x8FBCD4 #x5ED1) + (#x8FBCD5 #x5ED2) + (#x8FBCD6 #x5ED4) + (#x8FBCD7 #x5ED5) + (#x8FBCD8 #x5EDC) + (#x8FBCD9 #x5EDE) + (#x8FBCDA #x5EE5) + (#x8FBCDB #x5EEB) + (#x8FBCDC #x5F02) + (#x8FBCDD #x5F06) + (#x8FBCDE #x5F07) + (#x8FBCDF #x5F08) + (#x8FBCE0 #x5F0E) + (#x8FBCE1 #x5F19) + (#x8FBCE2 #x5F1C) + (#x8FBCE3 #x5F1D) + (#x8FBCE4 #x5F21) + (#x8FBCE5 #x5F22) + (#x8FBCE6 #x5F23) + (#x8FBCE7 #x5F24) + (#x8FBCE8 #x5F28) + (#x8FBCE9 #x5F2B) + (#x8FBCEA #x5F2C) + (#x8FBCEB #x5F2E) + (#x8FBCEC #x5F30) + (#x8FBCED #x5F34) + (#x8FBCEE #x5F36) + (#x8FBCEF #x5F3B) + (#x8FBCF0 #x5F3D) + (#x8FBCF1 #x5F3F) + (#x8FBCF2 #x5F40) + (#x8FBCF3 #x5F44) + (#x8FBCF4 #x5F45) + (#x8FBCF5 #x5F47) + (#x8FBCF6 #x5F4D) + (#x8FBCF7 #x5F50) + (#x8FBCF8 #x5F54) + (#x8FBCF9 #x5F58) + (#x8FBCFA #x5F5B) + (#x8FBCFB #x5F60) + (#x8FBCFC #x5F63) + (#x8FBCFD #x5F64) + (#x8FBCFE #x5F67) + (#x8FBDA1 #x5F6F) + (#x8FBDA2 #x5F72) + (#x8FBDA3 #x5F74) + (#x8FBDA4 #x5F75) + (#x8FBDA5 #x5F78) + (#x8FBDA6 #x5F7A) + (#x8FBDA7 #x5F7D) + (#x8FBDA8 #x5F7E) + (#x8FBDA9 #x5F89) + (#x8FBDAA #x5F8D) + (#x8FBDAB #x5F8F) + (#x8FBDAC #x5F96) + (#x8FBDAD #x5F9C) + (#x8FBDAE #x5F9D) + (#x8FBDAF #x5FA2) + (#x8FBDB0 #x5FA7) + (#x8FBDB1 #x5FAB) + (#x8FBDB2 #x5FA4) + (#x8FBDB3 #x5FAC) + (#x8FBDB4 #x5FAF) + (#x8FBDB5 #x5FB0) + (#x8FBDB6 #x5FB1) + (#x8FBDB7 #x5FB8) + (#x8FBDB8 #x5FC4) + (#x8FBDB9 #x5FC7) + (#x8FBDBA #x5FC8) + (#x8FBDBB #x5FC9) + (#x8FBDBC #x5FCB) + (#x8FBDBD #x5FD0) + (#x8FBDBE #x5FD1) + (#x8FBDBF #x5FD2) + (#x8FBDC0 #x5FD3) + (#x8FBDC1 #x5FD4) + (#x8FBDC2 #x5FDE) + (#x8FBDC3 #x5FE1) + (#x8FBDC4 #x5FE2) + (#x8FBDC5 #x5FE8) + (#x8FBDC6 #x5FE9) + (#x8FBDC7 #x5FEA) + (#x8FBDC8 #x5FEC) + (#x8FBDC9 #x5FED) + (#x8FBDCA #x5FEE) + (#x8FBDCB #x5FEF) + (#x8FBDCC #x5FF2) + (#x8FBDCD #x5FF3) + (#x8FBDCE #x5FF6) + (#x8FBDCF #x5FFA) + (#x8FBDD0 #x5FFC) + (#x8FBDD1 #x6007) + (#x8FBDD2 #x600A) + (#x8FBDD3 #x600D) + (#x8FBDD4 #x6013) + (#x8FBDD5 #x6014) + (#x8FBDD6 #x6017) + (#x8FBDD7 #x6018) + (#x8FBDD8 #x601A) + (#x8FBDD9 #x601F) + (#x8FBDDA #x6024) + (#x8FBDDB #x602D) + (#x8FBDDC #x6033) + (#x8FBDDD #x6035) + (#x8FBDDE #x6040) + (#x8FBDDF #x6047) + (#x8FBDE0 #x6048) + (#x8FBDE1 #x6049) + (#x8FBDE2 #x604C) + (#x8FBDE3 #x6051) + (#x8FBDE4 #x6054) + (#x8FBDE5 #x6056) + (#x8FBDE6 #x6057) + (#x8FBDE7 #x605D) + (#x8FBDE8 #x6061) + (#x8FBDE9 #x6067) + (#x8FBDEA #x6071) + (#x8FBDEB #x607E) + (#x8FBDEC #x607F) + (#x8FBDED #x6082) + (#x8FBDEE #x6086) + (#x8FBDEF #x6088) + (#x8FBDF0 #x608A) + (#x8FBDF1 #x608E) + (#x8FBDF2 #x6091) + (#x8FBDF3 #x6093) + (#x8FBDF4 #x6095) + (#x8FBDF5 #x6098) + (#x8FBDF6 #x609D) + (#x8FBDF7 #x609E) + (#x8FBDF8 #x60A2) + (#x8FBDF9 #x60A4) + (#x8FBDFA #x60A5) + (#x8FBDFB #x60A8) + (#x8FBDFC #x60B0) + (#x8FBDFD #x60B1) + (#x8FBDFE #x60B7) + (#x8FBEA1 #x60BB) + (#x8FBEA2 #x60BE) + (#x8FBEA3 #x60C2) + (#x8FBEA4 #x60C4) + (#x8FBEA5 #x60C8) + (#x8FBEA6 #x60C9) + (#x8FBEA7 #x60CA) + (#x8FBEA8 #x60CB) + (#x8FBEA9 #x60CE) + (#x8FBEAA #x60CF) + (#x8FBEAB #x60D4) + (#x8FBEAC #x60D5) + (#x8FBEAD #x60D9) + (#x8FBEAE #x60DB) + (#x8FBEAF #x60DD) + (#x8FBEB0 #x60DE) + (#x8FBEB1 #x60E2) + (#x8FBEB2 #x60E5) + (#x8FBEB3 #x60F2) + (#x8FBEB4 #x60F5) + (#x8FBEB5 #x60F8) + (#x8FBEB6 #x60FC) + (#x8FBEB7 #x60FD) + (#x8FBEB8 #x6102) + (#x8FBEB9 #x6107) + (#x8FBEBA #x610A) + (#x8FBEBB #x610C) + (#x8FBEBC #x6110) + (#x8FBEBD #x6111) + (#x8FBEBE #x6112) + (#x8FBEBF #x6113) + (#x8FBEC0 #x6114) + (#x8FBEC1 #x6116) + (#x8FBEC2 #x6117) + (#x8FBEC3 #x6119) + (#x8FBEC4 #x611C) + (#x8FBEC5 #x611E) + (#x8FBEC6 #x6122) + (#x8FBEC7 #x612A) + (#x8FBEC8 #x612B) + (#x8FBEC9 #x6130) + (#x8FBECA #x6131) + (#x8FBECB #x6135) + (#x8FBECC #x6136) + (#x8FBECD #x6137) + (#x8FBECE #x6139) + (#x8FBECF #x6141) + (#x8FBED0 #x6145) + (#x8FBED1 #x6146) + (#x8FBED2 #x6149) + (#x8FBED3 #x615E) + (#x8FBED4 #x6160) + (#x8FBED5 #x616C) + (#x8FBED6 #x6172) + (#x8FBED7 #x6178) + (#x8FBED8 #x617B) + (#x8FBED9 #x617C) + (#x8FBEDA #x617F) + (#x8FBEDB #x6180) + (#x8FBEDC #x6181) + (#x8FBEDD #x6183) + (#x8FBEDE #x6184) + (#x8FBEDF #x618B) + (#x8FBEE0 #x618D) + (#x8FBEE1 #x6192) + (#x8FBEE2 #x6193) + (#x8FBEE3 #x6197) + (#x8FBEE4 #x6198) + (#x8FBEE5 #x619C) + (#x8FBEE6 #x619D) + (#x8FBEE7 #x619F) + (#x8FBEE8 #x61A0) + (#x8FBEE9 #x61A5) + (#x8FBEEA #x61A8) + (#x8FBEEB #x61AA) + (#x8FBEEC #x61AD) + (#x8FBEED #x61B8) + (#x8FBEEE #x61B9) + (#x8FBEEF #x61BC) + (#x8FBEF0 #x61C0) + (#x8FBEF1 #x61C1) + (#x8FBEF2 #x61C2) + (#x8FBEF3 #x61CE) + (#x8FBEF4 #x61CF) + (#x8FBEF5 #x61D5) + (#x8FBEF6 #x61DC) + (#x8FBEF7 #x61DD) + (#x8FBEF8 #x61DE) + (#x8FBEF9 #x61DF) + (#x8FBEFA #x61E1) + (#x8FBEFB #x61E2) + (#x8FBEFC #x61E7) + (#x8FBEFD #x61E9) + (#x8FBEFE #x61E5) + (#x8FBFA1 #x61EC) + (#x8FBFA2 #x61ED) + (#x8FBFA3 #x61EF) + (#x8FBFA4 #x6201) + (#x8FBFA5 #x6203) + (#x8FBFA6 #x6204) + (#x8FBFA7 #x6207) + (#x8FBFA8 #x6213) + (#x8FBFA9 #x6215) + (#x8FBFAA #x621C) + (#x8FBFAB #x6220) + (#x8FBFAC #x6222) + (#x8FBFAD #x6223) + (#x8FBFAE #x6227) + (#x8FBFAF #x6229) + (#x8FBFB0 #x622B) + (#x8FBFB1 #x6239) + (#x8FBFB2 #x623D) + (#x8FBFB3 #x6242) + (#x8FBFB4 #x6243) + (#x8FBFB5 #x6244) + (#x8FBFB6 #x6246) + (#x8FBFB7 #x624C) + (#x8FBFB8 #x6250) + (#x8FBFB9 #x6251) + (#x8FBFBA #x6252) + (#x8FBFBB #x6254) + (#x8FBFBC #x6256) + (#x8FBFBD #x625A) + (#x8FBFBE #x625C) + (#x8FBFBF #x6264) + (#x8FBFC0 #x626D) + (#x8FBFC1 #x626F) + (#x8FBFC2 #x6273) + (#x8FBFC3 #x627A) + (#x8FBFC4 #x627D) + (#x8FBFC5 #x628D) + (#x8FBFC6 #x628E) + (#x8FBFC7 #x628F) + (#x8FBFC8 #x6290) + (#x8FBFC9 #x62A6) + (#x8FBFCA #x62A8) + (#x8FBFCB #x62B3) + (#x8FBFCC #x62B6) + (#x8FBFCD #x62B7) + (#x8FBFCE #x62BA) + (#x8FBFCF #x62BE) + (#x8FBFD0 #x62BF) + (#x8FBFD1 #x62C4) + (#x8FBFD2 #x62CE) + (#x8FBFD3 #x62D5) + (#x8FBFD4 #x62D6) + (#x8FBFD5 #x62DA) + (#x8FBFD6 #x62EA) + (#x8FBFD7 #x62F2) + (#x8FBFD8 #x62F4) + (#x8FBFD9 #x62FC) + (#x8FBFDA #x62FD) + (#x8FBFDB #x6303) + (#x8FBFDC #x6304) + (#x8FBFDD #x630A) + (#x8FBFDE #x630B) + (#x8FBFDF #x630D) + (#x8FBFE0 #x6310) + (#x8FBFE1 #x6313) + (#x8FBFE2 #x6316) + (#x8FBFE3 #x6318) + (#x8FBFE4 #x6329) + (#x8FBFE5 #x632A) + (#x8FBFE6 #x632D) + (#x8FBFE7 #x6335) + (#x8FBFE8 #x6336) + (#x8FBFE9 #x6339) + (#x8FBFEA #x633C) + (#x8FBFEB #x6341) + (#x8FBFEC #x6342) + (#x8FBFED #x6343) + (#x8FBFEE #x6344) + (#x8FBFEF #x6346) + (#x8FBFF0 #x634A) + (#x8FBFF1 #x634B) + (#x8FBFF2 #x634E) + (#x8FBFF3 #x6352) + (#x8FBFF4 #x6353) + (#x8FBFF5 #x6354) + (#x8FBFF6 #x6358) + (#x8FBFF7 #x635B) + (#x8FBFF8 #x6365) + (#x8FBFF9 #x6366) + (#x8FBFFA #x636C) + (#x8FBFFB #x636D) + (#x8FBFFC #x6371) + (#x8FBFFD #x6374) + (#x8FBFFE #x6375) + (#x8FC0A1 #x6378) + (#x8FC0A2 #x637C) + (#x8FC0A3 #x637D) + (#x8FC0A4 #x637F) + (#x8FC0A5 #x6382) + (#x8FC0A6 #x6384) + (#x8FC0A7 #x6387) + (#x8FC0A8 #x638A) + (#x8FC0A9 #x6390) + (#x8FC0AA #x6394) + (#x8FC0AB #x6395) + (#x8FC0AC #x6399) + (#x8FC0AD #x639A) + (#x8FC0AE #x639E) + (#x8FC0AF #x63A4) + (#x8FC0B0 #x63A6) + (#x8FC0B1 #x63AD) + (#x8FC0B2 #x63AE) + (#x8FC0B3 #x63AF) + (#x8FC0B4 #x63BD) + (#x8FC0B5 #x63C1) + (#x8FC0B6 #x63C5) + (#x8FC0B7 #x63C8) + (#x8FC0B8 #x63CE) + (#x8FC0B9 #x63D1) + (#x8FC0BA #x63D3) + (#x8FC0BB #x63D4) + (#x8FC0BC #x63D5) + (#x8FC0BD #x63DC) + (#x8FC0BE #x63E0) + (#x8FC0BF #x63E5) + (#x8FC0C0 #x63EA) + (#x8FC0C1 #x63EC) + (#x8FC0C2 #x63F2) + (#x8FC0C3 #x63F3) + (#x8FC0C4 #x63F5) + (#x8FC0C5 #x63F8) + (#x8FC0C6 #x63F9) + (#x8FC0C7 #x6409) + (#x8FC0C8 #x640A) + (#x8FC0C9 #x6410) + (#x8FC0CA #x6412) + (#x8FC0CB #x6414) + (#x8FC0CC #x6418) + (#x8FC0CD #x641E) + (#x8FC0CE #x6420) + (#x8FC0CF #x6422) + (#x8FC0D0 #x6424) + (#x8FC0D1 #x6425) + (#x8FC0D2 #x6429) + (#x8FC0D3 #x642A) + (#x8FC0D4 #x642F) + (#x8FC0D5 #x6430) + (#x8FC0D6 #x6435) + (#x8FC0D7 #x643D) + (#x8FC0D8 #x643F) + (#x8FC0D9 #x644B) + (#x8FC0DA #x644F) + (#x8FC0DB #x6451) + (#x8FC0DC #x6452) + (#x8FC0DD #x6453) + (#x8FC0DE #x6454) + (#x8FC0DF #x645A) + (#x8FC0E0 #x645B) + (#x8FC0E1 #x645C) + (#x8FC0E2 #x645D) + (#x8FC0E3 #x645F) + (#x8FC0E4 #x6460) + (#x8FC0E5 #x6461) + (#x8FC0E6 #x6463) + (#x8FC0E7 #x646D) + (#x8FC0E8 #x6473) + (#x8FC0E9 #x6474) + (#x8FC0EA #x647B) + (#x8FC0EB #x647D) + (#x8FC0EC #x6485) + (#x8FC0ED #x6487) + (#x8FC0EE #x648F) + (#x8FC0EF #x6490) + (#x8FC0F0 #x6491) + (#x8FC0F1 #x6498) + (#x8FC0F2 #x6499) + (#x8FC0F3 #x649B) + (#x8FC0F4 #x649D) + (#x8FC0F5 #x649F) + (#x8FC0F6 #x64A1) + (#x8FC0F7 #x64A3) + (#x8FC0F8 #x64A6) + (#x8FC0F9 #x64A8) + (#x8FC0FA #x64AC) + (#x8FC0FB #x64B3) + (#x8FC0FC #x64BD) + (#x8FC0FD #x64BE) + (#x8FC0FE #x64BF) + (#x8FC1A1 #x64C4) + (#x8FC1A2 #x64C9) + (#x8FC1A3 #x64CA) + (#x8FC1A4 #x64CB) + (#x8FC1A5 #x64CC) + (#x8FC1A6 #x64CE) + (#x8FC1A7 #x64D0) + (#x8FC1A8 #x64D1) + (#x8FC1A9 #x64D5) + (#x8FC1AA #x64D7) + (#x8FC1AB #x64E4) + (#x8FC1AC #x64E5) + (#x8FC1AD #x64E9) + (#x8FC1AE #x64EA) + (#x8FC1AF #x64ED) + (#x8FC1B0 #x64F0) + (#x8FC1B1 #x64F5) + (#x8FC1B2 #x64F7) + (#x8FC1B3 #x64FB) + (#x8FC1B4 #x64FF) + (#x8FC1B5 #x6501) + (#x8FC1B6 #x6504) + (#x8FC1B7 #x6508) + (#x8FC1B8 #x6509) + (#x8FC1B9 #x650A) + (#x8FC1BA #x650F) + (#x8FC1BB #x6513) + (#x8FC1BC #x6514) + (#x8FC1BD #x6516) + (#x8FC1BE #x6519) + (#x8FC1BF #x651B) + (#x8FC1C0 #x651E) + (#x8FC1C1 #x651F) + (#x8FC1C2 #x6522) + (#x8FC1C3 #x6526) + (#x8FC1C4 #x6529) + (#x8FC1C5 #x652E) + (#x8FC1C6 #x6531) + (#x8FC1C7 #x653A) + (#x8FC1C8 #x653C) + (#x8FC1C9 #x653D) + (#x8FC1CA #x6543) + (#x8FC1CB #x6547) + (#x8FC1CC #x6549) + (#x8FC1CD #x6550) + (#x8FC1CE #x6552) + (#x8FC1CF #x6554) + (#x8FC1D0 #x655F) + (#x8FC1D1 #x6560) + (#x8FC1D2 #x6567) + (#x8FC1D3 #x656B) + (#x8FC1D4 #x657A) + (#x8FC1D5 #x657D) + (#x8FC1D6 #x6581) + (#x8FC1D7 #x6585) + (#x8FC1D8 #x658A) + (#x8FC1D9 #x6592) + (#x8FC1DA #x6595) + (#x8FC1DB #x6598) + (#x8FC1DC #x659D) + (#x8FC1DD #x65A0) + (#x8FC1DE #x65A3) + (#x8FC1DF #x65A6) + (#x8FC1E0 #x65AE) + (#x8FC1E1 #x65B2) + (#x8FC1E2 #x65B3) + (#x8FC1E3 #x65B4) + (#x8FC1E4 #x65BF) + (#x8FC1E5 #x65C2) + (#x8FC1E6 #x65C8) + (#x8FC1E7 #x65C9) + (#x8FC1E8 #x65CE) + (#x8FC1E9 #x65D0) + (#x8FC1EA #x65D4) + (#x8FC1EB #x65D6) + (#x8FC1EC #x65D8) + (#x8FC1ED #x65DF) + (#x8FC1EE #x65F0) + (#x8FC1EF #x65F2) + (#x8FC1F0 #x65F4) + (#x8FC1F1 #x65F5) + (#x8FC1F2 #x65F9) + (#x8FC1F3 #x65FE) + (#x8FC1F4 #x65FF) + (#x8FC1F5 #x6600) + (#x8FC1F6 #x6604) + (#x8FC1F7 #x6608) + (#x8FC1F8 #x6609) + (#x8FC1F9 #x660D) + (#x8FC1FA #x6611) + (#x8FC1FB #x6612) + (#x8FC1FC #x6615) + (#x8FC1FD #x6616) + (#x8FC1FE #x661D) + (#x8FC2A1 #x661E) + (#x8FC2A2 #x6621) + (#x8FC2A3 #x6622) + (#x8FC2A4 #x6623) + (#x8FC2A5 #x6624) + (#x8FC2A6 #x6626) + (#x8FC2A7 #x6629) + (#x8FC2A8 #x662A) + (#x8FC2A9 #x662B) + (#x8FC2AA #x662C) + (#x8FC2AB #x662E) + (#x8FC2AC #x6630) + (#x8FC2AD #x6631) + (#x8FC2AE #x6633) + (#x8FC2AF #x6639) + (#x8FC2B0 #x6637) + (#x8FC2B1 #x6640) + (#x8FC2B2 #x6645) + (#x8FC2B3 #x6646) + (#x8FC2B4 #x664A) + (#x8FC2B5 #x664C) + (#x8FC2B6 #x6651) + (#x8FC2B7 #x664E) + (#x8FC2B8 #x6657) + (#x8FC2B9 #x6658) + (#x8FC2BA #x6659) + (#x8FC2BB #x665B) + (#x8FC2BC #x665C) + (#x8FC2BD #x6660) + (#x8FC2BE #x6661) + (#x8FC2BF #x66FB) + (#x8FC2C0 #x666A) + (#x8FC2C1 #x666B) + (#x8FC2C2 #x666C) + (#x8FC2C3 #x667E) + (#x8FC2C4 #x6673) + (#x8FC2C5 #x6675) + (#x8FC2C6 #x667F) + (#x8FC2C7 #x6677) + (#x8FC2C8 #x6678) + (#x8FC2C9 #x6679) + (#x8FC2CA #x667B) + (#x8FC2CB #x6680) + (#x8FC2CC #x667C) + (#x8FC2CD #x668B) + (#x8FC2CE #x668C) + (#x8FC2CF #x668D) + (#x8FC2D0 #x6690) + (#x8FC2D1 #x6692) + (#x8FC2D2 #x6699) + (#x8FC2D3 #x669A) + (#x8FC2D4 #x669B) + (#x8FC2D5 #x669C) + (#x8FC2D6 #x669F) + (#x8FC2D7 #x66A0) + (#x8FC2D8 #x66A4) + (#x8FC2D9 #x66AD) + (#x8FC2DA #x66B1) + (#x8FC2DB #x66B2) + (#x8FC2DC #x66B5) + (#x8FC2DD #x66BB) + (#x8FC2DE #x66BF) + (#x8FC2DF #x66C0) + (#x8FC2E0 #x66C2) + (#x8FC2E1 #x66C3) + (#x8FC2E2 #x66C8) + (#x8FC2E3 #x66CC) + (#x8FC2E4 #x66CE) + (#x8FC2E5 #x66CF) + (#x8FC2E6 #x66D4) + (#x8FC2E7 #x66DB) + (#x8FC2E8 #x66DF) + (#x8FC2E9 #x66E8) + (#x8FC2EA #x66EB) + (#x8FC2EB #x66EC) + (#x8FC2EC #x66EE) + (#x8FC2ED #x66FA) + (#x8FC2EE #x6705) + (#x8FC2EF #x6707) + (#x8FC2F0 #x670E) + (#x8FC2F1 #x6713) + (#x8FC2F2 #x6719) + (#x8FC2F3 #x671C) + (#x8FC2F4 #x6720) + (#x8FC2F5 #x6722) + (#x8FC2F6 #x6733) + (#x8FC2F7 #x673E) + (#x8FC2F8 #x6745) + (#x8FC2F9 #x6747) + (#x8FC2FA #x6748) + (#x8FC2FB #x674C) + (#x8FC2FC #x6754) + (#x8FC2FD #x6755) + (#x8FC2FE #x675D) + (#x8FC3A1 #x6766) + (#x8FC3A2 #x676C) + (#x8FC3A3 #x676E) + (#x8FC3A4 #x6774) + (#x8FC3A5 #x6776) + (#x8FC3A6 #x677B) + (#x8FC3A7 #x6781) + (#x8FC3A8 #x6784) + (#x8FC3A9 #x678E) + (#x8FC3AA #x678F) + (#x8FC3AB #x6791) + (#x8FC3AC #x6793) + (#x8FC3AD #x6796) + (#x8FC3AE #x6798) + (#x8FC3AF #x6799) + (#x8FC3B0 #x679B) + (#x8FC3B1 #x67B0) + (#x8FC3B2 #x67B1) + (#x8FC3B3 #x67B2) + (#x8FC3B4 #x67B5) + (#x8FC3B5 #x67BB) + (#x8FC3B6 #x67BC) + (#x8FC3B7 #x67BD) + (#x8FC3B8 #x67F9) + (#x8FC3B9 #x67C0) + (#x8FC3BA #x67C2) + (#x8FC3BB #x67C3) + (#x8FC3BC #x67C5) + (#x8FC3BD #x67C8) + (#x8FC3BE #x67C9) + (#x8FC3BF #x67D2) + (#x8FC3C0 #x67D7) + (#x8FC3C1 #x67D9) + (#x8FC3C2 #x67DC) + (#x8FC3C3 #x67E1) + (#x8FC3C4 #x67E6) + (#x8FC3C5 #x67F0) + (#x8FC3C6 #x67F2) + (#x8FC3C7 #x67F6) + (#x8FC3C8 #x67F7) + (#x8FC3C9 #x6852) + (#x8FC3CA #x6814) + (#x8FC3CB #x6819) + (#x8FC3CC #x681D) + (#x8FC3CD #x681F) + (#x8FC3CE #x6828) + (#x8FC3CF #x6827) + (#x8FC3D0 #x682C) + (#x8FC3D1 #x682D) + (#x8FC3D2 #x682F) + (#x8FC3D3 #x6830) + (#x8FC3D4 #x6831) + (#x8FC3D5 #x6833) + (#x8FC3D6 #x683B) + (#x8FC3D7 #x683F) + (#x8FC3D8 #x6844) + (#x8FC3D9 #x6845) + (#x8FC3DA #x684A) + (#x8FC3DB #x684C) + (#x8FC3DC #x6855) + (#x8FC3DD #x6857) + (#x8FC3DE #x6858) + (#x8FC3DF #x685B) + (#x8FC3E0 #x686B) + (#x8FC3E1 #x686E) + (#x8FC3E2 #x686F) + (#x8FC3E3 #x6870) + (#x8FC3E4 #x6871) + (#x8FC3E5 #x6872) + (#x8FC3E6 #x6875) + (#x8FC3E7 #x6879) + (#x8FC3E8 #x687A) + (#x8FC3E9 #x687B) + (#x8FC3EA #x687C) + (#x8FC3EB #x6882) + (#x8FC3EC #x6884) + (#x8FC3ED #x6886) + (#x8FC3EE #x6888) + (#x8FC3EF #x6896) + (#x8FC3F0 #x6898) + (#x8FC3F1 #x689A) + (#x8FC3F2 #x689C) + (#x8FC3F3 #x68A1) + (#x8FC3F4 #x68A3) + (#x8FC3F5 #x68A5) + (#x8FC3F6 #x68A9) + (#x8FC3F7 #x68AA) + (#x8FC3F8 #x68AE) + (#x8FC3F9 #x68B2) + (#x8FC3FA #x68BB) + (#x8FC3FB #x68C5) + (#x8FC3FC #x68C8) + (#x8FC3FD #x68CC) + (#x8FC3FE #x68CF) + (#x8FC4A1 #x68D0) + (#x8FC4A2 #x68D1) + (#x8FC4A3 #x68D3) + (#x8FC4A4 #x68D6) + (#x8FC4A5 #x68D9) + (#x8FC4A6 #x68DC) + (#x8FC4A7 #x68DD) + (#x8FC4A8 #x68E5) + (#x8FC4A9 #x68E8) + (#x8FC4AA #x68EA) + (#x8FC4AB #x68EB) + (#x8FC4AC #x68EC) + (#x8FC4AD #x68ED) + (#x8FC4AE #x68F0) + (#x8FC4AF #x68F1) + (#x8FC4B0 #x68F5) + (#x8FC4B1 #x68F6) + (#x8FC4B2 #x68FB) + (#x8FC4B3 #x68FC) + (#x8FC4B4 #x68FD) + (#x8FC4B5 #x6906) + (#x8FC4B6 #x6909) + (#x8FC4B7 #x690A) + (#x8FC4B8 #x6910) + (#x8FC4B9 #x6911) + (#x8FC4BA #x6913) + (#x8FC4BB #x6916) + (#x8FC4BC #x6917) + (#x8FC4BD #x6931) + (#x8FC4BE #x6933) + (#x8FC4BF #x6935) + (#x8FC4C0 #x6938) + (#x8FC4C1 #x693B) + (#x8FC4C2 #x6942) + (#x8FC4C3 #x6945) + (#x8FC4C4 #x6949) + (#x8FC4C5 #x694E) + (#x8FC4C6 #x6957) + (#x8FC4C7 #x695B) + (#x8FC4C8 #x6963) + (#x8FC4C9 #x6964) + (#x8FC4CA #x6965) + (#x8FC4CB #x6966) + (#x8FC4CC #x6968) + (#x8FC4CD #x6969) + (#x8FC4CE #x696C) + (#x8FC4CF #x6970) + (#x8FC4D0 #x6971) + (#x8FC4D1 #x6972) + (#x8FC4D2 #x697A) + (#x8FC4D3 #x697B) + (#x8FC4D4 #x697F) + (#x8FC4D5 #x6980) + (#x8FC4D6 #x698D) + (#x8FC4D7 #x6992) + (#x8FC4D8 #x6996) + (#x8FC4D9 #x6998) + (#x8FC4DA #x69A1) + (#x8FC4DB #x69A5) + (#x8FC4DC #x69A6) + (#x8FC4DD #x69A8) + (#x8FC4DE #x69AB) + (#x8FC4DF #x69AD) + (#x8FC4E0 #x69AF) + (#x8FC4E1 #x69B7) + (#x8FC4E2 #x69B8) + (#x8FC4E3 #x69BA) + (#x8FC4E4 #x69BC) + (#x8FC4E5 #x69C5) + (#x8FC4E6 #x69C8) + (#x8FC4E7 #x69D1) + (#x8FC4E8 #x69D6) + (#x8FC4E9 #x69D7) + (#x8FC4EA #x69E2) + (#x8FC4EB #x69E5) + (#x8FC4EC #x69EE) + (#x8FC4ED #x69EF) + (#x8FC4EE #x69F1) + (#x8FC4EF #x69F3) + (#x8FC4F0 #x69F5) + (#x8FC4F1 #x69FE) + (#x8FC4F2 #x6A00) + (#x8FC4F3 #x6A01) + (#x8FC4F4 #x6A03) + (#x8FC4F5 #x6A0F) + (#x8FC4F6 #x6A11) + (#x8FC4F7 #x6A15) + (#x8FC4F8 #x6A1A) + (#x8FC4F9 #x6A1D) + (#x8FC4FA #x6A20) + (#x8FC4FB #x6A24) + (#x8FC4FC #x6A28) + (#x8FC4FD #x6A30) + (#x8FC4FE #x6A32) + (#x8FC5A1 #x6A34) + (#x8FC5A2 #x6A37) + (#x8FC5A3 #x6A3B) + (#x8FC5A4 #x6A3E) + (#x8FC5A5 #x6A3F) + (#x8FC5A6 #x6A45) + (#x8FC5A7 #x6A46) + (#x8FC5A8 #x6A49) + (#x8FC5A9 #x6A4A) + (#x8FC5AA #x6A4E) + (#x8FC5AB #x6A50) + (#x8FC5AC #x6A51) + (#x8FC5AD #x6A52) + (#x8FC5AE #x6A55) + (#x8FC5AF #x6A56) + (#x8FC5B0 #x6A5B) + (#x8FC5B1 #x6A64) + (#x8FC5B2 #x6A67) + (#x8FC5B3 #x6A6A) + (#x8FC5B4 #x6A71) + (#x8FC5B5 #x6A73) + (#x8FC5B6 #x6A7E) + (#x8FC5B7 #x6A81) + (#x8FC5B8 #x6A83) + (#x8FC5B9 #x6A86) + (#x8FC5BA #x6A87) + (#x8FC5BB #x6A89) + (#x8FC5BC #x6A8B) + (#x8FC5BD #x6A91) + (#x8FC5BE #x6A9B) + (#x8FC5BF #x6A9D) + (#x8FC5C0 #x6A9E) + (#x8FC5C1 #x6A9F) + (#x8FC5C2 #x6AA5) + (#x8FC5C3 #x6AAB) + (#x8FC5C4 #x6AAF) + (#x8FC5C5 #x6AB0) + (#x8FC5C6 #x6AB1) + (#x8FC5C7 #x6AB4) + (#x8FC5C8 #x6ABD) + (#x8FC5C9 #x6ABE) + (#x8FC5CA #x6ABF) + (#x8FC5CB #x6AC6) + (#x8FC5CC #x6AC9) + (#x8FC5CD #x6AC8) + (#x8FC5CE #x6ACC) + (#x8FC5CF #x6AD0) + (#x8FC5D0 #x6AD4) + (#x8FC5D1 #x6AD5) + (#x8FC5D2 #x6AD6) + (#x8FC5D3 #x6ADC) + (#x8FC5D4 #x6ADD) + (#x8FC5D5 #x6AE4) + (#x8FC5D6 #x6AE7) + (#x8FC5D7 #x6AEC) + (#x8FC5D8 #x6AF0) + (#x8FC5D9 #x6AF1) + (#x8FC5DA #x6AF2) + (#x8FC5DB #x6AFC) + (#x8FC5DC #x6AFD) + (#x8FC5DD #x6B02) + (#x8FC5DE #x6B03) + (#x8FC5DF #x6B06) + (#x8FC5E0 #x6B07) + (#x8FC5E1 #x6B09) + (#x8FC5E2 #x6B0F) + (#x8FC5E3 #x6B10) + (#x8FC5E4 #x6B11) + (#x8FC5E5 #x6B17) + (#x8FC5E6 #x6B1B) + (#x8FC5E7 #x6B1E) + (#x8FC5E8 #x6B24) + (#x8FC5E9 #x6B28) + (#x8FC5EA #x6B2B) + (#x8FC5EB #x6B2C) + (#x8FC5EC #x6B2F) + (#x8FC5ED #x6B35) + (#x8FC5EE #x6B36) + (#x8FC5EF #x6B3B) + (#x8FC5F0 #x6B3F) + (#x8FC5F1 #x6B46) + (#x8FC5F2 #x6B4A) + (#x8FC5F3 #x6B4D) + (#x8FC5F4 #x6B52) + (#x8FC5F5 #x6B56) + (#x8FC5F6 #x6B58) + (#x8FC5F7 #x6B5D) + (#x8FC5F8 #x6B60) + (#x8FC5F9 #x6B67) + (#x8FC5FA #x6B6B) + (#x8FC5FB #x6B6E) + (#x8FC5FC #x6B70) + (#x8FC5FD #x6B75) + (#x8FC5FE #x6B7D) + (#x8FC6A1 #x6B7E) + (#x8FC6A2 #x6B82) + (#x8FC6A3 #x6B85) + (#x8FC6A4 #x6B97) + (#x8FC6A5 #x6B9B) + (#x8FC6A6 #x6B9F) + (#x8FC6A7 #x6BA0) + (#x8FC6A8 #x6BA2) + (#x8FC6A9 #x6BA3) + (#x8FC6AA #x6BA8) + (#x8FC6AB #x6BA9) + (#x8FC6AC #x6BAC) + (#x8FC6AD #x6BAD) + (#x8FC6AE #x6BAE) + (#x8FC6AF #x6BB0) + (#x8FC6B0 #x6BB8) + (#x8FC6B1 #x6BB9) + (#x8FC6B2 #x6BBD) + (#x8FC6B3 #x6BBE) + (#x8FC6B4 #x6BC3) + (#x8FC6B5 #x6BC4) + (#x8FC6B6 #x6BC9) + (#x8FC6B7 #x6BCC) + (#x8FC6B8 #x6BD6) + (#x8FC6B9 #x6BDA) + (#x8FC6BA #x6BE1) + (#x8FC6BB #x6BE3) + (#x8FC6BC #x6BE6) + (#x8FC6BD #x6BE7) + (#x8FC6BE #x6BEE) + (#x8FC6BF #x6BF1) + (#x8FC6C0 #x6BF7) + (#x8FC6C1 #x6BF9) + (#x8FC6C2 #x6BFF) + (#x8FC6C3 #x6C02) + (#x8FC6C4 #x6C04) + (#x8FC6C5 #x6C05) + (#x8FC6C6 #x6C09) + (#x8FC6C7 #x6C0D) + (#x8FC6C8 #x6C0E) + (#x8FC6C9 #x6C10) + (#x8FC6CA #x6C12) + (#x8FC6CB #x6C19) + (#x8FC6CC #x6C1F) + (#x8FC6CD #x6C26) + (#x8FC6CE #x6C27) + (#x8FC6CF #x6C28) + (#x8FC6D0 #x6C2C) + (#x8FC6D1 #x6C2E) + (#x8FC6D2 #x6C33) + (#x8FC6D3 #x6C35) + (#x8FC6D4 #x6C36) + (#x8FC6D5 #x6C3A) + (#x8FC6D6 #x6C3B) + (#x8FC6D7 #x6C3F) + (#x8FC6D8 #x6C4A) + (#x8FC6D9 #x6C4B) + (#x8FC6DA #x6C4D) + (#x8FC6DB #x6C4F) + (#x8FC6DC #x6C52) + (#x8FC6DD #x6C54) + (#x8FC6DE #x6C59) + (#x8FC6DF #x6C5B) + (#x8FC6E0 #x6C5C) + (#x8FC6E1 #x6C6B) + (#x8FC6E2 #x6C6D) + (#x8FC6E3 #x6C6F) + (#x8FC6E4 #x6C74) + (#x8FC6E5 #x6C76) + (#x8FC6E6 #x6C78) + (#x8FC6E7 #x6C79) + (#x8FC6E8 #x6C7B) + (#x8FC6E9 #x6C85) + (#x8FC6EA #x6C86) + (#x8FC6EB #x6C87) + (#x8FC6EC #x6C89) + (#x8FC6ED #x6C94) + (#x8FC6EE #x6C95) + (#x8FC6EF #x6C97) + (#x8FC6F0 #x6C98) + (#x8FC6F1 #x6C9C) + (#x8FC6F2 #x6C9F) + (#x8FC6F3 #x6CB0) + (#x8FC6F4 #x6CB2) + (#x8FC6F5 #x6CB4) + (#x8FC6F6 #x6CC2) + (#x8FC6F7 #x6CC6) + (#x8FC6F8 #x6CCD) + (#x8FC6F9 #x6CCF) + (#x8FC6FA #x6CD0) + (#x8FC6FB #x6CD1) + (#x8FC6FC #x6CD2) + (#x8FC6FD #x6CD4) + (#x8FC6FE #x6CD6) + (#x8FC7A1 #x6CDA) + (#x8FC7A2 #x6CDC) + (#x8FC7A3 #x6CE0) + (#x8FC7A4 #x6CE7) + (#x8FC7A5 #x6CE9) + (#x8FC7A6 #x6CEB) + (#x8FC7A7 #x6CEC) + (#x8FC7A8 #x6CEE) + (#x8FC7A9 #x6CF2) + (#x8FC7AA #x6CF4) + (#x8FC7AB #x6D04) + (#x8FC7AC #x6D07) + (#x8FC7AD #x6D0A) + (#x8FC7AE #x6D0E) + (#x8FC7AF #x6D0F) + (#x8FC7B0 #x6D11) + (#x8FC7B1 #x6D13) + (#x8FC7B2 #x6D1A) + (#x8FC7B3 #x6D26) + (#x8FC7B4 #x6D27) + (#x8FC7B5 #x6D28) + (#x8FC7B6 #x6C67) + (#x8FC7B7 #x6D2E) + (#x8FC7B8 #x6D2F) + (#x8FC7B9 #x6D31) + (#x8FC7BA #x6D39) + (#x8FC7BB #x6D3C) + (#x8FC7BC #x6D3F) + (#x8FC7BD #x6D57) + (#x8FC7BE #x6D5E) + (#x8FC7BF #x6D5F) + (#x8FC7C0 #x6D61) + (#x8FC7C1 #x6D65) + (#x8FC7C2 #x6D67) + (#x8FC7C3 #x6D6F) + (#x8FC7C4 #x6D70) + (#x8FC7C5 #x6D7C) + (#x8FC7C6 #x6D82) + (#x8FC7C7 #x6D87) + (#x8FC7C8 #x6D91) + (#x8FC7C9 #x6D92) + (#x8FC7CA #x6D94) + (#x8FC7CB #x6D96) + (#x8FC7CC #x6D97) + (#x8FC7CD #x6D98) + (#x8FC7CE #x6DAA) + (#x8FC7CF #x6DAC) + (#x8FC7D0 #x6DB4) + (#x8FC7D1 #x6DB7) + (#x8FC7D2 #x6DB9) + (#x8FC7D3 #x6DBD) + (#x8FC7D4 #x6DBF) + (#x8FC7D5 #x6DC4) + (#x8FC7D6 #x6DC8) + (#x8FC7D7 #x6DCA) + (#x8FC7D8 #x6DCE) + (#x8FC7D9 #x6DCF) + (#x8FC7DA #x6DD6) + (#x8FC7DB #x6DDB) + (#x8FC7DC #x6DDD) + (#x8FC7DD #x6DDF) + (#x8FC7DE #x6DE0) + (#x8FC7DF #x6DE2) + (#x8FC7E0 #x6DE5) + (#x8FC7E1 #x6DE9) + (#x8FC7E2 #x6DEF) + (#x8FC7E3 #x6DF0) + (#x8FC7E4 #x6DF4) + (#x8FC7E5 #x6DF6) + (#x8FC7E6 #x6DFC) + (#x8FC7E7 #x6E00) + (#x8FC7E8 #x6E04) + (#x8FC7E9 #x6E1E) + (#x8FC7EA #x6E22) + (#x8FC7EB #x6E27) + (#x8FC7EC #x6E32) + (#x8FC7ED #x6E36) + (#x8FC7EE #x6E39) + (#x8FC7EF #x6E3B) + (#x8FC7F0 #x6E3C) + (#x8FC7F1 #x6E44) + (#x8FC7F2 #x6E45) + (#x8FC7F3 #x6E48) + (#x8FC7F4 #x6E49) + (#x8FC7F5 #x6E4B) + (#x8FC7F6 #x6E4F) + (#x8FC7F7 #x6E51) + (#x8FC7F8 #x6E52) + (#x8FC7F9 #x6E53) + (#x8FC7FA #x6E54) + (#x8FC7FB #x6E57) + (#x8FC7FC #x6E5C) + (#x8FC7FD #x6E5D) + (#x8FC7FE #x6E5E) + (#x8FC8A1 #x6E62) + (#x8FC8A2 #x6E63) + (#x8FC8A3 #x6E68) + (#x8FC8A4 #x6E73) + (#x8FC8A5 #x6E7B) + (#x8FC8A6 #x6E7D) + (#x8FC8A7 #x6E8D) + (#x8FC8A8 #x6E93) + (#x8FC8A9 #x6E99) + (#x8FC8AA #x6EA0) + (#x8FC8AB #x6EA7) + (#x8FC8AC #x6EAD) + (#x8FC8AD #x6EAE) + (#x8FC8AE #x6EB1) + (#x8FC8AF #x6EB3) + (#x8FC8B0 #x6EBB) + (#x8FC8B1 #x6EBF) + (#x8FC8B2 #x6EC0) + (#x8FC8B3 #x6EC1) + (#x8FC8B4 #x6EC3) + (#x8FC8B5 #x6EC7) + (#x8FC8B6 #x6EC8) + (#x8FC8B7 #x6ECA) + (#x8FC8B8 #x6ECD) + (#x8FC8B9 #x6ECE) + (#x8FC8BA #x6ECF) + (#x8FC8BB #x6EEB) + (#x8FC8BC #x6EED) + (#x8FC8BD #x6EEE) + (#x8FC8BE #x6EF9) + (#x8FC8BF #x6EFB) + (#x8FC8C0 #x6EFD) + (#x8FC8C1 #x6F04) + (#x8FC8C2 #x6F08) + (#x8FC8C3 #x6F0A) + (#x8FC8C4 #x6F0C) + (#x8FC8C5 #x6F0D) + (#x8FC8C6 #x6F16) + (#x8FC8C7 #x6F18) + (#x8FC8C8 #x6F1A) + (#x8FC8C9 #x6F1B) + (#x8FC8CA #x6F26) + (#x8FC8CB #x6F29) + (#x8FC8CC #x6F2A) + (#x8FC8CD #x6F2F) + (#x8FC8CE #x6F30) + (#x8FC8CF #x6F33) + (#x8FC8D0 #x6F36) + (#x8FC8D1 #x6F3B) + (#x8FC8D2 #x6F3C) + (#x8FC8D3 #x6F2D) + (#x8FC8D4 #x6F4F) + (#x8FC8D5 #x6F51) + (#x8FC8D6 #x6F52) + (#x8FC8D7 #x6F53) + (#x8FC8D8 #x6F57) + (#x8FC8D9 #x6F59) + (#x8FC8DA #x6F5A) + (#x8FC8DB #x6F5D) + (#x8FC8DC #x6F5E) + (#x8FC8DD #x6F61) + (#x8FC8DE #x6F62) + (#x8FC8DF #x6F68) + (#x8FC8E0 #x6F6C) + (#x8FC8E1 #x6F7D) + (#x8FC8E2 #x6F7E) + (#x8FC8E3 #x6F83) + (#x8FC8E4 #x6F87) + (#x8FC8E5 #x6F88) + (#x8FC8E6 #x6F8B) + (#x8FC8E7 #x6F8C) + (#x8FC8E8 #x6F8D) + (#x8FC8E9 #x6F90) + (#x8FC8EA #x6F92) + (#x8FC8EB #x6F93) + (#x8FC8EC #x6F94) + (#x8FC8ED #x6F96) + (#x8FC8EE #x6F9A) + (#x8FC8EF #x6F9F) + (#x8FC8F0 #x6FA0) + (#x8FC8F1 #x6FA5) + (#x8FC8F2 #x6FA6) + (#x8FC8F3 #x6FA7) + (#x8FC8F4 #x6FA8) + (#x8FC8F5 #x6FAE) + (#x8FC8F6 #x6FAF) + (#x8FC8F7 #x6FB0) + (#x8FC8F8 #x6FB5) + (#x8FC8F9 #x6FB6) + (#x8FC8FA #x6FBC) + (#x8FC8FB #x6FC5) + (#x8FC8FC #x6FC7) + (#x8FC8FD #x6FC8) + (#x8FC8FE #x6FCA) + (#x8FC9A1 #x6FDA) + (#x8FC9A2 #x6FDE) + (#x8FC9A3 #x6FE8) + (#x8FC9A4 #x6FE9) + (#x8FC9A5 #x6FF0) + (#x8FC9A6 #x6FF5) + (#x8FC9A7 #x6FF9) + (#x8FC9A8 #x6FFC) + (#x8FC9A9 #x6FFD) + (#x8FC9AA #x7000) + (#x8FC9AB #x7005) + (#x8FC9AC #x7006) + (#x8FC9AD #x7007) + (#x8FC9AE #x700D) + (#x8FC9AF #x7017) + (#x8FC9B0 #x7020) + (#x8FC9B1 #x7023) + (#x8FC9B2 #x702F) + (#x8FC9B3 #x7034) + (#x8FC9B4 #x7037) + (#x8FC9B5 #x7039) + (#x8FC9B6 #x703C) + (#x8FC9B7 #x7043) + (#x8FC9B8 #x7044) + (#x8FC9B9 #x7048) + (#x8FC9BA #x7049) + (#x8FC9BB #x704A) + (#x8FC9BC #x704B) + (#x8FC9BD #x7054) + (#x8FC9BE #x7055) + (#x8FC9BF #x705D) + (#x8FC9C0 #x705E) + (#x8FC9C1 #x704E) + (#x8FC9C2 #x7064) + (#x8FC9C3 #x7065) + (#x8FC9C4 #x706C) + (#x8FC9C5 #x706E) + (#x8FC9C6 #x7075) + (#x8FC9C7 #x7076) + (#x8FC9C8 #x707E) + (#x8FC9C9 #x7081) + (#x8FC9CA #x7085) + (#x8FC9CB #x7086) + (#x8FC9CC #x7094) + (#x8FC9CD #x7095) + (#x8FC9CE #x7096) + (#x8FC9CF #x7097) + (#x8FC9D0 #x7098) + (#x8FC9D1 #x709B) + (#x8FC9D2 #x70A4) + (#x8FC9D3 #x70AB) + (#x8FC9D4 #x70B0) + (#x8FC9D5 #x70B1) + (#x8FC9D6 #x70B4) + (#x8FC9D7 #x70B7) + (#x8FC9D8 #x70CA) + (#x8FC9D9 #x70D1) + (#x8FC9DA #x70D3) + (#x8FC9DB #x70D4) + (#x8FC9DC #x70D5) + (#x8FC9DD #x70D6) + (#x8FC9DE #x70D8) + (#x8FC9DF #x70DC) + (#x8FC9E0 #x70E4) + (#x8FC9E1 #x70FA) + (#x8FC9E2 #x7103) + (#x8FC9E3 #x7104) + (#x8FC9E4 #x7105) + (#x8FC9E5 #x7106) + (#x8FC9E6 #x7107) + (#x8FC9E7 #x710B) + (#x8FC9E8 #x710C) + (#x8FC9E9 #x710F) + (#x8FC9EA #x711E) + (#x8FC9EB #x7120) + (#x8FC9EC #x712B) + (#x8FC9ED #x712D) + (#x8FC9EE #x712F) + (#x8FC9EF #x7130) + (#x8FC9F0 #x7131) + (#x8FC9F1 #x7138) + (#x8FC9F2 #x7141) + (#x8FC9F3 #x7145) + (#x8FC9F4 #x7146) + (#x8FC9F5 #x7147) + (#x8FC9F6 #x714A) + (#x8FC9F7 #x714B) + (#x8FC9F8 #x7150) + (#x8FC9F9 #x7152) + (#x8FC9FA #x7157) + (#x8FC9FB #x715A) + (#x8FC9FC #x715C) + (#x8FC9FD #x715E) + (#x8FC9FE #x7160) + (#x8FCAA1 #x7168) + (#x8FCAA2 #x7179) + (#x8FCAA3 #x7180) + (#x8FCAA4 #x7185) + (#x8FCAA5 #x7187) + (#x8FCAA6 #x718C) + (#x8FCAA7 #x7192) + (#x8FCAA8 #x719A) + (#x8FCAA9 #x719B) + (#x8FCAAA #x71A0) + (#x8FCAAB #x71A2) + (#x8FCAAC #x71AF) + (#x8FCAAD #x71B0) + (#x8FCAAE #x71B2) + (#x8FCAAF #x71B3) + (#x8FCAB0 #x71BA) + (#x8FCAB1 #x71BF) + (#x8FCAB2 #x71C0) + (#x8FCAB3 #x71C1) + (#x8FCAB4 #x71C4) + (#x8FCAB5 #x71CB) + (#x8FCAB6 #x71CC) + (#x8FCAB7 #x71D3) + (#x8FCAB8 #x71D6) + (#x8FCAB9 #x71D9) + (#x8FCABA #x71DA) + (#x8FCABB #x71DC) + (#x8FCABC #x71F8) + (#x8FCABD #x71FE) + (#x8FCABE #x7200) + (#x8FCABF #x7207) + (#x8FCAC0 #x7208) + (#x8FCAC1 #x7209) + (#x8FCAC2 #x7213) + (#x8FCAC3 #x7217) + (#x8FCAC4 #x721A) + (#x8FCAC5 #x721D) + (#x8FCAC6 #x721F) + (#x8FCAC7 #x7224) + (#x8FCAC8 #x722B) + (#x8FCAC9 #x722F) + (#x8FCACA #x7234) + (#x8FCACB #x7238) + (#x8FCACC #x7239) + (#x8FCACD #x7241) + (#x8FCACE #x7242) + (#x8FCACF #x7243) + (#x8FCAD0 #x7245) + (#x8FCAD1 #x724E) + (#x8FCAD2 #x724F) + (#x8FCAD3 #x7250) + (#x8FCAD4 #x7253) + (#x8FCAD5 #x7255) + (#x8FCAD6 #x7256) + (#x8FCAD7 #x725A) + (#x8FCAD8 #x725C) + (#x8FCAD9 #x725E) + (#x8FCADA #x7260) + (#x8FCADB #x7263) + (#x8FCADC #x7268) + (#x8FCADD #x726B) + (#x8FCADE #x726E) + (#x8FCADF #x726F) + (#x8FCAE0 #x7271) + (#x8FCAE1 #x7277) + (#x8FCAE2 #x7278) + (#x8FCAE3 #x727B) + (#x8FCAE4 #x727C) + (#x8FCAE5 #x727F) + (#x8FCAE6 #x7284) + (#x8FCAE7 #x7289) + (#x8FCAE8 #x728D) + (#x8FCAE9 #x728E) + (#x8FCAEA #x7293) + (#x8FCAEB #x729B) + (#x8FCAEC #x72A8) + (#x8FCAED #x72AD) + (#x8FCAEE #x72AE) + (#x8FCAEF #x72B1) + (#x8FCAF0 #x72B4) + (#x8FCAF1 #x72BE) + (#x8FCAF2 #x72C1) + (#x8FCAF3 #x72C7) + (#x8FCAF4 #x72C9) + (#x8FCAF5 #x72CC) + (#x8FCAF6 #x72D5) + (#x8FCAF7 #x72D6) + (#x8FCAF8 #x72D8) + (#x8FCAF9 #x72DF) + (#x8FCAFA #x72E5) + (#x8FCAFB #x72F3) + (#x8FCAFC #x72F4) + (#x8FCAFD #x72FA) + (#x8FCAFE #x72FB) + (#x8FCBA1 #x72FE) + (#x8FCBA2 #x7302) + (#x8FCBA3 #x7304) + (#x8FCBA4 #x7305) + (#x8FCBA5 #x7307) + (#x8FCBA6 #x730B) + (#x8FCBA7 #x730D) + (#x8FCBA8 #x7312) + (#x8FCBA9 #x7313) + (#x8FCBAA #x7318) + (#x8FCBAB #x7319) + (#x8FCBAC #x731E) + (#x8FCBAD #x7322) + (#x8FCBAE #x7324) + (#x8FCBAF #x7327) + (#x8FCBB0 #x7328) + (#x8FCBB1 #x732C) + (#x8FCBB2 #x7331) + (#x8FCBB3 #x7332) + (#x8FCBB4 #x7335) + (#x8FCBB5 #x733A) + (#x8FCBB6 #x733B) + (#x8FCBB7 #x733D) + (#x8FCBB8 #x7343) + (#x8FCBB9 #x734D) + (#x8FCBBA #x7350) + (#x8FCBBB #x7352) + (#x8FCBBC #x7356) + (#x8FCBBD #x7358) + (#x8FCBBE #x735D) + (#x8FCBBF #x735E) + (#x8FCBC0 #x735F) + (#x8FCBC1 #x7360) + (#x8FCBC2 #x7366) + (#x8FCBC3 #x7367) + (#x8FCBC4 #x7369) + (#x8FCBC5 #x736B) + (#x8FCBC6 #x736C) + (#x8FCBC7 #x736E) + (#x8FCBC8 #x736F) + (#x8FCBC9 #x7371) + (#x8FCBCA #x7377) + (#x8FCBCB #x7379) + (#x8FCBCC #x737C) + (#x8FCBCD #x7380) + (#x8FCBCE #x7381) + (#x8FCBCF #x7383) + (#x8FCBD0 #x7385) + (#x8FCBD1 #x7386) + (#x8FCBD2 #x738E) + (#x8FCBD3 #x7390) + (#x8FCBD4 #x7393) + (#x8FCBD5 #x7395) + (#x8FCBD6 #x7397) + (#x8FCBD7 #x7398) + (#x8FCBD8 #x739C) + (#x8FCBD9 #x739E) + (#x8FCBDA #x739F) + (#x8FCBDB #x73A0) + (#x8FCBDC #x73A2) + (#x8FCBDD #x73A5) + (#x8FCBDE #x73A6) + (#x8FCBDF #x73AA) + (#x8FCBE0 #x73AB) + (#x8FCBE1 #x73AD) + (#x8FCBE2 #x73B5) + (#x8FCBE3 #x73B7) + (#x8FCBE4 #x73B9) + (#x8FCBE5 #x73BC) + (#x8FCBE6 #x73BD) + (#x8FCBE7 #x73BF) + (#x8FCBE8 #x73C5) + (#x8FCBE9 #x73C6) + (#x8FCBEA #x73C9) + (#x8FCBEB #x73CB) + (#x8FCBEC #x73CC) + (#x8FCBED #x73CF) + (#x8FCBEE #x73D2) + (#x8FCBEF #x73D3) + (#x8FCBF0 #x73D6) + (#x8FCBF1 #x73D9) + (#x8FCBF2 #x73DD) + (#x8FCBF3 #x73E1) + (#x8FCBF4 #x73E3) + (#x8FCBF5 #x73E6) + (#x8FCBF6 #x73E7) + (#x8FCBF7 #x73E9) + (#x8FCBF8 #x73F4) + (#x8FCBF9 #x73F5) + (#x8FCBFA #x73F7) + (#x8FCBFB #x73F9) + (#x8FCBFC #x73FA) + (#x8FCBFD #x73FB) + (#x8FCBFE #x73FD) + (#x8FCCA1 #x73FF) + (#x8FCCA2 #x7400) + (#x8FCCA3 #x7401) + (#x8FCCA4 #x7404) + (#x8FCCA5 #x7407) + (#x8FCCA6 #x740A) + (#x8FCCA7 #x7411) + (#x8FCCA8 #x741A) + (#x8FCCA9 #x741B) + (#x8FCCAA #x7424) + (#x8FCCAB #x7426) + (#x8FCCAC #x7428) + (#x8FCCAD #x7429) + (#x8FCCAE #x742A) + (#x8FCCAF #x742B) + (#x8FCCB0 #x742C) + (#x8FCCB1 #x742D) + (#x8FCCB2 #x742E) + (#x8FCCB3 #x742F) + (#x8FCCB4 #x7430) + (#x8FCCB5 #x7431) + (#x8FCCB6 #x7439) + (#x8FCCB7 #x7440) + (#x8FCCB8 #x7443) + (#x8FCCB9 #x7444) + (#x8FCCBA #x7446) + (#x8FCCBB #x7447) + (#x8FCCBC #x744B) + (#x8FCCBD #x744D) + (#x8FCCBE #x7451) + (#x8FCCBF #x7452) + (#x8FCCC0 #x7457) + (#x8FCCC1 #x745D) + (#x8FCCC2 #x7462) + (#x8FCCC3 #x7466) + (#x8FCCC4 #x7467) + (#x8FCCC5 #x7468) + (#x8FCCC6 #x746B) + (#x8FCCC7 #x746D) + (#x8FCCC8 #x746E) + (#x8FCCC9 #x7471) + (#x8FCCCA #x7472) + (#x8FCCCB #x7480) + (#x8FCCCC #x7481) + (#x8FCCCD #x7485) + (#x8FCCCE #x7486) + (#x8FCCCF #x7487) + (#x8FCCD0 #x7489) + (#x8FCCD1 #x748F) + (#x8FCCD2 #x7490) + (#x8FCCD3 #x7491) + (#x8FCCD4 #x7492) + (#x8FCCD5 #x7498) + (#x8FCCD6 #x7499) + (#x8FCCD7 #x749A) + (#x8FCCD8 #x749C) + (#x8FCCD9 #x749F) + (#x8FCCDA #x74A0) + (#x8FCCDB #x74A1) + (#x8FCCDC #x74A3) + (#x8FCCDD #x74A6) + (#x8FCCDE #x74A8) + (#x8FCCDF #x74A9) + (#x8FCCE0 #x74AA) + (#x8FCCE1 #x74AB) + (#x8FCCE2 #x74AE) + (#x8FCCE3 #x74AF) + (#x8FCCE4 #x74B1) + (#x8FCCE5 #x74B2) + (#x8FCCE6 #x74B5) + (#x8FCCE7 #x74B9) + (#x8FCCE8 #x74BB) + (#x8FCCE9 #x74BF) + (#x8FCCEA #x74C8) + (#x8FCCEB #x74C9) + (#x8FCCEC #x74CC) + (#x8FCCED #x74D0) + (#x8FCCEE #x74D3) + (#x8FCCEF #x74D8) + (#x8FCCF0 #x74DA) + (#x8FCCF1 #x74DB) + (#x8FCCF2 #x74DE) + (#x8FCCF3 #x74DF) + (#x8FCCF4 #x74E4) + (#x8FCCF5 #x74E8) + (#x8FCCF6 #x74EA) + (#x8FCCF7 #x74EB) + (#x8FCCF8 #x74EF) + (#x8FCCF9 #x74F4) + (#x8FCCFA #x74FA) + (#x8FCCFB #x74FB) + (#x8FCCFC #x74FC) + (#x8FCCFD #x74FF) + (#x8FCCFE #x7506) + (#x8FCDA1 #x7512) + (#x8FCDA2 #x7516) + (#x8FCDA3 #x7517) + (#x8FCDA4 #x7520) + (#x8FCDA5 #x7521) + (#x8FCDA6 #x7524) + (#x8FCDA7 #x7527) + (#x8FCDA8 #x7529) + (#x8FCDA9 #x752A) + (#x8FCDAA #x752F) + (#x8FCDAB #x7536) + (#x8FCDAC #x7539) + (#x8FCDAD #x753D) + (#x8FCDAE #x753E) + (#x8FCDAF #x753F) + (#x8FCDB0 #x7540) + (#x8FCDB1 #x7543) + (#x8FCDB2 #x7547) + (#x8FCDB3 #x7548) + (#x8FCDB4 #x754E) + (#x8FCDB5 #x7550) + (#x8FCDB6 #x7552) + (#x8FCDB7 #x7557) + (#x8FCDB8 #x755E) + (#x8FCDB9 #x755F) + (#x8FCDBA #x7561) + (#x8FCDBB #x756F) + (#x8FCDBC #x7571) + (#x8FCDBD #x7579) + (#x8FCDBE #x757A) + (#x8FCDBF #x757B) + (#x8FCDC0 #x757C) + (#x8FCDC1 #x757D) + (#x8FCDC2 #x757E) + (#x8FCDC3 #x7581) + (#x8FCDC4 #x7585) + (#x8FCDC5 #x7590) + (#x8FCDC6 #x7592) + (#x8FCDC7 #x7593) + (#x8FCDC8 #x7595) + (#x8FCDC9 #x7599) + (#x8FCDCA #x759C) + (#x8FCDCB #x75A2) + (#x8FCDCC #x75A4) + (#x8FCDCD #x75B4) + (#x8FCDCE #x75BA) + (#x8FCDCF #x75BF) + (#x8FCDD0 #x75C0) + (#x8FCDD1 #x75C1) + (#x8FCDD2 #x75C4) + (#x8FCDD3 #x75C6) + (#x8FCDD4 #x75CC) + (#x8FCDD5 #x75CE) + (#x8FCDD6 #x75CF) + (#x8FCDD7 #x75D7) + (#x8FCDD8 #x75DC) + (#x8FCDD9 #x75DF) + (#x8FCDDA #x75E0) + (#x8FCDDB #x75E1) + (#x8FCDDC #x75E4) + (#x8FCDDD #x75E7) + (#x8FCDDE #x75EC) + (#x8FCDDF #x75EE) + (#x8FCDE0 #x75EF) + (#x8FCDE1 #x75F1) + (#x8FCDE2 #x75F9) + (#x8FCDE3 #x7600) + (#x8FCDE4 #x7602) + (#x8FCDE5 #x7603) + (#x8FCDE6 #x7604) + (#x8FCDE7 #x7607) + (#x8FCDE8 #x7608) + (#x8FCDE9 #x760A) + (#x8FCDEA #x760C) + (#x8FCDEB #x760F) + (#x8FCDEC #x7612) + (#x8FCDED #x7613) + (#x8FCDEE #x7615) + (#x8FCDEF #x7616) + (#x8FCDF0 #x7619) + (#x8FCDF1 #x761B) + (#x8FCDF2 #x761C) + (#x8FCDF3 #x761D) + (#x8FCDF4 #x761E) + (#x8FCDF5 #x7623) + (#x8FCDF6 #x7625) + (#x8FCDF7 #x7626) + (#x8FCDF8 #x7629) + (#x8FCDF9 #x762D) + (#x8FCDFA #x7632) + (#x8FCDFB #x7633) + (#x8FCDFC #x7635) + (#x8FCDFD #x7638) + (#x8FCDFE #x7639) + (#x8FCEA1 #x763A) + (#x8FCEA2 #x763C) + (#x8FCEA3 #x764A) + (#x8FCEA4 #x7640) + (#x8FCEA5 #x7641) + (#x8FCEA6 #x7643) + (#x8FCEA7 #x7644) + (#x8FCEA8 #x7645) + (#x8FCEA9 #x7649) + (#x8FCEAA #x764B) + (#x8FCEAB #x7655) + (#x8FCEAC #x7659) + (#x8FCEAD #x765F) + (#x8FCEAE #x7664) + (#x8FCEAF #x7665) + (#x8FCEB0 #x766D) + (#x8FCEB1 #x766E) + (#x8FCEB2 #x766F) + (#x8FCEB3 #x7671) + (#x8FCEB4 #x7674) + (#x8FCEB5 #x7681) + (#x8FCEB6 #x7685) + (#x8FCEB7 #x768C) + (#x8FCEB8 #x768D) + (#x8FCEB9 #x7695) + (#x8FCEBA #x769B) + (#x8FCEBB #x769C) + (#x8FCEBC #x769D) + (#x8FCEBD #x769F) + (#x8FCEBE #x76A0) + (#x8FCEBF #x76A2) + (#x8FCEC0 #x76A3) + (#x8FCEC1 #x76A4) + (#x8FCEC2 #x76A5) + (#x8FCEC3 #x76A6) + (#x8FCEC4 #x76A7) + (#x8FCEC5 #x76A8) + (#x8FCEC6 #x76AA) + (#x8FCEC7 #x76AD) + (#x8FCEC8 #x76BD) + (#x8FCEC9 #x76C1) + (#x8FCECA #x76C5) + (#x8FCECB #x76C9) + (#x8FCECC #x76CB) + (#x8FCECD #x76CC) + (#x8FCECE #x76CE) + (#x8FCECF #x76D4) + (#x8FCED0 #x76D9) + (#x8FCED1 #x76E0) + (#x8FCED2 #x76E6) + (#x8FCED3 #x76E8) + (#x8FCED4 #x76EC) + (#x8FCED5 #x76F0) + (#x8FCED6 #x76F1) + (#x8FCED7 #x76F6) + (#x8FCED8 #x76F9) + (#x8FCED9 #x76FC) + (#x8FCEDA #x7700) + (#x8FCEDB #x7706) + (#x8FCEDC #x770A) + (#x8FCEDD #x770E) + (#x8FCEDE #x7712) + (#x8FCEDF #x7714) + (#x8FCEE0 #x7715) + (#x8FCEE1 #x7717) + (#x8FCEE2 #x7719) + (#x8FCEE3 #x771A) + (#x8FCEE4 #x771C) + (#x8FCEE5 #x7722) + (#x8FCEE6 #x7728) + (#x8FCEE7 #x772D) + (#x8FCEE8 #x772E) + (#x8FCEE9 #x772F) + (#x8FCEEA #x7734) + (#x8FCEEB #x7735) + (#x8FCEEC #x7736) + (#x8FCEED #x7739) + (#x8FCEEE #x773D) + (#x8FCEEF #x773E) + (#x8FCEF0 #x7742) + (#x8FCEF1 #x7745) + (#x8FCEF2 #x7746) + (#x8FCEF3 #x774A) + (#x8FCEF4 #x774D) + (#x8FCEF5 #x774E) + (#x8FCEF6 #x774F) + (#x8FCEF7 #x7752) + (#x8FCEF8 #x7756) + (#x8FCEF9 #x7757) + (#x8FCEFA #x775C) + (#x8FCEFB #x775E) + (#x8FCEFC #x775F) + (#x8FCEFD #x7760) + (#x8FCEFE #x7762) + (#x8FCFA1 #x7764) + (#x8FCFA2 #x7767) + (#x8FCFA3 #x776A) + (#x8FCFA4 #x776C) + (#x8FCFA5 #x7770) + (#x8FCFA6 #x7772) + (#x8FCFA7 #x7773) + (#x8FCFA8 #x7774) + (#x8FCFA9 #x777A) + (#x8FCFAA #x777D) + (#x8FCFAB #x7780) + (#x8FCFAC #x7784) + (#x8FCFAD #x778C) + (#x8FCFAE #x778D) + (#x8FCFAF #x7794) + (#x8FCFB0 #x7795) + (#x8FCFB1 #x7796) + (#x8FCFB2 #x779A) + (#x8FCFB3 #x779F) + (#x8FCFB4 #x77A2) + (#x8FCFB5 #x77A7) + (#x8FCFB6 #x77AA) + (#x8FCFB7 #x77AE) + (#x8FCFB8 #x77AF) + (#x8FCFB9 #x77B1) + (#x8FCFBA #x77B5) + (#x8FCFBB #x77BE) + (#x8FCFBC #x77C3) + (#x8FCFBD #x77C9) + (#x8FCFBE #x77D1) + (#x8FCFBF #x77D2) + (#x8FCFC0 #x77D5) + (#x8FCFC1 #x77D9) + (#x8FCFC2 #x77DE) + (#x8FCFC3 #x77DF) + (#x8FCFC4 #x77E0) + (#x8FCFC5 #x77E4) + (#x8FCFC6 #x77E6) + (#x8FCFC7 #x77EA) + (#x8FCFC8 #x77EC) + (#x8FCFC9 #x77F0) + (#x8FCFCA #x77F1) + (#x8FCFCB #x77F4) + (#x8FCFCC #x77F8) + (#x8FCFCD #x77FB) + (#x8FCFCE #x7805) + (#x8FCFCF #x7806) + (#x8FCFD0 #x7809) + (#x8FCFD1 #x780D) + (#x8FCFD2 #x780E) + (#x8FCFD3 #x7811) + (#x8FCFD4 #x781D) + (#x8FCFD5 #x7821) + (#x8FCFD6 #x7822) + (#x8FCFD7 #x7823) + (#x8FCFD8 #x782D) + (#x8FCFD9 #x782E) + (#x8FCFDA #x7830) + (#x8FCFDB #x7835) + (#x8FCFDC #x7837) + (#x8FCFDD #x7843) + (#x8FCFDE #x7844) + (#x8FCFDF #x7847) + (#x8FCFE0 #x7848) + (#x8FCFE1 #x784C) + (#x8FCFE2 #x784E) + (#x8FCFE3 #x7852) + (#x8FCFE4 #x785C) + (#x8FCFE5 #x785E) + (#x8FCFE6 #x7860) + (#x8FCFE7 #x7861) + (#x8FCFE8 #x7863) + (#x8FCFE9 #x7864) + (#x8FCFEA #x7868) + (#x8FCFEB #x786A) + (#x8FCFEC #x786E) + (#x8FCFED #x787A) + (#x8FCFEE #x787E) + (#x8FCFEF #x788A) + (#x8FCFF0 #x788F) + (#x8FCFF1 #x7894) + (#x8FCFF2 #x7898) + (#x8FCFF3 #x78A1) + (#x8FCFF4 #x789D) + (#x8FCFF5 #x789E) + (#x8FCFF6 #x789F) + (#x8FCFF7 #x78A4) + (#x8FCFF8 #x78A8) + (#x8FCFF9 #x78AC) + (#x8FCFFA #x78AD) + (#x8FCFFB #x78B0) + (#x8FCFFC #x78B1) + (#x8FCFFD #x78B2) + (#x8FCFFE #x78B3) + (#x8FD0A1 #x78BB) + (#x8FD0A2 #x78BD) + (#x8FD0A3 #x78BF) + (#x8FD0A4 #x78C7) + (#x8FD0A5 #x78C8) + (#x8FD0A6 #x78C9) + (#x8FD0A7 #x78CC) + (#x8FD0A8 #x78CE) + (#x8FD0A9 #x78D2) + (#x8FD0AA #x78D3) + (#x8FD0AB #x78D5) + (#x8FD0AC #x78D6) + (#x8FD0AD #x78E4) + (#x8FD0AE #x78DB) + (#x8FD0AF #x78DF) + (#x8FD0B0 #x78E0) + (#x8FD0B1 #x78E1) + (#x8FD0B2 #x78E6) + (#x8FD0B3 #x78EA) + (#x8FD0B4 #x78F2) + (#x8FD0B5 #x78F3) + (#x8FD0B6 #x7900) + (#x8FD0B7 #x78F6) + (#x8FD0B8 #x78F7) + (#x8FD0B9 #x78FA) + (#x8FD0BA #x78FB) + (#x8FD0BB #x78FF) + (#x8FD0BC #x7906) + (#x8FD0BD #x790C) + (#x8FD0BE #x7910) + (#x8FD0BF #x791A) + (#x8FD0C0 #x791C) + (#x8FD0C1 #x791E) + (#x8FD0C2 #x791F) + (#x8FD0C3 #x7920) + (#x8FD0C4 #x7925) + (#x8FD0C5 #x7927) + (#x8FD0C6 #x7929) + (#x8FD0C7 #x792D) + (#x8FD0C8 #x7931) + (#x8FD0C9 #x7934) + (#x8FD0CA #x7935) + (#x8FD0CB #x793B) + (#x8FD0CC #x793D) + (#x8FD0CD #x793F) + (#x8FD0CE #x7944) + (#x8FD0CF #x7945) + (#x8FD0D0 #x7946) + (#x8FD0D1 #x794A) + (#x8FD0D2 #x794B) + (#x8FD0D3 #x794F) + (#x8FD0D4 #x7951) + (#x8FD0D5 #x7954) + (#x8FD0D6 #x7958) + (#x8FD0D7 #x795B) + (#x8FD0D8 #x795C) + (#x8FD0D9 #x7967) + (#x8FD0DA #x7969) + (#x8FD0DB #x796B) + (#x8FD0DC #x7972) + (#x8FD0DD #x7979) + (#x8FD0DE #x797B) + (#x8FD0DF #x797C) + (#x8FD0E0 #x797E) + (#x8FD0E1 #x798B) + (#x8FD0E2 #x798C) + (#x8FD0E3 #x7991) + (#x8FD0E4 #x7993) + (#x8FD0E5 #x7994) + (#x8FD0E6 #x7995) + (#x8FD0E7 #x7996) + (#x8FD0E8 #x7998) + (#x8FD0E9 #x799B) + (#x8FD0EA #x799C) + (#x8FD0EB #x79A1) + (#x8FD0EC #x79A8) + (#x8FD0ED #x79A9) + (#x8FD0EE #x79AB) + (#x8FD0EF #x79AF) + (#x8FD0F0 #x79B1) + (#x8FD0F1 #x79B4) + (#x8FD0F2 #x79B8) + (#x8FD0F3 #x79BB) + (#x8FD0F4 #x79C2) + (#x8FD0F5 #x79C4) + (#x8FD0F6 #x79C7) + (#x8FD0F7 #x79C8) + (#x8FD0F8 #x79CA) + (#x8FD0F9 #x79CF) + (#x8FD0FA #x79D4) + (#x8FD0FB #x79D6) + (#x8FD0FC #x79DA) + (#x8FD0FD #x79DD) + (#x8FD0FE #x79DE) + (#x8FD1A1 #x79E0) + (#x8FD1A2 #x79E2) + (#x8FD1A3 #x79E5) + (#x8FD1A4 #x79EA) + (#x8FD1A5 #x79EB) + (#x8FD1A6 #x79ED) + (#x8FD1A7 #x79F1) + (#x8FD1A8 #x79F8) + (#x8FD1A9 #x79FC) + (#x8FD1AA #x7A02) + (#x8FD1AB #x7A03) + (#x8FD1AC #x7A07) + (#x8FD1AD #x7A09) + (#x8FD1AE #x7A0A) + (#x8FD1AF #x7A0C) + (#x8FD1B0 #x7A11) + (#x8FD1B1 #x7A15) + (#x8FD1B2 #x7A1B) + (#x8FD1B3 #x7A1E) + (#x8FD1B4 #x7A21) + (#x8FD1B5 #x7A27) + (#x8FD1B6 #x7A2B) + (#x8FD1B7 #x7A2D) + (#x8FD1B8 #x7A2F) + (#x8FD1B9 #x7A30) + (#x8FD1BA #x7A34) + (#x8FD1BB #x7A35) + (#x8FD1BC #x7A38) + (#x8FD1BD #x7A39) + (#x8FD1BE #x7A3A) + (#x8FD1BF #x7A44) + (#x8FD1C0 #x7A45) + (#x8FD1C1 #x7A47) + (#x8FD1C2 #x7A48) + (#x8FD1C3 #x7A4C) + (#x8FD1C4 #x7A55) + (#x8FD1C5 #x7A56) + (#x8FD1C6 #x7A59) + (#x8FD1C7 #x7A5C) + (#x8FD1C8 #x7A5D) + (#x8FD1C9 #x7A5F) + (#x8FD1CA #x7A60) + (#x8FD1CB #x7A65) + (#x8FD1CC #x7A67) + (#x8FD1CD #x7A6A) + (#x8FD1CE #x7A6D) + (#x8FD1CF #x7A75) + (#x8FD1D0 #x7A78) + (#x8FD1D1 #x7A7E) + (#x8FD1D2 #x7A80) + (#x8FD1D3 #x7A82) + (#x8FD1D4 #x7A85) + (#x8FD1D5 #x7A86) + (#x8FD1D6 #x7A8A) + (#x8FD1D7 #x7A8B) + (#x8FD1D8 #x7A90) + (#x8FD1D9 #x7A91) + (#x8FD1DA #x7A94) + (#x8FD1DB #x7A9E) + (#x8FD1DC #x7AA0) + (#x8FD1DD #x7AA3) + (#x8FD1DE #x7AAC) + (#x8FD1DF #x7AB3) + (#x8FD1E0 #x7AB5) + (#x8FD1E1 #x7AB9) + (#x8FD1E2 #x7ABB) + (#x8FD1E3 #x7ABC) + (#x8FD1E4 #x7AC6) + (#x8FD1E5 #x7AC9) + (#x8FD1E6 #x7ACC) + (#x8FD1E7 #x7ACE) + (#x8FD1E8 #x7AD1) + (#x8FD1E9 #x7ADB) + (#x8FD1EA #x7AE8) + (#x8FD1EB #x7AE9) + (#x8FD1EC #x7AEB) + (#x8FD1ED #x7AEC) + (#x8FD1EE #x7AF1) + (#x8FD1EF #x7AF4) + (#x8FD1F0 #x7AFB) + (#x8FD1F1 #x7AFD) + (#x8FD1F2 #x7AFE) + (#x8FD1F3 #x7B07) + (#x8FD1F4 #x7B14) + (#x8FD1F5 #x7B1F) + (#x8FD1F6 #x7B23) + (#x8FD1F7 #x7B27) + (#x8FD1F8 #x7B29) + (#x8FD1F9 #x7B2A) + (#x8FD1FA #x7B2B) + (#x8FD1FB #x7B2D) + (#x8FD1FC #x7B2E) + (#x8FD1FD #x7B2F) + (#x8FD1FE #x7B30) + (#x8FD2A1 #x7B31) + (#x8FD2A2 #x7B34) + (#x8FD2A3 #x7B3D) + (#x8FD2A4 #x7B3F) + (#x8FD2A5 #x7B40) + (#x8FD2A6 #x7B41) + (#x8FD2A7 #x7B47) + (#x8FD2A8 #x7B4E) + (#x8FD2A9 #x7B55) + (#x8FD2AA #x7B60) + (#x8FD2AB #x7B64) + (#x8FD2AC #x7B66) + (#x8FD2AD #x7B69) + (#x8FD2AE #x7B6A) + (#x8FD2AF #x7B6D) + (#x8FD2B0 #x7B6F) + (#x8FD2B1 #x7B72) + (#x8FD2B2 #x7B73) + (#x8FD2B3 #x7B77) + (#x8FD2B4 #x7B84) + (#x8FD2B5 #x7B89) + (#x8FD2B6 #x7B8E) + (#x8FD2B7 #x7B90) + (#x8FD2B8 #x7B91) + (#x8FD2B9 #x7B96) + (#x8FD2BA #x7B9B) + (#x8FD2BB #x7B9E) + (#x8FD2BC #x7BA0) + (#x8FD2BD #x7BA5) + (#x8FD2BE #x7BAC) + (#x8FD2BF #x7BAF) + (#x8FD2C0 #x7BB0) + (#x8FD2C1 #x7BB2) + (#x8FD2C2 #x7BB5) + (#x8FD2C3 #x7BB6) + (#x8FD2C4 #x7BBA) + (#x8FD2C5 #x7BBB) + (#x8FD2C6 #x7BBC) + (#x8FD2C7 #x7BBD) + (#x8FD2C8 #x7BC2) + (#x8FD2C9 #x7BC5) + (#x8FD2CA #x7BC8) + (#x8FD2CB #x7BCA) + (#x8FD2CC #x7BD4) + (#x8FD2CD #x7BD6) + (#x8FD2CE #x7BD7) + (#x8FD2CF #x7BD9) + (#x8FD2D0 #x7BDA) + (#x8FD2D1 #x7BDB) + (#x8FD2D2 #x7BE8) + (#x8FD2D3 #x7BEA) + (#x8FD2D4 #x7BF2) + (#x8FD2D5 #x7BF4) + (#x8FD2D6 #x7BF5) + (#x8FD2D7 #x7BF8) + (#x8FD2D8 #x7BF9) + (#x8FD2D9 #x7BFA) + (#x8FD2DA #x7BFC) + (#x8FD2DB #x7BFE) + (#x8FD2DC #x7C01) + (#x8FD2DD #x7C02) + (#x8FD2DE #x7C03) + (#x8FD2DF #x7C04) + (#x8FD2E0 #x7C06) + (#x8FD2E1 #x7C09) + (#x8FD2E2 #x7C0B) + (#x8FD2E3 #x7C0C) + (#x8FD2E4 #x7C0E) + (#x8FD2E5 #x7C0F) + (#x8FD2E6 #x7C19) + (#x8FD2E7 #x7C1B) + (#x8FD2E8 #x7C20) + (#x8FD2E9 #x7C25) + (#x8FD2EA #x7C26) + (#x8FD2EB #x7C28) + (#x8FD2EC #x7C2C) + (#x8FD2ED #x7C31) + (#x8FD2EE #x7C33) + (#x8FD2EF #x7C34) + (#x8FD2F0 #x7C36) + (#x8FD2F1 #x7C39) + (#x8FD2F2 #x7C3A) + (#x8FD2F3 #x7C46) + (#x8FD2F4 #x7C4A) + (#x8FD2F5 #x7C55) + (#x8FD2F6 #x7C51) + (#x8FD2F7 #x7C52) + (#x8FD2F8 #x7C53) + (#x8FD2F9 #x7C59) + (#x8FD2FA #x7C5A) + (#x8FD2FB #x7C5B) + (#x8FD2FC #x7C5C) + (#x8FD2FD #x7C5D) + (#x8FD2FE #x7C5E) + (#x8FD3A1 #x7C61) + (#x8FD3A2 #x7C63) + (#x8FD3A3 #x7C67) + (#x8FD3A4 #x7C69) + (#x8FD3A5 #x7C6D) + (#x8FD3A6 #x7C6E) + (#x8FD3A7 #x7C70) + (#x8FD3A8 #x7C72) + (#x8FD3A9 #x7C79) + (#x8FD3AA #x7C7C) + (#x8FD3AB #x7C7D) + (#x8FD3AC #x7C86) + (#x8FD3AD #x7C87) + (#x8FD3AE #x7C8F) + (#x8FD3AF #x7C94) + (#x8FD3B0 #x7C9E) + (#x8FD3B1 #x7CA0) + (#x8FD3B2 #x7CA6) + (#x8FD3B3 #x7CB0) + (#x8FD3B4 #x7CB6) + (#x8FD3B5 #x7CB7) + (#x8FD3B6 #x7CBA) + (#x8FD3B7 #x7CBB) + (#x8FD3B8 #x7CBC) + (#x8FD3B9 #x7CBF) + (#x8FD3BA #x7CC4) + (#x8FD3BB #x7CC7) + (#x8FD3BC #x7CC8) + (#x8FD3BD #x7CC9) + (#x8FD3BE #x7CCD) + (#x8FD3BF #x7CCF) + (#x8FD3C0 #x7CD3) + (#x8FD3C1 #x7CD4) + (#x8FD3C2 #x7CD5) + (#x8FD3C3 #x7CD7) + (#x8FD3C4 #x7CD9) + (#x8FD3C5 #x7CDA) + (#x8FD3C6 #x7CDD) + (#x8FD3C7 #x7CE6) + (#x8FD3C8 #x7CE9) + (#x8FD3C9 #x7CEB) + (#x8FD3CA #x7CF5) + (#x8FD3CB #x7D03) + (#x8FD3CC #x7D07) + (#x8FD3CD #x7D08) + (#x8FD3CE #x7D09) + (#x8FD3CF #x7D0F) + (#x8FD3D0 #x7D11) + (#x8FD3D1 #x7D12) + (#x8FD3D2 #x7D13) + (#x8FD3D3 #x7D16) + (#x8FD3D4 #x7D1D) + (#x8FD3D5 #x7D1E) + (#x8FD3D6 #x7D23) + (#x8FD3D7 #x7D26) + (#x8FD3D8 #x7D2A) + (#x8FD3D9 #x7D2D) + (#x8FD3DA #x7D31) + (#x8FD3DB #x7D3C) + (#x8FD3DC #x7D3D) + (#x8FD3DD #x7D3E) + (#x8FD3DE #x7D40) + (#x8FD3DF #x7D41) + (#x8FD3E0 #x7D47) + (#x8FD3E1 #x7D48) + (#x8FD3E2 #x7D4D) + (#x8FD3E3 #x7D51) + (#x8FD3E4 #x7D53) + (#x8FD3E5 #x7D57) + (#x8FD3E6 #x7D59) + (#x8FD3E7 #x7D5A) + (#x8FD3E8 #x7D5C) + (#x8FD3E9 #x7D5D) + (#x8FD3EA #x7D65) + (#x8FD3EB #x7D67) + (#x8FD3EC #x7D6A) + (#x8FD3ED #x7D70) + (#x8FD3EE #x7D78) + (#x8FD3EF #x7D7A) + (#x8FD3F0 #x7D7B) + (#x8FD3F1 #x7D7F) + (#x8FD3F2 #x7D81) + (#x8FD3F3 #x7D82) + (#x8FD3F4 #x7D83) + (#x8FD3F5 #x7D85) + (#x8FD3F6 #x7D86) + (#x8FD3F7 #x7D88) + (#x8FD3F8 #x7D8B) + (#x8FD3F9 #x7D8C) + (#x8FD3FA #x7D8D) + (#x8FD3FB #x7D91) + (#x8FD3FC #x7D96) + (#x8FD3FD #x7D97) + (#x8FD3FE #x7D9D) + (#x8FD4A1 #x7D9E) + (#x8FD4A2 #x7DA6) + (#x8FD4A3 #x7DA7) + (#x8FD4A4 #x7DAA) + (#x8FD4A5 #x7DB3) + (#x8FD4A6 #x7DB6) + (#x8FD4A7 #x7DB7) + (#x8FD4A8 #x7DB9) + (#x8FD4A9 #x7DC2) + (#x8FD4AA #x7DC3) + (#x8FD4AB #x7DC4) + (#x8FD4AC #x7DC5) + (#x8FD4AD #x7DC6) + (#x8FD4AE #x7DCC) + (#x8FD4AF #x7DCD) + (#x8FD4B0 #x7DCE) + (#x8FD4B1 #x7DD7) + (#x8FD4B2 #x7DD9) + (#x8FD4B3 #x7E00) + (#x8FD4B4 #x7DE2) + (#x8FD4B5 #x7DE5) + (#x8FD4B6 #x7DE6) + (#x8FD4B7 #x7DEA) + (#x8FD4B8 #x7DEB) + (#x8FD4B9 #x7DED) + (#x8FD4BA #x7DF1) + (#x8FD4BB #x7DF5) + (#x8FD4BC #x7DF6) + (#x8FD4BD #x7DF9) + (#x8FD4BE #x7DFA) + (#x8FD4BF #x7E08) + (#x8FD4C0 #x7E10) + (#x8FD4C1 #x7E11) + (#x8FD4C2 #x7E15) + (#x8FD4C3 #x7E17) + (#x8FD4C4 #x7E1C) + (#x8FD4C5 #x7E1D) + (#x8FD4C6 #x7E20) + (#x8FD4C7 #x7E27) + (#x8FD4C8 #x7E28) + (#x8FD4C9 #x7E2C) + (#x8FD4CA #x7E2D) + (#x8FD4CB #x7E2F) + (#x8FD4CC #x7E33) + (#x8FD4CD #x7E36) + (#x8FD4CE #x7E3F) + (#x8FD4CF #x7E44) + (#x8FD4D0 #x7E45) + (#x8FD4D1 #x7E47) + (#x8FD4D2 #x7E4E) + (#x8FD4D3 #x7E50) + (#x8FD4D4 #x7E52) + (#x8FD4D5 #x7E58) + (#x8FD4D6 #x7E5F) + (#x8FD4D7 #x7E61) + (#x8FD4D8 #x7E62) + (#x8FD4D9 #x7E65) + (#x8FD4DA #x7E6B) + (#x8FD4DB #x7E6E) + (#x8FD4DC #x7E6F) + (#x8FD4DD #x7E73) + (#x8FD4DE #x7E78) + (#x8FD4DF #x7E7E) + (#x8FD4E0 #x7E81) + (#x8FD4E1 #x7E86) + (#x8FD4E2 #x7E87) + (#x8FD4E3 #x7E8A) + (#x8FD4E4 #x7E8D) + (#x8FD4E5 #x7E91) + (#x8FD4E6 #x7E95) + (#x8FD4E7 #x7E98) + (#x8FD4E8 #x7E9A) + (#x8FD4E9 #x7E9D) + (#x8FD4EA #x7E9E) + (#x8FD4EB #x7F3C) + (#x8FD4EC #x7F3B) + (#x8FD4ED #x7F3D) + (#x8FD4EE #x7F3E) + (#x8FD4EF #x7F3F) + (#x8FD4F0 #x7F43) + (#x8FD4F1 #x7F44) + (#x8FD4F2 #x7F47) + (#x8FD4F3 #x7F4F) + (#x8FD4F4 #x7F52) + (#x8FD4F5 #x7F53) + (#x8FD4F6 #x7F5B) + (#x8FD4F7 #x7F5C) + (#x8FD4F8 #x7F5D) + (#x8FD4F9 #x7F61) + (#x8FD4FA #x7F63) + (#x8FD4FB #x7F64) + (#x8FD4FC #x7F65) + (#x8FD4FD #x7F66) + (#x8FD4FE #x7F6D) + (#x8FD5A1 #x7F71) + (#x8FD5A2 #x7F7D) + (#x8FD5A3 #x7F7E) + (#x8FD5A4 #x7F7F) + (#x8FD5A5 #x7F80) + (#x8FD5A6 #x7F8B) + (#x8FD5A7 #x7F8D) + (#x8FD5A8 #x7F8F) + (#x8FD5A9 #x7F90) + (#x8FD5AA #x7F91) + (#x8FD5AB #x7F96) + (#x8FD5AC #x7F97) + (#x8FD5AD #x7F9C) + (#x8FD5AE #x7FA1) + (#x8FD5AF #x7FA2) + (#x8FD5B0 #x7FA6) + (#x8FD5B1 #x7FAA) + (#x8FD5B2 #x7FAD) + (#x8FD5B3 #x7FB4) + (#x8FD5B4 #x7FBC) + (#x8FD5B5 #x7FBF) + (#x8FD5B6 #x7FC0) + (#x8FD5B7 #x7FC3) + (#x8FD5B8 #x7FC8) + (#x8FD5B9 #x7FCE) + (#x8FD5BA #x7FCF) + (#x8FD5BB #x7FDB) + (#x8FD5BC #x7FDF) + (#x8FD5BD #x7FE3) + (#x8FD5BE #x7FE5) + (#x8FD5BF #x7FE8) + (#x8FD5C0 #x7FEC) + (#x8FD5C1 #x7FEE) + (#x8FD5C2 #x7FEF) + (#x8FD5C3 #x7FF2) + (#x8FD5C4 #x7FFA) + (#x8FD5C5 #x7FFD) + (#x8FD5C6 #x7FFE) + (#x8FD5C7 #x7FFF) + (#x8FD5C8 #x8007) + (#x8FD5C9 #x8008) + (#x8FD5CA #x800A) + (#x8FD5CB #x800D) + (#x8FD5CC #x800E) + (#x8FD5CD #x800F) + (#x8FD5CE #x8011) + (#x8FD5CF #x8013) + (#x8FD5D0 #x8014) + (#x8FD5D1 #x8016) + (#x8FD5D2 #x801D) + (#x8FD5D3 #x801E) + (#x8FD5D4 #x801F) + (#x8FD5D5 #x8020) + (#x8FD5D6 #x8024) + (#x8FD5D7 #x8026) + (#x8FD5D8 #x802C) + (#x8FD5D9 #x802E) + (#x8FD5DA #x8030) + (#x8FD5DB #x8034) + (#x8FD5DC #x8035) + (#x8FD5DD #x8037) + (#x8FD5DE #x8039) + (#x8FD5DF #x803A) + (#x8FD5E0 #x803C) + (#x8FD5E1 #x803E) + (#x8FD5E2 #x8040) + (#x8FD5E3 #x8044) + (#x8FD5E4 #x8060) + (#x8FD5E5 #x8064) + (#x8FD5E6 #x8066) + (#x8FD5E7 #x806D) + (#x8FD5E8 #x8071) + (#x8FD5E9 #x8075) + (#x8FD5EA #x8081) + (#x8FD5EB #x8088) + (#x8FD5EC #x808E) + (#x8FD5ED #x809C) + (#x8FD5EE #x809E) + (#x8FD5EF #x80A6) + (#x8FD5F0 #x80A7) + (#x8FD5F1 #x80AB) + (#x8FD5F2 #x80B8) + (#x8FD5F3 #x80B9) + (#x8FD5F4 #x80C8) + (#x8FD5F5 #x80CD) + (#x8FD5F6 #x80CF) + (#x8FD5F7 #x80D2) + (#x8FD5F8 #x80D4) + (#x8FD5F9 #x80D5) + (#x8FD5FA #x80D7) + (#x8FD5FB #x80D8) + (#x8FD5FC #x80E0) + (#x8FD5FD #x80ED) + (#x8FD5FE #x80EE) + (#x8FD6A1 #x80F0) + (#x8FD6A2 #x80F2) + (#x8FD6A3 #x80F3) + (#x8FD6A4 #x80F6) + (#x8FD6A5 #x80F9) + (#x8FD6A6 #x80FA) + (#x8FD6A7 #x80FE) + (#x8FD6A8 #x8103) + (#x8FD6A9 #x810B) + (#x8FD6AA #x8116) + (#x8FD6AB #x8117) + (#x8FD6AC #x8118) + (#x8FD6AD #x811C) + (#x8FD6AE #x811E) + (#x8FD6AF #x8120) + (#x8FD6B0 #x8124) + (#x8FD6B1 #x8127) + (#x8FD6B2 #x812C) + (#x8FD6B3 #x8130) + (#x8FD6B4 #x8135) + (#x8FD6B5 #x813A) + (#x8FD6B6 #x813C) + (#x8FD6B7 #x8145) + (#x8FD6B8 #x8147) + (#x8FD6B9 #x814A) + (#x8FD6BA #x814C) + (#x8FD6BB #x8152) + (#x8FD6BC #x8157) + (#x8FD6BD #x8160) + (#x8FD6BE #x8161) + (#x8FD6BF #x8167) + (#x8FD6C0 #x8168) + (#x8FD6C1 #x8169) + (#x8FD6C2 #x816D) + (#x8FD6C3 #x816F) + (#x8FD6C4 #x8177) + (#x8FD6C5 #x8181) + (#x8FD6C6 #x8190) + (#x8FD6C7 #x8184) + (#x8FD6C8 #x8185) + (#x8FD6C9 #x8186) + (#x8FD6CA #x818B) + (#x8FD6CB #x818E) + (#x8FD6CC #x8196) + (#x8FD6CD #x8198) + (#x8FD6CE #x819B) + (#x8FD6CF #x819E) + (#x8FD6D0 #x81A2) + (#x8FD6D1 #x81AE) + (#x8FD6D2 #x81B2) + (#x8FD6D3 #x81B4) + (#x8FD6D4 #x81BB) + (#x8FD6D5 #x81CB) + (#x8FD6D6 #x81C3) + (#x8FD6D7 #x81C5) + (#x8FD6D8 #x81CA) + (#x8FD6D9 #x81CE) + (#x8FD6DA #x81CF) + (#x8FD6DB #x81D5) + (#x8FD6DC #x81D7) + (#x8FD6DD #x81DB) + (#x8FD6DE #x81DD) + (#x8FD6DF #x81DE) + (#x8FD6E0 #x81E1) + (#x8FD6E1 #x81E4) + (#x8FD6E2 #x81EB) + (#x8FD6E3 #x81EC) + (#x8FD6E4 #x81F0) + (#x8FD6E5 #x81F1) + (#x8FD6E6 #x81F2) + (#x8FD6E7 #x81F5) + (#x8FD6E8 #x81F6) + (#x8FD6E9 #x81F8) + (#x8FD6EA #x81F9) + (#x8FD6EB #x81FD) + (#x8FD6EC #x81FF) + (#x8FD6ED #x8200) + (#x8FD6EE #x8203) + (#x8FD6EF #x820F) + (#x8FD6F0 #x8213) + (#x8FD6F1 #x8214) + (#x8FD6F2 #x8219) + (#x8FD6F3 #x821A) + (#x8FD6F4 #x821D) + (#x8FD6F5 #x8221) + (#x8FD6F6 #x8222) + (#x8FD6F7 #x8228) + (#x8FD6F8 #x8232) + (#x8FD6F9 #x8234) + (#x8FD6FA #x823A) + (#x8FD6FB #x8243) + (#x8FD6FC #x8244) + (#x8FD6FD #x8245) + (#x8FD6FE #x8246) + (#x8FD7A1 #x824B) + (#x8FD7A2 #x824E) + (#x8FD7A3 #x824F) + (#x8FD7A4 #x8251) + (#x8FD7A5 #x8256) + (#x8FD7A6 #x825C) + (#x8FD7A7 #x8260) + (#x8FD7A8 #x8263) + (#x8FD7A9 #x8267) + (#x8FD7AA #x826D) + (#x8FD7AB #x8274) + (#x8FD7AC #x827B) + (#x8FD7AD #x827D) + (#x8FD7AE #x827F) + (#x8FD7AF #x8280) + (#x8FD7B0 #x8281) + (#x8FD7B1 #x8283) + (#x8FD7B2 #x8284) + (#x8FD7B3 #x8287) + (#x8FD7B4 #x8289) + (#x8FD7B5 #x828A) + (#x8FD7B6 #x828E) + (#x8FD7B7 #x8291) + (#x8FD7B8 #x8294) + (#x8FD7B9 #x8296) + (#x8FD7BA #x8298) + (#x8FD7BB #x829A) + (#x8FD7BC #x829B) + (#x8FD7BD #x82A0) + (#x8FD7BE #x82A1) + (#x8FD7BF #x82A3) + (#x8FD7C0 #x82A4) + (#x8FD7C1 #x82A7) + (#x8FD7C2 #x82A8) + (#x8FD7C3 #x82A9) + (#x8FD7C4 #x82AA) + (#x8FD7C5 #x82AE) + (#x8FD7C6 #x82B0) + (#x8FD7C7 #x82B2) + (#x8FD7C8 #x82B4) + (#x8FD7C9 #x82B7) + (#x8FD7CA #x82BA) + (#x8FD7CB #x82BC) + (#x8FD7CC #x82BE) + (#x8FD7CD #x82BF) + (#x8FD7CE #x82C6) + (#x8FD7CF #x82D0) + (#x8FD7D0 #x82D5) + (#x8FD7D1 #x82DA) + (#x8FD7D2 #x82E0) + (#x8FD7D3 #x82E2) + (#x8FD7D4 #x82E4) + (#x8FD7D5 #x82E8) + (#x8FD7D6 #x82EA) + (#x8FD7D7 #x82ED) + (#x8FD7D8 #x82EF) + (#x8FD7D9 #x82F6) + (#x8FD7DA #x82F7) + (#x8FD7DB #x82FD) + (#x8FD7DC #x82FE) + (#x8FD7DD #x8300) + (#x8FD7DE #x8301) + (#x8FD7DF #x8307) + (#x8FD7E0 #x8308) + (#x8FD7E1 #x830A) + (#x8FD7E2 #x830B) + (#x8FD7E3 #x8354) + (#x8FD7E4 #x831B) + (#x8FD7E5 #x831D) + (#x8FD7E6 #x831E) + (#x8FD7E7 #x831F) + (#x8FD7E8 #x8321) + (#x8FD7E9 #x8322) + (#x8FD7EA #x832C) + (#x8FD7EB #x832D) + (#x8FD7EC #x832E) + (#x8FD7ED #x8330) + (#x8FD7EE #x8333) + (#x8FD7EF #x8337) + (#x8FD7F0 #x833A) + (#x8FD7F1 #x833C) + (#x8FD7F2 #x833D) + (#x8FD7F3 #x8342) + (#x8FD7F4 #x8343) + (#x8FD7F5 #x8344) + (#x8FD7F6 #x8347) + (#x8FD7F7 #x834D) + (#x8FD7F8 #x834E) + (#x8FD7F9 #x8351) + (#x8FD7FA #x8355) + (#x8FD7FB #x8356) + (#x8FD7FC #x8357) + (#x8FD7FD #x8370) + (#x8FD7FE #x8378) + (#x8FD8A1 #x837D) + (#x8FD8A2 #x837F) + (#x8FD8A3 #x8380) + (#x8FD8A4 #x8382) + (#x8FD8A5 #x8384) + (#x8FD8A6 #x8386) + (#x8FD8A7 #x838D) + (#x8FD8A8 #x8392) + (#x8FD8A9 #x8394) + (#x8FD8AA #x8395) + (#x8FD8AB #x8398) + (#x8FD8AC #x8399) + (#x8FD8AD #x839B) + (#x8FD8AE #x839C) + (#x8FD8AF #x839D) + (#x8FD8B0 #x83A6) + (#x8FD8B1 #x83A7) + (#x8FD8B2 #x83A9) + (#x8FD8B3 #x83AC) + (#x8FD8B4 #x83BE) + (#x8FD8B5 #x83BF) + (#x8FD8B6 #x83C0) + (#x8FD8B7 #x83C7) + (#x8FD8B8 #x83C9) + (#x8FD8B9 #x83CF) + (#x8FD8BA #x83D0) + (#x8FD8BB #x83D1) + (#x8FD8BC #x83D4) + (#x8FD8BD #x83DD) + (#x8FD8BE #x8353) + (#x8FD8BF #x83E8) + (#x8FD8C0 #x83EA) + (#x8FD8C1 #x83F6) + (#x8FD8C2 #x83F8) + (#x8FD8C3 #x83F9) + (#x8FD8C4 #x83FC) + (#x8FD8C5 #x8401) + (#x8FD8C6 #x8406) + (#x8FD8C7 #x840A) + (#x8FD8C8 #x840F) + (#x8FD8C9 #x8411) + (#x8FD8CA #x8415) + (#x8FD8CB #x8419) + (#x8FD8CC #x83AD) + (#x8FD8CD #x842F) + (#x8FD8CE #x8439) + (#x8FD8CF #x8445) + (#x8FD8D0 #x8447) + (#x8FD8D1 #x8448) + (#x8FD8D2 #x844A) + (#x8FD8D3 #x844D) + (#x8FD8D4 #x844F) + (#x8FD8D5 #x8451) + (#x8FD8D6 #x8452) + (#x8FD8D7 #x8456) + (#x8FD8D8 #x8458) + (#x8FD8D9 #x8459) + (#x8FD8DA #x845A) + (#x8FD8DB #x845C) + (#x8FD8DC #x8460) + (#x8FD8DD #x8464) + (#x8FD8DE #x8465) + (#x8FD8DF #x8467) + (#x8FD8E0 #x846A) + (#x8FD8E1 #x8470) + (#x8FD8E2 #x8473) + (#x8FD8E3 #x8474) + (#x8FD8E4 #x8476) + (#x8FD8E5 #x8478) + (#x8FD8E6 #x847C) + (#x8FD8E7 #x847D) + (#x8FD8E8 #x8481) + (#x8FD8E9 #x8485) + (#x8FD8EA #x8492) + (#x8FD8EB #x8493) + (#x8FD8EC #x8495) + (#x8FD8ED #x849E) + (#x8FD8EE #x84A6) + (#x8FD8EF #x84A8) + (#x8FD8F0 #x84A9) + (#x8FD8F1 #x84AA) + (#x8FD8F2 #x84AF) + (#x8FD8F3 #x84B1) + (#x8FD8F4 #x84B4) + (#x8FD8F5 #x84BA) + (#x8FD8F6 #x84BD) + (#x8FD8F7 #x84BE) + (#x8FD8F8 #x84C0) + (#x8FD8F9 #x84C2) + (#x8FD8FA #x84C7) + (#x8FD8FB #x84C8) + (#x8FD8FC #x84CC) + (#x8FD8FD #x84CF) + (#x8FD8FE #x84D3) + (#x8FD9A1 #x84DC) + (#x8FD9A2 #x84E7) + (#x8FD9A3 #x84EA) + (#x8FD9A4 #x84EF) + (#x8FD9A5 #x84F0) + (#x8FD9A6 #x84F1) + (#x8FD9A7 #x84F2) + (#x8FD9A8 #x84F7) + (#x8FD9A9 #x8532) + (#x8FD9AA #x84FA) + (#x8FD9AB #x84FB) + (#x8FD9AC #x84FD) + (#x8FD9AD #x8502) + (#x8FD9AE #x8503) + (#x8FD9AF #x8507) + (#x8FD9B0 #x850C) + (#x8FD9B1 #x850E) + (#x8FD9B2 #x8510) + (#x8FD9B3 #x851C) + (#x8FD9B4 #x851E) + (#x8FD9B5 #x8522) + (#x8FD9B6 #x8523) + (#x8FD9B7 #x8524) + (#x8FD9B8 #x8525) + (#x8FD9B9 #x8527) + (#x8FD9BA #x852A) + (#x8FD9BB #x852B) + (#x8FD9BC #x852F) + (#x8FD9BD #x8533) + (#x8FD9BE #x8534) + (#x8FD9BF #x8536) + (#x8FD9C0 #x853F) + (#x8FD9C1 #x8546) + (#x8FD9C2 #x854F) + (#x8FD9C3 #x8550) + (#x8FD9C4 #x8551) + (#x8FD9C5 #x8552) + (#x8FD9C6 #x8553) + (#x8FD9C7 #x8556) + (#x8FD9C8 #x8559) + (#x8FD9C9 #x855C) + (#x8FD9CA #x855D) + (#x8FD9CB #x855E) + (#x8FD9CC #x855F) + (#x8FD9CD #x8560) + (#x8FD9CE #x8561) + (#x8FD9CF #x8562) + (#x8FD9D0 #x8564) + (#x8FD9D1 #x856B) + (#x8FD9D2 #x856F) + (#x8FD9D3 #x8579) + (#x8FD9D4 #x857A) + (#x8FD9D5 #x857B) + (#x8FD9D6 #x857D) + (#x8FD9D7 #x857F) + (#x8FD9D8 #x8581) + (#x8FD9D9 #x8585) + (#x8FD9DA #x8586) + (#x8FD9DB #x8589) + (#x8FD9DC #x858B) + (#x8FD9DD #x858C) + (#x8FD9DE #x858F) + (#x8FD9DF #x8593) + (#x8FD9E0 #x8598) + (#x8FD9E1 #x859D) + (#x8FD9E2 #x859F) + (#x8FD9E3 #x85A0) + (#x8FD9E4 #x85A2) + (#x8FD9E5 #x85A5) + (#x8FD9E6 #x85A7) + (#x8FD9E7 #x85B4) + (#x8FD9E8 #x85B6) + (#x8FD9E9 #x85B7) + (#x8FD9EA #x85B8) + (#x8FD9EB #x85BC) + (#x8FD9EC #x85BD) + (#x8FD9ED #x85BE) + (#x8FD9EE #x85BF) + (#x8FD9EF #x85C2) + (#x8FD9F0 #x85C7) + (#x8FD9F1 #x85CA) + (#x8FD9F2 #x85CB) + (#x8FD9F3 #x85CE) + (#x8FD9F4 #x85AD) + (#x8FD9F5 #x85D8) + (#x8FD9F6 #x85DA) + (#x8FD9F7 #x85DF) + (#x8FD9F8 #x85E0) + (#x8FD9F9 #x85E6) + (#x8FD9FA #x85E8) + (#x8FD9FB #x85ED) + (#x8FD9FC #x85F3) + (#x8FD9FD #x85F6) + (#x8FD9FE #x85FC) + (#x8FDAA1 #x85FF) + (#x8FDAA2 #x8600) + (#x8FDAA3 #x8604) + (#x8FDAA4 #x8605) + (#x8FDAA5 #x860D) + (#x8FDAA6 #x860E) + (#x8FDAA7 #x8610) + (#x8FDAA8 #x8611) + (#x8FDAA9 #x8612) + (#x8FDAAA #x8618) + (#x8FDAAB #x8619) + (#x8FDAAC #x861B) + (#x8FDAAD #x861E) + (#x8FDAAE #x8621) + (#x8FDAAF #x8627) + (#x8FDAB0 #x8629) + (#x8FDAB1 #x8636) + (#x8FDAB2 #x8638) + (#x8FDAB3 #x863A) + (#x8FDAB4 #x863C) + (#x8FDAB5 #x863D) + (#x8FDAB6 #x8640) + (#x8FDAB7 #x8642) + (#x8FDAB8 #x8646) + (#x8FDAB9 #x8652) + (#x8FDABA #x8653) + (#x8FDABB #x8656) + (#x8FDABC #x8657) + (#x8FDABD #x8658) + (#x8FDABE #x8659) + (#x8FDABF #x865D) + (#x8FDAC0 #x8660) + (#x8FDAC1 #x8661) + (#x8FDAC2 #x8662) + (#x8FDAC3 #x8663) + (#x8FDAC4 #x8664) + (#x8FDAC5 #x8669) + (#x8FDAC6 #x866C) + (#x8FDAC7 #x866F) + (#x8FDAC8 #x8675) + (#x8FDAC9 #x8676) + (#x8FDACA #x8677) + (#x8FDACB #x867A) + (#x8FDACC #x868D) + (#x8FDACD #x8691) + (#x8FDACE #x8696) + (#x8FDACF #x8698) + (#x8FDAD0 #x869A) + (#x8FDAD1 #x869C) + (#x8FDAD2 #x86A1) + (#x8FDAD3 #x86A6) + (#x8FDAD4 #x86A7) + (#x8FDAD5 #x86A8) + (#x8FDAD6 #x86AD) + (#x8FDAD7 #x86B1) + (#x8FDAD8 #x86B3) + (#x8FDAD9 #x86B4) + (#x8FDADA #x86B5) + (#x8FDADB #x86B7) + (#x8FDADC #x86B8) + (#x8FDADD #x86B9) + (#x8FDADE #x86BF) + (#x8FDADF #x86C0) + (#x8FDAE0 #x86C1) + (#x8FDAE1 #x86C3) + (#x8FDAE2 #x86C5) + (#x8FDAE3 #x86D1) + (#x8FDAE4 #x86D2) + (#x8FDAE5 #x86D5) + (#x8FDAE6 #x86D7) + (#x8FDAE7 #x86DA) + (#x8FDAE8 #x86DC) + (#x8FDAE9 #x86E0) + (#x8FDAEA #x86E3) + (#x8FDAEB #x86E5) + (#x8FDAEC #x86E7) + (#x8FDAED #x8688) + (#x8FDAEE #x86FA) + (#x8FDAEF #x86FC) + (#x8FDAF0 #x86FD) + (#x8FDAF1 #x8704) + (#x8FDAF2 #x8705) + (#x8FDAF3 #x8707) + (#x8FDAF4 #x870B) + (#x8FDAF5 #x870E) + (#x8FDAF6 #x870F) + (#x8FDAF7 #x8710) + (#x8FDAF8 #x8713) + (#x8FDAF9 #x8714) + (#x8FDAFA #x8719) + (#x8FDAFB #x871E) + (#x8FDAFC #x871F) + (#x8FDAFD #x8721) + (#x8FDAFE #x8723) + (#x8FDBA1 #x8728) + (#x8FDBA2 #x872E) + (#x8FDBA3 #x872F) + (#x8FDBA4 #x8731) + (#x8FDBA5 #x8732) + (#x8FDBA6 #x8739) + (#x8FDBA7 #x873A) + (#x8FDBA8 #x873C) + (#x8FDBA9 #x873D) + (#x8FDBAA #x873E) + (#x8FDBAB #x8740) + (#x8FDBAC #x8743) + (#x8FDBAD #x8745) + (#x8FDBAE #x874D) + (#x8FDBAF #x8758) + (#x8FDBB0 #x875D) + (#x8FDBB1 #x8761) + (#x8FDBB2 #x8764) + (#x8FDBB3 #x8765) + (#x8FDBB4 #x876F) + (#x8FDBB5 #x8771) + (#x8FDBB6 #x8772) + (#x8FDBB7 #x877B) + (#x8FDBB8 #x8783) + (#x8FDBB9 #x8784) + (#x8FDBBA #x8785) + (#x8FDBBB #x8786) + (#x8FDBBC #x8787) + (#x8FDBBD #x8788) + (#x8FDBBE #x8789) + (#x8FDBBF #x878B) + (#x8FDBC0 #x878C) + (#x8FDBC1 #x8790) + (#x8FDBC2 #x8793) + (#x8FDBC3 #x8795) + (#x8FDBC4 #x8797) + (#x8FDBC5 #x8798) + (#x8FDBC6 #x8799) + (#x8FDBC7 #x879E) + (#x8FDBC8 #x87A0) + (#x8FDBC9 #x87A3) + (#x8FDBCA #x87A7) + (#x8FDBCB #x87AC) + (#x8FDBCC #x87AD) + (#x8FDBCD #x87AE) + (#x8FDBCE #x87B1) + (#x8FDBCF #x87B5) + (#x8FDBD0 #x87BE) + (#x8FDBD1 #x87BF) + (#x8FDBD2 #x87C1) + (#x8FDBD3 #x87C8) + (#x8FDBD4 #x87C9) + (#x8FDBD5 #x87CA) + (#x8FDBD6 #x87CE) + (#x8FDBD7 #x87D5) + (#x8FDBD8 #x87D6) + (#x8FDBD9 #x87D9) + (#x8FDBDA #x87DA) + (#x8FDBDB #x87DC) + (#x8FDBDC #x87DF) + (#x8FDBDD #x87E2) + (#x8FDBDE #x87E3) + (#x8FDBDF #x87E4) + (#x8FDBE0 #x87EA) + (#x8FDBE1 #x87EB) + (#x8FDBE2 #x87ED) + (#x8FDBE3 #x87F1) + (#x8FDBE4 #x87F3) + (#x8FDBE5 #x87F8) + (#x8FDBE6 #x87FA) + (#x8FDBE7 #x87FF) + (#x8FDBE8 #x8801) + (#x8FDBE9 #x8803) + (#x8FDBEA #x8806) + (#x8FDBEB #x8809) + (#x8FDBEC #x880A) + (#x8FDBED #x880B) + (#x8FDBEE #x8810) + (#x8FDBEF #x8819) + (#x8FDBF0 #x8812) + (#x8FDBF1 #x8813) + (#x8FDBF2 #x8814) + (#x8FDBF3 #x8818) + (#x8FDBF4 #x881A) + (#x8FDBF5 #x881B) + (#x8FDBF6 #x881C) + (#x8FDBF7 #x881E) + (#x8FDBF8 #x881F) + (#x8FDBF9 #x8828) + (#x8FDBFA #x882D) + (#x8FDBFB #x882E) + (#x8FDBFC #x8830) + (#x8FDBFD #x8832) + (#x8FDBFE #x8835) + (#x8FDCA1 #x883A) + (#x8FDCA2 #x883C) + (#x8FDCA3 #x8841) + (#x8FDCA4 #x8843) + (#x8FDCA5 #x8845) + (#x8FDCA6 #x8848) + (#x8FDCA7 #x8849) + (#x8FDCA8 #x884A) + (#x8FDCA9 #x884B) + (#x8FDCAA #x884E) + (#x8FDCAB #x8851) + (#x8FDCAC #x8855) + (#x8FDCAD #x8856) + (#x8FDCAE #x8858) + (#x8FDCAF #x885A) + (#x8FDCB0 #x885C) + (#x8FDCB1 #x885F) + (#x8FDCB2 #x8860) + (#x8FDCB3 #x8864) + (#x8FDCB4 #x8869) + (#x8FDCB5 #x8871) + (#x8FDCB6 #x8879) + (#x8FDCB7 #x887B) + (#x8FDCB8 #x8880) + (#x8FDCB9 #x8898) + (#x8FDCBA #x889A) + (#x8FDCBB #x889B) + (#x8FDCBC #x889C) + (#x8FDCBD #x889F) + (#x8FDCBE #x88A0) + (#x8FDCBF #x88A8) + (#x8FDCC0 #x88AA) + (#x8FDCC1 #x88BA) + (#x8FDCC2 #x88BD) + (#x8FDCC3 #x88BE) + (#x8FDCC4 #x88C0) + (#x8FDCC5 #x88CA) + (#x8FDCC6 #x88CB) + (#x8FDCC7 #x88CC) + (#x8FDCC8 #x88CD) + (#x8FDCC9 #x88CE) + (#x8FDCCA #x88D1) + (#x8FDCCB #x88D2) + (#x8FDCCC #x88D3) + (#x8FDCCD #x88DB) + (#x8FDCCE #x88DE) + (#x8FDCCF #x88E7) + (#x8FDCD0 #x88EF) + (#x8FDCD1 #x88F0) + (#x8FDCD2 #x88F1) + (#x8FDCD3 #x88F5) + (#x8FDCD4 #x88F7) + (#x8FDCD5 #x8901) + (#x8FDCD6 #x8906) + (#x8FDCD7 #x890D) + (#x8FDCD8 #x890E) + (#x8FDCD9 #x890F) + (#x8FDCDA #x8915) + (#x8FDCDB #x8916) + (#x8FDCDC #x8918) + (#x8FDCDD #x8919) + (#x8FDCDE #x891A) + (#x8FDCDF #x891C) + (#x8FDCE0 #x8920) + (#x8FDCE1 #x8926) + (#x8FDCE2 #x8927) + (#x8FDCE3 #x8928) + (#x8FDCE4 #x8930) + (#x8FDCE5 #x8931) + (#x8FDCE6 #x8932) + (#x8FDCE7 #x8935) + (#x8FDCE8 #x8939) + (#x8FDCE9 #x893A) + (#x8FDCEA #x893E) + (#x8FDCEB #x8940) + (#x8FDCEC #x8942) + (#x8FDCED #x8945) + (#x8FDCEE #x8946) + (#x8FDCEF #x8949) + (#x8FDCF0 #x894F) + (#x8FDCF1 #x8952) + (#x8FDCF2 #x8957) + (#x8FDCF3 #x895A) + (#x8FDCF4 #x895B) + (#x8FDCF5 #x895C) + (#x8FDCF6 #x8961) + (#x8FDCF7 #x8962) + (#x8FDCF8 #x8963) + (#x8FDCF9 #x896B) + (#x8FDCFA #x896E) + (#x8FDCFB #x8970) + (#x8FDCFC #x8973) + (#x8FDCFD #x8975) + (#x8FDCFE #x897A) + (#x8FDDA1 #x897B) + (#x8FDDA2 #x897C) + (#x8FDDA3 #x897D) + (#x8FDDA4 #x8989) + (#x8FDDA5 #x898D) + (#x8FDDA6 #x8990) + (#x8FDDA7 #x8994) + (#x8FDDA8 #x8995) + (#x8FDDA9 #x899B) + (#x8FDDAA #x899C) + (#x8FDDAB #x899F) + (#x8FDDAC #x89A0) + (#x8FDDAD #x89A5) + (#x8FDDAE #x89B0) + (#x8FDDAF #x89B4) + (#x8FDDB0 #x89B5) + (#x8FDDB1 #x89B6) + (#x8FDDB2 #x89B7) + (#x8FDDB3 #x89BC) + (#x8FDDB4 #x89D4) + (#x8FDDB5 #x89D5) + (#x8FDDB6 #x89D6) + (#x8FDDB7 #x89D7) + (#x8FDDB8 #x89D8) + (#x8FDDB9 #x89E5) + (#x8FDDBA #x89E9) + (#x8FDDBB #x89EB) + (#x8FDDBC #x89ED) + (#x8FDDBD #x89F1) + (#x8FDDBE #x89F3) + (#x8FDDBF #x89F6) + (#x8FDDC0 #x89F9) + (#x8FDDC1 #x89FD) + (#x8FDDC2 #x89FF) + (#x8FDDC3 #x8A04) + (#x8FDDC4 #x8A05) + (#x8FDDC5 #x8A07) + (#x8FDDC6 #x8A0F) + (#x8FDDC7 #x8A11) + (#x8FDDC8 #x8A12) + (#x8FDDC9 #x8A14) + (#x8FDDCA #x8A15) + (#x8FDDCB #x8A1E) + (#x8FDDCC #x8A20) + (#x8FDDCD #x8A22) + (#x8FDDCE #x8A24) + (#x8FDDCF #x8A26) + (#x8FDDD0 #x8A2B) + (#x8FDDD1 #x8A2C) + (#x8FDDD2 #x8A2F) + (#x8FDDD3 #x8A35) + (#x8FDDD4 #x8A37) + (#x8FDDD5 #x8A3D) + (#x8FDDD6 #x8A3E) + (#x8FDDD7 #x8A40) + (#x8FDDD8 #x8A43) + (#x8FDDD9 #x8A45) + (#x8FDDDA #x8A47) + (#x8FDDDB #x8A49) + (#x8FDDDC #x8A4D) + (#x8FDDDD #x8A4E) + (#x8FDDDE #x8A53) + (#x8FDDDF #x8A56) + (#x8FDDE0 #x8A57) + (#x8FDDE1 #x8A58) + (#x8FDDE2 #x8A5C) + (#x8FDDE3 #x8A5D) + (#x8FDDE4 #x8A61) + (#x8FDDE5 #x8A65) + (#x8FDDE6 #x8A67) + (#x8FDDE7 #x8A75) + (#x8FDDE8 #x8A76) + (#x8FDDE9 #x8A77) + (#x8FDDEA #x8A79) + (#x8FDDEB #x8A7A) + (#x8FDDEC #x8A7B) + (#x8FDDED #x8A7E) + (#x8FDDEE #x8A7F) + (#x8FDDEF #x8A80) + (#x8FDDF0 #x8A83) + (#x8FDDF1 #x8A86) + (#x8FDDF2 #x8A8B) + (#x8FDDF3 #x8A8F) + (#x8FDDF4 #x8A90) + (#x8FDDF5 #x8A92) + (#x8FDDF6 #x8A96) + (#x8FDDF7 #x8A97) + (#x8FDDF8 #x8A99) + (#x8FDDF9 #x8A9F) + (#x8FDDFA #x8AA7) + (#x8FDDFB #x8AA9) + (#x8FDDFC #x8AAE) + (#x8FDDFD #x8AAF) + (#x8FDDFE #x8AB3) + (#x8FDEA1 #x8AB6) + (#x8FDEA2 #x8AB7) + (#x8FDEA3 #x8ABB) + (#x8FDEA4 #x8ABE) + (#x8FDEA5 #x8AC3) + (#x8FDEA6 #x8AC6) + (#x8FDEA7 #x8AC8) + (#x8FDEA8 #x8AC9) + (#x8FDEA9 #x8ACA) + (#x8FDEAA #x8AD1) + (#x8FDEAB #x8AD3) + (#x8FDEAC #x8AD4) + (#x8FDEAD #x8AD5) + (#x8FDEAE #x8AD7) + (#x8FDEAF #x8ADD) + (#x8FDEB0 #x8ADF) + (#x8FDEB1 #x8AEC) + (#x8FDEB2 #x8AF0) + (#x8FDEB3 #x8AF4) + (#x8FDEB4 #x8AF5) + (#x8FDEB5 #x8AF6) + (#x8FDEB6 #x8AFC) + (#x8FDEB7 #x8AFF) + (#x8FDEB8 #x8B05) + (#x8FDEB9 #x8B06) + (#x8FDEBA #x8B0B) + (#x8FDEBB #x8B11) + (#x8FDEBC #x8B1C) + (#x8FDEBD #x8B1E) + (#x8FDEBE #x8B1F) + (#x8FDEBF #x8B0A) + (#x8FDEC0 #x8B2D) + (#x8FDEC1 #x8B30) + (#x8FDEC2 #x8B37) + (#x8FDEC3 #x8B3C) + (#x8FDEC4 #x8B42) + (#x8FDEC5 #x8B43) + (#x8FDEC6 #x8B44) + (#x8FDEC7 #x8B45) + (#x8FDEC8 #x8B46) + (#x8FDEC9 #x8B48) + (#x8FDECA #x8B52) + (#x8FDECB #x8B53) + (#x8FDECC #x8B54) + (#x8FDECD #x8B59) + (#x8FDECE #x8B4D) + (#x8FDECF #x8B5E) + (#x8FDED0 #x8B63) + (#x8FDED1 #x8B6D) + (#x8FDED2 #x8B76) + (#x8FDED3 #x8B78) + (#x8FDED4 #x8B79) + (#x8FDED5 #x8B7C) + (#x8FDED6 #x8B7E) + (#x8FDED7 #x8B81) + (#x8FDED8 #x8B84) + (#x8FDED9 #x8B85) + (#x8FDEDA #x8B8B) + (#x8FDEDB #x8B8D) + (#x8FDEDC #x8B8F) + (#x8FDEDD #x8B94) + (#x8FDEDE #x8B95) + (#x8FDEDF #x8B9C) + (#x8FDEE0 #x8B9E) + (#x8FDEE1 #x8B9F) + (#x8FDEE2 #x8C38) + (#x8FDEE3 #x8C39) + (#x8FDEE4 #x8C3D) + (#x8FDEE5 #x8C3E) + (#x8FDEE6 #x8C45) + (#x8FDEE7 #x8C47) + (#x8FDEE8 #x8C49) + (#x8FDEE9 #x8C4B) + (#x8FDEEA #x8C4F) + (#x8FDEEB #x8C51) + (#x8FDEEC #x8C53) + (#x8FDEED #x8C54) + (#x8FDEEE #x8C57) + (#x8FDEEF #x8C58) + (#x8FDEF0 #x8C5B) + (#x8FDEF1 #x8C5D) + (#x8FDEF2 #x8C59) + (#x8FDEF3 #x8C63) + (#x8FDEF4 #x8C64) + (#x8FDEF5 #x8C66) + (#x8FDEF6 #x8C68) + (#x8FDEF7 #x8C69) + (#x8FDEF8 #x8C6D) + (#x8FDEF9 #x8C73) + (#x8FDEFA #x8C75) + (#x8FDEFB #x8C76) + (#x8FDEFC #x8C7B) + (#x8FDEFD #x8C7E) + (#x8FDEFE #x8C86) + (#x8FDFA1 #x8C87) + (#x8FDFA2 #x8C8B) + (#x8FDFA3 #x8C90) + (#x8FDFA4 #x8C92) + (#x8FDFA5 #x8C93) + (#x8FDFA6 #x8C99) + (#x8FDFA7 #x8C9B) + (#x8FDFA8 #x8C9C) + (#x8FDFA9 #x8CA4) + (#x8FDFAA #x8CB9) + (#x8FDFAB #x8CBA) + (#x8FDFAC #x8CC5) + (#x8FDFAD #x8CC6) + (#x8FDFAE #x8CC9) + (#x8FDFAF #x8CCB) + (#x8FDFB0 #x8CCF) + (#x8FDFB1 #x8CD6) + (#x8FDFB2 #x8CD5) + (#x8FDFB3 #x8CD9) + (#x8FDFB4 #x8CDD) + (#x8FDFB5 #x8CE1) + (#x8FDFB6 #x8CE8) + (#x8FDFB7 #x8CEC) + (#x8FDFB8 #x8CEF) + (#x8FDFB9 #x8CF0) + (#x8FDFBA #x8CF2) + (#x8FDFBB #x8CF5) + (#x8FDFBC #x8CF7) + (#x8FDFBD #x8CF8) + (#x8FDFBE #x8CFE) + (#x8FDFBF #x8CFF) + (#x8FDFC0 #x8D01) + (#x8FDFC1 #x8D03) + (#x8FDFC2 #x8D09) + (#x8FDFC3 #x8D12) + (#x8FDFC4 #x8D17) + (#x8FDFC5 #x8D1B) + (#x8FDFC6 #x8D65) + (#x8FDFC7 #x8D69) + (#x8FDFC8 #x8D6C) + (#x8FDFC9 #x8D6E) + (#x8FDFCA #x8D7F) + (#x8FDFCB #x8D82) + (#x8FDFCC #x8D84) + (#x8FDFCD #x8D88) + (#x8FDFCE #x8D8D) + (#x8FDFCF #x8D90) + (#x8FDFD0 #x8D91) + (#x8FDFD1 #x8D95) + (#x8FDFD2 #x8D9E) + (#x8FDFD3 #x8D9F) + (#x8FDFD4 #x8DA0) + (#x8FDFD5 #x8DA6) + (#x8FDFD6 #x8DAB) + (#x8FDFD7 #x8DAC) + (#x8FDFD8 #x8DAF) + (#x8FDFD9 #x8DB2) + (#x8FDFDA #x8DB5) + (#x8FDFDB #x8DB7) + (#x8FDFDC #x8DB9) + (#x8FDFDD #x8DBB) + (#x8FDFDE #x8DC0) + (#x8FDFDF #x8DC5) + (#x8FDFE0 #x8DC6) + (#x8FDFE1 #x8DC7) + (#x8FDFE2 #x8DC8) + (#x8FDFE3 #x8DCA) + (#x8FDFE4 #x8DCE) + (#x8FDFE5 #x8DD1) + (#x8FDFE6 #x8DD4) + (#x8FDFE7 #x8DD5) + (#x8FDFE8 #x8DD7) + (#x8FDFE9 #x8DD9) + (#x8FDFEA #x8DE4) + (#x8FDFEB #x8DE5) + (#x8FDFEC #x8DE7) + (#x8FDFED #x8DEC) + (#x8FDFEE #x8DF0) + (#x8FDFEF #x8DBC) + (#x8FDFF0 #x8DF1) + (#x8FDFF1 #x8DF2) + (#x8FDFF2 #x8DF4) + (#x8FDFF3 #x8DFD) + (#x8FDFF4 #x8E01) + (#x8FDFF5 #x8E04) + (#x8FDFF6 #x8E05) + (#x8FDFF7 #x8E06) + (#x8FDFF8 #x8E0B) + (#x8FDFF9 #x8E11) + (#x8FDFFA #x8E14) + (#x8FDFFB #x8E16) + (#x8FDFFC #x8E20) + (#x8FDFFD #x8E21) + (#x8FDFFE #x8E22) + (#x8FE0A1 #x8E23) + (#x8FE0A2 #x8E26) + (#x8FE0A3 #x8E27) + (#x8FE0A4 #x8E31) + (#x8FE0A5 #x8E33) + (#x8FE0A6 #x8E36) + (#x8FE0A7 #x8E37) + (#x8FE0A8 #x8E38) + (#x8FE0A9 #x8E39) + (#x8FE0AA #x8E3D) + (#x8FE0AB #x8E40) + (#x8FE0AC #x8E41) + (#x8FE0AD #x8E4B) + (#x8FE0AE #x8E4D) + (#x8FE0AF #x8E4E) + (#x8FE0B0 #x8E4F) + (#x8FE0B1 #x8E54) + (#x8FE0B2 #x8E5B) + (#x8FE0B3 #x8E5C) + (#x8FE0B4 #x8E5D) + (#x8FE0B5 #x8E5E) + (#x8FE0B6 #x8E61) + (#x8FE0B7 #x8E62) + (#x8FE0B8 #x8E69) + (#x8FE0B9 #x8E6C) + (#x8FE0BA #x8E6D) + (#x8FE0BB #x8E6F) + (#x8FE0BC #x8E70) + (#x8FE0BD #x8E71) + (#x8FE0BE #x8E79) + (#x8FE0BF #x8E7A) + (#x8FE0C0 #x8E7B) + (#x8FE0C1 #x8E82) + (#x8FE0C2 #x8E83) + (#x8FE0C3 #x8E89) + (#x8FE0C4 #x8E90) + (#x8FE0C5 #x8E92) + (#x8FE0C6 #x8E95) + (#x8FE0C7 #x8E9A) + (#x8FE0C8 #x8E9B) + (#x8FE0C9 #x8E9D) + (#x8FE0CA #x8E9E) + (#x8FE0CB #x8EA2) + (#x8FE0CC #x8EA7) + (#x8FE0CD #x8EA9) + (#x8FE0CE #x8EAD) + (#x8FE0CF #x8EAE) + (#x8FE0D0 #x8EB3) + (#x8FE0D1 #x8EB5) + (#x8FE0D2 #x8EBA) + (#x8FE0D3 #x8EBB) + (#x8FE0D4 #x8EC0) + (#x8FE0D5 #x8EC1) + (#x8FE0D6 #x8EC3) + (#x8FE0D7 #x8EC4) + (#x8FE0D8 #x8EC7) + (#x8FE0D9 #x8ECF) + (#x8FE0DA #x8ED1) + (#x8FE0DB #x8ED4) + (#x8FE0DC #x8EDC) + (#x8FE0DD #x8EE8) + (#x8FE0DE #x8EEE) + (#x8FE0DF #x8EF0) + (#x8FE0E0 #x8EF1) + (#x8FE0E1 #x8EF7) + (#x8FE0E2 #x8EF9) + (#x8FE0E3 #x8EFA) + (#x8FE0E4 #x8EED) + (#x8FE0E5 #x8F00) + (#x8FE0E6 #x8F02) + (#x8FE0E7 #x8F07) + (#x8FE0E8 #x8F08) + (#x8FE0E9 #x8F0F) + (#x8FE0EA #x8F10) + (#x8FE0EB #x8F16) + (#x8FE0EC #x8F17) + (#x8FE0ED #x8F18) + (#x8FE0EE #x8F1E) + (#x8FE0EF #x8F20) + (#x8FE0F0 #x8F21) + (#x8FE0F1 #x8F23) + (#x8FE0F2 #x8F25) + (#x8FE0F3 #x8F27) + (#x8FE0F4 #x8F28) + (#x8FE0F5 #x8F2C) + (#x8FE0F6 #x8F2D) + (#x8FE0F7 #x8F2E) + (#x8FE0F8 #x8F34) + (#x8FE0F9 #x8F35) + (#x8FE0FA #x8F36) + (#x8FE0FB #x8F37) + (#x8FE0FC #x8F3A) + (#x8FE0FD #x8F40) + (#x8FE0FE #x8F41) + (#x8FE1A1 #x8F43) + (#x8FE1A2 #x8F47) + (#x8FE1A3 #x8F4F) + (#x8FE1A4 #x8F51) + (#x8FE1A5 #x8F52) + (#x8FE1A6 #x8F53) + (#x8FE1A7 #x8F54) + (#x8FE1A8 #x8F55) + (#x8FE1A9 #x8F58) + (#x8FE1AA #x8F5D) + (#x8FE1AB #x8F5E) + (#x8FE1AC #x8F65) + (#x8FE1AD #x8F9D) + (#x8FE1AE #x8FA0) + (#x8FE1AF #x8FA1) + (#x8FE1B0 #x8FA4) + (#x8FE1B1 #x8FA5) + (#x8FE1B2 #x8FA6) + (#x8FE1B3 #x8FB5) + (#x8FE1B4 #x8FB6) + (#x8FE1B5 #x8FB8) + (#x8FE1B6 #x8FBE) + (#x8FE1B7 #x8FC0) + (#x8FE1B8 #x8FC1) + (#x8FE1B9 #x8FC6) + (#x8FE1BA #x8FCA) + (#x8FE1BB #x8FCB) + (#x8FE1BC #x8FCD) + (#x8FE1BD #x8FD0) + (#x8FE1BE #x8FD2) + (#x8FE1BF #x8FD3) + (#x8FE1C0 #x8FD5) + (#x8FE1C1 #x8FE0) + (#x8FE1C2 #x8FE3) + (#x8FE1C3 #x8FE4) + (#x8FE1C4 #x8FE8) + (#x8FE1C5 #x8FEE) + (#x8FE1C6 #x8FF1) + (#x8FE1C7 #x8FF5) + (#x8FE1C8 #x8FF6) + (#x8FE1C9 #x8FFB) + (#x8FE1CA #x8FFE) + (#x8FE1CB #x9002) + (#x8FE1CC #x9004) + (#x8FE1CD #x9008) + (#x8FE1CE #x900C) + (#x8FE1CF #x9018) + (#x8FE1D0 #x901B) + (#x8FE1D1 #x9028) + (#x8FE1D2 #x9029) + (#x8FE1D3 #x902F) + (#x8FE1D4 #x902A) + (#x8FE1D5 #x902C) + (#x8FE1D6 #x902D) + (#x8FE1D7 #x9033) + (#x8FE1D8 #x9034) + (#x8FE1D9 #x9037) + (#x8FE1DA #x903F) + (#x8FE1DB #x9043) + (#x8FE1DC #x9044) + (#x8FE1DD #x904C) + (#x8FE1DE #x905B) + (#x8FE1DF #x905D) + (#x8FE1E0 #x9062) + (#x8FE1E1 #x9066) + (#x8FE1E2 #x9067) + (#x8FE1E3 #x906C) + (#x8FE1E4 #x9070) + (#x8FE1E5 #x9074) + (#x8FE1E6 #x9079) + (#x8FE1E7 #x9085) + (#x8FE1E8 #x9088) + (#x8FE1E9 #x908B) + (#x8FE1EA #x908C) + (#x8FE1EB #x908E) + (#x8FE1EC #x9090) + (#x8FE1ED #x9095) + (#x8FE1EE #x9097) + (#x8FE1EF #x9098) + (#x8FE1F0 #x9099) + (#x8FE1F1 #x909B) + (#x8FE1F2 #x90A0) + (#x8FE1F3 #x90A1) + (#x8FE1F4 #x90A2) + (#x8FE1F5 #x90A5) + (#x8FE1F6 #x90B0) + (#x8FE1F7 #x90B2) + (#x8FE1F8 #x90B3) + (#x8FE1F9 #x90B4) + (#x8FE1FA #x90B6) + (#x8FE1FB #x90BD) + (#x8FE1FC #x90CC) + (#x8FE1FD #x90BE) + (#x8FE1FE #x90C3) + (#x8FE2A1 #x90C4) + (#x8FE2A2 #x90C5) + (#x8FE2A3 #x90C7) + (#x8FE2A4 #x90C8) + (#x8FE2A5 #x90D5) + (#x8FE2A6 #x90D7) + (#x8FE2A7 #x90D8) + (#x8FE2A8 #x90D9) + (#x8FE2A9 #x90DC) + (#x8FE2AA #x90DD) + (#x8FE2AB #x90DF) + (#x8FE2AC #x90E5) + (#x8FE2AD #x90D2) + (#x8FE2AE #x90F6) + (#x8FE2AF #x90EB) + (#x8FE2B0 #x90EF) + (#x8FE2B1 #x90F0) + (#x8FE2B2 #x90F4) + (#x8FE2B3 #x90FE) + (#x8FE2B4 #x90FF) + (#x8FE2B5 #x9100) + (#x8FE2B6 #x9104) + (#x8FE2B7 #x9105) + (#x8FE2B8 #x9106) + (#x8FE2B9 #x9108) + (#x8FE2BA #x910D) + (#x8FE2BB #x9110) + (#x8FE2BC #x9114) + (#x8FE2BD #x9116) + (#x8FE2BE #x9117) + (#x8FE2BF #x9118) + (#x8FE2C0 #x911A) + (#x8FE2C1 #x911C) + (#x8FE2C2 #x911E) + (#x8FE2C3 #x9120) + (#x8FE2C4 #x9125) + (#x8FE2C5 #x9122) + (#x8FE2C6 #x9123) + (#x8FE2C7 #x9127) + (#x8FE2C8 #x9129) + (#x8FE2C9 #x912E) + (#x8FE2CA #x912F) + (#x8FE2CB #x9131) + (#x8FE2CC #x9134) + (#x8FE2CD #x9136) + (#x8FE2CE #x9137) + (#x8FE2CF #x9139) + (#x8FE2D0 #x913A) + (#x8FE2D1 #x913C) + (#x8FE2D2 #x913D) + (#x8FE2D3 #x9143) + (#x8FE2D4 #x9147) + (#x8FE2D5 #x9148) + (#x8FE2D6 #x914F) + (#x8FE2D7 #x9153) + (#x8FE2D8 #x9157) + (#x8FE2D9 #x9159) + (#x8FE2DA #x915A) + (#x8FE2DB #x915B) + (#x8FE2DC #x9161) + (#x8FE2DD #x9164) + (#x8FE2DE #x9167) + (#x8FE2DF #x916D) + (#x8FE2E0 #x9174) + (#x8FE2E1 #x9179) + (#x8FE2E2 #x917A) + (#x8FE2E3 #x917B) + (#x8FE2E4 #x9181) + (#x8FE2E5 #x9183) + (#x8FE2E6 #x9185) + (#x8FE2E7 #x9186) + (#x8FE2E8 #x918A) + (#x8FE2E9 #x918E) + (#x8FE2EA #x9191) + (#x8FE2EB #x9193) + (#x8FE2EC #x9194) + (#x8FE2ED #x9195) + (#x8FE2EE #x9198) + (#x8FE2EF #x919E) + (#x8FE2F0 #x91A1) + (#x8FE2F1 #x91A6) + (#x8FE2F2 #x91A8) + (#x8FE2F3 #x91AC) + (#x8FE2F4 #x91AD) + (#x8FE2F5 #x91AE) + (#x8FE2F6 #x91B0) + (#x8FE2F7 #x91B1) + (#x8FE2F8 #x91B2) + (#x8FE2F9 #x91B3) + (#x8FE2FA #x91B6) + (#x8FE2FB #x91BB) + (#x8FE2FC #x91BC) + (#x8FE2FD #x91BD) + (#x8FE2FE #x91BF) + (#x8FE3A1 #x91C2) + (#x8FE3A2 #x91C3) + (#x8FE3A3 #x91C5) + (#x8FE3A4 #x91D3) + (#x8FE3A5 #x91D4) + (#x8FE3A6 #x91D7) + (#x8FE3A7 #x91D9) + (#x8FE3A8 #x91DA) + (#x8FE3A9 #x91DE) + (#x8FE3AA #x91E4) + (#x8FE3AB #x91E5) + (#x8FE3AC #x91E9) + (#x8FE3AD #x91EA) + (#x8FE3AE #x91EC) + (#x8FE3AF #x91ED) + (#x8FE3B0 #x91EE) + (#x8FE3B1 #x91EF) + (#x8FE3B2 #x91F0) + (#x8FE3B3 #x91F1) + (#x8FE3B4 #x91F7) + (#x8FE3B5 #x91F9) + (#x8FE3B6 #x91FB) + (#x8FE3B7 #x91FD) + (#x8FE3B8 #x9200) + (#x8FE3B9 #x9201) + (#x8FE3BA #x9204) + (#x8FE3BB #x9205) + (#x8FE3BC #x9206) + (#x8FE3BD #x9207) + (#x8FE3BE #x9209) + (#x8FE3BF #x920A) + (#x8FE3C0 #x920C) + (#x8FE3C1 #x9210) + (#x8FE3C2 #x9212) + (#x8FE3C3 #x9213) + (#x8FE3C4 #x9216) + (#x8FE3C5 #x9218) + (#x8FE3C6 #x921C) + (#x8FE3C7 #x921D) + (#x8FE3C8 #x9223) + (#x8FE3C9 #x9224) + (#x8FE3CA #x9225) + (#x8FE3CB #x9226) + (#x8FE3CC #x9228) + (#x8FE3CD #x922E) + (#x8FE3CE #x922F) + (#x8FE3CF #x9230) + (#x8FE3D0 #x9233) + (#x8FE3D1 #x9235) + (#x8FE3D2 #x9236) + (#x8FE3D3 #x9238) + (#x8FE3D4 #x9239) + (#x8FE3D5 #x923A) + (#x8FE3D6 #x923C) + (#x8FE3D7 #x923E) + (#x8FE3D8 #x9240) + (#x8FE3D9 #x9242) + (#x8FE3DA #x9243) + (#x8FE3DB #x9246) + (#x8FE3DC #x9247) + (#x8FE3DD #x924A) + (#x8FE3DE #x924D) + (#x8FE3DF #x924E) + (#x8FE3E0 #x924F) + (#x8FE3E1 #x9251) + (#x8FE3E2 #x9258) + (#x8FE3E3 #x9259) + (#x8FE3E4 #x925C) + (#x8FE3E5 #x925D) + (#x8FE3E6 #x9260) + (#x8FE3E7 #x9261) + (#x8FE3E8 #x9265) + (#x8FE3E9 #x9267) + (#x8FE3EA #x9268) + (#x8FE3EB #x9269) + (#x8FE3EC #x926E) + (#x8FE3ED #x926F) + (#x8FE3EE #x9270) + (#x8FE3EF #x9275) + (#x8FE3F0 #x9276) + (#x8FE3F1 #x9277) + (#x8FE3F2 #x9278) + (#x8FE3F3 #x9279) + (#x8FE3F4 #x927B) + (#x8FE3F5 #x927C) + (#x8FE3F6 #x927D) + (#x8FE3F7 #x927F) + (#x8FE3F8 #x9288) + (#x8FE3F9 #x9289) + (#x8FE3FA #x928A) + (#x8FE3FB #x928D) + (#x8FE3FC #x928E) + (#x8FE3FD #x9292) + (#x8FE3FE #x9297) + (#x8FE4A1 #x9299) + (#x8FE4A2 #x929F) + (#x8FE4A3 #x92A0) + (#x8FE4A4 #x92A4) + (#x8FE4A5 #x92A5) + (#x8FE4A6 #x92A7) + (#x8FE4A7 #x92A8) + (#x8FE4A8 #x92AB) + (#x8FE4A9 #x92AF) + (#x8FE4AA #x92B2) + (#x8FE4AB #x92B6) + (#x8FE4AC #x92B8) + (#x8FE4AD #x92BA) + (#x8FE4AE #x92BB) + (#x8FE4AF #x92BC) + (#x8FE4B0 #x92BD) + (#x8FE4B1 #x92BF) + (#x8FE4B2 #x92C0) + (#x8FE4B3 #x92C1) + (#x8FE4B4 #x92C2) + (#x8FE4B5 #x92C3) + (#x8FE4B6 #x92C5) + (#x8FE4B7 #x92C6) + (#x8FE4B8 #x92C7) + (#x8FE4B9 #x92C8) + (#x8FE4BA #x92CB) + (#x8FE4BB #x92CC) + (#x8FE4BC #x92CD) + (#x8FE4BD #x92CE) + (#x8FE4BE #x92D0) + (#x8FE4BF #x92D3) + (#x8FE4C0 #x92D5) + (#x8FE4C1 #x92D7) + (#x8FE4C2 #x92D8) + (#x8FE4C3 #x92D9) + (#x8FE4C4 #x92DC) + (#x8FE4C5 #x92DD) + (#x8FE4C6 #x92DF) + (#x8FE4C7 #x92E0) + (#x8FE4C8 #x92E1) + (#x8FE4C9 #x92E3) + (#x8FE4CA #x92E5) + (#x8FE4CB #x92E7) + (#x8FE4CC #x92E8) + (#x8FE4CD #x92EC) + (#x8FE4CE #x92EE) + (#x8FE4CF #x92F0) + (#x8FE4D0 #x92F9) + (#x8FE4D1 #x92FB) + (#x8FE4D2 #x92FF) + (#x8FE4D3 #x9300) + (#x8FE4D4 #x9302) + (#x8FE4D5 #x9308) + (#x8FE4D6 #x930D) + (#x8FE4D7 #x9311) + (#x8FE4D8 #x9314) + (#x8FE4D9 #x9315) + (#x8FE4DA #x931C) + (#x8FE4DB #x931D) + (#x8FE4DC #x931E) + (#x8FE4DD #x931F) + (#x8FE4DE #x9321) + (#x8FE4DF #x9324) + (#x8FE4E0 #x9325) + (#x8FE4E1 #x9327) + (#x8FE4E2 #x9329) + (#x8FE4E3 #x932A) + (#x8FE4E4 #x9333) + (#x8FE4E5 #x9334) + (#x8FE4E6 #x9336) + (#x8FE4E7 #x9337) + (#x8FE4E8 #x9347) + (#x8FE4E9 #x9348) + (#x8FE4EA #x9349) + (#x8FE4EB #x9350) + (#x8FE4EC #x9351) + (#x8FE4ED #x9352) + (#x8FE4EE #x9355) + (#x8FE4EF #x9357) + (#x8FE4F0 #x9358) + (#x8FE4F1 #x935A) + (#x8FE4F2 #x935E) + (#x8FE4F3 #x9364) + (#x8FE4F4 #x9365) + (#x8FE4F5 #x9367) + (#x8FE4F6 #x9369) + (#x8FE4F7 #x936A) + (#x8FE4F8 #x936D) + (#x8FE4F9 #x936F) + (#x8FE4FA #x9370) + (#x8FE4FB #x9371) + (#x8FE4FC #x9373) + (#x8FE4FD #x9374) + (#x8FE4FE #x9376) + (#x8FE5A1 #x937A) + (#x8FE5A2 #x937D) + (#x8FE5A3 #x937F) + (#x8FE5A4 #x9380) + (#x8FE5A5 #x9381) + (#x8FE5A6 #x9382) + (#x8FE5A7 #x9388) + (#x8FE5A8 #x938A) + (#x8FE5A9 #x938B) + (#x8FE5AA #x938D) + (#x8FE5AB #x938F) + (#x8FE5AC #x9392) + (#x8FE5AD #x9395) + (#x8FE5AE #x9398) + (#x8FE5AF #x939B) + (#x8FE5B0 #x939E) + (#x8FE5B1 #x93A1) + (#x8FE5B2 #x93A3) + (#x8FE5B3 #x93A4) + (#x8FE5B4 #x93A6) + (#x8FE5B5 #x93A8) + (#x8FE5B6 #x93AB) + (#x8FE5B7 #x93B4) + (#x8FE5B8 #x93B5) + (#x8FE5B9 #x93B6) + (#x8FE5BA #x93BA) + (#x8FE5BB #x93A9) + (#x8FE5BC #x93C1) + (#x8FE5BD #x93C4) + (#x8FE5BE #x93C5) + (#x8FE5BF #x93C6) + (#x8FE5C0 #x93C7) + (#x8FE5C1 #x93C9) + (#x8FE5C2 #x93CA) + (#x8FE5C3 #x93CB) + (#x8FE5C4 #x93CC) + (#x8FE5C5 #x93CD) + (#x8FE5C6 #x93D3) + (#x8FE5C7 #x93D9) + (#x8FE5C8 #x93DC) + (#x8FE5C9 #x93DE) + (#x8FE5CA #x93DF) + (#x8FE5CB #x93E2) + (#x8FE5CC #x93E6) + (#x8FE5CD #x93E7) + (#x8FE5CE #x93F9) + (#x8FE5CF #x93F7) + (#x8FE5D0 #x93F8) + (#x8FE5D1 #x93FA) + (#x8FE5D2 #x93FB) + (#x8FE5D3 #x93FD) + (#x8FE5D4 #x9401) + (#x8FE5D5 #x9402) + (#x8FE5D6 #x9404) + (#x8FE5D7 #x9408) + (#x8FE5D8 #x9409) + (#x8FE5D9 #x940D) + (#x8FE5DA #x940E) + (#x8FE5DB #x940F) + (#x8FE5DC #x9415) + (#x8FE5DD #x9416) + (#x8FE5DE #x9417) + (#x8FE5DF #x941F) + (#x8FE5E0 #x942E) + (#x8FE5E1 #x942F) + (#x8FE5E2 #x9431) + (#x8FE5E3 #x9432) + (#x8FE5E4 #x9433) + (#x8FE5E5 #x9434) + (#x8FE5E6 #x943B) + (#x8FE5E7 #x943F) + (#x8FE5E8 #x943D) + (#x8FE5E9 #x9443) + (#x8FE5EA #x9445) + (#x8FE5EB #x9448) + (#x8FE5EC #x944A) + (#x8FE5ED #x944C) + (#x8FE5EE #x9455) + (#x8FE5EF #x9459) + (#x8FE5F0 #x945C) + (#x8FE5F1 #x945F) + (#x8FE5F2 #x9461) + (#x8FE5F3 #x9463) + (#x8FE5F4 #x9468) + (#x8FE5F5 #x946B) + (#x8FE5F6 #x946D) + (#x8FE5F7 #x946E) + (#x8FE5F8 #x946F) + (#x8FE5F9 #x9471) + (#x8FE5FA #x9472) + (#x8FE5FB #x9484) + (#x8FE5FC #x9483) + (#x8FE5FD #x9578) + (#x8FE5FE #x9579) + (#x8FE6A1 #x957E) + (#x8FE6A2 #x9584) + (#x8FE6A3 #x9588) + (#x8FE6A4 #x958C) + (#x8FE6A5 #x958D) + (#x8FE6A6 #x958E) + (#x8FE6A7 #x959D) + (#x8FE6A8 #x959E) + (#x8FE6A9 #x959F) + (#x8FE6AA #x95A1) + (#x8FE6AB #x95A6) + (#x8FE6AC #x95A9) + (#x8FE6AD #x95AB) + (#x8FE6AE #x95AC) + (#x8FE6AF #x95B4) + (#x8FE6B0 #x95B6) + (#x8FE6B1 #x95BA) + (#x8FE6B2 #x95BD) + (#x8FE6B3 #x95BF) + (#x8FE6B4 #x95C6) + (#x8FE6B5 #x95C8) + (#x8FE6B6 #x95C9) + (#x8FE6B7 #x95CB) + (#x8FE6B8 #x95D0) + (#x8FE6B9 #x95D1) + (#x8FE6BA #x95D2) + (#x8FE6BB #x95D3) + (#x8FE6BC #x95D9) + (#x8FE6BD #x95DA) + (#x8FE6BE #x95DD) + (#x8FE6BF #x95DE) + (#x8FE6C0 #x95DF) + (#x8FE6C1 #x95E0) + (#x8FE6C2 #x95E4) + (#x8FE6C3 #x95E6) + (#x8FE6C4 #x961D) + (#x8FE6C5 #x961E) + (#x8FE6C6 #x9622) + (#x8FE6C7 #x9624) + (#x8FE6C8 #x9625) + (#x8FE6C9 #x9626) + (#x8FE6CA #x962C) + (#x8FE6CB #x9631) + (#x8FE6CC #x9633) + (#x8FE6CD #x9637) + (#x8FE6CE #x9638) + (#x8FE6CF #x9639) + (#x8FE6D0 #x963A) + (#x8FE6D1 #x963C) + (#x8FE6D2 #x963D) + (#x8FE6D3 #x9641) + (#x8FE6D4 #x9652) + (#x8FE6D5 #x9654) + (#x8FE6D6 #x9656) + (#x8FE6D7 #x9657) + (#x8FE6D8 #x9658) + (#x8FE6D9 #x9661) + (#x8FE6DA #x966E) + (#x8FE6DB #x9674) + (#x8FE6DC #x967B) + (#x8FE6DD #x967C) + (#x8FE6DE #x967E) + (#x8FE6DF #x967F) + (#x8FE6E0 #x9681) + (#x8FE6E1 #x9682) + (#x8FE6E2 #x9683) + (#x8FE6E3 #x9684) + (#x8FE6E4 #x9689) + (#x8FE6E5 #x9691) + (#x8FE6E6 #x9696) + (#x8FE6E7 #x969A) + (#x8FE6E8 #x969D) + (#x8FE6E9 #x969F) + (#x8FE6EA #x96A4) + (#x8FE6EB #x96A5) + (#x8FE6EC #x96A6) + (#x8FE6ED #x96A9) + (#x8FE6EE #x96AE) + (#x8FE6EF #x96AF) + (#x8FE6F0 #x96B3) + (#x8FE6F1 #x96BA) + (#x8FE6F2 #x96CA) + (#x8FE6F3 #x96D2) + (#x8FE6F4 #x5DB2) + (#x8FE6F5 #x96D8) + (#x8FE6F6 #x96DA) + (#x8FE6F7 #x96DD) + (#x8FE6F8 #x96DE) + (#x8FE6F9 #x96DF) + (#x8FE6FA #x96E9) + (#x8FE6FB #x96EF) + (#x8FE6FC #x96F1) + (#x8FE6FD #x96FA) + (#x8FE6FE #x9702) + (#x8FE7A1 #x9703) + (#x8FE7A2 #x9705) + (#x8FE7A3 #x9709) + (#x8FE7A4 #x971A) + (#x8FE7A5 #x971B) + (#x8FE7A6 #x971D) + (#x8FE7A7 #x9721) + (#x8FE7A8 #x9722) + (#x8FE7A9 #x9723) + (#x8FE7AA #x9728) + (#x8FE7AB #x9731) + (#x8FE7AC #x9733) + (#x8FE7AD #x9741) + (#x8FE7AE #x9743) + (#x8FE7AF #x974A) + (#x8FE7B0 #x974E) + (#x8FE7B1 #x974F) + (#x8FE7B2 #x9755) + (#x8FE7B3 #x9757) + (#x8FE7B4 #x9758) + (#x8FE7B5 #x975A) + (#x8FE7B6 #x975B) + (#x8FE7B7 #x9763) + (#x8FE7B8 #x9767) + (#x8FE7B9 #x976A) + (#x8FE7BA #x976E) + (#x8FE7BB #x9773) + (#x8FE7BC #x9776) + (#x8FE7BD #x9777) + (#x8FE7BE #x9778) + (#x8FE7BF #x977B) + (#x8FE7C0 #x977D) + (#x8FE7C1 #x977F) + (#x8FE7C2 #x9780) + (#x8FE7C3 #x9789) + (#x8FE7C4 #x9795) + (#x8FE7C5 #x9796) + (#x8FE7C6 #x9797) + (#x8FE7C7 #x9799) + (#x8FE7C8 #x979A) + (#x8FE7C9 #x979E) + (#x8FE7CA #x979F) + (#x8FE7CB #x97A2) + (#x8FE7CC #x97AC) + (#x8FE7CD #x97AE) + (#x8FE7CE #x97B1) + (#x8FE7CF #x97B2) + (#x8FE7D0 #x97B5) + (#x8FE7D1 #x97B6) + (#x8FE7D2 #x97B8) + (#x8FE7D3 #x97B9) + (#x8FE7D4 #x97BA) + (#x8FE7D5 #x97BC) + (#x8FE7D6 #x97BE) + (#x8FE7D7 #x97BF) + (#x8FE7D8 #x97C1) + (#x8FE7D9 #x97C4) + (#x8FE7DA #x97C5) + (#x8FE7DB #x97C7) + (#x8FE7DC #x97C9) + (#x8FE7DD #x97CA) + (#x8FE7DE #x97CC) + (#x8FE7DF #x97CD) + (#x8FE7E0 #x97CE) + (#x8FE7E1 #x97D0) + (#x8FE7E2 #x97D1) + (#x8FE7E3 #x97D4) + (#x8FE7E4 #x97D7) + (#x8FE7E5 #x97D8) + (#x8FE7E6 #x97D9) + (#x8FE7E7 #x97DD) + (#x8FE7E8 #x97DE) + (#x8FE7E9 #x97E0) + (#x8FE7EA #x97DB) + (#x8FE7EB #x97E1) + (#x8FE7EC #x97E4) + (#x8FE7ED #x97EF) + (#x8FE7EE #x97F1) + (#x8FE7EF #x97F4) + (#x8FE7F0 #x97F7) + (#x8FE7F1 #x97F8) + (#x8FE7F2 #x97FA) + (#x8FE7F3 #x9807) + (#x8FE7F4 #x980A) + (#x8FE7F5 #x9819) + (#x8FE7F6 #x980D) + (#x8FE7F7 #x980E) + (#x8FE7F8 #x9814) + (#x8FE7F9 #x9816) + (#x8FE7FA #x981C) + (#x8FE7FB #x981E) + (#x8FE7FC #x9820) + (#x8FE7FD #x9823) + (#x8FE7FE #x9826) + (#x8FE8A1 #x982B) + (#x8FE8A2 #x982E) + (#x8FE8A3 #x982F) + (#x8FE8A4 #x9830) + (#x8FE8A5 #x9832) + (#x8FE8A6 #x9833) + (#x8FE8A7 #x9835) + (#x8FE8A8 #x9825) + (#x8FE8A9 #x983E) + (#x8FE8AA #x9844) + (#x8FE8AB #x9847) + (#x8FE8AC #x984A) + (#x8FE8AD #x9851) + (#x8FE8AE #x9852) + (#x8FE8AF #x9853) + (#x8FE8B0 #x9856) + (#x8FE8B1 #x9857) + (#x8FE8B2 #x9859) + (#x8FE8B3 #x985A) + (#x8FE8B4 #x9862) + (#x8FE8B5 #x9863) + (#x8FE8B6 #x9865) + (#x8FE8B7 #x9866) + (#x8FE8B8 #x986A) + (#x8FE8B9 #x986C) + (#x8FE8BA #x98AB) + (#x8FE8BB #x98AD) + (#x8FE8BC #x98AE) + (#x8FE8BD #x98B0) + (#x8FE8BE #x98B4) + (#x8FE8BF #x98B7) + (#x8FE8C0 #x98B8) + (#x8FE8C1 #x98BA) + (#x8FE8C2 #x98BB) + (#x8FE8C3 #x98BF) + (#x8FE8C4 #x98C2) + (#x8FE8C5 #x98C5) + (#x8FE8C6 #x98C8) + (#x8FE8C7 #x98CC) + (#x8FE8C8 #x98E1) + (#x8FE8C9 #x98E3) + (#x8FE8CA #x98E5) + (#x8FE8CB #x98E6) + (#x8FE8CC #x98E7) + (#x8FE8CD #x98EA) + (#x8FE8CE #x98F3) + (#x8FE8CF #x98F6) + (#x8FE8D0 #x9902) + (#x8FE8D1 #x9907) + (#x8FE8D2 #x9908) + (#x8FE8D3 #x9911) + (#x8FE8D4 #x9915) + (#x8FE8D5 #x9916) + (#x8FE8D6 #x9917) + (#x8FE8D7 #x991A) + (#x8FE8D8 #x991B) + (#x8FE8D9 #x991C) + (#x8FE8DA #x991F) + (#x8FE8DB #x9922) + (#x8FE8DC #x9926) + (#x8FE8DD #x9927) + (#x8FE8DE #x992B) + (#x8FE8DF #x9931) + (#x8FE8E0 #x9932) + (#x8FE8E1 #x9933) + (#x8FE8E2 #x9934) + (#x8FE8E3 #x9935) + (#x8FE8E4 #x9939) + (#x8FE8E5 #x993A) + (#x8FE8E6 #x993B) + (#x8FE8E7 #x993C) + (#x8FE8E8 #x9940) + (#x8FE8E9 #x9941) + (#x8FE8EA #x9946) + (#x8FE8EB #x9947) + (#x8FE8EC #x9948) + (#x8FE8ED #x994D) + (#x8FE8EE #x994E) + (#x8FE8EF #x9954) + (#x8FE8F0 #x9958) + (#x8FE8F1 #x9959) + (#x8FE8F2 #x995B) + (#x8FE8F3 #x995C) + (#x8FE8F4 #x995E) + (#x8FE8F5 #x995F) + (#x8FE8F6 #x9960) + (#x8FE8F7 #x999B) + (#x8FE8F8 #x999D) + (#x8FE8F9 #x999F) + (#x8FE8FA #x99A6) + (#x8FE8FB #x99B0) + (#x8FE8FC #x99B1) + (#x8FE8FD #x99B2) + (#x8FE8FE #x99B5) + (#x8FE9A1 #x99B9) + (#x8FE9A2 #x99BA) + (#x8FE9A3 #x99BD) + (#x8FE9A4 #x99BF) + (#x8FE9A5 #x99C3) + (#x8FE9A6 #x99C9) + (#x8FE9A7 #x99D3) + (#x8FE9A8 #x99D4) + (#x8FE9A9 #x99D9) + (#x8FE9AA #x99DA) + (#x8FE9AB #x99DC) + (#x8FE9AC #x99DE) + (#x8FE9AD #x99E7) + (#x8FE9AE #x99EA) + (#x8FE9AF #x99EB) + (#x8FE9B0 #x99EC) + (#x8FE9B1 #x99F0) + (#x8FE9B2 #x99F4) + (#x8FE9B3 #x99F5) + (#x8FE9B4 #x99F9) + (#x8FE9B5 #x99FD) + (#x8FE9B6 #x99FE) + (#x8FE9B7 #x9A02) + (#x8FE9B8 #x9A03) + (#x8FE9B9 #x9A04) + (#x8FE9BA #x9A0B) + (#x8FE9BB #x9A0C) + (#x8FE9BC #x9A10) + (#x8FE9BD #x9A11) + (#x8FE9BE #x9A16) + (#x8FE9BF #x9A1E) + (#x8FE9C0 #x9A20) + (#x8FE9C1 #x9A22) + (#x8FE9C2 #x9A23) + (#x8FE9C3 #x9A24) + (#x8FE9C4 #x9A27) + (#x8FE9C5 #x9A2D) + (#x8FE9C6 #x9A2E) + (#x8FE9C7 #x9A33) + (#x8FE9C8 #x9A35) + (#x8FE9C9 #x9A36) + (#x8FE9CA #x9A38) + (#x8FE9CB #x9A47) + (#x8FE9CC #x9A41) + (#x8FE9CD #x9A44) + (#x8FE9CE #x9A4A) + (#x8FE9CF #x9A4B) + (#x8FE9D0 #x9A4C) + (#x8FE9D1 #x9A4E) + (#x8FE9D2 #x9A51) + (#x8FE9D3 #x9A54) + (#x8FE9D4 #x9A56) + (#x8FE9D5 #x9A5D) + (#x8FE9D6 #x9AAA) + (#x8FE9D7 #x9AAC) + (#x8FE9D8 #x9AAE) + (#x8FE9D9 #x9AAF) + (#x8FE9DA #x9AB2) + (#x8FE9DB #x9AB4) + (#x8FE9DC #x9AB5) + (#x8FE9DD #x9AB6) + (#x8FE9DE #x9AB9) + (#x8FE9DF #x9ABB) + (#x8FE9E0 #x9ABE) + (#x8FE9E1 #x9ABF) + (#x8FE9E2 #x9AC1) + (#x8FE9E3 #x9AC3) + (#x8FE9E4 #x9AC6) + (#x8FE9E5 #x9AC8) + (#x8FE9E6 #x9ACE) + (#x8FE9E7 #x9AD0) + (#x8FE9E8 #x9AD2) + (#x8FE9E9 #x9AD5) + (#x8FE9EA #x9AD6) + (#x8FE9EB #x9AD7) + (#x8FE9EC #x9ADB) + (#x8FE9ED #x9ADC) + (#x8FE9EE #x9AE0) + (#x8FE9EF #x9AE4) + (#x8FE9F0 #x9AE5) + (#x8FE9F1 #x9AE7) + (#x8FE9F2 #x9AE9) + (#x8FE9F3 #x9AEC) + (#x8FE9F4 #x9AF2) + (#x8FE9F5 #x9AF3) + (#x8FE9F6 #x9AF5) + (#x8FE9F7 #x9AF9) + (#x8FE9F8 #x9AFA) + (#x8FE9F9 #x9AFD) + (#x8FE9FA #x9AFF) + (#x8FE9FB #x9B00) + (#x8FE9FC #x9B01) + (#x8FE9FD #x9B02) + (#x8FE9FE #x9B03) + (#x8FEAA1 #x9B04) + (#x8FEAA2 #x9B05) + (#x8FEAA3 #x9B08) + (#x8FEAA4 #x9B09) + (#x8FEAA5 #x9B0B) + (#x8FEAA6 #x9B0C) + (#x8FEAA7 #x9B0D) + (#x8FEAA8 #x9B0E) + (#x8FEAA9 #x9B10) + (#x8FEAAA #x9B12) + (#x8FEAAB #x9B16) + (#x8FEAAC #x9B19) + (#x8FEAAD #x9B1B) + (#x8FEAAE #x9B1C) + (#x8FEAAF #x9B20) + (#x8FEAB0 #x9B26) + (#x8FEAB1 #x9B2B) + (#x8FEAB2 #x9B2D) + (#x8FEAB3 #x9B33) + (#x8FEAB4 #x9B34) + (#x8FEAB5 #x9B35) + (#x8FEAB6 #x9B37) + (#x8FEAB7 #x9B39) + (#x8FEAB8 #x9B3A) + (#x8FEAB9 #x9B3D) + (#x8FEABA #x9B48) + (#x8FEABB #x9B4B) + (#x8FEABC #x9B4C) + (#x8FEABD #x9B55) + (#x8FEABE #x9B56) + (#x8FEABF #x9B57) + (#x8FEAC0 #x9B5B) + (#x8FEAC1 #x9B5E) + (#x8FEAC2 #x9B61) + (#x8FEAC3 #x9B63) + (#x8FEAC4 #x9B65) + (#x8FEAC5 #x9B66) + (#x8FEAC6 #x9B68) + (#x8FEAC7 #x9B6A) + (#x8FEAC8 #x9B6B) + (#x8FEAC9 #x9B6C) + (#x8FEACA #x9B6D) + (#x8FEACB #x9B6E) + (#x8FEACC #x9B73) + (#x8FEACD #x9B75) + (#x8FEACE #x9B77) + (#x8FEACF #x9B78) + (#x8FEAD0 #x9B79) + (#x8FEAD1 #x9B7F) + (#x8FEAD2 #x9B80) + (#x8FEAD3 #x9B84) + (#x8FEAD4 #x9B85) + (#x8FEAD5 #x9B86) + (#x8FEAD6 #x9B87) + (#x8FEAD7 #x9B89) + (#x8FEAD8 #x9B8A) + (#x8FEAD9 #x9B8B) + (#x8FEADA #x9B8D) + (#x8FEADB #x9B8F) + (#x8FEADC #x9B90) + (#x8FEADD #x9B94) + (#x8FEADE #x9B9A) + (#x8FEADF #x9B9D) + (#x8FEAE0 #x9B9E) + (#x8FEAE1 #x9BA6) + (#x8FEAE2 #x9BA7) + (#x8FEAE3 #x9BA9) + (#x8FEAE4 #x9BAC) + (#x8FEAE5 #x9BB0) + (#x8FEAE6 #x9BB1) + (#x8FEAE7 #x9BB2) + (#x8FEAE8 #x9BB7) + (#x8FEAE9 #x9BB8) + (#x8FEAEA #x9BBB) + (#x8FEAEB #x9BBC) + (#x8FEAEC #x9BBE) + (#x8FEAED #x9BBF) + (#x8FEAEE #x9BC1) + (#x8FEAEF #x9BC7) + (#x8FEAF0 #x9BC8) + (#x8FEAF1 #x9BCE) + (#x8FEAF2 #x9BD0) + (#x8FEAF3 #x9BD7) + (#x8FEAF4 #x9BD8) + (#x8FEAF5 #x9BDD) + (#x8FEAF6 #x9BDF) + (#x8FEAF7 #x9BE5) + (#x8FEAF8 #x9BE7) + (#x8FEAF9 #x9BEA) + (#x8FEAFA #x9BEB) + (#x8FEAFB #x9BEF) + (#x8FEAFC #x9BF3) + (#x8FEAFD #x9BF7) + (#x8FEAFE #x9BF8) + (#x8FEBA1 #x9BF9) + (#x8FEBA2 #x9BFA) + (#x8FEBA3 #x9BFD) + (#x8FEBA4 #x9BFF) + (#x8FEBA5 #x9C00) + (#x8FEBA6 #x9C02) + (#x8FEBA7 #x9C0B) + (#x8FEBA8 #x9C0F) + (#x8FEBA9 #x9C11) + (#x8FEBAA #x9C16) + (#x8FEBAB #x9C18) + (#x8FEBAC #x9C19) + (#x8FEBAD #x9C1A) + (#x8FEBAE #x9C1C) + (#x8FEBAF #x9C1E) + (#x8FEBB0 #x9C22) + (#x8FEBB1 #x9C23) + (#x8FEBB2 #x9C26) + (#x8FEBB3 #x9C27) + (#x8FEBB4 #x9C28) + (#x8FEBB5 #x9C29) + (#x8FEBB6 #x9C2A) + (#x8FEBB7 #x9C31) + (#x8FEBB8 #x9C35) + (#x8FEBB9 #x9C36) + (#x8FEBBA #x9C37) + (#x8FEBBB #x9C3D) + (#x8FEBBC #x9C41) + (#x8FEBBD #x9C43) + (#x8FEBBE #x9C44) + (#x8FEBBF #x9C45) + (#x8FEBC0 #x9C49) + (#x8FEBC1 #x9C4A) + (#x8FEBC2 #x9C4E) + (#x8FEBC3 #x9C4F) + (#x8FEBC4 #x9C50) + (#x8FEBC5 #x9C53) + (#x8FEBC6 #x9C54) + (#x8FEBC7 #x9C56) + (#x8FEBC8 #x9C58) + (#x8FEBC9 #x9C5B) + (#x8FEBCA #x9C5D) + (#x8FEBCB #x9C5E) + (#x8FEBCC #x9C5F) + (#x8FEBCD #x9C63) + (#x8FEBCE #x9C69) + (#x8FEBCF #x9C6A) + (#x8FEBD0 #x9C5C) + (#x8FEBD1 #x9C6B) + (#x8FEBD2 #x9C68) + (#x8FEBD3 #x9C6E) + (#x8FEBD4 #x9C70) + (#x8FEBD5 #x9C72) + (#x8FEBD6 #x9C75) + (#x8FEBD7 #x9C77) + (#x8FEBD8 #x9C7B) + (#x8FEBD9 #x9CE6) + (#x8FEBDA #x9CF2) + (#x8FEBDB #x9CF7) + (#x8FEBDC #x9CF9) + (#x8FEBDD #x9D0B) + (#x8FEBDE #x9D02) + (#x8FEBDF #x9D11) + (#x8FEBE0 #x9D17) + (#x8FEBE1 #x9D18) + (#x8FEBE2 #x9D1C) + (#x8FEBE3 #x9D1D) + (#x8FEBE4 #x9D1E) + (#x8FEBE5 #x9D2F) + (#x8FEBE6 #x9D30) + (#x8FEBE7 #x9D32) + (#x8FEBE8 #x9D33) + (#x8FEBE9 #x9D34) + (#x8FEBEA #x9D3A) + (#x8FEBEB #x9D3C) + (#x8FEBEC #x9D45) + (#x8FEBED #x9D3D) + (#x8FEBEE #x9D42) + (#x8FEBEF #x9D43) + (#x8FEBF0 #x9D47) + (#x8FEBF1 #x9D4A) + (#x8FEBF2 #x9D53) + (#x8FEBF3 #x9D54) + (#x8FEBF4 #x9D5F) + (#x8FEBF5 #x9D63) + (#x8FEBF6 #x9D62) + (#x8FEBF7 #x9D65) + (#x8FEBF8 #x9D69) + (#x8FEBF9 #x9D6A) + (#x8FEBFA #x9D6B) + (#x8FEBFB #x9D70) + (#x8FEBFC #x9D76) + (#x8FEBFD #x9D77) + (#x8FEBFE #x9D7B) + (#x8FECA1 #x9D7C) + (#x8FECA2 #x9D7E) + (#x8FECA3 #x9D83) + (#x8FECA4 #x9D84) + (#x8FECA5 #x9D86) + (#x8FECA6 #x9D8A) + (#x8FECA7 #x9D8D) + (#x8FECA8 #x9D8E) + (#x8FECA9 #x9D92) + (#x8FECAA #x9D93) + (#x8FECAB #x9D95) + (#x8FECAC #x9D96) + (#x8FECAD #x9D97) + (#x8FECAE #x9D98) + (#x8FECAF #x9DA1) + (#x8FECB0 #x9DAA) + (#x8FECB1 #x9DAC) + (#x8FECB2 #x9DAE) + (#x8FECB3 #x9DB1) + (#x8FECB4 #x9DB5) + (#x8FECB5 #x9DB9) + (#x8FECB6 #x9DBC) + (#x8FECB7 #x9DBF) + (#x8FECB8 #x9DC3) + (#x8FECB9 #x9DC7) + (#x8FECBA #x9DC9) + (#x8FECBB #x9DCA) + (#x8FECBC #x9DD4) + (#x8FECBD #x9DD5) + (#x8FECBE #x9DD6) + (#x8FECBF #x9DD7) + (#x8FECC0 #x9DDA) + (#x8FECC1 #x9DDE) + (#x8FECC2 #x9DDF) + (#x8FECC3 #x9DE0) + (#x8FECC4 #x9DE5) + (#x8FECC5 #x9DE7) + (#x8FECC6 #x9DE9) + (#x8FECC7 #x9DEB) + (#x8FECC8 #x9DEE) + (#x8FECC9 #x9DF0) + (#x8FECCA #x9DF3) + (#x8FECCB #x9DF4) + (#x8FECCC #x9DFE) + (#x8FECCD #x9E0A) + (#x8FECCE #x9E02) + (#x8FECCF #x9E07) + (#x8FECD0 #x9E0E) + (#x8FECD1 #x9E10) + (#x8FECD2 #x9E11) + (#x8FECD3 #x9E12) + (#x8FECD4 #x9E15) + (#x8FECD5 #x9E16) + (#x8FECD6 #x9E19) + (#x8FECD7 #x9E1C) + (#x8FECD8 #x9E1D) + (#x8FECD9 #x9E7A) + (#x8FECDA #x9E7B) + (#x8FECDB #x9E7C) + (#x8FECDC #x9E80) + (#x8FECDD #x9E82) + (#x8FECDE #x9E83) + (#x8FECDF #x9E84) + (#x8FECE0 #x9E85) + (#x8FECE1 #x9E87) + (#x8FECE2 #x9E8E) + (#x8FECE3 #x9E8F) + (#x8FECE4 #x9E96) + (#x8FECE5 #x9E98) + (#x8FECE6 #x9E9B) + (#x8FECE7 #x9E9E) + (#x8FECE8 #x9EA4) + (#x8FECE9 #x9EA8) + (#x8FECEA #x9EAC) + (#x8FECEB #x9EAE) + (#x8FECEC #x9EAF) + (#x8FECED #x9EB0) + (#x8FECEE #x9EB3) + (#x8FECEF #x9EB4) + (#x8FECF0 #x9EB5) + (#x8FECF1 #x9EC6) + (#x8FECF2 #x9EC8) + (#x8FECF3 #x9ECB) + (#x8FECF4 #x9ED5) + (#x8FECF5 #x9EDF) + (#x8FECF6 #x9EE4) + (#x8FECF7 #x9EE7) + (#x8FECF8 #x9EEC) + (#x8FECF9 #x9EED) + (#x8FECFA #x9EEE) + (#x8FECFB #x9EF0) + (#x8FECFC #x9EF1) + (#x8FECFD #x9EF2) + (#x8FECFE #x9EF5) + (#x8FEDA1 #x9EF8) + (#x8FEDA2 #x9EFF) + (#x8FEDA3 #x9F02) + (#x8FEDA4 #x9F03) + (#x8FEDA5 #x9F09) + (#x8FEDA6 #x9F0F) + (#x8FEDA7 #x9F10) + (#x8FEDA8 #x9F11) + (#x8FEDA9 #x9F12) + (#x8FEDAA #x9F14) + (#x8FEDAB #x9F16) + (#x8FEDAC #x9F17) + (#x8FEDAD #x9F19) + (#x8FEDAE #x9F1A) + (#x8FEDAF #x9F1B) + (#x8FEDB0 #x9F1F) + (#x8FEDB1 #x9F22) + (#x8FEDB2 #x9F26) + (#x8FEDB3 #x9F2A) + (#x8FEDB4 #x9F2B) + (#x8FEDB5 #x9F2F) + (#x8FEDB6 #x9F31) + (#x8FEDB7 #x9F32) + (#x8FEDB8 #x9F34) + (#x8FEDB9 #x9F37) + (#x8FEDBA #x9F39) + (#x8FEDBB #x9F3A) + (#x8FEDBC #x9F3C) + (#x8FEDBD #x9F3D) + (#x8FEDBE #x9F3F) + (#x8FEDBF #x9F41) + (#x8FEDC0 #x9F43) + (#x8FEDC1 #x9F44) + (#x8FEDC2 #x9F45) + (#x8FEDC3 #x9F46) + (#x8FEDC4 #x9F47) + (#x8FEDC5 #x9F53) + (#x8FEDC6 #x9F55) + (#x8FEDC7 #x9F56) + (#x8FEDC8 #x9F57) + (#x8FEDC9 #x9F58) + (#x8FEDCA #x9F5A) + (#x8FEDCB #x9F5D) + (#x8FEDCC #x9F5E) + (#x8FEDCD #x9F68) + (#x8FEDCE #x9F69) + (#x8FEDCF #x9F6D) + (#x8FEDD0 #x9F6E) + (#x8FEDD1 #x9F6F) + (#x8FEDD2 #x9F70) + (#x8FEDD3 #x9F71) + (#x8FEDD4 #x9F73) + (#x8FEDD5 #x9F75) + (#x8FEDD6 #x9F7A) + (#x8FEDD7 #x9F7D) + (#x8FEDD8 #x9F8F) + (#x8FEDD9 #x9F90) + (#x8FEDDA #x9F91) + (#x8FEDDB #x9F92) + (#x8FEDDC #x9F94) + (#x8FEDDD #x9F96) + (#x8FEDDE #x9F97) + (#x8FEDDF #x9F9E) + (#x8FEDE0 #x9FA1) + (#x8FEDE1 #x9FA2) + (#x8FEDE2 #x9FA3) + (#x8FEDE3 #x9FA5) + (#x8FF5A1 #xE3AC) + (#x8FF5A2 #xE3AD) + (#x8FF5A3 #xE3AE) + (#x8FF5A4 #xE3AF) + (#x8FF5A5 #xE3B0) + (#x8FF5A6 #xE3B1) + (#x8FF5A7 #xE3B2) + (#x8FF5A8 #xE3B3) + (#x8FF5A9 #xE3B4) + (#x8FF5AA #xE3B5) + (#x8FF5AB #xE3B6) + (#x8FF5AC #xE3B7) + (#x8FF5AD #xE3B8) + (#x8FF5AE #xE3B9) + (#x8FF5AF #xE3BA) + (#x8FF5B0 #xE3BB) + (#x8FF5B1 #xE3BC) + (#x8FF5B2 #xE3BD) + (#x8FF5B3 #xE3BE) + (#x8FF5B4 #xE3BF) + (#x8FF5B5 #xE3C0) + (#x8FF5B6 #xE3C1) + (#x8FF5B7 #xE3C2) + (#x8FF5B8 #xE3C3) + (#x8FF5B9 #xE3C4) + (#x8FF5BA #xE3C5) + (#x8FF5BB #xE3C6) + (#x8FF5BC #xE3C7) + (#x8FF5BD #xE3C8) + (#x8FF5BE #xE3C9) + (#x8FF5BF #xE3CA) + (#x8FF5C0 #xE3CB) + (#x8FF5C1 #xE3CC) + (#x8FF5C2 #xE3CD) + (#x8FF5C3 #xE3CE) + (#x8FF5C4 #xE3CF) + (#x8FF5C5 #xE3D0) + (#x8FF5C6 #xE3D1) + (#x8FF5C7 #xE3D2) + (#x8FF5C8 #xE3D3) + (#x8FF5C9 #xE3D4) + (#x8FF5CA #xE3D5) + (#x8FF5CB #xE3D6) + (#x8FF5CC #xE3D7) + (#x8FF5CD #xE3D8) + (#x8FF5CE #xE3D9) + (#x8FF5CF #xE3DA) + (#x8FF5D0 #xE3DB) + (#x8FF5D1 #xE3DC) + (#x8FF5D2 #xE3DD) + (#x8FF5D3 #xE3DE) + (#x8FF5D4 #xE3DF) + (#x8FF5D5 #xE3E0) + (#x8FF5D6 #xE3E1) + (#x8FF5D7 #xE3E2) + (#x8FF5D8 #xE3E3) + (#x8FF5D9 #xE3E4) + (#x8FF5DA #xE3E5) + (#x8FF5DB #xE3E6) + (#x8FF5DC #xE3E7) + (#x8FF5DD #xE3E8) + (#x8FF5DE #xE3E9) + (#x8FF5DF #xE3EA) + (#x8FF5E0 #xE3EB) + (#x8FF5E1 #xE3EC) + (#x8FF5E2 #xE3ED) + (#x8FF5E3 #xE3EE) + (#x8FF5E4 #xE3EF) + (#x8FF5E5 #xE3F0) + (#x8FF5E6 #xE3F1) + (#x8FF5E7 #xE3F2) + (#x8FF5E8 #xE3F3) + (#x8FF5E9 #xE3F4) + (#x8FF5EA #xE3F5) + (#x8FF5EB #xE3F6) + (#x8FF5EC #xE3F7) + (#x8FF5ED #xE3F8) + (#x8FF5EE #xE3F9) + (#x8FF5EF #xE3FA) + (#x8FF5F0 #xE3FB) + (#x8FF5F1 #xE3FC) + (#x8FF5F2 #xE3FD) + (#x8FF5F3 #xE3FE) + (#x8FF5F4 #xE3FF) + (#x8FF5F5 #xE400) + (#x8FF5F6 #xE401) + (#x8FF5F7 #xE402) + (#x8FF5F8 #xE403) + (#x8FF5F9 #xE404) + (#x8FF5FA #xE405) + (#x8FF5FB #xE406) + (#x8FF5FC #xE407) + (#x8FF5FD #xE408) + (#x8FF5FE #xE409) + (#x8FF6A1 #xE40A) + (#x8FF6A2 #xE40B) + (#x8FF6A3 #xE40C) + (#x8FF6A4 #xE40D) + (#x8FF6A5 #xE40E) + (#x8FF6A6 #xE40F) + (#x8FF6A7 #xE410) + (#x8FF6A8 #xE411) + (#x8FF6A9 #xE412) + (#x8FF6AA #xE413) + (#x8FF6AB #xE414) + (#x8FF6AC #xE415) + (#x8FF6AD #xE416) + (#x8FF6AE #xE417) + (#x8FF6AF #xE418) + (#x8FF6B0 #xE419) + (#x8FF6B1 #xE41A) + (#x8FF6B2 #xE41B) + (#x8FF6B3 #xE41C) + (#x8FF6B4 #xE41D) + (#x8FF6B5 #xE41E) + (#x8FF6B6 #xE41F) + (#x8FF6B7 #xE420) + (#x8FF6B8 #xE421) + (#x8FF6B9 #xE422) + (#x8FF6BA #xE423) + (#x8FF6BB #xE424) + (#x8FF6BC #xE425) + (#x8FF6BD #xE426) + (#x8FF6BE #xE427) + (#x8FF6BF #xE428) + (#x8FF6C0 #xE429) + (#x8FF6C1 #xE42A) + (#x8FF6C2 #xE42B) + (#x8FF6C3 #xE42C) + (#x8FF6C4 #xE42D) + (#x8FF6C5 #xE42E) + (#x8FF6C6 #xE42F) + (#x8FF6C7 #xE430) + (#x8FF6C8 #xE431) + (#x8FF6C9 #xE432) + (#x8FF6CA #xE433) + (#x8FF6CB #xE434) + (#x8FF6CC #xE435) + (#x8FF6CD #xE436) + (#x8FF6CE #xE437) + (#x8FF6CF #xE438) + (#x8FF6D0 #xE439) + (#x8FF6D1 #xE43A) + (#x8FF6D2 #xE43B) + (#x8FF6D3 #xE43C) + (#x8FF6D4 #xE43D) + (#x8FF6D5 #xE43E) + (#x8FF6D6 #xE43F) + (#x8FF6D7 #xE440) + (#x8FF6D8 #xE441) + (#x8FF6D9 #xE442) + (#x8FF6DA #xE443) + (#x8FF6DB #xE444) + (#x8FF6DC #xE445) + (#x8FF6DD #xE446) + (#x8FF6DE #xE447) + (#x8FF6DF #xE448) + (#x8FF6E0 #xE449) + (#x8FF6E1 #xE44A) + (#x8FF6E2 #xE44B) + (#x8FF6E3 #xE44C) + (#x8FF6E4 #xE44D) + (#x8FF6E5 #xE44E) + (#x8FF6E6 #xE44F) + (#x8FF6E7 #xE450) + (#x8FF6E8 #xE451) + (#x8FF6E9 #xE452) + (#x8FF6EA #xE453) + (#x8FF6EB #xE454) + (#x8FF6EC #xE455) + (#x8FF6ED #xE456) + (#x8FF6EE #xE457) + (#x8FF6EF #xE458) + (#x8FF6F0 #xE459) + (#x8FF6F1 #xE45A) + (#x8FF6F2 #xE45B) + (#x8FF6F3 #xE45C) + (#x8FF6F4 #xE45D) + (#x8FF6F5 #xE45E) + (#x8FF6F6 #xE45F) + (#x8FF6F7 #xE460) + (#x8FF6F8 #xE461) + (#x8FF6F9 #xE462) + (#x8FF6FA #xE463) + (#x8FF6FB #xE464) + (#x8FF6FC #xE465) + (#x8FF6FD #xE466) + (#x8FF6FE #xE467) + (#x8FF7A1 #xE468) + (#x8FF7A2 #xE469) + (#x8FF7A3 #xE46A) + (#x8FF7A4 #xE46B) + (#x8FF7A5 #xE46C) + (#x8FF7A6 #xE46D) + (#x8FF7A7 #xE46E) + (#x8FF7A8 #xE46F) + (#x8FF7A9 #xE470) + (#x8FF7AA #xE471) + (#x8FF7AB #xE472) + (#x8FF7AC #xE473) + (#x8FF7AD #xE474) + (#x8FF7AE #xE475) + (#x8FF7AF #xE476) + (#x8FF7B0 #xE477) + (#x8FF7B1 #xE478) + (#x8FF7B2 #xE479) + (#x8FF7B3 #xE47A) + (#x8FF7B4 #xE47B) + (#x8FF7B5 #xE47C) + (#x8FF7B6 #xE47D) + (#x8FF7B7 #xE47E) + (#x8FF7B8 #xE47F) + (#x8FF7B9 #xE480) + (#x8FF7BA #xE481) + (#x8FF7BB #xE482) + (#x8FF7BC #xE483) + (#x8FF7BD #xE484) + (#x8FF7BE #xE485) + (#x8FF7BF #xE486) + (#x8FF7C0 #xE487) + (#x8FF7C1 #xE488) + (#x8FF7C2 #xE489) + (#x8FF7C3 #xE48A) + (#x8FF7C4 #xE48B) + (#x8FF7C5 #xE48C) + (#x8FF7C6 #xE48D) + (#x8FF7C7 #xE48E) + (#x8FF7C8 #xE48F) + (#x8FF7C9 #xE490) + (#x8FF7CA #xE491) + (#x8FF7CB #xE492) + (#x8FF7CC #xE493) + (#x8FF7CD #xE494) + (#x8FF7CE #xE495) + (#x8FF7CF #xE496) + (#x8FF7D0 #xE497) + (#x8FF7D1 #xE498) + (#x8FF7D2 #xE499) + (#x8FF7D3 #xE49A) + (#x8FF7D4 #xE49B) + (#x8FF7D5 #xE49C) + (#x8FF7D6 #xE49D) + (#x8FF7D7 #xE49E) + (#x8FF7D8 #xE49F) + (#x8FF7D9 #xE4A0) + (#x8FF7DA #xE4A1) + (#x8FF7DB #xE4A2) + (#x8FF7DC #xE4A3) + (#x8FF7DD #xE4A4) + (#x8FF7DE #xE4A5) + (#x8FF7DF #xE4A6) + (#x8FF7E0 #xE4A7) + (#x8FF7E1 #xE4A8) + (#x8FF7E2 #xE4A9) + (#x8FF7E3 #xE4AA) + (#x8FF7E4 #xE4AB) + (#x8FF7E5 #xE4AC) + (#x8FF7E6 #xE4AD) + (#x8FF7E7 #xE4AE) + (#x8FF7E8 #xE4AF) + (#x8FF7E9 #xE4B0) + (#x8FF7EA #xE4B1) + (#x8FF7EB #xE4B2) + (#x8FF7EC #xE4B3) + (#x8FF7ED #xE4B4) + (#x8FF7EE #xE4B5) + (#x8FF7EF #xE4B6) + (#x8FF7F0 #xE4B7) + (#x8FF7F1 #xE4B8) + (#x8FF7F2 #xE4B9) + (#x8FF7F3 #xE4BA) + (#x8FF7F4 #xE4BB) + (#x8FF7F5 #xE4BC) + (#x8FF7F6 #xE4BD) + (#x8FF7F7 #xE4BE) + (#x8FF7F8 #xE4BF) + (#x8FF7F9 #xE4C0) + (#x8FF7FA #xE4C1) + (#x8FF7FB #xE4C2) + (#x8FF7FC #xE4C3) + (#x8FF7FD #xE4C4) + (#x8FF7FE #xE4C5) + (#x8FF8A1 #xE4C6) + (#x8FF8A2 #xE4C7) + (#x8FF8A3 #xE4C8) + (#x8FF8A4 #xE4C9) + (#x8FF8A5 #xE4CA) + (#x8FF8A6 #xE4CB) + (#x8FF8A7 #xE4CC) + (#x8FF8A8 #xE4CD) + (#x8FF8A9 #xE4CE) + (#x8FF8AA #xE4CF) + (#x8FF8AB #xE4D0) + (#x8FF8AC #xE4D1) + (#x8FF8AD #xE4D2) + (#x8FF8AE #xE4D3) + (#x8FF8AF #xE4D4) + (#x8FF8B0 #xE4D5) + (#x8FF8B1 #xE4D6) + (#x8FF8B2 #xE4D7) + (#x8FF8B3 #xE4D8) + (#x8FF8B4 #xE4D9) + (#x8FF8B5 #xE4DA) + (#x8FF8B6 #xE4DB) + (#x8FF8B7 #xE4DC) + (#x8FF8B8 #xE4DD) + (#x8FF8B9 #xE4DE) + (#x8FF8BA #xE4DF) + (#x8FF8BB #xE4E0) + (#x8FF8BC #xE4E1) + (#x8FF8BD #xE4E2) + (#x8FF8BE #xE4E3) + (#x8FF8BF #xE4E4) + (#x8FF8C0 #xE4E5) + (#x8FF8C1 #xE4E6) + (#x8FF8C2 #xE4E7) + (#x8FF8C3 #xE4E8) + (#x8FF8C4 #xE4E9) + (#x8FF8C5 #xE4EA) + (#x8FF8C6 #xE4EB) + (#x8FF8C7 #xE4EC) + (#x8FF8C8 #xE4ED) + (#x8FF8C9 #xE4EE) + (#x8FF8CA #xE4EF) + (#x8FF8CB #xE4F0) + (#x8FF8CC #xE4F1) + (#x8FF8CD #xE4F2) + (#x8FF8CE #xE4F3) + (#x8FF8CF #xE4F4) + (#x8FF8D0 #xE4F5) + (#x8FF8D1 #xE4F6) + (#x8FF8D2 #xE4F7) + (#x8FF8D3 #xE4F8) + (#x8FF8D4 #xE4F9) + (#x8FF8D5 #xE4FA) + (#x8FF8D6 #xE4FB) + (#x8FF8D7 #xE4FC) + (#x8FF8D8 #xE4FD) + (#x8FF8D9 #xE4FE) + (#x8FF8DA #xE4FF) + (#x8FF8DB #xE500) + (#x8FF8DC #xE501) + (#x8FF8DD #xE502) + (#x8FF8DE #xE503) + (#x8FF8DF #xE504) + (#x8FF8E0 #xE505) + (#x8FF8E1 #xE506) + (#x8FF8E2 #xE507) + (#x8FF8E3 #xE508) + (#x8FF8E4 #xE509) + (#x8FF8E5 #xE50A) + (#x8FF8E6 #xE50B) + (#x8FF8E7 #xE50C) + (#x8FF8E8 #xE50D) + (#x8FF8E9 #xE50E) + (#x8FF8EA #xE50F) + (#x8FF8EB #xE510) + (#x8FF8EC #xE511) + (#x8FF8ED #xE512) + (#x8FF8EE #xE513) + (#x8FF8EF #xE514) + (#x8FF8F0 #xE515) + (#x8FF8F1 #xE516) + (#x8FF8F2 #xE517) + (#x8FF8F3 #xE518) + (#x8FF8F4 #xE519) + (#x8FF8F5 #xE51A) + (#x8FF8F6 #xE51B) + (#x8FF8F7 #xE51C) + (#x8FF8F8 #xE51D) + (#x8FF8F9 #xE51E) + (#x8FF8FA #xE51F) + (#x8FF8FB #xE520) + (#x8FF8FC #xE521) + (#x8FF8FD #xE522) + (#x8FF8FE #xE523) + (#x8FF9A1 #xE524) + (#x8FF9A2 #xE525) + (#x8FF9A3 #xE526) + (#x8FF9A4 #xE527) + (#x8FF9A5 #xE528) + (#x8FF9A6 #xE529) + (#x8FF9A7 #xE52A) + (#x8FF9A8 #xE52B) + (#x8FF9A9 #xE52C) + (#x8FF9AA #xE52D) + (#x8FF9AB #xE52E) + (#x8FF9AC #xE52F) + (#x8FF9AD #xE530) + (#x8FF9AE #xE531) + (#x8FF9AF #xE532) + (#x8FF9B0 #xE533) + (#x8FF9B1 #xE534) + (#x8FF9B2 #xE535) + (#x8FF9B3 #xE536) + (#x8FF9B4 #xE537) + (#x8FF9B5 #xE538) + (#x8FF9B6 #xE539) + (#x8FF9B7 #xE53A) + (#x8FF9B8 #xE53B) + (#x8FF9B9 #xE53C) + (#x8FF9BA #xE53D) + (#x8FF9BB #xE53E) + (#x8FF9BC #xE53F) + (#x8FF9BD #xE540) + (#x8FF9BE #xE541) + (#x8FF9BF #xE542) + (#x8FF9C0 #xE543) + (#x8FF9C1 #xE544) + (#x8FF9C2 #xE545) + (#x8FF9C3 #xE546) + (#x8FF9C4 #xE547) + (#x8FF9C5 #xE548) + (#x8FF9C6 #xE549) + (#x8FF9C7 #xE54A) + (#x8FF9C8 #xE54B) + (#x8FF9C9 #xE54C) + (#x8FF9CA #xE54D) + (#x8FF9CB #xE54E) + (#x8FF9CC #xE54F) + (#x8FF9CD #xE550) + (#x8FF9CE #xE551) + (#x8FF9CF #xE552) + (#x8FF9D0 #xE553) + (#x8FF9D1 #xE554) + (#x8FF9D2 #xE555) + (#x8FF9D3 #xE556) + (#x8FF9D4 #xE557) + (#x8FF9D5 #xE558) + (#x8FF9D6 #xE559) + (#x8FF9D7 #xE55A) + (#x8FF9D8 #xE55B) + (#x8FF9D9 #xE55C) + (#x8FF9DA #xE55D) + (#x8FF9DB #xE55E) + (#x8FF9DC #xE55F) + (#x8FF9DD #xE560) + (#x8FF9DE #xE561) + (#x8FF9DF #xE562) + (#x8FF9E0 #xE563) + (#x8FF9E1 #xE564) + (#x8FF9E2 #xE565) + (#x8FF9E3 #xE566) + (#x8FF9E4 #xE567) + (#x8FF9E5 #xE568) + (#x8FF9E6 #xE569) + (#x8FF9E7 #xE56A) + (#x8FF9E8 #xE56B) + (#x8FF9E9 #xE56C) + (#x8FF9EA #xE56D) + (#x8FF9EB #xE56E) + (#x8FF9EC #xE56F) + (#x8FF9ED #xE570) + (#x8FF9EE #xE571) + (#x8FF9EF #xE572) + (#x8FF9F0 #xE573) + (#x8FF9F1 #xE574) + (#x8FF9F2 #xE575) + (#x8FF9F3 #xE576) + (#x8FF9F4 #xE577) + (#x8FF9F5 #xE578) + (#x8FF9F6 #xE579) + (#x8FF9F7 #xE57A) + (#x8FF9F8 #xE57B) + (#x8FF9F9 #xE57C) + (#x8FF9FA #xE57D) + (#x8FF9FB #xE57E) + (#x8FF9FC #xE57F) + (#x8FF9FD #xE580) + (#x8FF9FE #xE581) + (#x8FFAA1 #xE582) + (#x8FFAA2 #xE583) + (#x8FFAA3 #xE584) + (#x8FFAA4 #xE585) + (#x8FFAA5 #xE586) + (#x8FFAA6 #xE587) + (#x8FFAA7 #xE588) + (#x8FFAA8 #xE589) + (#x8FFAA9 #xE58A) + (#x8FFAAA #xE58B) + (#x8FFAAB #xE58C) + (#x8FFAAC #xE58D) + (#x8FFAAD #xE58E) + (#x8FFAAE #xE58F) + (#x8FFAAF #xE590) + (#x8FFAB0 #xE591) + (#x8FFAB1 #xE592) + (#x8FFAB2 #xE593) + (#x8FFAB3 #xE594) + (#x8FFAB4 #xE595) + (#x8FFAB5 #xE596) + (#x8FFAB6 #xE597) + (#x8FFAB7 #xE598) + (#x8FFAB8 #xE599) + (#x8FFAB9 #xE59A) + (#x8FFABA #xE59B) + (#x8FFABB #xE59C) + (#x8FFABC #xE59D) + (#x8FFABD #xE59E) + (#x8FFABE #xE59F) + (#x8FFABF #xE5A0) + (#x8FFAC0 #xE5A1) + (#x8FFAC1 #xE5A2) + (#x8FFAC2 #xE5A3) + (#x8FFAC3 #xE5A4) + (#x8FFAC4 #xE5A5) + (#x8FFAC5 #xE5A6) + (#x8FFAC6 #xE5A7) + (#x8FFAC7 #xE5A8) + (#x8FFAC8 #xE5A9) + (#x8FFAC9 #xE5AA) + (#x8FFACA #xE5AB) + (#x8FFACB #xE5AC) + (#x8FFACC #xE5AD) + (#x8FFACD #xE5AE) + (#x8FFACE #xE5AF) + (#x8FFACF #xE5B0) + (#x8FFAD0 #xE5B1) + (#x8FFAD1 #xE5B2) + (#x8FFAD2 #xE5B3) + (#x8FFAD3 #xE5B4) + (#x8FFAD4 #xE5B5) + (#x8FFAD5 #xE5B6) + (#x8FFAD6 #xE5B7) + (#x8FFAD7 #xE5B8) + (#x8FFAD8 #xE5B9) + (#x8FFAD9 #xE5BA) + (#x8FFADA #xE5BB) + (#x8FFADB #xE5BC) + (#x8FFADC #xE5BD) + (#x8FFADD #xE5BE) + (#x8FFADE #xE5BF) + (#x8FFADF #xE5C0) + (#x8FFAE0 #xE5C1) + (#x8FFAE1 #xE5C2) + (#x8FFAE2 #xE5C3) + (#x8FFAE3 #xE5C4) + (#x8FFAE4 #xE5C5) + (#x8FFAE5 #xE5C6) + (#x8FFAE6 #xE5C7) + (#x8FFAE7 #xE5C8) + (#x8FFAE8 #xE5C9) + (#x8FFAE9 #xE5CA) + (#x8FFAEA #xE5CB) + (#x8FFAEB #xE5CC) + (#x8FFAEC #xE5CD) + (#x8FFAED #xE5CE) + (#x8FFAEE #xE5CF) + (#x8FFAEF #xE5D0) + (#x8FFAF0 #xE5D1) + (#x8FFAF1 #xE5D2) + (#x8FFAF2 #xE5D3) + (#x8FFAF3 #xE5D4) + (#x8FFAF4 #xE5D5) + (#x8FFAF5 #xE5D6) + (#x8FFAF6 #xE5D7) + (#x8FFAF7 #xE5D8) + (#x8FFAF8 #xE5D9) + (#x8FFAF9 #xE5DA) + (#x8FFAFA #xE5DB) + (#x8FFAFB #xE5DC) + (#x8FFAFC #xE5DD) + (#x8FFAFD #xE5DE) + (#x8FFAFE #xE5DF) + (#x8FFBA1 #xE5E0) + (#x8FFBA2 #xE5E1) + (#x8FFBA3 #xE5E2) + (#x8FFBA4 #xE5E3) + (#x8FFBA5 #xE5E4) + (#x8FFBA6 #xE5E5) + (#x8FFBA7 #xE5E6) + (#x8FFBA8 #xE5E7) + (#x8FFBA9 #xE5E8) + (#x8FFBAA #xE5E9) + (#x8FFBAB #xE5EA) + (#x8FFBAC #xE5EB) + (#x8FFBAD #xE5EC) + (#x8FFBAE #xE5ED) + (#x8FFBAF #xE5EE) + (#x8FFBB0 #xE5EF) + (#x8FFBB1 #xE5F0) + (#x8FFBB2 #xE5F1) + (#x8FFBB3 #xE5F2) + (#x8FFBB4 #xE5F3) + (#x8FFBB5 #xE5F4) + (#x8FFBB6 #xE5F5) + (#x8FFBB7 #xE5F6) + (#x8FFBB8 #xE5F7) + (#x8FFBB9 #xE5F8) + (#x8FFBBA #xE5F9) + (#x8FFBBB #xE5FA) + (#x8FFBBC #xE5FB) + (#x8FFBBD #xE5FC) + (#x8FFBBE #xE5FD) + (#x8FFBBF #xE5FE) + (#x8FFBC0 #xE5FF) + (#x8FFBC1 #xE600) + (#x8FFBC2 #xE601) + (#x8FFBC3 #xE602) + (#x8FFBC4 #xE603) + (#x8FFBC5 #xE604) + (#x8FFBC6 #xE605) + (#x8FFBC7 #xE606) + (#x8FFBC8 #xE607) + (#x8FFBC9 #xE608) + (#x8FFBCA #xE609) + (#x8FFBCB #xE60A) + (#x8FFBCC #xE60B) + (#x8FFBCD #xE60C) + (#x8FFBCE #xE60D) + (#x8FFBCF #xE60E) + (#x8FFBD0 #xE60F) + (#x8FFBD1 #xE610) + (#x8FFBD2 #xE611) + (#x8FFBD3 #xE612) + (#x8FFBD4 #xE613) + (#x8FFBD5 #xE614) + (#x8FFBD6 #xE615) + (#x8FFBD7 #xE616) + (#x8FFBD8 #xE617) + (#x8FFBD9 #xE618) + (#x8FFBDA #xE619) + (#x8FFBDB #xE61A) + (#x8FFBDC #xE61B) + (#x8FFBDD #xE61C) + (#x8FFBDE #xE61D) + (#x8FFBDF #xE61E) + (#x8FFBE0 #xE61F) + (#x8FFBE1 #xE620) + (#x8FFBE2 #xE621) + (#x8FFBE3 #xE622) + (#x8FFBE4 #xE623) + (#x8FFBE5 #xE624) + (#x8FFBE6 #xE625) + (#x8FFBE7 #xE626) + (#x8FFBE8 #xE627) + (#x8FFBE9 #xE628) + (#x8FFBEA #xE629) + (#x8FFBEB #xE62A) + (#x8FFBEC #xE62B) + (#x8FFBED #xE62C) + (#x8FFBEE #xE62D) + (#x8FFBEF #xE62E) + (#x8FFBF0 #xE62F) + (#x8FFBF1 #xE630) + (#x8FFBF2 #xE631) + (#x8FFBF3 #xE632) + (#x8FFBF4 #xE633) + (#x8FFBF5 #xE634) + (#x8FFBF6 #xE635) + (#x8FFBF7 #xE636) + (#x8FFBF8 #xE637) + (#x8FFBF9 #xE638) + (#x8FFBFA #xE639) + (#x8FFBFB #xE63A) + (#x8FFBFC #xE63B) + (#x8FFBFD #xE63C) + (#x8FFBFE #xE63D) + (#x8FFCA1 #xE63E) + (#x8FFCA2 #xE63F) + (#x8FFCA3 #xE640) + (#x8FFCA4 #xE641) + (#x8FFCA5 #xE642) + (#x8FFCA6 #xE643) + (#x8FFCA7 #xE644) + (#x8FFCA8 #xE645) + (#x8FFCA9 #xE646) + (#x8FFCAA #xE647) + (#x8FFCAB #xE648) + (#x8FFCAC #xE649) + (#x8FFCAD #xE64A) + (#x8FFCAE #xE64B) + (#x8FFCAF #xE64C) + (#x8FFCB0 #xE64D) + (#x8FFCB1 #xE64E) + (#x8FFCB2 #xE64F) + (#x8FFCB3 #xE650) + (#x8FFCB4 #xE651) + (#x8FFCB5 #xE652) + (#x8FFCB6 #xE653) + (#x8FFCB7 #xE654) + (#x8FFCB8 #xE655) + (#x8FFCB9 #xE656) + (#x8FFCBA #xE657) + (#x8FFCBB #xE658) + (#x8FFCBC #xE659) + (#x8FFCBD #xE65A) + (#x8FFCBE #xE65B) + (#x8FFCBF #xE65C) + (#x8FFCC0 #xE65D) + (#x8FFCC1 #xE65E) + (#x8FFCC2 #xE65F) + (#x8FFCC3 #xE660) + (#x8FFCC4 #xE661) + (#x8FFCC5 #xE662) + (#x8FFCC6 #xE663) + (#x8FFCC7 #xE664) + (#x8FFCC8 #xE665) + (#x8FFCC9 #xE666) + (#x8FFCCA #xE667) + (#x8FFCCB #xE668) + (#x8FFCCC #xE669) + (#x8FFCCD #xE66A) + (#x8FFCCE #xE66B) + (#x8FFCCF #xE66C) + (#x8FFCD0 #xE66D) + (#x8FFCD1 #xE66E) + (#x8FFCD2 #xE66F) + (#x8FFCD3 #xE670) + (#x8FFCD4 #xE671) + (#x8FFCD5 #xE672) + (#x8FFCD6 #xE673) + (#x8FFCD7 #xE674) + (#x8FFCD8 #xE675) + (#x8FFCD9 #xE676) + (#x8FFCDA #xE677) + (#x8FFCDB #xE678) + (#x8FFCDC #xE679) + (#x8FFCDD #xE67A) + (#x8FFCDE #xE67B) + (#x8FFCDF #xE67C) + (#x8FFCE0 #xE67D) + (#x8FFCE1 #xE67E) + (#x8FFCE2 #xE67F) + (#x8FFCE3 #xE680) + (#x8FFCE4 #xE681) + (#x8FFCE5 #xE682) + (#x8FFCE6 #xE683) + (#x8FFCE7 #xE684) + (#x8FFCE8 #xE685) + (#x8FFCE9 #xE686) + (#x8FFCEA #xE687) + (#x8FFCEB #xE688) + (#x8FFCEC #xE689) + (#x8FFCED #xE68A) + (#x8FFCEE #xE68B) + (#x8FFCEF #xE68C) + (#x8FFCF0 #xE68D) + (#x8FFCF1 #xE68E) + (#x8FFCF2 #xE68F) + (#x8FFCF3 #xE690) + (#x8FFCF4 #xE691) + (#x8FFCF5 #xE692) + (#x8FFCF6 #xE693) + (#x8FFCF7 #xE694) + (#x8FFCF8 #xE695) + (#x8FFCF9 #xE696) + (#x8FFCFA #xE697) + (#x8FFCFB #xE698) + (#x8FFCFC #xE699) + (#x8FFCFD #xE69A) + (#x8FFCFE #xE69B) + (#x8FFDA1 #xE69C) + (#x8FFDA2 #xE69D) + (#x8FFDA3 #xE69E) + (#x8FFDA4 #xE69F) + (#x8FFDA5 #xE6A0) + (#x8FFDA6 #xE6A1) + (#x8FFDA7 #xE6A2) + (#x8FFDA8 #xE6A3) + (#x8FFDA9 #xE6A4) + (#x8FFDAA #xE6A5) + (#x8FFDAB #xE6A6) + (#x8FFDAC #xE6A7) + (#x8FFDAD #xE6A8) + (#x8FFDAE #xE6A9) + (#x8FFDAF #xE6AA) + (#x8FFDB0 #xE6AB) + (#x8FFDB1 #xE6AC) + (#x8FFDB2 #xE6AD) + (#x8FFDB3 #xE6AE) + (#x8FFDB4 #xE6AF) + (#x8FFDB5 #xE6B0) + (#x8FFDB6 #xE6B1) + (#x8FFDB7 #xE6B2) + (#x8FFDB8 #xE6B3) + (#x8FFDB9 #xE6B4) + (#x8FFDBA #xE6B5) + (#x8FFDBB #xE6B6) + (#x8FFDBC #xE6B7) + (#x8FFDBD #xE6B8) + (#x8FFDBE #xE6B9) + (#x8FFDBF #xE6BA) + (#x8FFDC0 #xE6BB) + (#x8FFDC1 #xE6BC) + (#x8FFDC2 #xE6BD) + (#x8FFDC3 #xE6BE) + (#x8FFDC4 #xE6BF) + (#x8FFDC5 #xE6C0) + (#x8FFDC6 #xE6C1) + (#x8FFDC7 #xE6C2) + (#x8FFDC8 #xE6C3) + (#x8FFDC9 #xE6C4) + (#x8FFDCA #xE6C5) + (#x8FFDCB #xE6C6) + (#x8FFDCC #xE6C7) + (#x8FFDCD #xE6C8) + (#x8FFDCE #xE6C9) + (#x8FFDCF #xE6CA) + (#x8FFDD0 #xE6CB) + (#x8FFDD1 #xE6CC) + (#x8FFDD2 #xE6CD) + (#x8FFDD3 #xE6CE) + (#x8FFDD4 #xE6CF) + (#x8FFDD5 #xE6D0) + (#x8FFDD6 #xE6D1) + (#x8FFDD7 #xE6D2) + (#x8FFDD8 #xE6D3) + (#x8FFDD9 #xE6D4) + (#x8FFDDA #xE6D5) + (#x8FFDDB #xE6D6) + (#x8FFDDC #xE6D7) + (#x8FFDDD #xE6D8) + (#x8FFDDE #xE6D9) + (#x8FFDDF #xE6DA) + (#x8FFDE0 #xE6DB) + (#x8FFDE1 #xE6DC) + (#x8FFDE2 #xE6DD) + (#x8FFDE3 #xE6DE) + (#x8FFDE4 #xE6DF) + (#x8FFDE5 #xE6E0) + (#x8FFDE6 #xE6E1) + (#x8FFDE7 #xE6E2) + (#x8FFDE8 #xE6E3) + (#x8FFDE9 #xE6E4) + (#x8FFDEA #xE6E5) + (#x8FFDEB #xE6E6) + (#x8FFDEC #xE6E7) + (#x8FFDED #xE6E8) + (#x8FFDEE #xE6E9) + (#x8FFDEF #xE6EA) + (#x8FFDF0 #xE6EB) + (#x8FFDF1 #xE6EC) + (#x8FFDF2 #xE6ED) + (#x8FFDF3 #xE6EE) + (#x8FFDF4 #xE6EF) + (#x8FFDF5 #xE6F0) + (#x8FFDF6 #xE6F1) + (#x8FFDF7 #xE6F2) + (#x8FFDF8 #xE6F3) + (#x8FFDF9 #xE6F4) + (#x8FFDFA #xE6F5) + (#x8FFDFB #xE6F6) + (#x8FFDFC #xE6F7) + (#x8FFDFD #xE6F8) + (#x8FFDFE #xE6F9) + (#x8FFEA1 #xE6FA) + (#x8FFEA2 #xE6FB) + (#x8FFEA3 #xE6FC) + (#x8FFEA4 #xE6FD) + (#x8FFEA5 #xE6FE) + (#x8FFEA6 #xE6FF) + (#x8FFEA7 #xE700) + (#x8FFEA8 #xE701) + (#x8FFEA9 #xE702) + (#x8FFEAA #xE703) + (#x8FFEAB #xE704) + (#x8FFEAC #xE705) + (#x8FFEAD #xE706) + (#x8FFEAE #xE707) + (#x8FFEAF #xE708) + (#x8FFEB0 #xE709) + (#x8FFEB1 #xE70A) + (#x8FFEB2 #xE70B) + (#x8FFEB3 #xE70C) + (#x8FFEB4 #xE70D) + (#x8FFEB5 #xE70E) + (#x8FFEB6 #xE70F) + (#x8FFEB7 #xE710) + (#x8FFEB8 #xE711) + (#x8FFEB9 #xE712) + (#x8FFEBA #xE713) + (#x8FFEBB #xE714) + (#x8FFEBC #xE715) + (#x8FFEBD #xE716) + (#x8FFEBE #xE717) + (#x8FFEBF #xE718) + (#x8FFEC0 #xE719) + (#x8FFEC1 #xE71A) + (#x8FFEC2 #xE71B) + (#x8FFEC3 #xE71C) + (#x8FFEC4 #xE71D) + (#x8FFEC5 #xE71E) + (#x8FFEC6 #xE71F) + (#x8FFEC7 #xE720) + (#x8FFEC8 #xE721) + (#x8FFEC9 #xE722) + (#x8FFECA #xE723) + (#x8FFECB #xE724) + (#x8FFECC #xE725) + (#x8FFECD #xE726) + (#x8FFECE #xE727) + (#x8FFECF #xE728) + (#x8FFED0 #xE729) + (#x8FFED1 #xE72A) + (#x8FFED2 #xE72B) + (#x8FFED3 #xE72C) + (#x8FFED4 #xE72D) + (#x8FFED5 #xE72E) + (#x8FFED6 #xE72F) + (#x8FFED7 #xE730) + (#x8FFED8 #xE731) + (#x8FFED9 #xE732) + (#x8FFEDA #xE733) + (#x8FFEDB #xE734) + (#x8FFEDC #xE735) + (#x8FFEDD #xE736) + (#x8FFEDE #xE737) + (#x8FFEDF #xE738) + (#x8FFEE0 #xE739) + (#x8FFEE1 #xE73A) + (#x8FFEE2 #xE73B) + (#x8FFEE3 #xE73C) + (#x8FFEE4 #xE73D) + (#x8FFEE5 #xE73E) + (#x8FFEE6 #xE73F) + (#x8FFEE7 #xE740) + (#x8FFEE8 #xE741) + (#x8FFEE9 #xE742) + (#x8FFEEA #xE743) + (#x8FFEEB #xE744) + (#x8FFEEC #xE745) + (#x8FFEED #xE746) + (#x8FFEEE #xE747) + (#x8FFEEF #xE748) + (#x8FFEF0 #xE749) + (#x8FFEF1 #xE74A) + (#x8FFEF2 #xE74B) + (#x8FFEF3 #xE74C) + (#x8FFEF4 #xE74D) + (#x8FFEF5 #xE74E) + (#x8FFEF6 #xE74F) + (#x8FFEF7 #xE750) + (#x8FFEF8 #xE751) + (#x8FFEF9 #xE752) + (#x8FFEFA #xE753) + (#x8FFEFB #xE754) + (#x8FFEFC #xE755) + (#x8FFEFD #xE756) + (#x8FFEFE #xE757) + (#xA1A1 #x3000) + (#xA1A2 #x3001) + (#xA1A3 #x3002) + (#xA1A4 #xFF0C) + (#xA1A5 #xFF0E) + (#xA1A6 #x30FB) + (#xA1A7 #xFF1A) + (#xA1A8 #xFF1B) + (#xA1A9 #xFF1F) + (#xA1AA #xFF01) + (#xA1AB #x309B) + (#xA1AC #x309C) + (#xA1AD #xB4) + (#xA1AE #xFF40) + (#xA1AF #xA8) + (#xA1B0 #xFF3E) + (#xA1B1 #xFFE3) + (#xA1B2 #xFF3F) + (#xA1B3 #x30FD) + (#xA1B4 #x30FE) + (#xA1B5 #x309D) + (#xA1B6 #x309E) + (#xA1B7 #x3003) + (#xA1B8 #x4EDD) + (#xA1B9 #x3005) + (#xA1BA #x3006) + (#xA1BB #x3007) + (#xA1BC #x30FC) + (#xA1BD #x2015) + (#xA1BE #x2010) + (#xA1BF #xFF0F) + (#xA1C0 #xFF3C) + (#xA1C1 #x301C) + (#xA1C2 #x2016) + (#xA1C3 #xFF5C) + (#xA1C4 #x2026) + (#xA1C5 #x2025) + (#xA1C6 #x2018) + (#xA1C7 #x2019) + (#xA1C8 #x201C) + (#xA1C9 #x201D) + (#xA1CA #xFF08) + (#xA1CB #xFF09) + (#xA1CC #x3014) + (#xA1CD #x3015) + (#xA1CE #xFF3B) + (#xA1CF #xFF3D) + (#xA1D0 #xFF5B) + (#xA1D1 #xFF5D) + (#xA1D2 #x3008) + (#xA1D3 #x3009) + (#xA1D4 #x300A) + (#xA1D5 #x300B) + (#xA1D6 #x300C) + (#xA1D7 #x300D) + (#xA1D8 #x300E) + (#xA1D9 #x300F) + (#xA1DA #x3010) + (#xA1DB #x3011) + (#xA1DC #xFF0B) + (#xA1DD #x2212) + (#xA1DE #xB1) + (#xA1DF #xD7) + (#xA1E0 #xF7) + (#xA1E1 #xFF1D) + (#xA1E2 #x2260) + (#xA1E3 #xFF1C) + (#xA1E4 #xFF1E) + (#xA1E5 #x2266) + (#xA1E6 #x2267) + (#xA1E7 #x221E) + (#xA1E8 #x2234) + (#xA1E9 #x2642) + (#xA1EA #x2640) + (#xA1EB #xB0) + (#xA1EC #x2032) + (#xA1ED #x2033) + (#xA1EE #x2103) + (#xA1EF #xFFE5) + (#xA1F0 #xFF04) + (#xA1F1 #xA2) + (#xA1F2 #xA3) + (#xA1F3 #xFF05) + (#xA1F4 #xFF03) + (#xA1F5 #xFF06) + (#xA1F6 #xFF0A) + (#xA1F7 #xFF20) + (#xA1F8 #xA7) + (#xA1F9 #x2606) + (#xA1FA #x2605) + (#xA1FB #x25CB) + (#xA1FC #x25CF) + (#xA1FD #x25CE) + (#xA1FE #x25C7) + (#xA2A1 #x25C6) + (#xA2A2 #x25A1) + (#xA2A3 #x25A0) + (#xA2A4 #x25B3) + (#xA2A5 #x25B2) + (#xA2A6 #x25BD) + (#xA2A7 #x25BC) + (#xA2A8 #x203B) + (#xA2A9 #x3012) + (#xA2AA #x2192) + (#xA2AB #x2190) + (#xA2AC #x2191) + (#xA2AD #x2193) + (#xA2AE #x3013) + (#xA2BA #x2208) + (#xA2BB #x220B) + (#xA2BC #x2286) + (#xA2BD #x2287) + (#xA2BE #x2282) + (#xA2BF #x2283) + (#xA2C0 #x222A) + (#xA2C1 #x2229) + (#xA2CA #x2227) + (#xA2CB #x2228) + (#xA2CC #xAC) + (#xA2CD #x21D2) + (#xA2CE #x21D4) + (#xA2CF #x2200) + (#xA2D0 #x2203) + (#xA2DC #x2220) + (#xA2DD #x22A5) + (#xA2DE #x2312) + (#xA2DF #x2202) + (#xA2E0 #x2207) + (#xA2E1 #x2261) + (#xA2E2 #x2252) + (#xA2E3 #x226A) + (#xA2E4 #x226B) + (#xA2E5 #x221A) + (#xA2E6 #x223D) + (#xA2E7 #x221D) + (#xA2E8 #x2235) + (#xA2E9 #x222B) + (#xA2EA #x222C) + (#xA2F2 #x212B) + (#xA2F3 #x2030) + (#xA2F4 #x266F) + (#xA2F5 #x266D) + (#xA2F6 #x266A) + (#xA2F7 #x2020) + (#xA2F8 #x2021) + (#xA2F9 #xB6) + (#xA2FE #x25EF) + (#xA3B0 #xFF10) + (#xA3B1 #xFF11) + (#xA3B2 #xFF12) + (#xA3B3 #xFF13) + (#xA3B4 #xFF14) + (#xA3B5 #xFF15) + (#xA3B6 #xFF16) + (#xA3B7 #xFF17) + (#xA3B8 #xFF18) + (#xA3B9 #xFF19) + (#xA3C1 #xFF21) + (#xA3C2 #xFF22) + (#xA3C3 #xFF23) + (#xA3C4 #xFF24) + (#xA3C5 #xFF25) + (#xA3C6 #xFF26) + (#xA3C7 #xFF27) + (#xA3C8 #xFF28) + (#xA3C9 #xFF29) + (#xA3CA #xFF2A) + (#xA3CB #xFF2B) + (#xA3CC #xFF2C) + (#xA3CD #xFF2D) + (#xA3CE #xFF2E) + (#xA3CF #xFF2F) + (#xA3D0 #xFF30) + (#xA3D1 #xFF31) + (#xA3D2 #xFF32) + (#xA3D3 #xFF33) + (#xA3D4 #xFF34) + (#xA3D5 #xFF35) + (#xA3D6 #xFF36) + (#xA3D7 #xFF37) + (#xA3D8 #xFF38) + (#xA3D9 #xFF39) + (#xA3DA #xFF3A) + (#xA3E1 #xFF41) + (#xA3E2 #xFF42) + (#xA3E3 #xFF43) + (#xA3E4 #xFF44) + (#xA3E5 #xFF45) + (#xA3E6 #xFF46) + (#xA3E7 #xFF47) + (#xA3E8 #xFF48) + (#xA3E9 #xFF49) + (#xA3EA #xFF4A) + (#xA3EB #xFF4B) + (#xA3EC #xFF4C) + (#xA3ED #xFF4D) + (#xA3EE #xFF4E) + (#xA3EF #xFF4F) + (#xA3F0 #xFF50) + (#xA3F1 #xFF51) + (#xA3F2 #xFF52) + (#xA3F3 #xFF53) + (#xA3F4 #xFF54) + (#xA3F5 #xFF55) + (#xA3F6 #xFF56) + (#xA3F7 #xFF57) + (#xA3F8 #xFF58) + (#xA3F9 #xFF59) + (#xA3FA #xFF5A) + (#xA4A1 #x3041) + (#xA4A2 #x3042) + (#xA4A3 #x3043) + (#xA4A4 #x3044) + (#xA4A5 #x3045) + (#xA4A6 #x3046) + (#xA4A7 #x3047) + (#xA4A8 #x3048) + (#xA4A9 #x3049) + (#xA4AA #x304A) + (#xA4AB #x304B) + (#xA4AC #x304C) + (#xA4AD #x304D) + (#xA4AE #x304E) + (#xA4AF #x304F) + (#xA4B0 #x3050) + (#xA4B1 #x3051) + (#xA4B2 #x3052) + (#xA4B3 #x3053) + (#xA4B4 #x3054) + (#xA4B5 #x3055) + (#xA4B6 #x3056) + (#xA4B7 #x3057) + (#xA4B8 #x3058) + (#xA4B9 #x3059) + (#xA4BA #x305A) + (#xA4BB #x305B) + (#xA4BC #x305C) + (#xA4BD #x305D) + (#xA4BE #x305E) + (#xA4BF #x305F) + (#xA4C0 #x3060) + (#xA4C1 #x3061) + (#xA4C2 #x3062) + (#xA4C3 #x3063) + (#xA4C4 #x3064) + (#xA4C5 #x3065) + (#xA4C6 #x3066) + (#xA4C7 #x3067) + (#xA4C8 #x3068) + (#xA4C9 #x3069) + (#xA4CA #x306A) + (#xA4CB #x306B) + (#xA4CC #x306C) + (#xA4CD #x306D) + (#xA4CE #x306E) + (#xA4CF #x306F) + (#xA4D0 #x3070) + (#xA4D1 #x3071) + (#xA4D2 #x3072) + (#xA4D3 #x3073) + (#xA4D4 #x3074) + (#xA4D5 #x3075) + (#xA4D6 #x3076) + (#xA4D7 #x3077) + (#xA4D8 #x3078) + (#xA4D9 #x3079) + (#xA4DA #x307A) + (#xA4DB #x307B) + (#xA4DC #x307C) + (#xA4DD #x307D) + (#xA4DE #x307E) + (#xA4DF #x307F) + (#xA4E0 #x3080) + (#xA4E1 #x3081) + (#xA4E2 #x3082) + (#xA4E3 #x3083) + (#xA4E4 #x3084) + (#xA4E5 #x3085) + (#xA4E6 #x3086) + (#xA4E7 #x3087) + (#xA4E8 #x3088) + (#xA4E9 #x3089) + (#xA4EA #x308A) + (#xA4EB #x308B) + (#xA4EC #x308C) + (#xA4ED #x308D) + (#xA4EE #x308E) + (#xA4EF #x308F) + (#xA4F0 #x3090) + (#xA4F1 #x3091) + (#xA4F2 #x3092) + (#xA4F3 #x3093) + (#xA5A1 #x30A1) + (#xA5A2 #x30A2) + (#xA5A3 #x30A3) + (#xA5A4 #x30A4) + (#xA5A5 #x30A5) + (#xA5A6 #x30A6) + (#xA5A7 #x30A7) + (#xA5A8 #x30A8) + (#xA5A9 #x30A9) + (#xA5AA #x30AA) + (#xA5AB #x30AB) + (#xA5AC #x30AC) + (#xA5AD #x30AD) + (#xA5AE #x30AE) + (#xA5AF #x30AF) + (#xA5B0 #x30B0) + (#xA5B1 #x30B1) + (#xA5B2 #x30B2) + (#xA5B3 #x30B3) + (#xA5B4 #x30B4) + (#xA5B5 #x30B5) + (#xA5B6 #x30B6) + (#xA5B7 #x30B7) + (#xA5B8 #x30B8) + (#xA5B9 #x30B9) + (#xA5BA #x30BA) + (#xA5BB #x30BB) + (#xA5BC #x30BC) + (#xA5BD #x30BD) + (#xA5BE #x30BE) + (#xA5BF #x30BF) + (#xA5C0 #x30C0) + (#xA5C1 #x30C1) + (#xA5C2 #x30C2) + (#xA5C3 #x30C3) + (#xA5C4 #x30C4) + (#xA5C5 #x30C5) + (#xA5C6 #x30C6) + (#xA5C7 #x30C7) + (#xA5C8 #x30C8) + (#xA5C9 #x30C9) + (#xA5CA #x30CA) + (#xA5CB #x30CB) + (#xA5CC #x30CC) + (#xA5CD #x30CD) + (#xA5CE #x30CE) + (#xA5CF #x30CF) + (#xA5D0 #x30D0) + (#xA5D1 #x30D1) + (#xA5D2 #x30D2) + (#xA5D3 #x30D3) + (#xA5D4 #x30D4) + (#xA5D5 #x30D5) + (#xA5D6 #x30D6) + (#xA5D7 #x30D7) + (#xA5D8 #x30D8) + (#xA5D9 #x30D9) + (#xA5DA #x30DA) + (#xA5DB #x30DB) + (#xA5DC #x30DC) + (#xA5DD #x30DD) + (#xA5DE #x30DE) + (#xA5DF #x30DF) + (#xA5E0 #x30E0) + (#xA5E1 #x30E1) + (#xA5E2 #x30E2) + (#xA5E3 #x30E3) + (#xA5E4 #x30E4) + (#xA5E5 #x30E5) + (#xA5E6 #x30E6) + (#xA5E7 #x30E7) + (#xA5E8 #x30E8) + (#xA5E9 #x30E9) + (#xA5EA #x30EA) + (#xA5EB #x30EB) + (#xA5EC #x30EC) + (#xA5ED #x30ED) + (#xA5EE #x30EE) + (#xA5EF #x30EF) + (#xA5F0 #x30F0) + (#xA5F1 #x30F1) + (#xA5F2 #x30F2) + (#xA5F3 #x30F3) + (#xA5F4 #x30F4) + (#xA5F5 #x30F5) + (#xA5F6 #x30F6) + (#xA6A1 #x391) + (#xA6A2 #x392) + (#xA6A3 #x393) + (#xA6A4 #x394) + (#xA6A5 #x395) + (#xA6A6 #x396) + (#xA6A7 #x397) + (#xA6A8 #x398) + (#xA6A9 #x399) + (#xA6AA #x39A) + (#xA6AB #x39B) + (#xA6AC #x39C) + (#xA6AD #x39D) + (#xA6AE #x39E) + (#xA6AF #x39F) + (#xA6B0 #x3A0) + (#xA6B1 #x3A1) + (#xA6B2 #x3A3) + (#xA6B3 #x3A4) + (#xA6B4 #x3A5) + (#xA6B5 #x3A6) + (#xA6B6 #x3A7) + (#xA6B7 #x3A8) + (#xA6B8 #x3A9) + (#xA6C1 #x3B1) + (#xA6C2 #x3B2) + (#xA6C3 #x3B3) + (#xA6C4 #x3B4) + (#xA6C5 #x3B5) + (#xA6C6 #x3B6) + (#xA6C7 #x3B7) + (#xA6C8 #x3B8) + (#xA6C9 #x3B9) + (#xA6CA #x3BA) + (#xA6CB #x3BB) + (#xA6CC #x3BC) + (#xA6CD #x3BD) + (#xA6CE #x3BE) + (#xA6CF #x3BF) + (#xA6D0 #x3C0) + (#xA6D1 #x3C1) + (#xA6D2 #x3C3) + (#xA6D3 #x3C4) + (#xA6D4 #x3C5) + (#xA6D5 #x3C6) + (#xA6D6 #x3C7) + (#xA6D7 #x3C8) + (#xA6D8 #x3C9) + (#xA7A1 #x410) + (#xA7A2 #x411) + (#xA7A3 #x412) + (#xA7A4 #x413) + (#xA7A5 #x414) + (#xA7A6 #x415) + (#xA7A7 #x401) + (#xA7A8 #x416) + (#xA7A9 #x417) + (#xA7AA #x418) + (#xA7AB #x419) + (#xA7AC #x41A) + (#xA7AD #x41B) + (#xA7AE #x41C) + (#xA7AF #x41D) + (#xA7B0 #x41E) + (#xA7B1 #x41F) + (#xA7B2 #x420) + (#xA7B3 #x421) + (#xA7B4 #x422) + (#xA7B5 #x423) + (#xA7B6 #x424) + (#xA7B7 #x425) + (#xA7B8 #x426) + (#xA7B9 #x427) + (#xA7BA #x428) + (#xA7BB #x429) + (#xA7BC #x42A) + (#xA7BD #x42B) + (#xA7BE #x42C) + (#xA7BF #x42D) + (#xA7C0 #x42E) + (#xA7C1 #x42F) + (#xA7D1 #x430) + (#xA7D2 #x431) + (#xA7D3 #x432) + (#xA7D4 #x433) + (#xA7D5 #x434) + (#xA7D6 #x435) + (#xA7D7 #x451) + (#xA7D8 #x436) + (#xA7D9 #x437) + (#xA7DA #x438) + (#xA7DB #x439) + (#xA7DC #x43A) + (#xA7DD #x43B) + (#xA7DE #x43C) + (#xA7DF #x43D) + (#xA7E0 #x43E) + (#xA7E1 #x43F) + (#xA7E2 #x440) + (#xA7E3 #x441) + (#xA7E4 #x442) + (#xA7E5 #x443) + (#xA7E6 #x444) + (#xA7E7 #x445) + (#xA7E8 #x446) + (#xA7E9 #x447) + (#xA7EA #x448) + (#xA7EB #x449) + (#xA7EC #x44A) + (#xA7ED #x44B) + (#xA7EE #x44C) + (#xA7EF #x44D) + (#xA7F0 #x44E) + (#xA7F1 #x44F) + (#xA8A1 #x2500) + (#xA8A2 #x2502) + (#xA8A3 #x250C) + (#xA8A4 #x2510) + (#xA8A5 #x2518) + (#xA8A6 #x2514) + (#xA8A7 #x251C) + (#xA8A8 #x252C) + (#xA8A9 #x2524) + (#xA8AA #x2534) + (#xA8AB #x253C) + (#xA8AC #x2501) + (#xA8AD #x2503) + (#xA8AE #x250F) + (#xA8AF #x2513) + (#xA8B0 #x251B) + (#xA8B1 #x2517) + (#xA8B2 #x2523) + (#xA8B3 #x2533) + (#xA8B4 #x252B) + (#xA8B5 #x253B) + (#xA8B6 #x254B) + (#xA8B7 #x2520) + (#xA8B8 #x252F) + (#xA8B9 #x2528) + (#xA8BA #x2537) + (#xA8BB #x253F) + (#xA8BC #x251D) + (#xA8BD #x2530) + (#xA8BE #x2525) + (#xA8BF #x2538) + (#xA8C0 #x2542) + (#xB0A1 #x4E9C) + (#xB0A2 #x5516) + (#xB0A3 #x5A03) + (#xB0A4 #x963F) + (#xB0A5 #x54C0) + (#xB0A6 #x611B) + (#xB0A7 #x6328) + (#xB0A8 #x59F6) + (#xB0A9 #x9022) + (#xB0AA #x8475) + (#xB0AB #x831C) + (#xB0AC #x7A50) + (#xB0AD #x60AA) + (#xB0AE #x63E1) + (#xB0AF #x6E25) + (#xB0B0 #x65ED) + (#xB0B1 #x8466) + (#xB0B2 #x82A6) + (#xB0B3 #x9BF5) + (#xB0B4 #x6893) + (#xB0B5 #x5727) + (#xB0B6 #x65A1) + (#xB0B7 #x6271) + (#xB0B8 #x5B9B) + (#xB0B9 #x59D0) + (#xB0BA #x867B) + (#xB0BB #x98F4) + (#xB0BC #x7D62) + (#xB0BD #x7DBE) + (#xB0BE #x9B8E) + (#xB0BF #x6216) + (#xB0C0 #x7C9F) + (#xB0C1 #x88B7) + (#xB0C2 #x5B89) + (#xB0C3 #x5EB5) + (#xB0C4 #x6309) + (#xB0C5 #x6697) + (#xB0C6 #x6848) + (#xB0C7 #x95C7) + (#xB0C8 #x978D) + (#xB0C9 #x674F) + (#xB0CA #x4EE5) + (#xB0CB #x4F0A) + (#xB0CC #x4F4D) + (#xB0CD #x4F9D) + (#xB0CE #x5049) + (#xB0CF #x56F2) + (#xB0D0 #x5937) + (#xB0D1 #x59D4) + (#xB0D2 #x5A01) + (#xB0D3 #x5C09) + (#xB0D4 #x60DF) + (#xB0D5 #x610F) + (#xB0D6 #x6170) + (#xB0D7 #x6613) + (#xB0D8 #x6905) + (#xB0D9 #x70BA) + (#xB0DA #x754F) + (#xB0DB #x7570) + (#xB0DC #x79FB) + (#xB0DD #x7DAD) + (#xB0DE #x7DEF) + (#xB0DF #x80C3) + (#xB0E0 #x840E) + (#xB0E1 #x8863) + (#xB0E2 #x8B02) + (#xB0E3 #x9055) + (#xB0E4 #x907A) + (#xB0E5 #x533B) + (#xB0E6 #x4E95) + (#xB0E7 #x4EA5) + (#xB0E8 #x57DF) + (#xB0E9 #x80B2) + (#xB0EA #x90C1) + (#xB0EB #x78EF) + (#xB0EC #x4E00) + (#xB0ED #x58F1) + (#xB0EE #x6EA2) + (#xB0EF #x9038) + (#xB0F0 #x7A32) + (#xB0F1 #x8328) + (#xB0F2 #x828B) + (#xB0F3 #x9C2F) + (#xB0F4 #x5141) + (#xB0F5 #x5370) + (#xB0F6 #x54BD) + (#xB0F7 #x54E1) + (#xB0F8 #x56E0) + (#xB0F9 #x59FB) + (#xB0FA #x5F15) + (#xB0FB #x98F2) + (#xB0FC #x6DEB) + (#xB0FD #x80E4) + (#xB0FE #x852D) + (#xB1A1 #x9662) + (#xB1A2 #x9670) + (#xB1A3 #x96A0) + (#xB1A4 #x97FB) + (#xB1A5 #x540B) + (#xB1A6 #x53F3) + (#xB1A7 #x5B87) + (#xB1A8 #x70CF) + (#xB1A9 #x7FBD) + (#xB1AA #x8FC2) + (#xB1AB #x96E8) + (#xB1AC #x536F) + (#xB1AD #x9D5C) + (#xB1AE #x7ABA) + (#xB1AF #x4E11) + (#xB1B0 #x7893) + (#xB1B1 #x81FC) + (#xB1B2 #x6E26) + (#xB1B3 #x5618) + (#xB1B4 #x5504) + (#xB1B5 #x6B1D) + (#xB1B6 #x851A) + (#xB1B7 #x9C3B) + (#xB1B8 #x59E5) + (#xB1B9 #x53A9) + (#xB1BA #x6D66) + (#xB1BB #x74DC) + (#xB1BC #x958F) + (#xB1BD #x5642) + (#xB1BE #x4E91) + (#xB1BF #x904B) + (#xB1C0 #x96F2) + (#xB1C1 #x834F) + (#xB1C2 #x990C) + (#xB1C3 #x53E1) + (#xB1C4 #x55B6) + (#xB1C5 #x5B30) + (#xB1C6 #x5F71) + (#xB1C7 #x6620) + (#xB1C8 #x66F3) + (#xB1C9 #x6804) + (#xB1CA #x6C38) + (#xB1CB #x6CF3) + (#xB1CC #x6D29) + (#xB1CD #x745B) + (#xB1CE #x76C8) + (#xB1CF #x7A4E) + (#xB1D0 #x9834) + (#xB1D1 #x82F1) + (#xB1D2 #x885B) + (#xB1D3 #x8A60) + (#xB1D4 #x92ED) + (#xB1D5 #x6DB2) + (#xB1D6 #x75AB) + (#xB1D7 #x76CA) + (#xB1D8 #x99C5) + (#xB1D9 #x60A6) + (#xB1DA #x8B01) + (#xB1DB #x8D8A) + (#xB1DC #x95B2) + (#xB1DD #x698E) + (#xB1DE #x53AD) + (#xB1DF #x5186) + (#xB1E0 #x5712) + (#xB1E1 #x5830) + (#xB1E2 #x5944) + (#xB1E3 #x5BB4) + (#xB1E4 #x5EF6) + (#xB1E5 #x6028) + (#xB1E6 #x63A9) + (#xB1E7 #x63F4) + (#xB1E8 #x6CBF) + (#xB1E9 #x6F14) + (#xB1EA #x708E) + (#xB1EB #x7114) + (#xB1EC #x7159) + (#xB1ED #x71D5) + (#xB1EE #x733F) + (#xB1EF #x7E01) + (#xB1F0 #x8276) + (#xB1F1 #x82D1) + (#xB1F2 #x8597) + (#xB1F3 #x9060) + (#xB1F4 #x925B) + (#xB1F5 #x9D1B) + (#xB1F6 #x5869) + (#xB1F7 #x65BC) + (#xB1F8 #x6C5A) + (#xB1F9 #x7525) + (#xB1FA #x51F9) + (#xB1FB #x592E) + (#xB1FC #x5965) + (#xB1FD #x5F80) + (#xB1FE #x5FDC) + (#xB2A1 #x62BC) + (#xB2A2 #x65FA) + (#xB2A3 #x6A2A) + (#xB2A4 #x6B27) + (#xB2A5 #x6BB4) + (#xB2A6 #x738B) + (#xB2A7 #x7FC1) + (#xB2A8 #x8956) + (#xB2A9 #x9D2C) + (#xB2AA #x9D0E) + (#xB2AB #x9EC4) + (#xB2AC #x5CA1) + (#xB2AD #x6C96) + (#xB2AE #x837B) + (#xB2AF #x5104) + (#xB2B0 #x5C4B) + (#xB2B1 #x61B6) + (#xB2B2 #x81C6) + (#xB2B3 #x6876) + (#xB2B4 #x7261) + (#xB2B5 #x4E59) + (#xB2B6 #x4FFA) + (#xB2B7 #x5378) + (#xB2B8 #x6069) + (#xB2B9 #x6E29) + (#xB2BA #x7A4F) + (#xB2BB #x97F3) + (#xB2BC #x4E0B) + (#xB2BD #x5316) + (#xB2BE #x4EEE) + (#xB2BF #x4F55) + (#xB2C0 #x4F3D) + (#xB2C1 #x4FA1) + (#xB2C2 #x4F73) + (#xB2C3 #x52A0) + (#xB2C4 #x53EF) + (#xB2C5 #x5609) + (#xB2C6 #x590F) + (#xB2C7 #x5AC1) + (#xB2C8 #x5BB6) + (#xB2C9 #x5BE1) + (#xB2CA #x79D1) + (#xB2CB #x6687) + (#xB2CC #x679C) + (#xB2CD #x67B6) + (#xB2CE #x6B4C) + (#xB2CF #x6CB3) + (#xB2D0 #x706B) + (#xB2D1 #x73C2) + (#xB2D2 #x798D) + (#xB2D3 #x79BE) + (#xB2D4 #x7A3C) + (#xB2D5 #x7B87) + (#xB2D6 #x82B1) + (#xB2D7 #x82DB) + (#xB2D8 #x8304) + (#xB2D9 #x8377) + (#xB2DA #x83EF) + (#xB2DB #x83D3) + (#xB2DC #x8766) + (#xB2DD #x8AB2) + (#xB2DE #x5629) + (#xB2DF #x8CA8) + (#xB2E0 #x8FE6) + (#xB2E1 #x904E) + (#xB2E2 #x971E) + (#xB2E3 #x868A) + (#xB2E4 #x4FC4) + (#xB2E5 #x5CE8) + (#xB2E6 #x6211) + (#xB2E7 #x7259) + (#xB2E8 #x753B) + (#xB2E9 #x81E5) + (#xB2EA #x82BD) + (#xB2EB #x86FE) + (#xB2EC #x8CC0) + (#xB2ED #x96C5) + (#xB2EE #x9913) + (#xB2EF #x99D5) + (#xB2F0 #x4ECB) + (#xB2F1 #x4F1A) + (#xB2F2 #x89E3) + (#xB2F3 #x56DE) + (#xB2F4 #x584A) + (#xB2F5 #x58CA) + (#xB2F6 #x5EFB) + (#xB2F7 #x5FEB) + (#xB2F8 #x602A) + (#xB2F9 #x6094) + (#xB2FA #x6062) + (#xB2FB #x61D0) + (#xB2FC #x6212) + (#xB2FD #x62D0) + (#xB2FE #x6539) + (#xB3A1 #x9B41) + (#xB3A2 #x6666) + (#xB3A3 #x68B0) + (#xB3A4 #x6D77) + (#xB3A5 #x7070) + (#xB3A6 #x754C) + (#xB3A7 #x7686) + (#xB3A8 #x7D75) + (#xB3A9 #x82A5) + (#xB3AA #x87F9) + (#xB3AB #x958B) + (#xB3AC #x968E) + (#xB3AD #x8C9D) + (#xB3AE #x51F1) + (#xB3AF #x52BE) + (#xB3B0 #x5916) + (#xB3B1 #x54B3) + (#xB3B2 #x5BB3) + (#xB3B3 #x5D16) + (#xB3B4 #x6168) + (#xB3B5 #x6982) + (#xB3B6 #x6DAF) + (#xB3B7 #x788D) + (#xB3B8 #x84CB) + (#xB3B9 #x8857) + (#xB3BA #x8A72) + (#xB3BB #x93A7) + (#xB3BC #x9AB8) + (#xB3BD #x6D6C) + (#xB3BE #x99A8) + (#xB3BF #x86D9) + (#xB3C0 #x57A3) + (#xB3C1 #x67FF) + (#xB3C2 #x86CE) + (#xB3C3 #x920E) + (#xB3C4 #x5283) + (#xB3C5 #x5687) + (#xB3C6 #x5404) + (#xB3C7 #x5ED3) + (#xB3C8 #x62E1) + (#xB3C9 #x64B9) + (#xB3CA #x683C) + (#xB3CB #x6838) + (#xB3CC #x6BBB) + (#xB3CD #x7372) + (#xB3CE #x78BA) + (#xB3CF #x7A6B) + (#xB3D0 #x899A) + (#xB3D1 #x89D2) + (#xB3D2 #x8D6B) + (#xB3D3 #x8F03) + (#xB3D4 #x90ED) + (#xB3D5 #x95A3) + (#xB3D6 #x9694) + (#xB3D7 #x9769) + (#xB3D8 #x5B66) + (#xB3D9 #x5CB3) + (#xB3DA #x697D) + (#xB3DB #x984D) + (#xB3DC #x984E) + (#xB3DD #x639B) + (#xB3DE #x7B20) + (#xB3DF #x6A2B) + (#xB3E0 #x6A7F) + (#xB3E1 #x68B6) + (#xB3E2 #x9C0D) + (#xB3E3 #x6F5F) + (#xB3E4 #x5272) + (#xB3E5 #x559D) + (#xB3E6 #x6070) + (#xB3E7 #x62EC) + (#xB3E8 #x6D3B) + (#xB3E9 #x6E07) + (#xB3EA #x6ED1) + (#xB3EB #x845B) + (#xB3EC #x8910) + (#xB3ED #x8F44) + (#xB3EE #x4E14) + (#xB3EF #x9C39) + (#xB3F0 #x53F6) + (#xB3F1 #x691B) + (#xB3F2 #x6A3A) + (#xB3F3 #x9784) + (#xB3F4 #x682A) + (#xB3F5 #x515C) + (#xB3F6 #x7AC3) + (#xB3F7 #x84B2) + (#xB3F8 #x91DC) + (#xB3F9 #x938C) + (#xB3FA #x565B) + (#xB3FB #x9D28) + (#xB3FC #x6822) + (#xB3FD #x8305) + (#xB3FE #x8431) + (#xB4A1 #x7CA5) + (#xB4A2 #x5208) + (#xB4A3 #x82C5) + (#xB4A4 #x74E6) + (#xB4A5 #x4E7E) + (#xB4A6 #x4F83) + (#xB4A7 #x51A0) + (#xB4A8 #x5BD2) + (#xB4A9 #x520A) + (#xB4AA #x52D8) + (#xB4AB #x52E7) + (#xB4AC #x5DFB) + (#xB4AD #x559A) + (#xB4AE #x582A) + (#xB4AF #x59E6) + (#xB4B0 #x5B8C) + (#xB4B1 #x5B98) + (#xB4B2 #x5BDB) + (#xB4B3 #x5E72) + (#xB4B4 #x5E79) + (#xB4B5 #x60A3) + (#xB4B6 #x611F) + (#xB4B7 #x6163) + (#xB4B8 #x61BE) + (#xB4B9 #x63DB) + (#xB4BA #x6562) + (#xB4BB #x67D1) + (#xB4BC #x6853) + (#xB4BD #x68FA) + (#xB4BE #x6B3E) + (#xB4BF #x6B53) + (#xB4C0 #x6C57) + (#xB4C1 #x6F22) + (#xB4C2 #x6F97) + (#xB4C3 #x6F45) + (#xB4C4 #x74B0) + (#xB4C5 #x7518) + (#xB4C6 #x76E3) + (#xB4C7 #x770B) + (#xB4C8 #x7AFF) + (#xB4C9 #x7BA1) + (#xB4CA #x7C21) + (#xB4CB #x7DE9) + (#xB4CC #x7F36) + (#xB4CD #x7FF0) + (#xB4CE #x809D) + (#xB4CF #x8266) + (#xB4D0 #x839E) + (#xB4D1 #x89B3) + (#xB4D2 #x8ACC) + (#xB4D3 #x8CAB) + (#xB4D4 #x9084) + (#xB4D5 #x9451) + (#xB4D6 #x9593) + (#xB4D7 #x9591) + (#xB4D8 #x95A2) + (#xB4D9 #x9665) + (#xB4DA #x97D3) + (#xB4DB #x9928) + (#xB4DC #x8218) + (#xB4DD #x4E38) + (#xB4DE #x542B) + (#xB4DF #x5CB8) + (#xB4E0 #x5DCC) + (#xB4E1 #x73A9) + (#xB4E2 #x764C) + (#xB4E3 #x773C) + (#xB4E4 #x5CA9) + (#xB4E5 #x7FEB) + (#xB4E6 #x8D0B) + (#xB4E7 #x96C1) + (#xB4E8 #x9811) + (#xB4E9 #x9854) + (#xB4EA #x9858) + (#xB4EB #x4F01) + (#xB4EC #x4F0E) + (#xB4ED #x5371) + (#xB4EE #x559C) + (#xB4EF #x5668) + (#xB4F0 #x57FA) + (#xB4F1 #x5947) + (#xB4F2 #x5B09) + (#xB4F3 #x5BC4) + (#xB4F4 #x5C90) + (#xB4F5 #x5E0C) + (#xB4F6 #x5E7E) + (#xB4F7 #x5FCC) + (#xB4F8 #x63EE) + (#xB4F9 #x673A) + (#xB4FA #x65D7) + (#xB4FB #x65E2) + (#xB4FC #x671F) + (#xB4FD #x68CB) + (#xB4FE #x68C4) + (#xB5A1 #x6A5F) + (#xB5A2 #x5E30) + (#xB5A3 #x6BC5) + (#xB5A4 #x6C17) + (#xB5A5 #x6C7D) + (#xB5A6 #x757F) + (#xB5A7 #x7948) + (#xB5A8 #x5B63) + (#xB5A9 #x7A00) + (#xB5AA #x7D00) + (#xB5AB #x5FBD) + (#xB5AC #x898F) + (#xB5AD #x8A18) + (#xB5AE #x8CB4) + (#xB5AF #x8D77) + (#xB5B0 #x8ECC) + (#xB5B1 #x8F1D) + (#xB5B2 #x98E2) + (#xB5B3 #x9A0E) + (#xB5B4 #x9B3C) + (#xB5B5 #x4E80) + (#xB5B6 #x507D) + (#xB5B7 #x5100) + (#xB5B8 #x5993) + (#xB5B9 #x5B9C) + (#xB5BA #x622F) + (#xB5BB #x6280) + (#xB5BC #x64EC) + (#xB5BD #x6B3A) + (#xB5BE #x72A0) + (#xB5BF #x7591) + (#xB5C0 #x7947) + (#xB5C1 #x7FA9) + (#xB5C2 #x87FB) + (#xB5C3 #x8ABC) + (#xB5C4 #x8B70) + (#xB5C5 #x63AC) + (#xB5C6 #x83CA) + (#xB5C7 #x97A0) + (#xB5C8 #x5409) + (#xB5C9 #x5403) + (#xB5CA #x55AB) + (#xB5CB #x6854) + (#xB5CC #x6A58) + (#xB5CD #x8A70) + (#xB5CE #x7827) + (#xB5CF #x6775) + (#xB5D0 #x9ECD) + (#xB5D1 #x5374) + (#xB5D2 #x5BA2) + (#xB5D3 #x811A) + (#xB5D4 #x8650) + (#xB5D5 #x9006) + (#xB5D6 #x4E18) + (#xB5D7 #x4E45) + (#xB5D8 #x4EC7) + (#xB5D9 #x4F11) + (#xB5DA #x53CA) + (#xB5DB #x5438) + (#xB5DC #x5BAE) + (#xB5DD #x5F13) + (#xB5DE #x6025) + (#xB5DF #x6551) + (#xB5E0 #x673D) + (#xB5E1 #x6C42) + (#xB5E2 #x6C72) + (#xB5E3 #x6CE3) + (#xB5E4 #x7078) + (#xB5E5 #x7403) + (#xB5E6 #x7A76) + (#xB5E7 #x7AAE) + (#xB5E8 #x7B08) + (#xB5E9 #x7D1A) + (#xB5EA #x7CFE) + (#xB5EB #x7D66) + (#xB5EC #x65E7) + (#xB5ED #x725B) + (#xB5EE #x53BB) + (#xB5EF #x5C45) + (#xB5F0 #x5DE8) + (#xB5F1 #x62D2) + (#xB5F2 #x62E0) + (#xB5F3 #x6319) + (#xB5F4 #x6E20) + (#xB5F5 #x865A) + (#xB5F6 #x8A31) + (#xB5F7 #x8DDD) + (#xB5F8 #x92F8) + (#xB5F9 #x6F01) + (#xB5FA #x79A6) + (#xB5FB #x9B5A) + (#xB5FC #x4EA8) + (#xB5FD #x4EAB) + (#xB5FE #x4EAC) + (#xB6A1 #x4F9B) + (#xB6A2 #x4FA0) + (#xB6A3 #x50D1) + (#xB6A4 #x5147) + (#xB6A5 #x7AF6) + (#xB6A6 #x5171) + (#xB6A7 #x51F6) + (#xB6A8 #x5354) + (#xB6A9 #x5321) + (#xB6AA #x537F) + (#xB6AB #x53EB) + (#xB6AC #x55AC) + (#xB6AD #x5883) + (#xB6AE #x5CE1) + (#xB6AF #x5F37) + (#xB6B0 #x5F4A) + (#xB6B1 #x602F) + (#xB6B2 #x6050) + (#xB6B3 #x606D) + (#xB6B4 #x631F) + (#xB6B5 #x6559) + (#xB6B6 #x6A4B) + (#xB6B7 #x6CC1) + (#xB6B8 #x72C2) + (#xB6B9 #x72ED) + (#xB6BA #x77EF) + (#xB6BB #x80F8) + (#xB6BC #x8105) + (#xB6BD #x8208) + (#xB6BE #x854E) + (#xB6BF #x90F7) + (#xB6C0 #x93E1) + (#xB6C1 #x97FF) + (#xB6C2 #x9957) + (#xB6C3 #x9A5A) + (#xB6C4 #x4EF0) + (#xB6C5 #x51DD) + (#xB6C6 #x5C2D) + (#xB6C7 #x6681) + (#xB6C8 #x696D) + (#xB6C9 #x5C40) + (#xB6CA #x66F2) + (#xB6CB #x6975) + (#xB6CC #x7389) + (#xB6CD #x6850) + (#xB6CE #x7C81) + (#xB6CF #x50C5) + (#xB6D0 #x52E4) + (#xB6D1 #x5747) + (#xB6D2 #x5DFE) + (#xB6D3 #x9326) + (#xB6D4 #x65A4) + (#xB6D5 #x6B23) + (#xB6D6 #x6B3D) + (#xB6D7 #x7434) + (#xB6D8 #x7981) + (#xB6D9 #x79BD) + (#xB6DA #x7B4B) + (#xB6DB #x7DCA) + (#xB6DC #x82B9) + (#xB6DD #x83CC) + (#xB6DE #x887F) + (#xB6DF #x895F) + (#xB6E0 #x8B39) + (#xB6E1 #x8FD1) + (#xB6E2 #x91D1) + (#xB6E3 #x541F) + (#xB6E4 #x9280) + (#xB6E5 #x4E5D) + (#xB6E6 #x5036) + (#xB6E7 #x53E5) + (#xB6E8 #x533A) + (#xB6E9 #x72D7) + (#xB6EA #x7396) + (#xB6EB #x77E9) + (#xB6EC #x82E6) + (#xB6ED #x8EAF) + (#xB6EE #x99C6) + (#xB6EF #x99C8) + (#xB6F0 #x99D2) + (#xB6F1 #x5177) + (#xB6F2 #x611A) + (#xB6F3 #x865E) + (#xB6F4 #x55B0) + (#xB6F5 #x7A7A) + (#xB6F6 #x5076) + (#xB6F7 #x5BD3) + (#xB6F8 #x9047) + (#xB6F9 #x9685) + (#xB6FA #x4E32) + (#xB6FB #x6ADB) + (#xB6FC #x91E7) + (#xB6FD #x5C51) + (#xB6FE #x5C48) + (#xB7A1 #x6398) + (#xB7A2 #x7A9F) + (#xB7A3 #x6C93) + (#xB7A4 #x9774) + (#xB7A5 #x8F61) + (#xB7A6 #x7AAA) + (#xB7A7 #x718A) + (#xB7A8 #x9688) + (#xB7A9 #x7C82) + (#xB7AA #x6817) + (#xB7AB #x7E70) + (#xB7AC #x6851) + (#xB7AD #x936C) + (#xB7AE #x52F2) + (#xB7AF #x541B) + (#xB7B0 #x85AB) + (#xB7B1 #x8A13) + (#xB7B2 #x7FA4) + (#xB7B3 #x8ECD) + (#xB7B4 #x90E1) + (#xB7B5 #x5366) + (#xB7B6 #x8888) + (#xB7B7 #x7941) + (#xB7B8 #x4FC2) + (#xB7B9 #x50BE) + (#xB7BA #x5211) + (#xB7BB #x5144) + (#xB7BC #x5553) + (#xB7BD #x572D) + (#xB7BE #x73EA) + (#xB7BF #x578B) + (#xB7C0 #x5951) + (#xB7C1 #x5F62) + (#xB7C2 #x5F84) + (#xB7C3 #x6075) + (#xB7C4 #x6176) + (#xB7C5 #x6167) + (#xB7C6 #x61A9) + (#xB7C7 #x63B2) + (#xB7C8 #x643A) + (#xB7C9 #x656C) + (#xB7CA #x666F) + (#xB7CB #x6842) + (#xB7CC #x6E13) + (#xB7CD #x7566) + (#xB7CE #x7A3D) + (#xB7CF #x7CFB) + (#xB7D0 #x7D4C) + (#xB7D1 #x7D99) + (#xB7D2 #x7E4B) + (#xB7D3 #x7F6B) + (#xB7D4 #x830E) + (#xB7D5 #x834A) + (#xB7D6 #x86CD) + (#xB7D7 #x8A08) + (#xB7D8 #x8A63) + (#xB7D9 #x8B66) + (#xB7DA #x8EFD) + (#xB7DB #x981A) + (#xB7DC #x9D8F) + (#xB7DD #x82B8) + (#xB7DE #x8FCE) + (#xB7DF #x9BE8) + (#xB7E0 #x5287) + (#xB7E1 #x621F) + (#xB7E2 #x6483) + (#xB7E3 #x6FC0) + (#xB7E4 #x9699) + (#xB7E5 #x6841) + (#xB7E6 #x5091) + (#xB7E7 #x6B20) + (#xB7E8 #x6C7A) + (#xB7E9 #x6F54) + (#xB7EA #x7A74) + (#xB7EB #x7D50) + (#xB7EC #x8840) + (#xB7ED #x8A23) + (#xB7EE #x6708) + (#xB7EF #x4EF6) + (#xB7F0 #x5039) + (#xB7F1 #x5026) + (#xB7F2 #x5065) + (#xB7F3 #x517C) + (#xB7F4 #x5238) + (#xB7F5 #x5263) + (#xB7F6 #x55A7) + (#xB7F7 #x570F) + (#xB7F8 #x5805) + (#xB7F9 #x5ACC) + (#xB7FA #x5EFA) + (#xB7FB #x61B2) + (#xB7FC #x61F8) + (#xB7FD #x62F3) + (#xB7FE #x6372) + (#xB8A1 #x691C) + (#xB8A2 #x6A29) + (#xB8A3 #x727D) + (#xB8A4 #x72AC) + (#xB8A5 #x732E) + (#xB8A6 #x7814) + (#xB8A7 #x786F) + (#xB8A8 #x7D79) + (#xB8A9 #x770C) + (#xB8AA #x80A9) + (#xB8AB #x898B) + (#xB8AC #x8B19) + (#xB8AD #x8CE2) + (#xB8AE #x8ED2) + (#xB8AF #x9063) + (#xB8B0 #x9375) + (#xB8B1 #x967A) + (#xB8B2 #x9855) + (#xB8B3 #x9A13) + (#xB8B4 #x9E78) + (#xB8B5 #x5143) + (#xB8B6 #x539F) + (#xB8B7 #x53B3) + (#xB8B8 #x5E7B) + (#xB8B9 #x5F26) + (#xB8BA #x6E1B) + (#xB8BB #x6E90) + (#xB8BC #x7384) + (#xB8BD #x73FE) + (#xB8BE #x7D43) + (#xB8BF #x8237) + (#xB8C0 #x8A00) + (#xB8C1 #x8AFA) + (#xB8C2 #x9650) + (#xB8C3 #x4E4E) + (#xB8C4 #x500B) + (#xB8C5 #x53E4) + (#xB8C6 #x547C) + (#xB8C7 #x56FA) + (#xB8C8 #x59D1) + (#xB8C9 #x5B64) + (#xB8CA #x5DF1) + (#xB8CB #x5EAB) + (#xB8CC #x5F27) + (#xB8CD #x6238) + (#xB8CE #x6545) + (#xB8CF #x67AF) + (#xB8D0 #x6E56) + (#xB8D1 #x72D0) + (#xB8D2 #x7CCA) + (#xB8D3 #x88B4) + (#xB8D4 #x80A1) + (#xB8D5 #x80E1) + (#xB8D6 #x83F0) + (#xB8D7 #x864E) + (#xB8D8 #x8A87) + (#xB8D9 #x8DE8) + (#xB8DA #x9237) + (#xB8DB #x96C7) + (#xB8DC #x9867) + (#xB8DD #x9F13) + (#xB8DE #x4E94) + (#xB8DF #x4E92) + (#xB8E0 #x4F0D) + (#xB8E1 #x5348) + (#xB8E2 #x5449) + (#xB8E3 #x543E) + (#xB8E4 #x5A2F) + (#xB8E5 #x5F8C) + (#xB8E6 #x5FA1) + (#xB8E7 #x609F) + (#xB8E8 #x68A7) + (#xB8E9 #x6A8E) + (#xB8EA #x745A) + (#xB8EB #x7881) + (#xB8EC #x8A9E) + (#xB8ED #x8AA4) + (#xB8EE #x8B77) + (#xB8EF #x9190) + (#xB8F0 #x4E5E) + (#xB8F1 #x9BC9) + (#xB8F2 #x4EA4) + (#xB8F3 #x4F7C) + (#xB8F4 #x4FAF) + (#xB8F5 #x5019) + (#xB8F6 #x5016) + (#xB8F7 #x5149) + (#xB8F8 #x516C) + (#xB8F9 #x529F) + (#xB8FA #x52B9) + (#xB8FB #x52FE) + (#xB8FC #x539A) + (#xB8FD #x53E3) + (#xB8FE #x5411) + (#xB9A1 #x540E) + (#xB9A2 #x5589) + (#xB9A3 #x5751) + (#xB9A4 #x57A2) + (#xB9A5 #x597D) + (#xB9A6 #x5B54) + (#xB9A7 #x5B5D) + (#xB9A8 #x5B8F) + (#xB9A9 #x5DE5) + (#xB9AA #x5DE7) + (#xB9AB #x5DF7) + (#xB9AC #x5E78) + (#xB9AD #x5E83) + (#xB9AE #x5E9A) + (#xB9AF #x5EB7) + (#xB9B0 #x5F18) + (#xB9B1 #x6052) + (#xB9B2 #x614C) + (#xB9B3 #x6297) + (#xB9B4 #x62D8) + (#xB9B5 #x63A7) + (#xB9B6 #x653B) + (#xB9B7 #x6602) + (#xB9B8 #x6643) + (#xB9B9 #x66F4) + (#xB9BA #x676D) + (#xB9BB #x6821) + (#xB9BC #x6897) + (#xB9BD #x69CB) + (#xB9BE #x6C5F) + (#xB9BF #x6D2A) + (#xB9C0 #x6D69) + (#xB9C1 #x6E2F) + (#xB9C2 #x6E9D) + (#xB9C3 #x7532) + (#xB9C4 #x7687) + (#xB9C5 #x786C) + (#xB9C6 #x7A3F) + (#xB9C7 #x7CE0) + (#xB9C8 #x7D05) + (#xB9C9 #x7D18) + (#xB9CA #x7D5E) + (#xB9CB #x7DB1) + (#xB9CC #x8015) + (#xB9CD #x8003) + (#xB9CE #x80AF) + (#xB9CF #x80B1) + (#xB9D0 #x8154) + (#xB9D1 #x818F) + (#xB9D2 #x822A) + (#xB9D3 #x8352) + (#xB9D4 #x884C) + (#xB9D5 #x8861) + (#xB9D6 #x8B1B) + (#xB9D7 #x8CA2) + (#xB9D8 #x8CFC) + (#xB9D9 #x90CA) + (#xB9DA #x9175) + (#xB9DB #x9271) + (#xB9DC #x783F) + (#xB9DD #x92FC) + (#xB9DE #x95A4) + (#xB9DF #x964D) + (#xB9E0 #x9805) + (#xB9E1 #x9999) + (#xB9E2 #x9AD8) + (#xB9E3 #x9D3B) + (#xB9E4 #x525B) + (#xB9E5 #x52AB) + (#xB9E6 #x53F7) + (#xB9E7 #x5408) + (#xB9E8 #x58D5) + (#xB9E9 #x62F7) + (#xB9EA #x6FE0) + (#xB9EB #x8C6A) + (#xB9EC #x8F5F) + (#xB9ED #x9EB9) + (#xB9EE #x514B) + (#xB9EF #x523B) + (#xB9F0 #x544A) + (#xB9F1 #x56FD) + (#xB9F2 #x7A40) + (#xB9F3 #x9177) + (#xB9F4 #x9D60) + (#xB9F5 #x9ED2) + (#xB9F6 #x7344) + (#xB9F7 #x6F09) + (#xB9F8 #x8170) + (#xB9F9 #x7511) + (#xB9FA #x5FFD) + (#xB9FB #x60DA) + (#xB9FC #x9AA8) + (#xB9FD #x72DB) + (#xB9FE #x8FBC) + (#xBAA1 #x6B64) + (#xBAA2 #x9803) + (#xBAA3 #x4ECA) + (#xBAA4 #x56F0) + (#xBAA5 #x5764) + (#xBAA6 #x58BE) + (#xBAA7 #x5A5A) + (#xBAA8 #x6068) + (#xBAA9 #x61C7) + (#xBAAA #x660F) + (#xBAAB #x6606) + (#xBAAC #x6839) + (#xBAAD #x68B1) + (#xBAAE #x6DF7) + (#xBAAF #x75D5) + (#xBAB0 #x7D3A) + (#xBAB1 #x826E) + (#xBAB2 #x9B42) + (#xBAB3 #x4E9B) + (#xBAB4 #x4F50) + (#xBAB5 #x53C9) + (#xBAB6 #x5506) + (#xBAB7 #x5D6F) + (#xBAB8 #x5DE6) + (#xBAB9 #x5DEE) + (#xBABA #x67FB) + (#xBABB #x6C99) + (#xBABC #x7473) + (#xBABD #x7802) + (#xBABE #x8A50) + (#xBABF #x9396) + (#xBAC0 #x88DF) + (#xBAC1 #x5750) + (#xBAC2 #x5EA7) + (#xBAC3 #x632B) + (#xBAC4 #x50B5) + (#xBAC5 #x50AC) + (#xBAC6 #x518D) + (#xBAC7 #x6700) + (#xBAC8 #x54C9) + (#xBAC9 #x585E) + (#xBACA #x59BB) + (#xBACB #x5BB0) + (#xBACC #x5F69) + (#xBACD #x624D) + (#xBACE #x63A1) + (#xBACF #x683D) + (#xBAD0 #x6B73) + (#xBAD1 #x6E08) + (#xBAD2 #x707D) + (#xBAD3 #x91C7) + (#xBAD4 #x7280) + (#xBAD5 #x7815) + (#xBAD6 #x7826) + (#xBAD7 #x796D) + (#xBAD8 #x658E) + (#xBAD9 #x7D30) + (#xBADA #x83DC) + (#xBADB #x88C1) + (#xBADC #x8F09) + (#xBADD #x969B) + (#xBADE #x5264) + (#xBADF #x5728) + (#xBAE0 #x6750) + (#xBAE1 #x7F6A) + (#xBAE2 #x8CA1) + (#xBAE3 #x51B4) + (#xBAE4 #x5742) + (#xBAE5 #x962A) + (#xBAE6 #x583A) + (#xBAE7 #x698A) + (#xBAE8 #x80B4) + (#xBAE9 #x54B2) + (#xBAEA #x5D0E) + (#xBAEB #x57FC) + (#xBAEC #x7895) + (#xBAED #x9DFA) + (#xBAEE #x4F5C) + (#xBAEF #x524A) + (#xBAF0 #x548B) + (#xBAF1 #x643E) + (#xBAF2 #x6628) + (#xBAF3 #x6714) + (#xBAF4 #x67F5) + (#xBAF5 #x7A84) + (#xBAF6 #x7B56) + (#xBAF7 #x7D22) + (#xBAF8 #x932F) + (#xBAF9 #x685C) + (#xBAFA #x9BAD) + (#xBAFB #x7B39) + (#xBAFC #x5319) + (#xBAFD #x518A) + (#xBAFE #x5237) + (#xBBA1 #x5BDF) + (#xBBA2 #x62F6) + (#xBBA3 #x64AE) + (#xBBA4 #x64E6) + (#xBBA5 #x672D) + (#xBBA6 #x6BBA) + (#xBBA7 #x85A9) + (#xBBA8 #x96D1) + (#xBBA9 #x7690) + (#xBBAA #x9BD6) + (#xBBAB #x634C) + (#xBBAC #x9306) + (#xBBAD #x9BAB) + (#xBBAE #x76BF) + (#xBBAF #x6652) + (#xBBB0 #x4E09) + (#xBBB1 #x5098) + (#xBBB2 #x53C2) + (#xBBB3 #x5C71) + (#xBBB4 #x60E8) + (#xBBB5 #x6492) + (#xBBB6 #x6563) + (#xBBB7 #x685F) + (#xBBB8 #x71E6) + (#xBBB9 #x73CA) + (#xBBBA #x7523) + (#xBBBB #x7B97) + (#xBBBC #x7E82) + (#xBBBD #x8695) + (#xBBBE #x8B83) + (#xBBBF #x8CDB) + (#xBBC0 #x9178) + (#xBBC1 #x9910) + (#xBBC2 #x65AC) + (#xBBC3 #x66AB) + (#xBBC4 #x6B8B) + (#xBBC5 #x4ED5) + (#xBBC6 #x4ED4) + (#xBBC7 #x4F3A) + (#xBBC8 #x4F7F) + (#xBBC9 #x523A) + (#xBBCA #x53F8) + (#xBBCB #x53F2) + (#xBBCC #x55E3) + (#xBBCD #x56DB) + (#xBBCE #x58EB) + (#xBBCF #x59CB) + (#xBBD0 #x59C9) + (#xBBD1 #x59FF) + (#xBBD2 #x5B50) + (#xBBD3 #x5C4D) + (#xBBD4 #x5E02) + (#xBBD5 #x5E2B) + (#xBBD6 #x5FD7) + (#xBBD7 #x601D) + (#xBBD8 #x6307) + (#xBBD9 #x652F) + (#xBBDA #x5B5C) + (#xBBDB #x65AF) + (#xBBDC #x65BD) + (#xBBDD #x65E8) + (#xBBDE #x679D) + (#xBBDF #x6B62) + (#xBBE0 #x6B7B) + (#xBBE1 #x6C0F) + (#xBBE2 #x7345) + (#xBBE3 #x7949) + (#xBBE4 #x79C1) + (#xBBE5 #x7CF8) + (#xBBE6 #x7D19) + (#xBBE7 #x7D2B) + (#xBBE8 #x80A2) + (#xBBE9 #x8102) + (#xBBEA #x81F3) + (#xBBEB #x8996) + (#xBBEC #x8A5E) + (#xBBED #x8A69) + (#xBBEE #x8A66) + (#xBBEF #x8A8C) + (#xBBF0 #x8AEE) + (#xBBF1 #x8CC7) + (#xBBF2 #x8CDC) + (#xBBF3 #x96CC) + (#xBBF4 #x98FC) + (#xBBF5 #x6B6F) + (#xBBF6 #x4E8B) + (#xBBF7 #x4F3C) + (#xBBF8 #x4F8D) + (#xBBF9 #x5150) + (#xBBFA #x5B57) + (#xBBFB #x5BFA) + (#xBBFC #x6148) + (#xBBFD #x6301) + (#xBBFE #x6642) + (#xBCA1 #x6B21) + (#xBCA2 #x6ECB) + (#xBCA3 #x6CBB) + (#xBCA4 #x723E) + (#xBCA5 #x74BD) + (#xBCA6 #x75D4) + (#xBCA7 #x78C1) + (#xBCA8 #x793A) + (#xBCA9 #x800C) + (#xBCAA #x8033) + (#xBCAB #x81EA) + (#xBCAC #x8494) + (#xBCAD #x8F9E) + (#xBCAE #x6C50) + (#xBCAF #x9E7F) + (#xBCB0 #x5F0F) + (#xBCB1 #x8B58) + (#xBCB2 #x9D2B) + (#xBCB3 #x7AFA) + (#xBCB4 #x8EF8) + (#xBCB5 #x5B8D) + (#xBCB6 #x96EB) + (#xBCB7 #x4E03) + (#xBCB8 #x53F1) + (#xBCB9 #x57F7) + (#xBCBA #x5931) + (#xBCBB #x5AC9) + (#xBCBC #x5BA4) + (#xBCBD #x6089) + (#xBCBE #x6E7F) + (#xBCBF #x6F06) + (#xBCC0 #x75BE) + (#xBCC1 #x8CEA) + (#xBCC2 #x5B9F) + (#xBCC3 #x8500) + (#xBCC4 #x7BE0) + (#xBCC5 #x5072) + (#xBCC6 #x67F4) + (#xBCC7 #x829D) + (#xBCC8 #x5C61) + (#xBCC9 #x854A) + (#xBCCA #x7E1E) + (#xBCCB #x820E) + (#xBCCC #x5199) + (#xBCCD #x5C04) + (#xBCCE #x6368) + (#xBCCF #x8D66) + (#xBCD0 #x659C) + (#xBCD1 #x716E) + (#xBCD2 #x793E) + (#xBCD3 #x7D17) + (#xBCD4 #x8005) + (#xBCD5 #x8B1D) + (#xBCD6 #x8ECA) + (#xBCD7 #x906E) + (#xBCD8 #x86C7) + (#xBCD9 #x90AA) + (#xBCDA #x501F) + (#xBCDB #x52FA) + (#xBCDC #x5C3A) + (#xBCDD #x6753) + (#xBCDE #x707C) + (#xBCDF #x7235) + (#xBCE0 #x914C) + (#xBCE1 #x91C8) + (#xBCE2 #x932B) + (#xBCE3 #x82E5) + (#xBCE4 #x5BC2) + (#xBCE5 #x5F31) + (#xBCE6 #x60F9) + (#xBCE7 #x4E3B) + (#xBCE8 #x53D6) + (#xBCE9 #x5B88) + (#xBCEA #x624B) + (#xBCEB #x6731) + (#xBCEC #x6B8A) + (#xBCED #x72E9) + (#xBCEE #x73E0) + (#xBCEF #x7A2E) + (#xBCF0 #x816B) + (#xBCF1 #x8DA3) + (#xBCF2 #x9152) + (#xBCF3 #x9996) + (#xBCF4 #x5112) + (#xBCF5 #x53D7) + (#xBCF6 #x546A) + (#xBCF7 #x5BFF) + (#xBCF8 #x6388) + (#xBCF9 #x6A39) + (#xBCFA #x7DAC) + (#xBCFB #x9700) + (#xBCFC #x56DA) + (#xBCFD #x53CE) + (#xBCFE #x5468) + (#xBDA1 #x5B97) + (#xBDA2 #x5C31) + (#xBDA3 #x5DDE) + (#xBDA4 #x4FEE) + (#xBDA5 #x6101) + (#xBDA6 #x62FE) + (#xBDA7 #x6D32) + (#xBDA8 #x79C0) + (#xBDA9 #x79CB) + (#xBDAA #x7D42) + (#xBDAB #x7E4D) + (#xBDAC #x7FD2) + (#xBDAD #x81ED) + (#xBDAE #x821F) + (#xBDAF #x8490) + (#xBDB0 #x8846) + (#xBDB1 #x8972) + (#xBDB2 #x8B90) + (#xBDB3 #x8E74) + (#xBDB4 #x8F2F) + (#xBDB5 #x9031) + (#xBDB6 #x914B) + (#xBDB7 #x916C) + (#xBDB8 #x96C6) + (#xBDB9 #x919C) + (#xBDBA #x4EC0) + (#xBDBB #x4F4F) + (#xBDBC #x5145) + (#xBDBD #x5341) + (#xBDBE #x5F93) + (#xBDBF #x620E) + (#xBDC0 #x67D4) + (#xBDC1 #x6C41) + (#xBDC2 #x6E0B) + (#xBDC3 #x7363) + (#xBDC4 #x7E26) + (#xBDC5 #x91CD) + (#xBDC6 #x9283) + (#xBDC7 #x53D4) + (#xBDC8 #x5919) + (#xBDC9 #x5BBF) + (#xBDCA #x6DD1) + (#xBDCB #x795D) + (#xBDCC #x7E2E) + (#xBDCD #x7C9B) + (#xBDCE #x587E) + (#xBDCF #x719F) + (#xBDD0 #x51FA) + (#xBDD1 #x8853) + (#xBDD2 #x8FF0) + (#xBDD3 #x4FCA) + (#xBDD4 #x5CFB) + (#xBDD5 #x6625) + (#xBDD6 #x77AC) + (#xBDD7 #x7AE3) + (#xBDD8 #x821C) + (#xBDD9 #x99FF) + (#xBDDA #x51C6) + (#xBDDB #x5FAA) + (#xBDDC #x65EC) + (#xBDDD #x696F) + (#xBDDE #x6B89) + (#xBDDF #x6DF3) + (#xBDE0 #x6E96) + (#xBDE1 #x6F64) + (#xBDE2 #x76FE) + (#xBDE3 #x7D14) + (#xBDE4 #x5DE1) + (#xBDE5 #x9075) + (#xBDE6 #x9187) + (#xBDE7 #x9806) + (#xBDE8 #x51E6) + (#xBDE9 #x521D) + (#xBDEA #x6240) + (#xBDEB #x6691) + (#xBDEC #x66D9) + (#xBDED #x6E1A) + (#xBDEE #x5EB6) + (#xBDEF #x7DD2) + (#xBDF0 #x7F72) + (#xBDF1 #x66F8) + (#xBDF2 #x85AF) + (#xBDF3 #x85F7) + (#xBDF4 #x8AF8) + (#xBDF5 #x52A9) + (#xBDF6 #x53D9) + (#xBDF7 #x5973) + (#xBDF8 #x5E8F) + (#xBDF9 #x5F90) + (#xBDFA #x6055) + (#xBDFB #x92E4) + (#xBDFC #x9664) + (#xBDFD #x50B7) + (#xBDFE #x511F) + (#xBEA1 #x52DD) + (#xBEA2 #x5320) + (#xBEA3 #x5347) + (#xBEA4 #x53EC) + (#xBEA5 #x54E8) + (#xBEA6 #x5546) + (#xBEA7 #x5531) + (#xBEA8 #x5617) + (#xBEA9 #x5968) + (#xBEAA #x59BE) + (#xBEAB #x5A3C) + (#xBEAC #x5BB5) + (#xBEAD #x5C06) + (#xBEAE #x5C0F) + (#xBEAF #x5C11) + (#xBEB0 #x5C1A) + (#xBEB1 #x5E84) + (#xBEB2 #x5E8A) + (#xBEB3 #x5EE0) + (#xBEB4 #x5F70) + (#xBEB5 #x627F) + (#xBEB6 #x6284) + (#xBEB7 #x62DB) + (#xBEB8 #x638C) + (#xBEB9 #x6377) + (#xBEBA #x6607) + (#xBEBB #x660C) + (#xBEBC #x662D) + (#xBEBD #x6676) + (#xBEBE #x677E) + (#xBEBF #x68A2) + (#xBEC0 #x6A1F) + (#xBEC1 #x6A35) + (#xBEC2 #x6CBC) + (#xBEC3 #x6D88) + (#xBEC4 #x6E09) + (#xBEC5 #x6E58) + (#xBEC6 #x713C) + (#xBEC7 #x7126) + (#xBEC8 #x7167) + (#xBEC9 #x75C7) + (#xBECA #x7701) + (#xBECB #x785D) + (#xBECC #x7901) + (#xBECD #x7965) + (#xBECE #x79F0) + (#xBECF #x7AE0) + (#xBED0 #x7B11) + (#xBED1 #x7CA7) + (#xBED2 #x7D39) + (#xBED3 #x8096) + (#xBED4 #x83D6) + (#xBED5 #x848B) + (#xBED6 #x8549) + (#xBED7 #x885D) + (#xBED8 #x88F3) + (#xBED9 #x8A1F) + (#xBEDA #x8A3C) + (#xBEDB #x8A54) + (#xBEDC #x8A73) + (#xBEDD #x8C61) + (#xBEDE #x8CDE) + (#xBEDF #x91A4) + (#xBEE0 #x9266) + (#xBEE1 #x937E) + (#xBEE2 #x9418) + (#xBEE3 #x969C) + (#xBEE4 #x9798) + (#xBEE5 #x4E0A) + (#xBEE6 #x4E08) + (#xBEE7 #x4E1E) + (#xBEE8 #x4E57) + (#xBEE9 #x5197) + (#xBEEA #x5270) + (#xBEEB #x57CE) + (#xBEEC #x5834) + (#xBEED #x58CC) + (#xBEEE #x5B22) + (#xBEEF #x5E38) + (#xBEF0 #x60C5) + (#xBEF1 #x64FE) + (#xBEF2 #x6761) + (#xBEF3 #x6756) + (#xBEF4 #x6D44) + (#xBEF5 #x72B6) + (#xBEF6 #x7573) + (#xBEF7 #x7A63) + (#xBEF8 #x84B8) + (#xBEF9 #x8B72) + (#xBEFA #x91B8) + (#xBEFB #x9320) + (#xBEFC #x5631) + (#xBEFD #x57F4) + (#xBEFE #x98FE) + (#xBFA1 #x62ED) + (#xBFA2 #x690D) + (#xBFA3 #x6B96) + (#xBFA4 #x71ED) + (#xBFA5 #x7E54) + (#xBFA6 #x8077) + (#xBFA7 #x8272) + (#xBFA8 #x89E6) + (#xBFA9 #x98DF) + (#xBFAA #x8755) + (#xBFAB #x8FB1) + (#xBFAC #x5C3B) + (#xBFAD #x4F38) + (#xBFAE #x4FE1) + (#xBFAF #x4FB5) + (#xBFB0 #x5507) + (#xBFB1 #x5A20) + (#xBFB2 #x5BDD) + (#xBFB3 #x5BE9) + (#xBFB4 #x5FC3) + (#xBFB5 #x614E) + (#xBFB6 #x632F) + (#xBFB7 #x65B0) + (#xBFB8 #x664B) + (#xBFB9 #x68EE) + (#xBFBA #x699B) + (#xBFBB #x6D78) + (#xBFBC #x6DF1) + (#xBFBD #x7533) + (#xBFBE #x75B9) + (#xBFBF #x771F) + (#xBFC0 #x795E) + (#xBFC1 #x79E6) + (#xBFC2 #x7D33) + (#xBFC3 #x81E3) + (#xBFC4 #x82AF) + (#xBFC5 #x85AA) + (#xBFC6 #x89AA) + (#xBFC7 #x8A3A) + (#xBFC8 #x8EAB) + (#xBFC9 #x8F9B) + (#xBFCA #x9032) + (#xBFCB #x91DD) + (#xBFCC #x9707) + (#xBFCD #x4EBA) + (#xBFCE #x4EC1) + (#xBFCF #x5203) + (#xBFD0 #x5875) + (#xBFD1 #x58EC) + (#xBFD2 #x5C0B) + (#xBFD3 #x751A) + (#xBFD4 #x5C3D) + (#xBFD5 #x814E) + (#xBFD6 #x8A0A) + (#xBFD7 #x8FC5) + (#xBFD8 #x9663) + (#xBFD9 #x976D) + (#xBFDA #x7B25) + (#xBFDB #x8ACF) + (#xBFDC #x9808) + (#xBFDD #x9162) + (#xBFDE #x56F3) + (#xBFDF #x53A8) + (#xBFE0 #x9017) + (#xBFE1 #x5439) + (#xBFE2 #x5782) + (#xBFE3 #x5E25) + (#xBFE4 #x63A8) + (#xBFE5 #x6C34) + (#xBFE6 #x708A) + (#xBFE7 #x7761) + (#xBFE8 #x7C8B) + (#xBFE9 #x7FE0) + (#xBFEA #x8870) + (#xBFEB #x9042) + (#xBFEC #x9154) + (#xBFED #x9310) + (#xBFEE #x9318) + (#xBFEF #x968F) + (#xBFF0 #x745E) + (#xBFF1 #x9AC4) + (#xBFF2 #x5D07) + (#xBFF3 #x5D69) + (#xBFF4 #x6570) + (#xBFF5 #x67A2) + (#xBFF6 #x8DA8) + (#xBFF7 #x96DB) + (#xBFF8 #x636E) + (#xBFF9 #x6749) + (#xBFFA #x6919) + (#xBFFB #x83C5) + (#xBFFC #x9817) + (#xBFFD #x96C0) + (#xBFFE #x88FE) + (#xC0A1 #x6F84) + (#xC0A2 #x647A) + (#xC0A3 #x5BF8) + (#xC0A4 #x4E16) + (#xC0A5 #x702C) + (#xC0A6 #x755D) + (#xC0A7 #x662F) + (#xC0A8 #x51C4) + (#xC0A9 #x5236) + (#xC0AA #x52E2) + (#xC0AB #x59D3) + (#xC0AC #x5F81) + (#xC0AD #x6027) + (#xC0AE #x6210) + (#xC0AF #x653F) + (#xC0B0 #x6574) + (#xC0B1 #x661F) + (#xC0B2 #x6674) + (#xC0B3 #x68F2) + (#xC0B4 #x6816) + (#xC0B5 #x6B63) + (#xC0B6 #x6E05) + (#xC0B7 #x7272) + (#xC0B8 #x751F) + (#xC0B9 #x76DB) + (#xC0BA #x7CBE) + (#xC0BB #x8056) + (#xC0BC #x58F0) + (#xC0BD #x88FD) + (#xC0BE #x897F) + (#xC0BF #x8AA0) + (#xC0C0 #x8A93) + (#xC0C1 #x8ACB) + (#xC0C2 #x901D) + (#xC0C3 #x9192) + (#xC0C4 #x9752) + (#xC0C5 #x9759) + (#xC0C6 #x6589) + (#xC0C7 #x7A0E) + (#xC0C8 #x8106) + (#xC0C9 #x96BB) + (#xC0CA #x5E2D) + (#xC0CB #x60DC) + (#xC0CC #x621A) + (#xC0CD #x65A5) + (#xC0CE #x6614) + (#xC0CF #x6790) + (#xC0D0 #x77F3) + (#xC0D1 #x7A4D) + (#xC0D2 #x7C4D) + (#xC0D3 #x7E3E) + (#xC0D4 #x810A) + (#xC0D5 #x8CAC) + (#xC0D6 #x8D64) + (#xC0D7 #x8DE1) + (#xC0D8 #x8E5F) + (#xC0D9 #x78A9) + (#xC0DA #x5207) + (#xC0DB #x62D9) + (#xC0DC #x63A5) + (#xC0DD #x6442) + (#xC0DE #x6298) + (#xC0DF #x8A2D) + (#xC0E0 #x7A83) + (#xC0E1 #x7BC0) + (#xC0E2 #x8AAC) + (#xC0E3 #x96EA) + (#xC0E4 #x7D76) + (#xC0E5 #x820C) + (#xC0E6 #x8749) + (#xC0E7 #x4ED9) + (#xC0E8 #x5148) + (#xC0E9 #x5343) + (#xC0EA #x5360) + (#xC0EB #x5BA3) + (#xC0EC #x5C02) + (#xC0ED #x5C16) + (#xC0EE #x5DDD) + (#xC0EF #x6226) + (#xC0F0 #x6247) + (#xC0F1 #x64B0) + (#xC0F2 #x6813) + (#xC0F3 #x6834) + (#xC0F4 #x6CC9) + (#xC0F5 #x6D45) + (#xC0F6 #x6D17) + (#xC0F7 #x67D3) + (#xC0F8 #x6F5C) + (#xC0F9 #x714E) + (#xC0FA #x717D) + (#xC0FB #x65CB) + (#xC0FC #x7A7F) + (#xC0FD #x7BAD) + (#xC0FE #x7DDA) + (#xC1A1 #x7E4A) + (#xC1A2 #x7FA8) + (#xC1A3 #x817A) + (#xC1A4 #x821B) + (#xC1A5 #x8239) + (#xC1A6 #x85A6) + (#xC1A7 #x8A6E) + (#xC1A8 #x8CCE) + (#xC1A9 #x8DF5) + (#xC1AA #x9078) + (#xC1AB #x9077) + (#xC1AC #x92AD) + (#xC1AD #x9291) + (#xC1AE #x9583) + (#xC1AF #x9BAE) + (#xC1B0 #x524D) + (#xC1B1 #x5584) + (#xC1B2 #x6F38) + (#xC1B3 #x7136) + (#xC1B4 #x5168) + (#xC1B5 #x7985) + (#xC1B6 #x7E55) + (#xC1B7 #x81B3) + (#xC1B8 #x7CCE) + (#xC1B9 #x564C) + (#xC1BA #x5851) + (#xC1BB #x5CA8) + (#xC1BC #x63AA) + (#xC1BD #x66FE) + (#xC1BE #x66FD) + (#xC1BF #x695A) + (#xC1C0 #x72D9) + (#xC1C1 #x758F) + (#xC1C2 #x758E) + (#xC1C3 #x790E) + (#xC1C4 #x7956) + (#xC1C5 #x79DF) + (#xC1C6 #x7C97) + (#xC1C7 #x7D20) + (#xC1C8 #x7D44) + (#xC1C9 #x8607) + (#xC1CA #x8A34) + (#xC1CB #x963B) + (#xC1CC #x9061) + (#xC1CD #x9F20) + (#xC1CE #x50E7) + (#xC1CF #x5275) + (#xC1D0 #x53CC) + (#xC1D1 #x53E2) + (#xC1D2 #x5009) + (#xC1D3 #x55AA) + (#xC1D4 #x58EE) + (#xC1D5 #x594F) + (#xC1D6 #x723D) + (#xC1D7 #x5B8B) + (#xC1D8 #x5C64) + (#xC1D9 #x531D) + (#xC1DA #x60E3) + (#xC1DB #x60F3) + (#xC1DC #x635C) + (#xC1DD #x6383) + (#xC1DE #x633F) + (#xC1DF #x63BB) + (#xC1E0 #x64CD) + (#xC1E1 #x65E9) + (#xC1E2 #x66F9) + (#xC1E3 #x5DE3) + (#xC1E4 #x69CD) + (#xC1E5 #x69FD) + (#xC1E6 #x6F15) + (#xC1E7 #x71E5) + (#xC1E8 #x4E89) + (#xC1E9 #x75E9) + (#xC1EA #x76F8) + (#xC1EB #x7A93) + (#xC1EC #x7CDF) + (#xC1ED #x7DCF) + (#xC1EE #x7D9C) + (#xC1EF #x8061) + (#xC1F0 #x8349) + (#xC1F1 #x8358) + (#xC1F2 #x846C) + (#xC1F3 #x84BC) + (#xC1F4 #x85FB) + (#xC1F5 #x88C5) + (#xC1F6 #x8D70) + (#xC1F7 #x9001) + (#xC1F8 #x906D) + (#xC1F9 #x9397) + (#xC1FA #x971C) + (#xC1FB #x9A12) + (#xC1FC #x50CF) + (#xC1FD #x5897) + (#xC1FE #x618E) + (#xC2A1 #x81D3) + (#xC2A2 #x8535) + (#xC2A3 #x8D08) + (#xC2A4 #x9020) + (#xC2A5 #x4FC3) + (#xC2A6 #x5074) + (#xC2A7 #x5247) + (#xC2A8 #x5373) + (#xC2A9 #x606F) + (#xC2AA #x6349) + (#xC2AB #x675F) + (#xC2AC #x6E2C) + (#xC2AD #x8DB3) + (#xC2AE #x901F) + (#xC2AF #x4FD7) + (#xC2B0 #x5C5E) + (#xC2B1 #x8CCA) + (#xC2B2 #x65CF) + (#xC2B3 #x7D9A) + (#xC2B4 #x5352) + (#xC2B5 #x8896) + (#xC2B6 #x5176) + (#xC2B7 #x63C3) + (#xC2B8 #x5B58) + (#xC2B9 #x5B6B) + (#xC2BA #x5C0A) + (#xC2BB #x640D) + (#xC2BC #x6751) + (#xC2BD #x905C) + (#xC2BE #x4ED6) + (#xC2BF #x591A) + (#xC2C0 #x592A) + (#xC2C1 #x6C70) + (#xC2C2 #x8A51) + (#xC2C3 #x553E) + (#xC2C4 #x5815) + (#xC2C5 #x59A5) + (#xC2C6 #x60F0) + (#xC2C7 #x6253) + (#xC2C8 #x67C1) + (#xC2C9 #x8235) + (#xC2CA #x6955) + (#xC2CB #x9640) + (#xC2CC #x99C4) + (#xC2CD #x9A28) + (#xC2CE #x4F53) + (#xC2CF #x5806) + (#xC2D0 #x5BFE) + (#xC2D1 #x8010) + (#xC2D2 #x5CB1) + (#xC2D3 #x5E2F) + (#xC2D4 #x5F85) + (#xC2D5 #x6020) + (#xC2D6 #x614B) + (#xC2D7 #x6234) + (#xC2D8 #x66FF) + (#xC2D9 #x6CF0) + (#xC2DA #x6EDE) + (#xC2DB #x80CE) + (#xC2DC #x817F) + (#xC2DD #x82D4) + (#xC2DE #x888B) + (#xC2DF #x8CB8) + (#xC2E0 #x9000) + (#xC2E1 #x902E) + (#xC2E2 #x968A) + (#xC2E3 #x9EDB) + (#xC2E4 #x9BDB) + (#xC2E5 #x4EE3) + (#xC2E6 #x53F0) + (#xC2E7 #x5927) + (#xC2E8 #x7B2C) + (#xC2E9 #x918D) + (#xC2EA #x984C) + (#xC2EB #x9DF9) + (#xC2EC #x6EDD) + (#xC2ED #x7027) + (#xC2EE #x5353) + (#xC2EF #x5544) + (#xC2F0 #x5B85) + (#xC2F1 #x6258) + (#xC2F2 #x629E) + (#xC2F3 #x62D3) + (#xC2F4 #x6CA2) + (#xC2F5 #x6FEF) + (#xC2F6 #x7422) + (#xC2F7 #x8A17) + (#xC2F8 #x9438) + (#xC2F9 #x6FC1) + (#xC2FA #x8AFE) + (#xC2FB #x8338) + (#xC2FC #x51E7) + (#xC2FD #x86F8) + (#xC2FE #x53EA) + (#xC3A1 #x53E9) + (#xC3A2 #x4F46) + (#xC3A3 #x9054) + (#xC3A4 #x8FB0) + (#xC3A5 #x596A) + (#xC3A6 #x8131) + (#xC3A7 #x5DFD) + (#xC3A8 #x7AEA) + (#xC3A9 #x8FBF) + (#xC3AA #x68DA) + (#xC3AB #x8C37) + (#xC3AC #x72F8) + (#xC3AD #x9C48) + (#xC3AE #x6A3D) + (#xC3AF #x8AB0) + (#xC3B0 #x4E39) + (#xC3B1 #x5358) + (#xC3B2 #x5606) + (#xC3B3 #x5766) + (#xC3B4 #x62C5) + (#xC3B5 #x63A2) + (#xC3B6 #x65E6) + (#xC3B7 #x6B4E) + (#xC3B8 #x6DE1) + (#xC3B9 #x6E5B) + (#xC3BA #x70AD) + (#xC3BB #x77ED) + (#xC3BC #x7AEF) + (#xC3BD #x7BAA) + (#xC3BE #x7DBB) + (#xC3BF #x803D) + (#xC3C0 #x80C6) + (#xC3C1 #x86CB) + (#xC3C2 #x8A95) + (#xC3C3 #x935B) + (#xC3C4 #x56E3) + (#xC3C5 #x58C7) + (#xC3C6 #x5F3E) + (#xC3C7 #x65AD) + (#xC3C8 #x6696) + (#xC3C9 #x6A80) + (#xC3CA #x6BB5) + (#xC3CB #x7537) + (#xC3CC #x8AC7) + (#xC3CD #x5024) + (#xC3CE #x77E5) + (#xC3CF #x5730) + (#xC3D0 #x5F1B) + (#xC3D1 #x6065) + (#xC3D2 #x667A) + (#xC3D3 #x6C60) + (#xC3D4 #x75F4) + (#xC3D5 #x7A1A) + (#xC3D6 #x7F6E) + (#xC3D7 #x81F4) + (#xC3D8 #x8718) + (#xC3D9 #x9045) + (#xC3DA #x99B3) + (#xC3DB #x7BC9) + (#xC3DC #x755C) + (#xC3DD #x7AF9) + (#xC3DE #x7B51) + (#xC3DF #x84C4) + (#xC3E0 #x9010) + (#xC3E1 #x79E9) + (#xC3E2 #x7A92) + (#xC3E3 #x8336) + (#xC3E4 #x5AE1) + (#xC3E5 #x7740) + (#xC3E6 #x4E2D) + (#xC3E7 #x4EF2) + (#xC3E8 #x5B99) + (#xC3E9 #x5FE0) + (#xC3EA #x62BD) + (#xC3EB #x663C) + (#xC3EC #x67F1) + (#xC3ED #x6CE8) + (#xC3EE #x866B) + (#xC3EF #x8877) + (#xC3F0 #x8A3B) + (#xC3F1 #x914E) + (#xC3F2 #x92F3) + (#xC3F3 #x99D0) + (#xC3F4 #x6A17) + (#xC3F5 #x7026) + (#xC3F6 #x732A) + (#xC3F7 #x82E7) + (#xC3F8 #x8457) + (#xC3F9 #x8CAF) + (#xC3FA #x4E01) + (#xC3FB #x5146) + (#xC3FC #x51CB) + (#xC3FD #x558B) + (#xC3FE #x5BF5) + (#xC4A1 #x5E16) + (#xC4A2 #x5E33) + (#xC4A3 #x5E81) + (#xC4A4 #x5F14) + (#xC4A5 #x5F35) + (#xC4A6 #x5F6B) + (#xC4A7 #x5FB4) + (#xC4A8 #x61F2) + (#xC4A9 #x6311) + (#xC4AA #x66A2) + (#xC4AB #x671D) + (#xC4AC #x6F6E) + (#xC4AD #x7252) + (#xC4AE #x753A) + (#xC4AF #x773A) + (#xC4B0 #x8074) + (#xC4B1 #x8139) + (#xC4B2 #x8178) + (#xC4B3 #x8776) + (#xC4B4 #x8ABF) + (#xC4B5 #x8ADC) + (#xC4B6 #x8D85) + (#xC4B7 #x8DF3) + (#xC4B8 #x929A) + (#xC4B9 #x9577) + (#xC4BA #x9802) + (#xC4BB #x9CE5) + (#xC4BC #x52C5) + (#xC4BD #x6357) + (#xC4BE #x76F4) + (#xC4BF #x6715) + (#xC4C0 #x6C88) + (#xC4C1 #x73CD) + (#xC4C2 #x8CC3) + (#xC4C3 #x93AE) + (#xC4C4 #x9673) + (#xC4C5 #x6D25) + (#xC4C6 #x589C) + (#xC4C7 #x690E) + (#xC4C8 #x69CC) + (#xC4C9 #x8FFD) + (#xC4CA #x939A) + (#xC4CB #x75DB) + (#xC4CC #x901A) + (#xC4CD #x585A) + (#xC4CE #x6802) + (#xC4CF #x63B4) + (#xC4D0 #x69FB) + (#xC4D1 #x4F43) + (#xC4D2 #x6F2C) + (#xC4D3 #x67D8) + (#xC4D4 #x8FBB) + (#xC4D5 #x8526) + (#xC4D6 #x7DB4) + (#xC4D7 #x9354) + (#xC4D8 #x693F) + (#xC4D9 #x6F70) + (#xC4DA #x576A) + (#xC4DB #x58F7) + (#xC4DC #x5B2C) + (#xC4DD #x7D2C) + (#xC4DE #x722A) + (#xC4DF #x540A) + (#xC4E0 #x91E3) + (#xC4E1 #x9DB4) + (#xC4E2 #x4EAD) + (#xC4E3 #x4F4E) + (#xC4E4 #x505C) + (#xC4E5 #x5075) + (#xC4E6 #x5243) + (#xC4E7 #x8C9E) + (#xC4E8 #x5448) + (#xC4E9 #x5824) + (#xC4EA #x5B9A) + (#xC4EB #x5E1D) + (#xC4EC #x5E95) + (#xC4ED #x5EAD) + (#xC4EE #x5EF7) + (#xC4EF #x5F1F) + (#xC4F0 #x608C) + (#xC4F1 #x62B5) + (#xC4F2 #x633A) + (#xC4F3 #x63D0) + (#xC4F4 #x68AF) + (#xC4F5 #x6C40) + (#xC4F6 #x7887) + (#xC4F7 #x798E) + (#xC4F8 #x7A0B) + (#xC4F9 #x7DE0) + (#xC4FA #x8247) + (#xC4FB #x8A02) + (#xC4FC #x8AE6) + (#xC4FD #x8E44) + (#xC4FE #x9013) + (#xC5A1 #x90B8) + (#xC5A2 #x912D) + (#xC5A3 #x91D8) + (#xC5A4 #x9F0E) + (#xC5A5 #x6CE5) + (#xC5A6 #x6458) + (#xC5A7 #x64E2) + (#xC5A8 #x6575) + (#xC5A9 #x6EF4) + (#xC5AA #x7684) + (#xC5AB #x7B1B) + (#xC5AC #x9069) + (#xC5AD #x93D1) + (#xC5AE #x6EBA) + (#xC5AF #x54F2) + (#xC5B0 #x5FB9) + (#xC5B1 #x64A4) + (#xC5B2 #x8F4D) + (#xC5B3 #x8FED) + (#xC5B4 #x9244) + (#xC5B5 #x5178) + (#xC5B6 #x586B) + (#xC5B7 #x5929) + (#xC5B8 #x5C55) + (#xC5B9 #x5E97) + (#xC5BA #x6DFB) + (#xC5BB #x7E8F) + (#xC5BC #x751C) + (#xC5BD #x8CBC) + (#xC5BE #x8EE2) + (#xC5BF #x985B) + (#xC5C0 #x70B9) + (#xC5C1 #x4F1D) + (#xC5C2 #x6BBF) + (#xC5C3 #x6FB1) + (#xC5C4 #x7530) + (#xC5C5 #x96FB) + (#xC5C6 #x514E) + (#xC5C7 #x5410) + (#xC5C8 #x5835) + (#xC5C9 #x5857) + (#xC5CA #x59AC) + (#xC5CB #x5C60) + (#xC5CC #x5F92) + (#xC5CD #x6597) + (#xC5CE #x675C) + (#xC5CF #x6E21) + (#xC5D0 #x767B) + (#xC5D1 #x83DF) + (#xC5D2 #x8CED) + (#xC5D3 #x9014) + (#xC5D4 #x90FD) + (#xC5D5 #x934D) + (#xC5D6 #x7825) + (#xC5D7 #x783A) + (#xC5D8 #x52AA) + (#xC5D9 #x5EA6) + (#xC5DA #x571F) + (#xC5DB #x5974) + (#xC5DC #x6012) + (#xC5DD #x5012) + (#xC5DE #x515A) + (#xC5DF #x51AC) + (#xC5E0 #x51CD) + (#xC5E1 #x5200) + (#xC5E2 #x5510) + (#xC5E3 #x5854) + (#xC5E4 #x5858) + (#xC5E5 #x5957) + (#xC5E6 #x5B95) + (#xC5E7 #x5CF6) + (#xC5E8 #x5D8B) + (#xC5E9 #x60BC) + (#xC5EA #x6295) + (#xC5EB #x642D) + (#xC5EC #x6771) + (#xC5ED #x6843) + (#xC5EE #x68BC) + (#xC5EF #x68DF) + (#xC5F0 #x76D7) + (#xC5F1 #x6DD8) + (#xC5F2 #x6E6F) + (#xC5F3 #x6D9B) + (#xC5F4 #x706F) + (#xC5F5 #x71C8) + (#xC5F6 #x5F53) + (#xC5F7 #x75D8) + (#xC5F8 #x7977) + (#xC5F9 #x7B49) + (#xC5FA #x7B54) + (#xC5FB #x7B52) + (#xC5FC #x7CD6) + (#xC5FD #x7D71) + (#xC5FE #x5230) + (#xC6A1 #x8463) + (#xC6A2 #x8569) + (#xC6A3 #x85E4) + (#xC6A4 #x8A0E) + (#xC6A5 #x8B04) + (#xC6A6 #x8C46) + (#xC6A7 #x8E0F) + (#xC6A8 #x9003) + (#xC6A9 #x900F) + (#xC6AA #x9419) + (#xC6AB #x9676) + (#xC6AC #x982D) + (#xC6AD #x9A30) + (#xC6AE #x95D8) + (#xC6AF #x50CD) + (#xC6B0 #x52D5) + (#xC6B1 #x540C) + (#xC6B2 #x5802) + (#xC6B3 #x5C0E) + (#xC6B4 #x61A7) + (#xC6B5 #x649E) + (#xC6B6 #x6D1E) + (#xC6B7 #x77B3) + (#xC6B8 #x7AE5) + (#xC6B9 #x80F4) + (#xC6BA #x8404) + (#xC6BB #x9053) + (#xC6BC #x9285) + (#xC6BD #x5CE0) + (#xC6BE #x9D07) + (#xC6BF #x533F) + (#xC6C0 #x5F97) + (#xC6C1 #x5FB3) + (#xC6C2 #x6D9C) + (#xC6C3 #x7279) + (#xC6C4 #x7763) + (#xC6C5 #x79BF) + (#xC6C6 #x7BE4) + (#xC6C7 #x6BD2) + (#xC6C8 #x72EC) + (#xC6C9 #x8AAD) + (#xC6CA #x6803) + (#xC6CB #x6A61) + (#xC6CC #x51F8) + (#xC6CD #x7A81) + (#xC6CE #x6934) + (#xC6CF #x5C4A) + (#xC6D0 #x9CF6) + (#xC6D1 #x82EB) + (#xC6D2 #x5BC5) + (#xC6D3 #x9149) + (#xC6D4 #x701E) + (#xC6D5 #x5678) + (#xC6D6 #x5C6F) + (#xC6D7 #x60C7) + (#xC6D8 #x6566) + (#xC6D9 #x6C8C) + (#xC6DA #x8C5A) + (#xC6DB #x9041) + (#xC6DC #x9813) + (#xC6DD #x5451) + (#xC6DE #x66C7) + (#xC6DF #x920D) + (#xC6E0 #x5948) + (#xC6E1 #x90A3) + (#xC6E2 #x5185) + (#xC6E3 #x4E4D) + (#xC6E4 #x51EA) + (#xC6E5 #x8599) + (#xC6E6 #x8B0E) + (#xC6E7 #x7058) + (#xC6E8 #x637A) + (#xC6E9 #x934B) + (#xC6EA #x6962) + (#xC6EB #x99B4) + (#xC6EC #x7E04) + (#xC6ED #x7577) + (#xC6EE #x5357) + (#xC6EF #x6960) + (#xC6F0 #x8EDF) + (#xC6F1 #x96E3) + (#xC6F2 #x6C5D) + (#xC6F3 #x4E8C) + (#xC6F4 #x5C3C) + (#xC6F5 #x5F10) + (#xC6F6 #x8FE9) + (#xC6F7 #x5302) + (#xC6F8 #x8CD1) + (#xC6F9 #x8089) + (#xC6FA #x8679) + (#xC6FB #x5EFF) + (#xC6FC #x65E5) + (#xC6FD #x4E73) + (#xC6FE #x5165) + (#xC7A1 #x5982) + (#xC7A2 #x5C3F) + (#xC7A3 #x97EE) + (#xC7A4 #x4EFB) + (#xC7A5 #x598A) + (#xC7A6 #x5FCD) + (#xC7A7 #x8A8D) + (#xC7A8 #x6FE1) + (#xC7A9 #x79B0) + (#xC7AA #x7962) + (#xC7AB #x5BE7) + (#xC7AC #x8471) + (#xC7AD #x732B) + (#xC7AE #x71B1) + (#xC7AF #x5E74) + (#xC7B0 #x5FF5) + (#xC7B1 #x637B) + (#xC7B2 #x649A) + (#xC7B3 #x71C3) + (#xC7B4 #x7C98) + (#xC7B5 #x4E43) + (#xC7B6 #x5EFC) + (#xC7B7 #x4E4B) + (#xC7B8 #x57DC) + (#xC7B9 #x56A2) + (#xC7BA #x60A9) + (#xC7BB #x6FC3) + (#xC7BC #x7D0D) + (#xC7BD #x80FD) + (#xC7BE #x8133) + (#xC7BF #x81BF) + (#xC7C0 #x8FB2) + (#xC7C1 #x8997) + (#xC7C2 #x86A4) + (#xC7C3 #x5DF4) + (#xC7C4 #x628A) + (#xC7C5 #x64AD) + (#xC7C6 #x8987) + (#xC7C7 #x6777) + (#xC7C8 #x6CE2) + (#xC7C9 #x6D3E) + (#xC7CA #x7436) + (#xC7CB #x7834) + (#xC7CC #x5A46) + (#xC7CD #x7F75) + (#xC7CE #x82AD) + (#xC7CF #x99AC) + (#xC7D0 #x4FF3) + (#xC7D1 #x5EC3) + (#xC7D2 #x62DD) + (#xC7D3 #x6392) + (#xC7D4 #x6557) + (#xC7D5 #x676F) + (#xC7D6 #x76C3) + (#xC7D7 #x724C) + (#xC7D8 #x80CC) + (#xC7D9 #x80BA) + (#xC7DA #x8F29) + (#xC7DB #x914D) + (#xC7DC #x500D) + (#xC7DD #x57F9) + (#xC7DE #x5A92) + (#xC7DF #x6885) + (#xC7E0 #x6973) + (#xC7E1 #x7164) + (#xC7E2 #x72FD) + (#xC7E3 #x8CB7) + (#xC7E4 #x58F2) + (#xC7E5 #x8CE0) + (#xC7E6 #x966A) + (#xC7E7 #x9019) + (#xC7E8 #x877F) + (#xC7E9 #x79E4) + (#xC7EA #x77E7) + (#xC7EB #x8429) + (#xC7EC #x4F2F) + (#xC7ED #x5265) + (#xC7EE #x535A) + (#xC7EF #x62CD) + (#xC7F0 #x67CF) + (#xC7F1 #x6CCA) + (#xC7F2 #x767D) + (#xC7F3 #x7B94) + (#xC7F4 #x7C95) + (#xC7F5 #x8236) + (#xC7F6 #x8584) + (#xC7F7 #x8FEB) + (#xC7F8 #x66DD) + (#xC7F9 #x6F20) + (#xC7FA #x7206) + (#xC7FB #x7E1B) + (#xC7FC #x83AB) + (#xC7FD #x99C1) + (#xC7FE #x9EA6) + (#xC8A1 #x51FD) + (#xC8A2 #x7BB1) + (#xC8A3 #x7872) + (#xC8A4 #x7BB8) + (#xC8A5 #x8087) + (#xC8A6 #x7B48) + (#xC8A7 #x6AE8) + (#xC8A8 #x5E61) + (#xC8A9 #x808C) + (#xC8AA #x7551) + (#xC8AB #x7560) + (#xC8AC #x516B) + (#xC8AD #x9262) + (#xC8AE #x6E8C) + (#xC8AF #x767A) + (#xC8B0 #x9197) + (#xC8B1 #x9AEA) + (#xC8B2 #x4F10) + (#xC8B3 #x7F70) + (#xC8B4 #x629C) + (#xC8B5 #x7B4F) + (#xC8B6 #x95A5) + (#xC8B7 #x9CE9) + (#xC8B8 #x567A) + (#xC8B9 #x5859) + (#xC8BA #x86E4) + (#xC8BB #x96BC) + (#xC8BC #x4F34) + (#xC8BD #x5224) + (#xC8BE #x534A) + (#xC8BF #x53CD) + (#xC8C0 #x53DB) + (#xC8C1 #x5E06) + (#xC8C2 #x642C) + (#xC8C3 #x6591) + (#xC8C4 #x677F) + (#xC8C5 #x6C3E) + (#xC8C6 #x6C4E) + (#xC8C7 #x7248) + (#xC8C8 #x72AF) + (#xC8C9 #x73ED) + (#xC8CA #x7554) + (#xC8CB #x7E41) + (#xC8CC #x822C) + (#xC8CD #x85E9) + (#xC8CE #x8CA9) + (#xC8CF #x7BC4) + (#xC8D0 #x91C6) + (#xC8D1 #x7169) + (#xC8D2 #x9812) + (#xC8D3 #x98EF) + (#xC8D4 #x633D) + (#xC8D5 #x6669) + (#xC8D6 #x756A) + (#xC8D7 #x76E4) + (#xC8D8 #x78D0) + (#xC8D9 #x8543) + (#xC8DA #x86EE) + (#xC8DB #x532A) + (#xC8DC #x5351) + (#xC8DD #x5426) + (#xC8DE #x5983) + (#xC8DF #x5E87) + (#xC8E0 #x5F7C) + (#xC8E1 #x60B2) + (#xC8E2 #x6249) + (#xC8E3 #x6279) + (#xC8E4 #x62AB) + (#xC8E5 #x6590) + (#xC8E6 #x6BD4) + (#xC8E7 #x6CCC) + (#xC8E8 #x75B2) + (#xC8E9 #x76AE) + (#xC8EA #x7891) + (#xC8EB #x79D8) + (#xC8EC #x7DCB) + (#xC8ED #x7F77) + (#xC8EE #x80A5) + (#xC8EF #x88AB) + (#xC8F0 #x8AB9) + (#xC8F1 #x8CBB) + (#xC8F2 #x907F) + (#xC8F3 #x975E) + (#xC8F4 #x98DB) + (#xC8F5 #x6A0B) + (#xC8F6 #x7C38) + (#xC8F7 #x5099) + (#xC8F8 #x5C3E) + (#xC8F9 #x5FAE) + (#xC8FA #x6787) + (#xC8FB #x6BD8) + (#xC8FC #x7435) + (#xC8FD #x7709) + (#xC8FE #x7F8E) + (#xC9A1 #x9F3B) + (#xC9A2 #x67CA) + (#xC9A3 #x7A17) + (#xC9A4 #x5339) + (#xC9A5 #x758B) + (#xC9A6 #x9AED) + (#xC9A7 #x5F66) + (#xC9A8 #x819D) + (#xC9A9 #x83F1) + (#xC9AA #x8098) + (#xC9AB #x5F3C) + (#xC9AC #x5FC5) + (#xC9AD #x7562) + (#xC9AE #x7B46) + (#xC9AF #x903C) + (#xC9B0 #x6867) + (#xC9B1 #x59EB) + (#xC9B2 #x5A9B) + (#xC9B3 #x7D10) + (#xC9B4 #x767E) + (#xC9B5 #x8B2C) + (#xC9B6 #x4FF5) + (#xC9B7 #x5F6A) + (#xC9B8 #x6A19) + (#xC9B9 #x6C37) + (#xC9BA #x6F02) + (#xC9BB #x74E2) + (#xC9BC #x7968) + (#xC9BD #x8868) + (#xC9BE #x8A55) + (#xC9BF #x8C79) + (#xC9C0 #x5EDF) + (#xC9C1 #x63CF) + (#xC9C2 #x75C5) + (#xC9C3 #x79D2) + (#xC9C4 #x82D7) + (#xC9C5 #x9328) + (#xC9C6 #x92F2) + (#xC9C7 #x849C) + (#xC9C8 #x86ED) + (#xC9C9 #x9C2D) + (#xC9CA #x54C1) + (#xC9CB #x5F6C) + (#xC9CC #x658C) + (#xC9CD #x6D5C) + (#xC9CE #x7015) + (#xC9CF #x8CA7) + (#xC9D0 #x8CD3) + (#xC9D1 #x983B) + (#xC9D2 #x654F) + (#xC9D3 #x74F6) + (#xC9D4 #x4E0D) + (#xC9D5 #x4ED8) + (#xC9D6 #x57E0) + (#xC9D7 #x592B) + (#xC9D8 #x5A66) + (#xC9D9 #x5BCC) + (#xC9DA #x51A8) + (#xC9DB #x5E03) + (#xC9DC #x5E9C) + (#xC9DD #x6016) + (#xC9DE #x6276) + (#xC9DF #x6577) + (#xC9E0 #x65A7) + (#xC9E1 #x666E) + (#xC9E2 #x6D6E) + (#xC9E3 #x7236) + (#xC9E4 #x7B26) + (#xC9E5 #x8150) + (#xC9E6 #x819A) + (#xC9E7 #x8299) + (#xC9E8 #x8B5C) + (#xC9E9 #x8CA0) + (#xC9EA #x8CE6) + (#xC9EB #x8D74) + (#xC9EC #x961C) + (#xC9ED #x9644) + (#xC9EE #x4FAE) + (#xC9EF #x64AB) + (#xC9F0 #x6B66) + (#xC9F1 #x821E) + (#xC9F2 #x8461) + (#xC9F3 #x856A) + (#xC9F4 #x90E8) + (#xC9F5 #x5C01) + (#xC9F6 #x6953) + (#xC9F7 #x98A8) + (#xC9F8 #x847A) + (#xC9F9 #x8557) + (#xC9FA #x4F0F) + (#xC9FB #x526F) + (#xC9FC #x5FA9) + (#xC9FD #x5E45) + (#xC9FE #x670D) + (#xCAA1 #x798F) + (#xCAA2 #x8179) + (#xCAA3 #x8907) + (#xCAA4 #x8986) + (#xCAA5 #x6DF5) + (#xCAA6 #x5F17) + (#xCAA7 #x6255) + (#xCAA8 #x6CB8) + (#xCAA9 #x4ECF) + (#xCAAA #x7269) + (#xCAAB #x9B92) + (#xCAAC #x5206) + (#xCAAD #x543B) + (#xCAAE #x5674) + (#xCAAF #x58B3) + (#xCAB0 #x61A4) + (#xCAB1 #x626E) + (#xCAB2 #x711A) + (#xCAB3 #x596E) + (#xCAB4 #x7C89) + (#xCAB5 #x7CDE) + (#xCAB6 #x7D1B) + (#xCAB7 #x96F0) + (#xCAB8 #x6587) + (#xCAB9 #x805E) + (#xCABA #x4E19) + (#xCABB #x4F75) + (#xCABC #x5175) + (#xCABD #x5840) + (#xCABE #x5E63) + (#xCABF #x5E73) + (#xCAC0 #x5F0A) + (#xCAC1 #x67C4) + (#xCAC2 #x4E26) + (#xCAC3 #x853D) + (#xCAC4 #x9589) + (#xCAC5 #x965B) + (#xCAC6 #x7C73) + (#xCAC7 #x9801) + (#xCAC8 #x50FB) + (#xCAC9 #x58C1) + (#xCACA #x7656) + (#xCACB #x78A7) + (#xCACC #x5225) + (#xCACD #x77A5) + (#xCACE #x8511) + (#xCACF #x7B86) + (#xCAD0 #x504F) + (#xCAD1 #x5909) + (#xCAD2 #x7247) + (#xCAD3 #x7BC7) + (#xCAD4 #x7DE8) + (#xCAD5 #x8FBA) + (#xCAD6 #x8FD4) + (#xCAD7 #x904D) + (#xCAD8 #x4FBF) + (#xCAD9 #x52C9) + (#xCADA #x5A29) + (#xCADB #x5F01) + (#xCADC #x97AD) + (#xCADD #x4FDD) + (#xCADE #x8217) + (#xCADF #x92EA) + (#xCAE0 #x5703) + (#xCAE1 #x6355) + (#xCAE2 #x6B69) + (#xCAE3 #x752B) + (#xCAE4 #x88DC) + (#xCAE5 #x8F14) + (#xCAE6 #x7A42) + (#xCAE7 #x52DF) + (#xCAE8 #x5893) + (#xCAE9 #x6155) + (#xCAEA #x620A) + (#xCAEB #x66AE) + (#xCAEC #x6BCD) + (#xCAED #x7C3F) + (#xCAEE #x83E9) + (#xCAEF #x5023) + (#xCAF0 #x4FF8) + (#xCAF1 #x5305) + (#xCAF2 #x5446) + (#xCAF3 #x5831) + (#xCAF4 #x5949) + (#xCAF5 #x5B9D) + (#xCAF6 #x5CF0) + (#xCAF7 #x5CEF) + (#xCAF8 #x5D29) + (#xCAF9 #x5E96) + (#xCAFA #x62B1) + (#xCAFB #x6367) + (#xCAFC #x653E) + (#xCAFD #x65B9) + (#xCAFE #x670B) + (#xCBA1 #x6CD5) + (#xCBA2 #x6CE1) + (#xCBA3 #x70F9) + (#xCBA4 #x7832) + (#xCBA5 #x7E2B) + (#xCBA6 #x80DE) + (#xCBA7 #x82B3) + (#xCBA8 #x840C) + (#xCBA9 #x84EC) + (#xCBAA #x8702) + (#xCBAB #x8912) + (#xCBAC #x8A2A) + (#xCBAD #x8C4A) + (#xCBAE #x90A6) + (#xCBAF #x92D2) + (#xCBB0 #x98FD) + (#xCBB1 #x9CF3) + (#xCBB2 #x9D6C) + (#xCBB3 #x4E4F) + (#xCBB4 #x4EA1) + (#xCBB5 #x508D) + (#xCBB6 #x5256) + (#xCBB7 #x574A) + (#xCBB8 #x59A8) + (#xCBB9 #x5E3D) + (#xCBBA #x5FD8) + (#xCBBB #x5FD9) + (#xCBBC #x623F) + (#xCBBD #x66B4) + (#xCBBE #x671B) + (#xCBBF #x67D0) + (#xCBC0 #x68D2) + (#xCBC1 #x5192) + (#xCBC2 #x7D21) + (#xCBC3 #x80AA) + (#xCBC4 #x81A8) + (#xCBC5 #x8B00) + (#xCBC6 #x8C8C) + (#xCBC7 #x8CBF) + (#xCBC8 #x927E) + (#xCBC9 #x9632) + (#xCBCA #x5420) + (#xCBCB #x982C) + (#xCBCC #x5317) + (#xCBCD #x50D5) + (#xCBCE #x535C) + (#xCBCF #x58A8) + (#xCBD0 #x64B2) + (#xCBD1 #x6734) + (#xCBD2 #x7267) + (#xCBD3 #x7766) + (#xCBD4 #x7A46) + (#xCBD5 #x91E6) + (#xCBD6 #x52C3) + (#xCBD7 #x6CA1) + (#xCBD8 #x6B86) + (#xCBD9 #x5800) + (#xCBDA #x5E4C) + (#xCBDB #x5954) + (#xCBDC #x672C) + (#xCBDD #x7FFB) + (#xCBDE #x51E1) + (#xCBDF #x76C6) + (#xCBE0 #x6469) + (#xCBE1 #x78E8) + (#xCBE2 #x9B54) + (#xCBE3 #x9EBB) + (#xCBE4 #x57CB) + (#xCBE5 #x59B9) + (#xCBE6 #x6627) + (#xCBE7 #x679A) + (#xCBE8 #x6BCE) + (#xCBE9 #x54E9) + (#xCBEA #x69D9) + (#xCBEB #x5E55) + (#xCBEC #x819C) + (#xCBED #x6795) + (#xCBEE #x9BAA) + (#xCBEF #x67FE) + (#xCBF0 #x9C52) + (#xCBF1 #x685D) + (#xCBF2 #x4EA6) + (#xCBF3 #x4FE3) + (#xCBF4 #x53C8) + (#xCBF5 #x62B9) + (#xCBF6 #x672B) + (#xCBF7 #x6CAB) + (#xCBF8 #x8FC4) + (#xCBF9 #x4FAD) + (#xCBFA #x7E6D) + (#xCBFB #x9EBF) + (#xCBFC #x4E07) + (#xCBFD #x6162) + (#xCBFE #x6E80) + (#xCCA1 #x6F2B) + (#xCCA2 #x8513) + (#xCCA3 #x5473) + (#xCCA4 #x672A) + (#xCCA5 #x9B45) + (#xCCA6 #x5DF3) + (#xCCA7 #x7B95) + (#xCCA8 #x5CAC) + (#xCCA9 #x5BC6) + (#xCCAA #x871C) + (#xCCAB #x6E4A) + (#xCCAC #x84D1) + (#xCCAD #x7A14) + (#xCCAE #x8108) + (#xCCAF #x5999) + (#xCCB0 #x7C8D) + (#xCCB1 #x6C11) + (#xCCB2 #x7720) + (#xCCB3 #x52D9) + (#xCCB4 #x5922) + (#xCCB5 #x7121) + (#xCCB6 #x725F) + (#xCCB7 #x77DB) + (#xCCB8 #x9727) + (#xCCB9 #x9D61) + (#xCCBA #x690B) + (#xCCBB #x5A7F) + (#xCCBC #x5A18) + (#xCCBD #x51A5) + (#xCCBE #x540D) + (#xCCBF #x547D) + (#xCCC0 #x660E) + (#xCCC1 #x76DF) + (#xCCC2 #x8FF7) + (#xCCC3 #x9298) + (#xCCC4 #x9CF4) + (#xCCC5 #x59EA) + (#xCCC6 #x725D) + (#xCCC7 #x6EC5) + (#xCCC8 #x514D) + (#xCCC9 #x68C9) + (#xCCCA #x7DBF) + (#xCCCB #x7DEC) + (#xCCCC #x9762) + (#xCCCD #x9EBA) + (#xCCCE #x6478) + (#xCCCF #x6A21) + (#xCCD0 #x8302) + (#xCCD1 #x5984) + (#xCCD2 #x5B5F) + (#xCCD3 #x6BDB) + (#xCCD4 #x731B) + (#xCCD5 #x76F2) + (#xCCD6 #x7DB2) + (#xCCD7 #x8017) + (#xCCD8 #x8499) + (#xCCD9 #x5132) + (#xCCDA #x6728) + (#xCCDB #x9ED9) + (#xCCDC #x76EE) + (#xCCDD #x6762) + (#xCCDE #x52FF) + (#xCCDF #x9905) + (#xCCE0 #x5C24) + (#xCCE1 #x623B) + (#xCCE2 #x7C7E) + (#xCCE3 #x8CB0) + (#xCCE4 #x554F) + (#xCCE5 #x60B6) + (#xCCE6 #x7D0B) + (#xCCE7 #x9580) + (#xCCE8 #x5301) + (#xCCE9 #x4E5F) + (#xCCEA #x51B6) + (#xCCEB #x591C) + (#xCCEC #x723A) + (#xCCED #x8036) + (#xCCEE #x91CE) + (#xCCEF #x5F25) + (#xCCF0 #x77E2) + (#xCCF1 #x5384) + (#xCCF2 #x5F79) + (#xCCF3 #x7D04) + (#xCCF4 #x85AC) + (#xCCF5 #x8A33) + (#xCCF6 #x8E8D) + (#xCCF7 #x9756) + (#xCCF8 #x67F3) + (#xCCF9 #x85AE) + (#xCCFA #x9453) + (#xCCFB #x6109) + (#xCCFC #x6108) + (#xCCFD #x6CB9) + (#xCCFE #x7652) + (#xCDA1 #x8AED) + (#xCDA2 #x8F38) + (#xCDA3 #x552F) + (#xCDA4 #x4F51) + (#xCDA5 #x512A) + (#xCDA6 #x52C7) + (#xCDA7 #x53CB) + (#xCDA8 #x5BA5) + (#xCDA9 #x5E7D) + (#xCDAA #x60A0) + (#xCDAB #x6182) + (#xCDAC #x63D6) + (#xCDAD #x6709) + (#xCDAE #x67DA) + (#xCDAF #x6E67) + (#xCDB0 #x6D8C) + (#xCDB1 #x7336) + (#xCDB2 #x7337) + (#xCDB3 #x7531) + (#xCDB4 #x7950) + (#xCDB5 #x88D5) + (#xCDB6 #x8A98) + (#xCDB7 #x904A) + (#xCDB8 #x9091) + (#xCDB9 #x90F5) + (#xCDBA #x96C4) + (#xCDBB #x878D) + (#xCDBC #x5915) + (#xCDBD #x4E88) + (#xCDBE #x4F59) + (#xCDBF #x4E0E) + (#xCDC0 #x8A89) + (#xCDC1 #x8F3F) + (#xCDC2 #x9810) + (#xCDC3 #x50AD) + (#xCDC4 #x5E7C) + (#xCDC5 #x5996) + (#xCDC6 #x5BB9) + (#xCDC7 #x5EB8) + (#xCDC8 #x63DA) + (#xCDC9 #x63FA) + (#xCDCA #x64C1) + (#xCDCB #x66DC) + (#xCDCC #x694A) + (#xCDCD #x69D8) + (#xCDCE #x6D0B) + (#xCDCF #x6EB6) + (#xCDD0 #x7194) + (#xCDD1 #x7528) + (#xCDD2 #x7AAF) + (#xCDD3 #x7F8A) + (#xCDD4 #x8000) + (#xCDD5 #x8449) + (#xCDD6 #x84C9) + (#xCDD7 #x8981) + (#xCDD8 #x8B21) + (#xCDD9 #x8E0A) + (#xCDDA #x9065) + (#xCDDB #x967D) + (#xCDDC #x990A) + (#xCDDD #x617E) + (#xCDDE #x6291) + (#xCDDF #x6B32) + (#xCDE0 #x6C83) + (#xCDE1 #x6D74) + (#xCDE2 #x7FCC) + (#xCDE3 #x7FFC) + (#xCDE4 #x6DC0) + (#xCDE5 #x7F85) + (#xCDE6 #x87BA) + (#xCDE7 #x88F8) + (#xCDE8 #x6765) + (#xCDE9 #x83B1) + (#xCDEA #x983C) + (#xCDEB #x96F7) + (#xCDEC #x6D1B) + (#xCDED #x7D61) + (#xCDEE #x843D) + (#xCDEF #x916A) + (#xCDF0 #x4E71) + (#xCDF1 #x5375) + (#xCDF2 #x5D50) + (#xCDF3 #x6B04) + (#xCDF4 #x6FEB) + (#xCDF5 #x85CD) + (#xCDF6 #x862D) + (#xCDF7 #x89A7) + (#xCDF8 #x5229) + (#xCDF9 #x540F) + (#xCDFA #x5C65) + (#xCDFB #x674E) + (#xCDFC #x68A8) + (#xCDFD #x7406) + (#xCDFE #x7483) + (#xCEA1 #x75E2) + (#xCEA2 #x88CF) + (#xCEA3 #x88E1) + (#xCEA4 #x91CC) + (#xCEA5 #x96E2) + (#xCEA6 #x9678) + (#xCEA7 #x5F8B) + (#xCEA8 #x7387) + (#xCEA9 #x7ACB) + (#xCEAA #x844E) + (#xCEAB #x63A0) + (#xCEAC #x7565) + (#xCEAD #x5289) + (#xCEAE #x6D41) + (#xCEAF #x6E9C) + (#xCEB0 #x7409) + (#xCEB1 #x7559) + (#xCEB2 #x786B) + (#xCEB3 #x7C92) + (#xCEB4 #x9686) + (#xCEB5 #x7ADC) + (#xCEB6 #x9F8D) + (#xCEB7 #x4FB6) + (#xCEB8 #x616E) + (#xCEB9 #x65C5) + (#xCEBA #x865C) + (#xCEBB #x4E86) + (#xCEBC #x4EAE) + (#xCEBD #x50DA) + (#xCEBE #x4E21) + (#xCEBF #x51CC) + (#xCEC0 #x5BEE) + (#xCEC1 #x6599) + (#xCEC2 #x6881) + (#xCEC3 #x6DBC) + (#xCEC4 #x731F) + (#xCEC5 #x7642) + (#xCEC6 #x77AD) + (#xCEC7 #x7A1C) + (#xCEC8 #x7CE7) + (#xCEC9 #x826F) + (#xCECA #x8AD2) + (#xCECB #x907C) + (#xCECC #x91CF) + (#xCECD #x9675) + (#xCECE #x9818) + (#xCECF #x529B) + (#xCED0 #x7DD1) + (#xCED1 #x502B) + (#xCED2 #x5398) + (#xCED3 #x6797) + (#xCED4 #x6DCB) + (#xCED5 #x71D0) + (#xCED6 #x7433) + (#xCED7 #x81E8) + (#xCED8 #x8F2A) + (#xCED9 #x96A3) + (#xCEDA #x9C57) + (#xCEDB #x9E9F) + (#xCEDC #x7460) + (#xCEDD #x5841) + (#xCEDE #x6D99) + (#xCEDF #x7D2F) + (#xCEE0 #x985E) + (#xCEE1 #x4EE4) + (#xCEE2 #x4F36) + (#xCEE3 #x4F8B) + (#xCEE4 #x51B7) + (#xCEE5 #x52B1) + (#xCEE6 #x5DBA) + (#xCEE7 #x601C) + (#xCEE8 #x73B2) + (#xCEE9 #x793C) + (#xCEEA #x82D3) + (#xCEEB #x9234) + (#xCEEC #x96B7) + (#xCEED #x96F6) + (#xCEEE #x970A) + (#xCEEF #x9E97) + (#xCEF0 #x9F62) + (#xCEF1 #x66A6) + (#xCEF2 #x6B74) + (#xCEF3 #x5217) + (#xCEF4 #x52A3) + (#xCEF5 #x70C8) + (#xCEF6 #x88C2) + (#xCEF7 #x5EC9) + (#xCEF8 #x604B) + (#xCEF9 #x6190) + (#xCEFA #x6F23) + (#xCEFB #x7149) + (#xCEFC #x7C3E) + (#xCEFD #x7DF4) + (#xCEFE #x806F) + (#xCFA1 #x84EE) + (#xCFA2 #x9023) + (#xCFA3 #x932C) + (#xCFA4 #x5442) + (#xCFA5 #x9B6F) + (#xCFA6 #x6AD3) + (#xCFA7 #x7089) + (#xCFA8 #x8CC2) + (#xCFA9 #x8DEF) + (#xCFAA #x9732) + (#xCFAB #x52B4) + (#xCFAC #x5A41) + (#xCFAD #x5ECA) + (#xCFAE #x5F04) + (#xCFAF #x6717) + (#xCFB0 #x697C) + (#xCFB1 #x6994) + (#xCFB2 #x6D6A) + (#xCFB3 #x6F0F) + (#xCFB4 #x7262) + (#xCFB5 #x72FC) + (#xCFB6 #x7BED) + (#xCFB7 #x8001) + (#xCFB8 #x807E) + (#xCFB9 #x874B) + (#xCFBA #x90CE) + (#xCFBB #x516D) + (#xCFBC #x9E93) + (#xCFBD #x7984) + (#xCFBE #x808B) + (#xCFBF #x9332) + (#xCFC0 #x8AD6) + (#xCFC1 #x502D) + (#xCFC2 #x548C) + (#xCFC3 #x8A71) + (#xCFC4 #x6B6A) + (#xCFC5 #x8CC4) + (#xCFC6 #x8107) + (#xCFC7 #x60D1) + (#xCFC8 #x67A0) + (#xCFC9 #x9DF2) + (#xCFCA #x4E99) + (#xCFCB #x4E98) + (#xCFCC #x9C10) + (#xCFCD #x8A6B) + (#xCFCE #x85C1) + (#xCFCF #x8568) + (#xCFD0 #x6900) + (#xCFD1 #x6E7E) + (#xCFD2 #x7897) + (#xCFD3 #x8155) + (#xD0A1 #x5F0C) + (#xD0A2 #x4E10) + (#xD0A3 #x4E15) + (#xD0A4 #x4E2A) + (#xD0A5 #x4E31) + (#xD0A6 #x4E36) + (#xD0A7 #x4E3C) + (#xD0A8 #x4E3F) + (#xD0A9 #x4E42) + (#xD0AA #x4E56) + (#xD0AB #x4E58) + (#xD0AC #x4E82) + (#xD0AD #x4E85) + (#xD0AE #x8C6B) + (#xD0AF #x4E8A) + (#xD0B0 #x8212) + (#xD0B1 #x5F0D) + (#xD0B2 #x4E8E) + (#xD0B3 #x4E9E) + (#xD0B4 #x4E9F) + (#xD0B5 #x4EA0) + (#xD0B6 #x4EA2) + (#xD0B7 #x4EB0) + (#xD0B8 #x4EB3) + (#xD0B9 #x4EB6) + (#xD0BA #x4ECE) + (#xD0BB #x4ECD) + (#xD0BC #x4EC4) + (#xD0BD #x4EC6) + (#xD0BE #x4EC2) + (#xD0BF #x4ED7) + (#xD0C0 #x4EDE) + (#xD0C1 #x4EED) + (#xD0C2 #x4EDF) + (#xD0C3 #x4EF7) + (#xD0C4 #x4F09) + (#xD0C5 #x4F5A) + (#xD0C6 #x4F30) + (#xD0C7 #x4F5B) + (#xD0C8 #x4F5D) + (#xD0C9 #x4F57) + (#xD0CA #x4F47) + (#xD0CB #x4F76) + (#xD0CC #x4F88) + (#xD0CD #x4F8F) + (#xD0CE #x4F98) + (#xD0CF #x4F7B) + (#xD0D0 #x4F69) + (#xD0D1 #x4F70) + (#xD0D2 #x4F91) + (#xD0D3 #x4F6F) + (#xD0D4 #x4F86) + (#xD0D5 #x4F96) + (#xD0D6 #x5118) + (#xD0D7 #x4FD4) + (#xD0D8 #x4FDF) + (#xD0D9 #x4FCE) + (#xD0DA #x4FD8) + (#xD0DB #x4FDB) + (#xD0DC #x4FD1) + (#xD0DD #x4FDA) + (#xD0DE #x4FD0) + (#xD0DF #x4FE4) + (#xD0E0 #x4FE5) + (#xD0E1 #x501A) + (#xD0E2 #x5028) + (#xD0E3 #x5014) + (#xD0E4 #x502A) + (#xD0E5 #x5025) + (#xD0E6 #x5005) + (#xD0E7 #x4F1C) + (#xD0E8 #x4FF6) + (#xD0E9 #x5021) + (#xD0EA #x5029) + (#xD0EB #x502C) + (#xD0EC #x4FFE) + (#xD0ED #x4FEF) + (#xD0EE #x5011) + (#xD0EF #x5006) + (#xD0F0 #x5043) + (#xD0F1 #x5047) + (#xD0F2 #x6703) + (#xD0F3 #x5055) + (#xD0F4 #x5050) + (#xD0F5 #x5048) + (#xD0F6 #x505A) + (#xD0F7 #x5056) + (#xD0F8 #x506C) + (#xD0F9 #x5078) + (#xD0FA #x5080) + (#xD0FB #x509A) + (#xD0FC #x5085) + (#xD0FD #x50B4) + (#xD0FE #x50B2) + (#xD1A1 #x50C9) + (#xD1A2 #x50CA) + (#xD1A3 #x50B3) + (#xD1A4 #x50C2) + (#xD1A5 #x50D6) + (#xD1A6 #x50DE) + (#xD1A7 #x50E5) + (#xD1A8 #x50ED) + (#xD1A9 #x50E3) + (#xD1AA #x50EE) + (#xD1AB #x50F9) + (#xD1AC #x50F5) + (#xD1AD #x5109) + (#xD1AE #x5101) + (#xD1AF #x5102) + (#xD1B0 #x5116) + (#xD1B1 #x5115) + (#xD1B2 #x5114) + (#xD1B3 #x511A) + (#xD1B4 #x5121) + (#xD1B5 #x513A) + (#xD1B6 #x5137) + (#xD1B7 #x513C) + (#xD1B8 #x513B) + (#xD1B9 #x513F) + (#xD1BA #x5140) + (#xD1BB #x5152) + (#xD1BC #x514C) + (#xD1BD #x5154) + (#xD1BE #x5162) + (#xD1BF #x7AF8) + (#xD1C0 #x5169) + (#xD1C1 #x516A) + (#xD1C2 #x516E) + (#xD1C3 #x5180) + (#xD1C4 #x5182) + (#xD1C5 #x56D8) + (#xD1C6 #x518C) + (#xD1C7 #x5189) + (#xD1C8 #x518F) + (#xD1C9 #x5191) + (#xD1CA #x5193) + (#xD1CB #x5195) + (#xD1CC #x5196) + (#xD1CD #x51A4) + (#xD1CE #x51A6) + (#xD1CF #x51A2) + (#xD1D0 #x51A9) + (#xD1D1 #x51AA) + (#xD1D2 #x51AB) + (#xD1D3 #x51B3) + (#xD1D4 #x51B1) + (#xD1D5 #x51B2) + (#xD1D6 #x51B0) + (#xD1D7 #x51B5) + (#xD1D8 #x51BD) + (#xD1D9 #x51C5) + (#xD1DA #x51C9) + (#xD1DB #x51DB) + (#xD1DC #x51E0) + (#xD1DD #x8655) + (#xD1DE #x51E9) + (#xD1DF #x51ED) + (#xD1E0 #x51F0) + (#xD1E1 #x51F5) + (#xD1E2 #x51FE) + (#xD1E3 #x5204) + (#xD1E4 #x520B) + (#xD1E5 #x5214) + (#xD1E6 #x520E) + (#xD1E7 #x5227) + (#xD1E8 #x522A) + (#xD1E9 #x522E) + (#xD1EA #x5233) + (#xD1EB #x5239) + (#xD1EC #x524F) + (#xD1ED #x5244) + (#xD1EE #x524B) + (#xD1EF #x524C) + (#xD1F0 #x525E) + (#xD1F1 #x5254) + (#xD1F2 #x526A) + (#xD1F3 #x5274) + (#xD1F4 #x5269) + (#xD1F5 #x5273) + (#xD1F6 #x527F) + (#xD1F7 #x527D) + (#xD1F8 #x528D) + (#xD1F9 #x5294) + (#xD1FA #x5292) + (#xD1FB #x5271) + (#xD1FC #x5288) + (#xD1FD #x5291) + (#xD1FE #x8FA8) + (#xD2A1 #x8FA7) + (#xD2A2 #x52AC) + (#xD2A3 #x52AD) + (#xD2A4 #x52BC) + (#xD2A5 #x52B5) + (#xD2A6 #x52C1) + (#xD2A7 #x52CD) + (#xD2A8 #x52D7) + (#xD2A9 #x52DE) + (#xD2AA #x52E3) + (#xD2AB #x52E6) + (#xD2AC #x98ED) + (#xD2AD #x52E0) + (#xD2AE #x52F3) + (#xD2AF #x52F5) + (#xD2B0 #x52F8) + (#xD2B1 #x52F9) + (#xD2B2 #x5306) + (#xD2B3 #x5308) + (#xD2B4 #x7538) + (#xD2B5 #x530D) + (#xD2B6 #x5310) + (#xD2B7 #x530F) + (#xD2B8 #x5315) + (#xD2B9 #x531A) + (#xD2BA #x5323) + (#xD2BB #x532F) + (#xD2BC #x5331) + (#xD2BD #x5333) + (#xD2BE #x5338) + (#xD2BF #x5340) + (#xD2C0 #x5346) + (#xD2C1 #x5345) + (#xD2C2 #x4E17) + (#xD2C3 #x5349) + (#xD2C4 #x534D) + (#xD2C5 #x51D6) + (#xD2C6 #x535E) + (#xD2C7 #x5369) + (#xD2C8 #x536E) + (#xD2C9 #x5918) + (#xD2CA #x537B) + (#xD2CB #x5377) + (#xD2CC #x5382) + (#xD2CD #x5396) + (#xD2CE #x53A0) + (#xD2CF #x53A6) + (#xD2D0 #x53A5) + (#xD2D1 #x53AE) + (#xD2D2 #x53B0) + (#xD2D3 #x53B6) + (#xD2D4 #x53C3) + (#xD2D5 #x7C12) + (#xD2D6 #x96D9) + (#xD2D7 #x53DF) + (#xD2D8 #x66FC) + (#xD2D9 #x71EE) + (#xD2DA #x53EE) + (#xD2DB #x53E8) + (#xD2DC #x53ED) + (#xD2DD #x53FA) + (#xD2DE #x5401) + (#xD2DF #x543D) + (#xD2E0 #x5440) + (#xD2E1 #x542C) + (#xD2E2 #x542D) + (#xD2E3 #x543C) + (#xD2E4 #x542E) + (#xD2E5 #x5436) + (#xD2E6 #x5429) + (#xD2E7 #x541D) + (#xD2E8 #x544E) + (#xD2E9 #x548F) + (#xD2EA #x5475) + (#xD2EB #x548E) + (#xD2EC #x545F) + (#xD2ED #x5471) + (#xD2EE #x5477) + (#xD2EF #x5470) + (#xD2F0 #x5492) + (#xD2F1 #x547B) + (#xD2F2 #x5480) + (#xD2F3 #x5476) + (#xD2F4 #x5484) + (#xD2F5 #x5490) + (#xD2F6 #x5486) + (#xD2F7 #x54C7) + (#xD2F8 #x54A2) + (#xD2F9 #x54B8) + (#xD2FA #x54A5) + (#xD2FB #x54AC) + (#xD2FC #x54C4) + (#xD2FD #x54C8) + (#xD2FE #x54A8) + (#xD3A1 #x54AB) + (#xD3A2 #x54C2) + (#xD3A3 #x54A4) + (#xD3A4 #x54BE) + (#xD3A5 #x54BC) + (#xD3A6 #x54D8) + (#xD3A7 #x54E5) + (#xD3A8 #x54E6) + (#xD3A9 #x550F) + (#xD3AA #x5514) + (#xD3AB #x54FD) + (#xD3AC #x54EE) + (#xD3AD #x54ED) + (#xD3AE #x54FA) + (#xD3AF #x54E2) + (#xD3B0 #x5539) + (#xD3B1 #x5540) + (#xD3B2 #x5563) + (#xD3B3 #x554C) + (#xD3B4 #x552E) + (#xD3B5 #x555C) + (#xD3B6 #x5545) + (#xD3B7 #x5556) + (#xD3B8 #x5557) + (#xD3B9 #x5538) + (#xD3BA #x5533) + (#xD3BB #x555D) + (#xD3BC #x5599) + (#xD3BD #x5580) + (#xD3BE #x54AF) + (#xD3BF #x558A) + (#xD3C0 #x559F) + (#xD3C1 #x557B) + (#xD3C2 #x557E) + (#xD3C3 #x5598) + (#xD3C4 #x559E) + (#xD3C5 #x55AE) + (#xD3C6 #x557C) + (#xD3C7 #x5583) + (#xD3C8 #x55A9) + (#xD3C9 #x5587) + (#xD3CA #x55A8) + (#xD3CB #x55DA) + (#xD3CC #x55C5) + (#xD3CD #x55DF) + (#xD3CE #x55C4) + (#xD3CF #x55DC) + (#xD3D0 #x55E4) + (#xD3D1 #x55D4) + (#xD3D2 #x5614) + (#xD3D3 #x55F7) + (#xD3D4 #x5616) + (#xD3D5 #x55FE) + (#xD3D6 #x55FD) + (#xD3D7 #x561B) + (#xD3D8 #x55F9) + (#xD3D9 #x564E) + (#xD3DA #x5650) + (#xD3DB #x71DF) + (#xD3DC #x5634) + (#xD3DD #x5636) + (#xD3DE #x5632) + (#xD3DF #x5638) + (#xD3E0 #x566B) + (#xD3E1 #x5664) + (#xD3E2 #x562F) + (#xD3E3 #x566C) + (#xD3E4 #x566A) + (#xD3E5 #x5686) + (#xD3E6 #x5680) + (#xD3E7 #x568A) + (#xD3E8 #x56A0) + (#xD3E9 #x5694) + (#xD3EA #x568F) + (#xD3EB #x56A5) + (#xD3EC #x56AE) + (#xD3ED #x56B6) + (#xD3EE #x56B4) + (#xD3EF #x56C2) + (#xD3F0 #x56BC) + (#xD3F1 #x56C1) + (#xD3F2 #x56C3) + (#xD3F3 #x56C0) + (#xD3F4 #x56C8) + (#xD3F5 #x56CE) + (#xD3F6 #x56D1) + (#xD3F7 #x56D3) + (#xD3F8 #x56D7) + (#xD3F9 #x56EE) + (#xD3FA #x56F9) + (#xD3FB #x5700) + (#xD3FC #x56FF) + (#xD3FD #x5704) + (#xD3FE #x5709) + (#xD4A1 #x5708) + (#xD4A2 #x570B) + (#xD4A3 #x570D) + (#xD4A4 #x5713) + (#xD4A5 #x5718) + (#xD4A6 #x5716) + (#xD4A7 #x55C7) + (#xD4A8 #x571C) + (#xD4A9 #x5726) + (#xD4AA #x5737) + (#xD4AB #x5738) + (#xD4AC #x574E) + (#xD4AD #x573B) + (#xD4AE #x5740) + (#xD4AF #x574F) + (#xD4B0 #x5769) + (#xD4B1 #x57C0) + (#xD4B2 #x5788) + (#xD4B3 #x5761) + (#xD4B4 #x577F) + (#xD4B5 #x5789) + (#xD4B6 #x5793) + (#xD4B7 #x57A0) + (#xD4B8 #x57B3) + (#xD4B9 #x57A4) + (#xD4BA #x57AA) + (#xD4BB #x57B0) + (#xD4BC #x57C3) + (#xD4BD #x57C6) + (#xD4BE #x57D4) + (#xD4BF #x57D2) + (#xD4C0 #x57D3) + (#xD4C1 #x580A) + (#xD4C2 #x57D6) + (#xD4C3 #x57E3) + (#xD4C4 #x580B) + (#xD4C5 #x5819) + (#xD4C6 #x581D) + (#xD4C7 #x5872) + (#xD4C8 #x5821) + (#xD4C9 #x5862) + (#xD4CA #x584B) + (#xD4CB #x5870) + (#xD4CC #x6BC0) + (#xD4CD #x5852) + (#xD4CE #x583D) + (#xD4CF #x5879) + (#xD4D0 #x5885) + (#xD4D1 #x58B9) + (#xD4D2 #x589F) + (#xD4D3 #x58AB) + (#xD4D4 #x58BA) + (#xD4D5 #x58DE) + (#xD4D6 #x58BB) + (#xD4D7 #x58B8) + (#xD4D8 #x58AE) + (#xD4D9 #x58C5) + (#xD4DA #x58D3) + (#xD4DB #x58D1) + (#xD4DC #x58D7) + (#xD4DD #x58D9) + (#xD4DE #x58D8) + (#xD4DF #x58E5) + (#xD4E0 #x58DC) + (#xD4E1 #x58E4) + (#xD4E2 #x58DF) + (#xD4E3 #x58EF) + (#xD4E4 #x58FA) + (#xD4E5 #x58F9) + (#xD4E6 #x58FB) + (#xD4E7 #x58FC) + (#xD4E8 #x58FD) + (#xD4E9 #x5902) + (#xD4EA #x590A) + (#xD4EB #x5910) + (#xD4EC #x591B) + (#xD4ED #x68A6) + (#xD4EE #x5925) + (#xD4EF #x592C) + (#xD4F0 #x592D) + (#xD4F1 #x5932) + (#xD4F2 #x5938) + (#xD4F3 #x593E) + (#xD4F4 #x7AD2) + (#xD4F5 #x5955) + (#xD4F6 #x5950) + (#xD4F7 #x594E) + (#xD4F8 #x595A) + (#xD4F9 #x5958) + (#xD4FA #x5962) + (#xD4FB #x5960) + (#xD4FC #x5967) + (#xD4FD #x596C) + (#xD4FE #x5969) + (#xD5A1 #x5978) + (#xD5A2 #x5981) + (#xD5A3 #x599D) + (#xD5A4 #x4F5E) + (#xD5A5 #x4FAB) + (#xD5A6 #x59A3) + (#xD5A7 #x59B2) + (#xD5A8 #x59C6) + (#xD5A9 #x59E8) + (#xD5AA #x59DC) + (#xD5AB #x598D) + (#xD5AC #x59D9) + (#xD5AD #x59DA) + (#xD5AE #x5A25) + (#xD5AF #x5A1F) + (#xD5B0 #x5A11) + (#xD5B1 #x5A1C) + (#xD5B2 #x5A09) + (#xD5B3 #x5A1A) + (#xD5B4 #x5A40) + (#xD5B5 #x5A6C) + (#xD5B6 #x5A49) + (#xD5B7 #x5A35) + (#xD5B8 #x5A36) + (#xD5B9 #x5A62) + (#xD5BA #x5A6A) + (#xD5BB #x5A9A) + (#xD5BC #x5ABC) + (#xD5BD #x5ABE) + (#xD5BE #x5ACB) + (#xD5BF #x5AC2) + (#xD5C0 #x5ABD) + (#xD5C1 #x5AE3) + (#xD5C2 #x5AD7) + (#xD5C3 #x5AE6) + (#xD5C4 #x5AE9) + (#xD5C5 #x5AD6) + (#xD5C6 #x5AFA) + (#xD5C7 #x5AFB) + (#xD5C8 #x5B0C) + (#xD5C9 #x5B0B) + (#xD5CA #x5B16) + (#xD5CB #x5B32) + (#xD5CC #x5AD0) + (#xD5CD #x5B2A) + (#xD5CE #x5B36) + (#xD5CF #x5B3E) + (#xD5D0 #x5B43) + (#xD5D1 #x5B45) + (#xD5D2 #x5B40) + (#xD5D3 #x5B51) + (#xD5D4 #x5B55) + (#xD5D5 #x5B5A) + (#xD5D6 #x5B5B) + (#xD5D7 #x5B65) + (#xD5D8 #x5B69) + (#xD5D9 #x5B70) + (#xD5DA #x5B73) + (#xD5DB #x5B75) + (#xD5DC #x5B78) + (#xD5DD #x6588) + (#xD5DE #x5B7A) + (#xD5DF #x5B80) + (#xD5E0 #x5B83) + (#xD5E1 #x5BA6) + (#xD5E2 #x5BB8) + (#xD5E3 #x5BC3) + (#xD5E4 #x5BC7) + (#xD5E5 #x5BC9) + (#xD5E6 #x5BD4) + (#xD5E7 #x5BD0) + (#xD5E8 #x5BE4) + (#xD5E9 #x5BE6) + (#xD5EA #x5BE2) + (#xD5EB #x5BDE) + (#xD5EC #x5BE5) + (#xD5ED #x5BEB) + (#xD5EE #x5BF0) + (#xD5EF #x5BF6) + (#xD5F0 #x5BF3) + (#xD5F1 #x5C05) + (#xD5F2 #x5C07) + (#xD5F3 #x5C08) + (#xD5F4 #x5C0D) + (#xD5F5 #x5C13) + (#xD5F6 #x5C20) + (#xD5F7 #x5C22) + (#xD5F8 #x5C28) + (#xD5F9 #x5C38) + (#xD5FA #x5C39) + (#xD5FB #x5C41) + (#xD5FC #x5C46) + (#xD5FD #x5C4E) + (#xD5FE #x5C53) + (#xD6A1 #x5C50) + (#xD6A2 #x5C4F) + (#xD6A3 #x5B71) + (#xD6A4 #x5C6C) + (#xD6A5 #x5C6E) + (#xD6A6 #x4E62) + (#xD6A7 #x5C76) + (#xD6A8 #x5C79) + (#xD6A9 #x5C8C) + (#xD6AA #x5C91) + (#xD6AB #x5C94) + (#xD6AC #x599B) + (#xD6AD #x5CAB) + (#xD6AE #x5CBB) + (#xD6AF #x5CB6) + (#xD6B0 #x5CBC) + (#xD6B1 #x5CB7) + (#xD6B2 #x5CC5) + (#xD6B3 #x5CBE) + (#xD6B4 #x5CC7) + (#xD6B5 #x5CD9) + (#xD6B6 #x5CE9) + (#xD6B7 #x5CFD) + (#xD6B8 #x5CFA) + (#xD6B9 #x5CED) + (#xD6BA #x5D8C) + (#xD6BB #x5CEA) + (#xD6BC #x5D0B) + (#xD6BD #x5D15) + (#xD6BE #x5D17) + (#xD6BF #x5D5C) + (#xD6C0 #x5D1F) + (#xD6C1 #x5D1B) + (#xD6C2 #x5D11) + (#xD6C3 #x5D14) + (#xD6C4 #x5D22) + (#xD6C5 #x5D1A) + (#xD6C6 #x5D19) + (#xD6C7 #x5D18) + (#xD6C8 #x5D4C) + (#xD6C9 #x5D52) + (#xD6CA #x5D4E) + (#xD6CB #x5D4B) + (#xD6CC #x5D6C) + (#xD6CD #x5D73) + (#xD6CE #x5D76) + (#xD6CF #x5D87) + (#xD6D0 #x5D84) + (#xD6D1 #x5D82) + (#xD6D2 #x5DA2) + (#xD6D3 #x5D9D) + (#xD6D4 #x5DAC) + (#xD6D5 #x5DAE) + (#xD6D6 #x5DBD) + (#xD6D7 #x5D90) + (#xD6D8 #x5DB7) + (#xD6D9 #x5DBC) + (#xD6DA #x5DC9) + (#xD6DB #x5DCD) + (#xD6DC #x5DD3) + (#xD6DD #x5DD2) + (#xD6DE #x5DD6) + (#xD6DF #x5DDB) + (#xD6E0 #x5DEB) + (#xD6E1 #x5DF2) + (#xD6E2 #x5DF5) + (#xD6E3 #x5E0B) + (#xD6E4 #x5E1A) + (#xD6E5 #x5E19) + (#xD6E6 #x5E11) + (#xD6E7 #x5E1B) + (#xD6E8 #x5E36) + (#xD6E9 #x5E37) + (#xD6EA #x5E44) + (#xD6EB #x5E43) + (#xD6EC #x5E40) + (#xD6ED #x5E4E) + (#xD6EE #x5E57) + (#xD6EF #x5E54) + (#xD6F0 #x5E5F) + (#xD6F1 #x5E62) + (#xD6F2 #x5E64) + (#xD6F3 #x5E47) + (#xD6F4 #x5E75) + (#xD6F5 #x5E76) + (#xD6F6 #x5E7A) + (#xD6F7 #x9EBC) + (#xD6F8 #x5E7F) + (#xD6F9 #x5EA0) + (#xD6FA #x5EC1) + (#xD6FB #x5EC2) + (#xD6FC #x5EC8) + (#xD6FD #x5ED0) + (#xD6FE #x5ECF) + (#xD7A1 #x5ED6) + (#xD7A2 #x5EE3) + (#xD7A3 #x5EDD) + (#xD7A4 #x5EDA) + (#xD7A5 #x5EDB) + (#xD7A6 #x5EE2) + (#xD7A7 #x5EE1) + (#xD7A8 #x5EE8) + (#xD7A9 #x5EE9) + (#xD7AA #x5EEC) + (#xD7AB #x5EF1) + (#xD7AC #x5EF3) + (#xD7AD #x5EF0) + (#xD7AE #x5EF4) + (#xD7AF #x5EF8) + (#xD7B0 #x5EFE) + (#xD7B1 #x5F03) + (#xD7B2 #x5F09) + (#xD7B3 #x5F5D) + (#xD7B4 #x5F5C) + (#xD7B5 #x5F0B) + (#xD7B6 #x5F11) + (#xD7B7 #x5F16) + (#xD7B8 #x5F29) + (#xD7B9 #x5F2D) + (#xD7BA #x5F38) + (#xD7BB #x5F41) + (#xD7BC #x5F48) + (#xD7BD #x5F4C) + (#xD7BE #x5F4E) + (#xD7BF #x5F2F) + (#xD7C0 #x5F51) + (#xD7C1 #x5F56) + (#xD7C2 #x5F57) + (#xD7C3 #x5F59) + (#xD7C4 #x5F61) + (#xD7C5 #x5F6D) + (#xD7C6 #x5F73) + (#xD7C7 #x5F77) + (#xD7C8 #x5F83) + (#xD7C9 #x5F82) + (#xD7CA #x5F7F) + (#xD7CB #x5F8A) + (#xD7CC #x5F88) + (#xD7CD #x5F91) + (#xD7CE #x5F87) + (#xD7CF #x5F9E) + (#xD7D0 #x5F99) + (#xD7D1 #x5F98) + (#xD7D2 #x5FA0) + (#xD7D3 #x5FA8) + (#xD7D4 #x5FAD) + (#xD7D5 #x5FBC) + (#xD7D6 #x5FD6) + (#xD7D7 #x5FFB) + (#xD7D8 #x5FE4) + (#xD7D9 #x5FF8) + (#xD7DA #x5FF1) + (#xD7DB #x5FDD) + (#xD7DC #x60B3) + (#xD7DD #x5FFF) + (#xD7DE #x6021) + (#xD7DF #x6060) + (#xD7E0 #x6019) + (#xD7E1 #x6010) + (#xD7E2 #x6029) + (#xD7E3 #x600E) + (#xD7E4 #x6031) + (#xD7E5 #x601B) + (#xD7E6 #x6015) + (#xD7E7 #x602B) + (#xD7E8 #x6026) + (#xD7E9 #x600F) + (#xD7EA #x603A) + (#xD7EB #x605A) + (#xD7EC #x6041) + (#xD7ED #x606A) + (#xD7EE #x6077) + (#xD7EF #x605F) + (#xD7F0 #x604A) + (#xD7F1 #x6046) + (#xD7F2 #x604D) + (#xD7F3 #x6063) + (#xD7F4 #x6043) + (#xD7F5 #x6064) + (#xD7F6 #x6042) + (#xD7F7 #x606C) + (#xD7F8 #x606B) + (#xD7F9 #x6059) + (#xD7FA #x6081) + (#xD7FB #x608D) + (#xD7FC #x60E7) + (#xD7FD #x6083) + (#xD7FE #x609A) + (#xD8A1 #x6084) + (#xD8A2 #x609B) + (#xD8A3 #x6096) + (#xD8A4 #x6097) + (#xD8A5 #x6092) + (#xD8A6 #x60A7) + (#xD8A7 #x608B) + (#xD8A8 #x60E1) + (#xD8A9 #x60B8) + (#xD8AA #x60E0) + (#xD8AB #x60D3) + (#xD8AC #x60B4) + (#xD8AD #x5FF0) + (#xD8AE #x60BD) + (#xD8AF #x60C6) + (#xD8B0 #x60B5) + (#xD8B1 #x60D8) + (#xD8B2 #x614D) + (#xD8B3 #x6115) + (#xD8B4 #x6106) + (#xD8B5 #x60F6) + (#xD8B6 #x60F7) + (#xD8B7 #x6100) + (#xD8B8 #x60F4) + (#xD8B9 #x60FA) + (#xD8BA #x6103) + (#xD8BB #x6121) + (#xD8BC #x60FB) + (#xD8BD #x60F1) + (#xD8BE #x610D) + (#xD8BF #x610E) + (#xD8C0 #x6147) + (#xD8C1 #x613E) + (#xD8C2 #x6128) + (#xD8C3 #x6127) + (#xD8C4 #x614A) + (#xD8C5 #x613F) + (#xD8C6 #x613C) + (#xD8C7 #x612C) + (#xD8C8 #x6134) + (#xD8C9 #x613D) + (#xD8CA #x6142) + (#xD8CB #x6144) + (#xD8CC #x6173) + (#xD8CD #x6177) + (#xD8CE #x6158) + (#xD8CF #x6159) + (#xD8D0 #x615A) + (#xD8D1 #x616B) + (#xD8D2 #x6174) + (#xD8D3 #x616F) + (#xD8D4 #x6165) + (#xD8D5 #x6171) + (#xD8D6 #x615F) + (#xD8D7 #x615D) + (#xD8D8 #x6153) + (#xD8D9 #x6175) + (#xD8DA #x6199) + (#xD8DB #x6196) + (#xD8DC #x6187) + (#xD8DD #x61AC) + (#xD8DE #x6194) + (#xD8DF #x619A) + (#xD8E0 #x618A) + (#xD8E1 #x6191) + (#xD8E2 #x61AB) + (#xD8E3 #x61AE) + (#xD8E4 #x61CC) + (#xD8E5 #x61CA) + (#xD8E6 #x61C9) + (#xD8E7 #x61F7) + (#xD8E8 #x61C8) + (#xD8E9 #x61C3) + (#xD8EA #x61C6) + (#xD8EB #x61BA) + (#xD8EC #x61CB) + (#xD8ED #x7F79) + (#xD8EE #x61CD) + (#xD8EF #x61E6) + (#xD8F0 #x61E3) + (#xD8F1 #x61F6) + (#xD8F2 #x61FA) + (#xD8F3 #x61F4) + (#xD8F4 #x61FF) + (#xD8F5 #x61FD) + (#xD8F6 #x61FC) + (#xD8F7 #x61FE) + (#xD8F8 #x6200) + (#xD8F9 #x6208) + (#xD8FA #x6209) + (#xD8FB #x620D) + (#xD8FC #x620C) + (#xD8FD #x6214) + (#xD8FE #x621B) + (#xD9A1 #x621E) + (#xD9A2 #x6221) + (#xD9A3 #x622A) + (#xD9A4 #x622E) + (#xD9A5 #x6230) + (#xD9A6 #x6232) + (#xD9A7 #x6233) + (#xD9A8 #x6241) + (#xD9A9 #x624E) + (#xD9AA #x625E) + (#xD9AB #x6263) + (#xD9AC #x625B) + (#xD9AD #x6260) + (#xD9AE #x6268) + (#xD9AF #x627C) + (#xD9B0 #x6282) + (#xD9B1 #x6289) + (#xD9B2 #x627E) + (#xD9B3 #x6292) + (#xD9B4 #x6293) + (#xD9B5 #x6296) + (#xD9B6 #x62D4) + (#xD9B7 #x6283) + (#xD9B8 #x6294) + (#xD9B9 #x62D7) + (#xD9BA #x62D1) + (#xD9BB #x62BB) + (#xD9BC #x62CF) + (#xD9BD #x62FF) + (#xD9BE #x62C6) + (#xD9BF #x64D4) + (#xD9C0 #x62C8) + (#xD9C1 #x62DC) + (#xD9C2 #x62CC) + (#xD9C3 #x62CA) + (#xD9C4 #x62C2) + (#xD9C5 #x62C7) + (#xD9C6 #x629B) + (#xD9C7 #x62C9) + (#xD9C8 #x630C) + (#xD9C9 #x62EE) + (#xD9CA #x62F1) + (#xD9CB #x6327) + (#xD9CC #x6302) + (#xD9CD #x6308) + (#xD9CE #x62EF) + (#xD9CF #x62F5) + (#xD9D0 #x6350) + (#xD9D1 #x633E) + (#xD9D2 #x634D) + (#xD9D3 #x641C) + (#xD9D4 #x634F) + (#xD9D5 #x6396) + (#xD9D6 #x638E) + (#xD9D7 #x6380) + (#xD9D8 #x63AB) + (#xD9D9 #x6376) + (#xD9DA #x63A3) + (#xD9DB #x638F) + (#xD9DC #x6389) + (#xD9DD #x639F) + (#xD9DE #x63B5) + (#xD9DF #x636B) + (#xD9E0 #x6369) + (#xD9E1 #x63BE) + (#xD9E2 #x63E9) + (#xD9E3 #x63C0) + (#xD9E4 #x63C6) + (#xD9E5 #x63E3) + (#xD9E6 #x63C9) + (#xD9E7 #x63D2) + (#xD9E8 #x63F6) + (#xD9E9 #x63C4) + (#xD9EA #x6416) + (#xD9EB #x6434) + (#xD9EC #x6406) + (#xD9ED #x6413) + (#xD9EE #x6426) + (#xD9EF #x6436) + (#xD9F0 #x651D) + (#xD9F1 #x6417) + (#xD9F2 #x6428) + (#xD9F3 #x640F) + (#xD9F4 #x6467) + (#xD9F5 #x646F) + (#xD9F6 #x6476) + (#xD9F7 #x644E) + (#xD9F8 #x652A) + (#xD9F9 #x6495) + (#xD9FA #x6493) + (#xD9FB #x64A5) + (#xD9FC #x64A9) + (#xD9FD #x6488) + (#xD9FE #x64BC) + (#xDAA1 #x64DA) + (#xDAA2 #x64D2) + (#xDAA3 #x64C5) + (#xDAA4 #x64C7) + (#xDAA5 #x64BB) + (#xDAA6 #x64D8) + (#xDAA7 #x64C2) + (#xDAA8 #x64F1) + (#xDAA9 #x64E7) + (#xDAAA #x8209) + (#xDAAB #x64E0) + (#xDAAC #x64E1) + (#xDAAD #x62AC) + (#xDAAE #x64E3) + (#xDAAF #x64EF) + (#xDAB0 #x652C) + (#xDAB1 #x64F6) + (#xDAB2 #x64F4) + (#xDAB3 #x64F2) + (#xDAB4 #x64FA) + (#xDAB5 #x6500) + (#xDAB6 #x64FD) + (#xDAB7 #x6518) + (#xDAB8 #x651C) + (#xDAB9 #x6505) + (#xDABA #x6524) + (#xDABB #x6523) + (#xDABC #x652B) + (#xDABD #x6534) + (#xDABE #x6535) + (#xDABF #x6537) + (#xDAC0 #x6536) + (#xDAC1 #x6538) + (#xDAC2 #x754B) + (#xDAC3 #x6548) + (#xDAC4 #x6556) + (#xDAC5 #x6555) + (#xDAC6 #x654D) + (#xDAC7 #x6558) + (#xDAC8 #x655E) + (#xDAC9 #x655D) + (#xDACA #x6572) + (#xDACB #x6578) + (#xDACC #x6582) + (#xDACD #x6583) + (#xDACE #x8B8A) + (#xDACF #x659B) + (#xDAD0 #x659F) + (#xDAD1 #x65AB) + (#xDAD2 #x65B7) + (#xDAD3 #x65C3) + (#xDAD4 #x65C6) + (#xDAD5 #x65C1) + (#xDAD6 #x65C4) + (#xDAD7 #x65CC) + (#xDAD8 #x65D2) + (#xDAD9 #x65DB) + (#xDADA #x65D9) + (#xDADB #x65E0) + (#xDADC #x65E1) + (#xDADD #x65F1) + (#xDADE #x6772) + (#xDADF #x660A) + (#xDAE0 #x6603) + (#xDAE1 #x65FB) + (#xDAE2 #x6773) + (#xDAE3 #x6635) + (#xDAE4 #x6636) + (#xDAE5 #x6634) + (#xDAE6 #x661C) + (#xDAE7 #x664F) + (#xDAE8 #x6644) + (#xDAE9 #x6649) + (#xDAEA #x6641) + (#xDAEB #x665E) + (#xDAEC #x665D) + (#xDAED #x6664) + (#xDAEE #x6667) + (#xDAEF #x6668) + (#xDAF0 #x665F) + (#xDAF1 #x6662) + (#xDAF2 #x6670) + (#xDAF3 #x6683) + (#xDAF4 #x6688) + (#xDAF5 #x668E) + (#xDAF6 #x6689) + (#xDAF7 #x6684) + (#xDAF8 #x6698) + (#xDAF9 #x669D) + (#xDAFA #x66C1) + (#xDAFB #x66B9) + (#xDAFC #x66C9) + (#xDAFD #x66BE) + (#xDAFE #x66BC) + (#xDBA1 #x66C4) + (#xDBA2 #x66B8) + (#xDBA3 #x66D6) + (#xDBA4 #x66DA) + (#xDBA5 #x66E0) + (#xDBA6 #x663F) + (#xDBA7 #x66E6) + (#xDBA8 #x66E9) + (#xDBA9 #x66F0) + (#xDBAA #x66F5) + (#xDBAB #x66F7) + (#xDBAC #x670F) + (#xDBAD #x6716) + (#xDBAE #x671E) + (#xDBAF #x6726) + (#xDBB0 #x6727) + (#xDBB1 #x9738) + (#xDBB2 #x672E) + (#xDBB3 #x673F) + (#xDBB4 #x6736) + (#xDBB5 #x6741) + (#xDBB6 #x6738) + (#xDBB7 #x6737) + (#xDBB8 #x6746) + (#xDBB9 #x675E) + (#xDBBA #x6760) + (#xDBBB #x6759) + (#xDBBC #x6763) + (#xDBBD #x6764) + (#xDBBE #x6789) + (#xDBBF #x6770) + (#xDBC0 #x67A9) + (#xDBC1 #x677C) + (#xDBC2 #x676A) + (#xDBC3 #x678C) + (#xDBC4 #x678B) + (#xDBC5 #x67A6) + (#xDBC6 #x67A1) + (#xDBC7 #x6785) + (#xDBC8 #x67B7) + (#xDBC9 #x67EF) + (#xDBCA #x67B4) + (#xDBCB #x67EC) + (#xDBCC #x67B3) + (#xDBCD #x67E9) + (#xDBCE #x67B8) + (#xDBCF #x67E4) + (#xDBD0 #x67DE) + (#xDBD1 #x67DD) + (#xDBD2 #x67E2) + (#xDBD3 #x67EE) + (#xDBD4 #x67B9) + (#xDBD5 #x67CE) + (#xDBD6 #x67C6) + (#xDBD7 #x67E7) + (#xDBD8 #x6A9C) + (#xDBD9 #x681E) + (#xDBDA #x6846) + (#xDBDB #x6829) + (#xDBDC #x6840) + (#xDBDD #x684D) + (#xDBDE #x6832) + (#xDBDF #x684E) + (#xDBE0 #x68B3) + (#xDBE1 #x682B) + (#xDBE2 #x6859) + (#xDBE3 #x6863) + (#xDBE4 #x6877) + (#xDBE5 #x687F) + (#xDBE6 #x689F) + (#xDBE7 #x688F) + (#xDBE8 #x68AD) + (#xDBE9 #x6894) + (#xDBEA #x689D) + (#xDBEB #x689B) + (#xDBEC #x6883) + (#xDBED #x6AAE) + (#xDBEE #x68B9) + (#xDBEF #x6874) + (#xDBF0 #x68B5) + (#xDBF1 #x68A0) + (#xDBF2 #x68BA) + (#xDBF3 #x690F) + (#xDBF4 #x688D) + (#xDBF5 #x687E) + (#xDBF6 #x6901) + (#xDBF7 #x68CA) + (#xDBF8 #x6908) + (#xDBF9 #x68D8) + (#xDBFA #x6922) + (#xDBFB #x6926) + (#xDBFC #x68E1) + (#xDBFD #x690C) + (#xDBFE #x68CD) + (#xDCA1 #x68D4) + (#xDCA2 #x68E7) + (#xDCA3 #x68D5) + (#xDCA4 #x6936) + (#xDCA5 #x6912) + (#xDCA6 #x6904) + (#xDCA7 #x68D7) + (#xDCA8 #x68E3) + (#xDCA9 #x6925) + (#xDCAA #x68F9) + (#xDCAB #x68E0) + (#xDCAC #x68EF) + (#xDCAD #x6928) + (#xDCAE #x692A) + (#xDCAF #x691A) + (#xDCB0 #x6923) + (#xDCB1 #x6921) + (#xDCB2 #x68C6) + (#xDCB3 #x6979) + (#xDCB4 #x6977) + (#xDCB5 #x695C) + (#xDCB6 #x6978) + (#xDCB7 #x696B) + (#xDCB8 #x6954) + (#xDCB9 #x697E) + (#xDCBA #x696E) + (#xDCBB #x6939) + (#xDCBC #x6974) + (#xDCBD #x693D) + (#xDCBE #x6959) + (#xDCBF #x6930) + (#xDCC0 #x6961) + (#xDCC1 #x695E) + (#xDCC2 #x695D) + (#xDCC3 #x6981) + (#xDCC4 #x696A) + (#xDCC5 #x69B2) + (#xDCC6 #x69AE) + (#xDCC7 #x69D0) + (#xDCC8 #x69BF) + (#xDCC9 #x69C1) + (#xDCCA #x69D3) + (#xDCCB #x69BE) + (#xDCCC #x69CE) + (#xDCCD #x5BE8) + (#xDCCE #x69CA) + (#xDCCF #x69DD) + (#xDCD0 #x69BB) + (#xDCD1 #x69C3) + (#xDCD2 #x69A7) + (#xDCD3 #x6A2E) + (#xDCD4 #x6991) + (#xDCD5 #x69A0) + (#xDCD6 #x699C) + (#xDCD7 #x6995) + (#xDCD8 #x69B4) + (#xDCD9 #x69DE) + (#xDCDA #x69E8) + (#xDCDB #x6A02) + (#xDCDC #x6A1B) + (#xDCDD #x69FF) + (#xDCDE #x6B0A) + (#xDCDF #x69F9) + (#xDCE0 #x69F2) + (#xDCE1 #x69E7) + (#xDCE2 #x6A05) + (#xDCE3 #x69B1) + (#xDCE4 #x6A1E) + (#xDCE5 #x69ED) + (#xDCE6 #x6A14) + (#xDCE7 #x69EB) + (#xDCE8 #x6A0A) + (#xDCE9 #x6A12) + (#xDCEA #x6AC1) + (#xDCEB #x6A23) + (#xDCEC #x6A13) + (#xDCED #x6A44) + (#xDCEE #x6A0C) + (#xDCEF #x6A72) + (#xDCF0 #x6A36) + (#xDCF1 #x6A78) + (#xDCF2 #x6A47) + (#xDCF3 #x6A62) + (#xDCF4 #x6A59) + (#xDCF5 #x6A66) + (#xDCF6 #x6A48) + (#xDCF7 #x6A38) + (#xDCF8 #x6A22) + (#xDCF9 #x6A90) + (#xDCFA #x6A8D) + (#xDCFB #x6AA0) + (#xDCFC #x6A84) + (#xDCFD #x6AA2) + (#xDCFE #x6AA3) + (#xDDA1 #x6A97) + (#xDDA2 #x8617) + (#xDDA3 #x6ABB) + (#xDDA4 #x6AC3) + (#xDDA5 #x6AC2) + (#xDDA6 #x6AB8) + (#xDDA7 #x6AB3) + (#xDDA8 #x6AAC) + (#xDDA9 #x6ADE) + (#xDDAA #x6AD1) + (#xDDAB #x6ADF) + (#xDDAC #x6AAA) + (#xDDAD #x6ADA) + (#xDDAE #x6AEA) + (#xDDAF #x6AFB) + (#xDDB0 #x6B05) + (#xDDB1 #x8616) + (#xDDB2 #x6AFA) + (#xDDB3 #x6B12) + (#xDDB4 #x6B16) + (#xDDB5 #x9B31) + (#xDDB6 #x6B1F) + (#xDDB7 #x6B38) + (#xDDB8 #x6B37) + (#xDDB9 #x76DC) + (#xDDBA #x6B39) + (#xDDBB #x98EE) + (#xDDBC #x6B47) + (#xDDBD #x6B43) + (#xDDBE #x6B49) + (#xDDBF #x6B50) + (#xDDC0 #x6B59) + (#xDDC1 #x6B54) + (#xDDC2 #x6B5B) + (#xDDC3 #x6B5F) + (#xDDC4 #x6B61) + (#xDDC5 #x6B78) + (#xDDC6 #x6B79) + (#xDDC7 #x6B7F) + (#xDDC8 #x6B80) + (#xDDC9 #x6B84) + (#xDDCA #x6B83) + (#xDDCB #x6B8D) + (#xDDCC #x6B98) + (#xDDCD #x6B95) + (#xDDCE #x6B9E) + (#xDDCF #x6BA4) + (#xDDD0 #x6BAA) + (#xDDD1 #x6BAB) + (#xDDD2 #x6BAF) + (#xDDD3 #x6BB2) + (#xDDD4 #x6BB1) + (#xDDD5 #x6BB3) + (#xDDD6 #x6BB7) + (#xDDD7 #x6BBC) + (#xDDD8 #x6BC6) + (#xDDD9 #x6BCB) + (#xDDDA #x6BD3) + (#xDDDB #x6BDF) + (#xDDDC #x6BEC) + (#xDDDD #x6BEB) + (#xDDDE #x6BF3) + (#xDDDF #x6BEF) + (#xDDE0 #x9EBE) + (#xDDE1 #x6C08) + (#xDDE2 #x6C13) + (#xDDE3 #x6C14) + (#xDDE4 #x6C1B) + (#xDDE5 #x6C24) + (#xDDE6 #x6C23) + (#xDDE7 #x6C5E) + (#xDDE8 #x6C55) + (#xDDE9 #x6C62) + (#xDDEA #x6C6A) + (#xDDEB #x6C82) + (#xDDEC #x6C8D) + (#xDDED #x6C9A) + (#xDDEE #x6C81) + (#xDDEF #x6C9B) + (#xDDF0 #x6C7E) + (#xDDF1 #x6C68) + (#xDDF2 #x6C73) + (#xDDF3 #x6C92) + (#xDDF4 #x6C90) + (#xDDF5 #x6CC4) + (#xDDF6 #x6CF1) + (#xDDF7 #x6CD3) + (#xDDF8 #x6CBD) + (#xDDF9 #x6CD7) + (#xDDFA #x6CC5) + (#xDDFB #x6CDD) + (#xDDFC #x6CAE) + (#xDDFD #x6CB1) + (#xDDFE #x6CBE) + (#xDEA1 #x6CBA) + (#xDEA2 #x6CDB) + (#xDEA3 #x6CEF) + (#xDEA4 #x6CD9) + (#xDEA5 #x6CEA) + (#xDEA6 #x6D1F) + (#xDEA7 #x884D) + (#xDEA8 #x6D36) + (#xDEA9 #x6D2B) + (#xDEAA #x6D3D) + (#xDEAB #x6D38) + (#xDEAC #x6D19) + (#xDEAD #x6D35) + (#xDEAE #x6D33) + (#xDEAF #x6D12) + (#xDEB0 #x6D0C) + (#xDEB1 #x6D63) + (#xDEB2 #x6D93) + (#xDEB3 #x6D64) + (#xDEB4 #x6D5A) + (#xDEB5 #x6D79) + (#xDEB6 #x6D59) + (#xDEB7 #x6D8E) + (#xDEB8 #x6D95) + (#xDEB9 #x6FE4) + (#xDEBA #x6D85) + (#xDEBB #x6DF9) + (#xDEBC #x6E15) + (#xDEBD #x6E0A) + (#xDEBE #x6DB5) + (#xDEBF #x6DC7) + (#xDEC0 #x6DE6) + (#xDEC1 #x6DB8) + (#xDEC2 #x6DC6) + (#xDEC3 #x6DEC) + (#xDEC4 #x6DDE) + (#xDEC5 #x6DCC) + (#xDEC6 #x6DE8) + (#xDEC7 #x6DD2) + (#xDEC8 #x6DC5) + (#xDEC9 #x6DFA) + (#xDECA #x6DD9) + (#xDECB #x6DE4) + (#xDECC #x6DD5) + (#xDECD #x6DEA) + (#xDECE #x6DEE) + (#xDECF #x6E2D) + (#xDED0 #x6E6E) + (#xDED1 #x6E2E) + (#xDED2 #x6E19) + (#xDED3 #x6E72) + (#xDED4 #x6E5F) + (#xDED5 #x6E3E) + (#xDED6 #x6E23) + (#xDED7 #x6E6B) + (#xDED8 #x6E2B) + (#xDED9 #x6E76) + (#xDEDA #x6E4D) + (#xDEDB #x6E1F) + (#xDEDC #x6E43) + (#xDEDD #x6E3A) + (#xDEDE #x6E4E) + (#xDEDF #x6E24) + (#xDEE0 #x6EFF) + (#xDEE1 #x6E1D) + (#xDEE2 #x6E38) + (#xDEE3 #x6E82) + (#xDEE4 #x6EAA) + (#xDEE5 #x6E98) + (#xDEE6 #x6EC9) + (#xDEE7 #x6EB7) + (#xDEE8 #x6ED3) + (#xDEE9 #x6EBD) + (#xDEEA #x6EAF) + (#xDEEB #x6EC4) + (#xDEEC #x6EB2) + (#xDEED #x6ED4) + (#xDEEE #x6ED5) + (#xDEEF #x6E8F) + (#xDEF0 #x6EA5) + (#xDEF1 #x6EC2) + (#xDEF2 #x6E9F) + (#xDEF3 #x6F41) + (#xDEF4 #x6F11) + (#xDEF5 #x704C) + (#xDEF6 #x6EEC) + (#xDEF7 #x6EF8) + (#xDEF8 #x6EFE) + (#xDEF9 #x6F3F) + (#xDEFA #x6EF2) + (#xDEFB #x6F31) + (#xDEFC #x6EEF) + (#xDEFD #x6F32) + (#xDEFE #x6ECC) + (#xDFA1 #x6F3E) + (#xDFA2 #x6F13) + (#xDFA3 #x6EF7) + (#xDFA4 #x6F86) + (#xDFA5 #x6F7A) + (#xDFA6 #x6F78) + (#xDFA7 #x6F81) + (#xDFA8 #x6F80) + (#xDFA9 #x6F6F) + (#xDFAA #x6F5B) + (#xDFAB #x6FF3) + (#xDFAC #x6F6D) + (#xDFAD #x6F82) + (#xDFAE #x6F7C) + (#xDFAF #x6F58) + (#xDFB0 #x6F8E) + (#xDFB1 #x6F91) + (#xDFB2 #x6FC2) + (#xDFB3 #x6F66) + (#xDFB4 #x6FB3) + (#xDFB5 #x6FA3) + (#xDFB6 #x6FA1) + (#xDFB7 #x6FA4) + (#xDFB8 #x6FB9) + (#xDFB9 #x6FC6) + (#xDFBA #x6FAA) + (#xDFBB #x6FDF) + (#xDFBC #x6FD5) + (#xDFBD #x6FEC) + (#xDFBE #x6FD4) + (#xDFBF #x6FD8) + (#xDFC0 #x6FF1) + (#xDFC1 #x6FEE) + (#xDFC2 #x6FDB) + (#xDFC3 #x7009) + (#xDFC4 #x700B) + (#xDFC5 #x6FFA) + (#xDFC6 #x7011) + (#xDFC7 #x7001) + (#xDFC8 #x700F) + (#xDFC9 #x6FFE) + (#xDFCA #x701B) + (#xDFCB #x701A) + (#xDFCC #x6F74) + (#xDFCD #x701D) + (#xDFCE #x7018) + (#xDFCF #x701F) + (#xDFD0 #x7030) + (#xDFD1 #x703E) + (#xDFD2 #x7032) + (#xDFD3 #x7051) + (#xDFD4 #x7063) + (#xDFD5 #x7099) + (#xDFD6 #x7092) + (#xDFD7 #x70AF) + (#xDFD8 #x70F1) + (#xDFD9 #x70AC) + (#xDFDA #x70B8) + (#xDFDB #x70B3) + (#xDFDC #x70AE) + (#xDFDD #x70DF) + (#xDFDE #x70CB) + (#xDFDF #x70DD) + (#xDFE0 #x70D9) + (#xDFE1 #x7109) + (#xDFE2 #x70FD) + (#xDFE3 #x711C) + (#xDFE4 #x7119) + (#xDFE5 #x7165) + (#xDFE6 #x7155) + (#xDFE7 #x7188) + (#xDFE8 #x7166) + (#xDFE9 #x7162) + (#xDFEA #x714C) + (#xDFEB #x7156) + (#xDFEC #x716C) + (#xDFED #x718F) + (#xDFEE #x71FB) + (#xDFEF #x7184) + (#xDFF0 #x7195) + (#xDFF1 #x71A8) + (#xDFF2 #x71AC) + (#xDFF3 #x71D7) + (#xDFF4 #x71B9) + (#xDFF5 #x71BE) + (#xDFF6 #x71D2) + (#xDFF7 #x71C9) + (#xDFF8 #x71D4) + (#xDFF9 #x71CE) + (#xDFFA #x71E0) + (#xDFFB #x71EC) + (#xDFFC #x71E7) + (#xDFFD #x71F5) + (#xDFFE #x71FC) + (#xE0A1 #x71F9) + (#xE0A2 #x71FF) + (#xE0A3 #x720D) + (#xE0A4 #x7210) + (#xE0A5 #x721B) + (#xE0A6 #x7228) + (#xE0A7 #x722D) + (#xE0A8 #x722C) + (#xE0A9 #x7230) + (#xE0AA #x7232) + (#xE0AB #x723B) + (#xE0AC #x723C) + (#xE0AD #x723F) + (#xE0AE #x7240) + (#xE0AF #x7246) + (#xE0B0 #x724B) + (#xE0B1 #x7258) + (#xE0B2 #x7274) + (#xE0B3 #x727E) + (#xE0B4 #x7282) + (#xE0B5 #x7281) + (#xE0B6 #x7287) + (#xE0B7 #x7292) + (#xE0B8 #x7296) + (#xE0B9 #x72A2) + (#xE0BA #x72A7) + (#xE0BB #x72B9) + (#xE0BC #x72B2) + (#xE0BD #x72C3) + (#xE0BE #x72C6) + (#xE0BF #x72C4) + (#xE0C0 #x72CE) + (#xE0C1 #x72D2) + (#xE0C2 #x72E2) + (#xE0C3 #x72E0) + (#xE0C4 #x72E1) + (#xE0C5 #x72F9) + (#xE0C6 #x72F7) + (#xE0C7 #x500F) + (#xE0C8 #x7317) + (#xE0C9 #x730A) + (#xE0CA #x731C) + (#xE0CB #x7316) + (#xE0CC #x731D) + (#xE0CD #x7334) + (#xE0CE #x732F) + (#xE0CF #x7329) + (#xE0D0 #x7325) + (#xE0D1 #x733E) + (#xE0D2 #x734E) + (#xE0D3 #x734F) + (#xE0D4 #x9ED8) + (#xE0D5 #x7357) + (#xE0D6 #x736A) + (#xE0D7 #x7368) + (#xE0D8 #x7370) + (#xE0D9 #x7378) + (#xE0DA #x7375) + (#xE0DB #x737B) + (#xE0DC #x737A) + (#xE0DD #x73C8) + (#xE0DE #x73B3) + (#xE0DF #x73CE) + (#xE0E0 #x73BB) + (#xE0E1 #x73C0) + (#xE0E2 #x73E5) + (#xE0E3 #x73EE) + (#xE0E4 #x73DE) + (#xE0E5 #x74A2) + (#xE0E6 #x7405) + (#xE0E7 #x746F) + (#xE0E8 #x7425) + (#xE0E9 #x73F8) + (#xE0EA #x7432) + (#xE0EB #x743A) + (#xE0EC #x7455) + (#xE0ED #x743F) + (#xE0EE #x745F) + (#xE0EF #x7459) + (#xE0F0 #x7441) + (#xE0F1 #x745C) + (#xE0F2 #x7469) + (#xE0F3 #x7470) + (#xE0F4 #x7463) + (#xE0F5 #x746A) + (#xE0F6 #x7476) + (#xE0F7 #x747E) + (#xE0F8 #x748B) + (#xE0F9 #x749E) + (#xE0FA #x74A7) + (#xE0FB #x74CA) + (#xE0FC #x74CF) + (#xE0FD #x74D4) + (#xE0FE #x73F1) + (#xE1A1 #x74E0) + (#xE1A2 #x74E3) + (#xE1A3 #x74E7) + (#xE1A4 #x74E9) + (#xE1A5 #x74EE) + (#xE1A6 #x74F2) + (#xE1A7 #x74F0) + (#xE1A8 #x74F1) + (#xE1A9 #x74F8) + (#xE1AA #x74F7) + (#xE1AB #x7504) + (#xE1AC #x7503) + (#xE1AD #x7505) + (#xE1AE #x750C) + (#xE1AF #x750E) + (#xE1B0 #x750D) + (#xE1B1 #x7515) + (#xE1B2 #x7513) + (#xE1B3 #x751E) + (#xE1B4 #x7526) + (#xE1B5 #x752C) + (#xE1B6 #x753C) + (#xE1B7 #x7544) + (#xE1B8 #x754D) + (#xE1B9 #x754A) + (#xE1BA #x7549) + (#xE1BB #x755B) + (#xE1BC #x7546) + (#xE1BD #x755A) + (#xE1BE #x7569) + (#xE1BF #x7564) + (#xE1C0 #x7567) + (#xE1C1 #x756B) + (#xE1C2 #x756D) + (#xE1C3 #x7578) + (#xE1C4 #x7576) + (#xE1C5 #x7586) + (#xE1C6 #x7587) + (#xE1C7 #x7574) + (#xE1C8 #x758A) + (#xE1C9 #x7589) + (#xE1CA #x7582) + (#xE1CB #x7594) + (#xE1CC #x759A) + (#xE1CD #x759D) + (#xE1CE #x75A5) + (#xE1CF #x75A3) + (#xE1D0 #x75C2) + (#xE1D1 #x75B3) + (#xE1D2 #x75C3) + (#xE1D3 #x75B5) + (#xE1D4 #x75BD) + (#xE1D5 #x75B8) + (#xE1D6 #x75BC) + (#xE1D7 #x75B1) + (#xE1D8 #x75CD) + (#xE1D9 #x75CA) + (#xE1DA #x75D2) + (#xE1DB #x75D9) + (#xE1DC #x75E3) + (#xE1DD #x75DE) + (#xE1DE #x75FE) + (#xE1DF #x75FF) + (#xE1E0 #x75FC) + (#xE1E1 #x7601) + (#xE1E2 #x75F0) + (#xE1E3 #x75FA) + (#xE1E4 #x75F2) + (#xE1E5 #x75F3) + (#xE1E6 #x760B) + (#xE1E7 #x760D) + (#xE1E8 #x7609) + (#xE1E9 #x761F) + (#xE1EA #x7627) + (#xE1EB #x7620) + (#xE1EC #x7621) + (#xE1ED #x7622) + (#xE1EE #x7624) + (#xE1EF #x7634) + (#xE1F0 #x7630) + (#xE1F1 #x763B) + (#xE1F2 #x7647) + (#xE1F3 #x7648) + (#xE1F4 #x7646) + (#xE1F5 #x765C) + (#xE1F6 #x7658) + (#xE1F7 #x7661) + (#xE1F8 #x7662) + (#xE1F9 #x7668) + (#xE1FA #x7669) + (#xE1FB #x766A) + (#xE1FC #x7667) + (#xE1FD #x766C) + (#xE1FE #x7670) + (#xE2A1 #x7672) + (#xE2A2 #x7676) + (#xE2A3 #x7678) + (#xE2A4 #x767C) + (#xE2A5 #x7680) + (#xE2A6 #x7683) + (#xE2A7 #x7688) + (#xE2A8 #x768B) + (#xE2A9 #x768E) + (#xE2AA #x7696) + (#xE2AB #x7693) + (#xE2AC #x7699) + (#xE2AD #x769A) + (#xE2AE #x76B0) + (#xE2AF #x76B4) + (#xE2B0 #x76B8) + (#xE2B1 #x76B9) + (#xE2B2 #x76BA) + (#xE2B3 #x76C2) + (#xE2B4 #x76CD) + (#xE2B5 #x76D6) + (#xE2B6 #x76D2) + (#xE2B7 #x76DE) + (#xE2B8 #x76E1) + (#xE2B9 #x76E5) + (#xE2BA #x76E7) + (#xE2BB #x76EA) + (#xE2BC #x862F) + (#xE2BD #x76FB) + (#xE2BE #x7708) + (#xE2BF #x7707) + (#xE2C0 #x7704) + (#xE2C1 #x7729) + (#xE2C2 #x7724) + (#xE2C3 #x771E) + (#xE2C4 #x7725) + (#xE2C5 #x7726) + (#xE2C6 #x771B) + (#xE2C7 #x7737) + (#xE2C8 #x7738) + (#xE2C9 #x7747) + (#xE2CA #x775A) + (#xE2CB #x7768) + (#xE2CC #x776B) + (#xE2CD #x775B) + (#xE2CE #x7765) + (#xE2CF #x777F) + (#xE2D0 #x777E) + (#xE2D1 #x7779) + (#xE2D2 #x778E) + (#xE2D3 #x778B) + (#xE2D4 #x7791) + (#xE2D5 #x77A0) + (#xE2D6 #x779E) + (#xE2D7 #x77B0) + (#xE2D8 #x77B6) + (#xE2D9 #x77B9) + (#xE2DA #x77BF) + (#xE2DB #x77BC) + (#xE2DC #x77BD) + (#xE2DD #x77BB) + (#xE2DE #x77C7) + (#xE2DF #x77CD) + (#xE2E0 #x77D7) + (#xE2E1 #x77DA) + (#xE2E2 #x77DC) + (#xE2E3 #x77E3) + (#xE2E4 #x77EE) + (#xE2E5 #x77FC) + (#xE2E6 #x780C) + (#xE2E7 #x7812) + (#xE2E8 #x7926) + (#xE2E9 #x7820) + (#xE2EA #x792A) + (#xE2EB #x7845) + (#xE2EC #x788E) + (#xE2ED #x7874) + (#xE2EE #x7886) + (#xE2EF #x787C) + (#xE2F0 #x789A) + (#xE2F1 #x788C) + (#xE2F2 #x78A3) + (#xE2F3 #x78B5) + (#xE2F4 #x78AA) + (#xE2F5 #x78AF) + (#xE2F6 #x78D1) + (#xE2F7 #x78C6) + (#xE2F8 #x78CB) + (#xE2F9 #x78D4) + (#xE2FA #x78BE) + (#xE2FB #x78BC) + (#xE2FC #x78C5) + (#xE2FD #x78CA) + (#xE2FE #x78EC) + (#xE3A1 #x78E7) + (#xE3A2 #x78DA) + (#xE3A3 #x78FD) + (#xE3A4 #x78F4) + (#xE3A5 #x7907) + (#xE3A6 #x7912) + (#xE3A7 #x7911) + (#xE3A8 #x7919) + (#xE3A9 #x792C) + (#xE3AA #x792B) + (#xE3AB #x7940) + (#xE3AC #x7960) + (#xE3AD #x7957) + (#xE3AE #x795F) + (#xE3AF #x795A) + (#xE3B0 #x7955) + (#xE3B1 #x7953) + (#xE3B2 #x797A) + (#xE3B3 #x797F) + (#xE3B4 #x798A) + (#xE3B5 #x799D) + (#xE3B6 #x79A7) + (#xE3B7 #x9F4B) + (#xE3B8 #x79AA) + (#xE3B9 #x79AE) + (#xE3BA #x79B3) + (#xE3BB #x79B9) + (#xE3BC #x79BA) + (#xE3BD #x79C9) + (#xE3BE #x79D5) + (#xE3BF #x79E7) + (#xE3C0 #x79EC) + (#xE3C1 #x79E1) + (#xE3C2 #x79E3) + (#xE3C3 #x7A08) + (#xE3C4 #x7A0D) + (#xE3C5 #x7A18) + (#xE3C6 #x7A19) + (#xE3C7 #x7A20) + (#xE3C8 #x7A1F) + (#xE3C9 #x7980) + (#xE3CA #x7A31) + (#xE3CB #x7A3B) + (#xE3CC #x7A3E) + (#xE3CD #x7A37) + (#xE3CE #x7A43) + (#xE3CF #x7A57) + (#xE3D0 #x7A49) + (#xE3D1 #x7A61) + (#xE3D2 #x7A62) + (#xE3D3 #x7A69) + (#xE3D4 #x9F9D) + (#xE3D5 #x7A70) + (#xE3D6 #x7A79) + (#xE3D7 #x7A7D) + (#xE3D8 #x7A88) + (#xE3D9 #x7A97) + (#xE3DA #x7A95) + (#xE3DB #x7A98) + (#xE3DC #x7A96) + (#xE3DD #x7AA9) + (#xE3DE #x7AC8) + (#xE3DF #x7AB0) + (#xE3E0 #x7AB6) + (#xE3E1 #x7AC5) + (#xE3E2 #x7AC4) + (#xE3E3 #x7ABF) + (#xE3E4 #x9083) + (#xE3E5 #x7AC7) + (#xE3E6 #x7ACA) + (#xE3E7 #x7ACD) + (#xE3E8 #x7ACF) + (#xE3E9 #x7AD5) + (#xE3EA #x7AD3) + (#xE3EB #x7AD9) + (#xE3EC #x7ADA) + (#xE3ED #x7ADD) + (#xE3EE #x7AE1) + (#xE3EF #x7AE2) + (#xE3F0 #x7AE6) + (#xE3F1 #x7AED) + (#xE3F2 #x7AF0) + (#xE3F3 #x7B02) + (#xE3F4 #x7B0F) + (#xE3F5 #x7B0A) + (#xE3F6 #x7B06) + (#xE3F7 #x7B33) + (#xE3F8 #x7B18) + (#xE3F9 #x7B19) + (#xE3FA #x7B1E) + (#xE3FB #x7B35) + (#xE3FC #x7B28) + (#xE3FD #x7B36) + (#xE3FE #x7B50) + (#xE4A1 #x7B7A) + (#xE4A2 #x7B04) + (#xE4A3 #x7B4D) + (#xE4A4 #x7B0B) + (#xE4A5 #x7B4C) + (#xE4A6 #x7B45) + (#xE4A7 #x7B75) + (#xE4A8 #x7B65) + (#xE4A9 #x7B74) + (#xE4AA #x7B67) + (#xE4AB #x7B70) + (#xE4AC #x7B71) + (#xE4AD #x7B6C) + (#xE4AE #x7B6E) + (#xE4AF #x7B9D) + (#xE4B0 #x7B98) + (#xE4B1 #x7B9F) + (#xE4B2 #x7B8D) + (#xE4B3 #x7B9C) + (#xE4B4 #x7B9A) + (#xE4B5 #x7B8B) + (#xE4B6 #x7B92) + (#xE4B7 #x7B8F) + (#xE4B8 #x7B5D) + (#xE4B9 #x7B99) + (#xE4BA #x7BCB) + (#xE4BB #x7BC1) + (#xE4BC #x7BCC) + (#xE4BD #x7BCF) + (#xE4BE #x7BB4) + (#xE4BF #x7BC6) + (#xE4C0 #x7BDD) + (#xE4C1 #x7BE9) + (#xE4C2 #x7C11) + (#xE4C3 #x7C14) + (#xE4C4 #x7BE6) + (#xE4C5 #x7BE5) + (#xE4C6 #x7C60) + (#xE4C7 #x7C00) + (#xE4C8 #x7C07) + (#xE4C9 #x7C13) + (#xE4CA #x7BF3) + (#xE4CB #x7BF7) + (#xE4CC #x7C17) + (#xE4CD #x7C0D) + (#xE4CE #x7BF6) + (#xE4CF #x7C23) + (#xE4D0 #x7C27) + (#xE4D1 #x7C2A) + (#xE4D2 #x7C1F) + (#xE4D3 #x7C37) + (#xE4D4 #x7C2B) + (#xE4D5 #x7C3D) + (#xE4D6 #x7C4C) + (#xE4D7 #x7C43) + (#xE4D8 #x7C54) + (#xE4D9 #x7C4F) + (#xE4DA #x7C40) + (#xE4DB #x7C50) + (#xE4DC #x7C58) + (#xE4DD #x7C5F) + (#xE4DE #x7C64) + (#xE4DF #x7C56) + (#xE4E0 #x7C65) + (#xE4E1 #x7C6C) + (#xE4E2 #x7C75) + (#xE4E3 #x7C83) + (#xE4E4 #x7C90) + (#xE4E5 #x7CA4) + (#xE4E6 #x7CAD) + (#xE4E7 #x7CA2) + (#xE4E8 #x7CAB) + (#xE4E9 #x7CA1) + (#xE4EA #x7CA8) + (#xE4EB #x7CB3) + (#xE4EC #x7CB2) + (#xE4ED #x7CB1) + (#xE4EE #x7CAE) + (#xE4EF #x7CB9) + (#xE4F0 #x7CBD) + (#xE4F1 #x7CC0) + (#xE4F2 #x7CC5) + (#xE4F3 #x7CC2) + (#xE4F4 #x7CD8) + (#xE4F5 #x7CD2) + (#xE4F6 #x7CDC) + (#xE4F7 #x7CE2) + (#xE4F8 #x9B3B) + (#xE4F9 #x7CEF) + (#xE4FA #x7CF2) + (#xE4FB #x7CF4) + (#xE4FC #x7CF6) + (#xE4FD #x7CFA) + (#xE4FE #x7D06) + (#xE5A1 #x7D02) + (#xE5A2 #x7D1C) + (#xE5A3 #x7D15) + (#xE5A4 #x7D0A) + (#xE5A5 #x7D45) + (#xE5A6 #x7D4B) + (#xE5A7 #x7D2E) + (#xE5A8 #x7D32) + (#xE5A9 #x7D3F) + (#xE5AA #x7D35) + (#xE5AB #x7D46) + (#xE5AC #x7D73) + (#xE5AD #x7D56) + (#xE5AE #x7D4E) + (#xE5AF #x7D72) + (#xE5B0 #x7D68) + (#xE5B1 #x7D6E) + (#xE5B2 #x7D4F) + (#xE5B3 #x7D63) + (#xE5B4 #x7D93) + (#xE5B5 #x7D89) + (#xE5B6 #x7D5B) + (#xE5B7 #x7D8F) + (#xE5B8 #x7D7D) + (#xE5B9 #x7D9B) + (#xE5BA #x7DBA) + (#xE5BB #x7DAE) + (#xE5BC #x7DA3) + (#xE5BD #x7DB5) + (#xE5BE #x7DC7) + (#xE5BF #x7DBD) + (#xE5C0 #x7DAB) + (#xE5C1 #x7E3D) + (#xE5C2 #x7DA2) + (#xE5C3 #x7DAF) + (#xE5C4 #x7DDC) + (#xE5C5 #x7DB8) + (#xE5C6 #x7D9F) + (#xE5C7 #x7DB0) + (#xE5C8 #x7DD8) + (#xE5C9 #x7DDD) + (#xE5CA #x7DE4) + (#xE5CB #x7DDE) + (#xE5CC #x7DFB) + (#xE5CD #x7DF2) + (#xE5CE #x7DE1) + (#xE5CF #x7E05) + (#xE5D0 #x7E0A) + (#xE5D1 #x7E23) + (#xE5D2 #x7E21) + (#xE5D3 #x7E12) + (#xE5D4 #x7E31) + (#xE5D5 #x7E1F) + (#xE5D6 #x7E09) + (#xE5D7 #x7E0B) + (#xE5D8 #x7E22) + (#xE5D9 #x7E46) + (#xE5DA #x7E66) + (#xE5DB #x7E3B) + (#xE5DC #x7E35) + (#xE5DD #x7E39) + (#xE5DE #x7E43) + (#xE5DF #x7E37) + (#xE5E0 #x7E32) + (#xE5E1 #x7E3A) + (#xE5E2 #x7E67) + (#xE5E3 #x7E5D) + (#xE5E4 #x7E56) + (#xE5E5 #x7E5E) + (#xE5E6 #x7E59) + (#xE5E7 #x7E5A) + (#xE5E8 #x7E79) + (#xE5E9 #x7E6A) + (#xE5EA #x7E69) + (#xE5EB #x7E7C) + (#xE5EC #x7E7B) + (#xE5ED #x7E83) + (#xE5EE #x7DD5) + (#xE5EF #x7E7D) + (#xE5F0 #x8FAE) + (#xE5F1 #x7E7F) + (#xE5F2 #x7E88) + (#xE5F3 #x7E89) + (#xE5F4 #x7E8C) + (#xE5F5 #x7E92) + (#xE5F6 #x7E90) + (#xE5F7 #x7E93) + (#xE5F8 #x7E94) + (#xE5F9 #x7E96) + (#xE5FA #x7E8E) + (#xE5FB #x7E9B) + (#xE5FC #x7E9C) + (#xE5FD #x7F38) + (#xE5FE #x7F3A) + (#xE6A1 #x7F45) + (#xE6A2 #x7F4C) + (#xE6A3 #x7F4D) + (#xE6A4 #x7F4E) + (#xE6A5 #x7F50) + (#xE6A6 #x7F51) + (#xE6A7 #x7F55) + (#xE6A8 #x7F54) + (#xE6A9 #x7F58) + (#xE6AA #x7F5F) + (#xE6AB #x7F60) + (#xE6AC #x7F68) + (#xE6AD #x7F69) + (#xE6AE #x7F67) + (#xE6AF #x7F78) + (#xE6B0 #x7F82) + (#xE6B1 #x7F86) + (#xE6B2 #x7F83) + (#xE6B3 #x7F88) + (#xE6B4 #x7F87) + (#xE6B5 #x7F8C) + (#xE6B6 #x7F94) + (#xE6B7 #x7F9E) + (#xE6B8 #x7F9D) + (#xE6B9 #x7F9A) + (#xE6BA #x7FA3) + (#xE6BB #x7FAF) + (#xE6BC #x7FB2) + (#xE6BD #x7FB9) + (#xE6BE #x7FAE) + (#xE6BF #x7FB6) + (#xE6C0 #x7FB8) + (#xE6C1 #x8B71) + (#xE6C2 #x7FC5) + (#xE6C3 #x7FC6) + (#xE6C4 #x7FCA) + (#xE6C5 #x7FD5) + (#xE6C6 #x7FD4) + (#xE6C7 #x7FE1) + (#xE6C8 #x7FE6) + (#xE6C9 #x7FE9) + (#xE6CA #x7FF3) + (#xE6CB #x7FF9) + (#xE6CC #x98DC) + (#xE6CD #x8006) + (#xE6CE #x8004) + (#xE6CF #x800B) + (#xE6D0 #x8012) + (#xE6D1 #x8018) + (#xE6D2 #x8019) + (#xE6D3 #x801C) + (#xE6D4 #x8021) + (#xE6D5 #x8028) + (#xE6D6 #x803F) + (#xE6D7 #x803B) + (#xE6D8 #x804A) + (#xE6D9 #x8046) + (#xE6DA #x8052) + (#xE6DB #x8058) + (#xE6DC #x805A) + (#xE6DD #x805F) + (#xE6DE #x8062) + (#xE6DF #x8068) + (#xE6E0 #x8073) + (#xE6E1 #x8072) + (#xE6E2 #x8070) + (#xE6E3 #x8076) + (#xE6E4 #x8079) + (#xE6E5 #x807D) + (#xE6E6 #x807F) + (#xE6E7 #x8084) + (#xE6E8 #x8086) + (#xE6E9 #x8085) + (#xE6EA #x809B) + (#xE6EB #x8093) + (#xE6EC #x809A) + (#xE6ED #x80AD) + (#xE6EE #x5190) + (#xE6EF #x80AC) + (#xE6F0 #x80DB) + (#xE6F1 #x80E5) + (#xE6F2 #x80D9) + (#xE6F3 #x80DD) + (#xE6F4 #x80C4) + (#xE6F5 #x80DA) + (#xE6F6 #x80D6) + (#xE6F7 #x8109) + (#xE6F8 #x80EF) + (#xE6F9 #x80F1) + (#xE6FA #x811B) + (#xE6FB #x8129) + (#xE6FC #x8123) + (#xE6FD #x812F) + (#xE6FE #x814B) + (#xE7A1 #x968B) + (#xE7A2 #x8146) + (#xE7A3 #x813E) + (#xE7A4 #x8153) + (#xE7A5 #x8151) + (#xE7A6 #x80FC) + (#xE7A7 #x8171) + (#xE7A8 #x816E) + (#xE7A9 #x8165) + (#xE7AA #x8166) + (#xE7AB #x8174) + (#xE7AC #x8183) + (#xE7AD #x8188) + (#xE7AE #x818A) + (#xE7AF #x8180) + (#xE7B0 #x8182) + (#xE7B1 #x81A0) + (#xE7B2 #x8195) + (#xE7B3 #x81A4) + (#xE7B4 #x81A3) + (#xE7B5 #x815F) + (#xE7B6 #x8193) + (#xE7B7 #x81A9) + (#xE7B8 #x81B0) + (#xE7B9 #x81B5) + (#xE7BA #x81BE) + (#xE7BB #x81B8) + (#xE7BC #x81BD) + (#xE7BD #x81C0) + (#xE7BE #x81C2) + (#xE7BF #x81BA) + (#xE7C0 #x81C9) + (#xE7C1 #x81CD) + (#xE7C2 #x81D1) + (#xE7C3 #x81D9) + (#xE7C4 #x81D8) + (#xE7C5 #x81C8) + (#xE7C6 #x81DA) + (#xE7C7 #x81DF) + (#xE7C8 #x81E0) + (#xE7C9 #x81E7) + (#xE7CA #x81FA) + (#xE7CB #x81FB) + (#xE7CC #x81FE) + (#xE7CD #x8201) + (#xE7CE #x8202) + (#xE7CF #x8205) + (#xE7D0 #x8207) + (#xE7D1 #x820A) + (#xE7D2 #x820D) + (#xE7D3 #x8210) + (#xE7D4 #x8216) + (#xE7D5 #x8229) + (#xE7D6 #x822B) + (#xE7D7 #x8238) + (#xE7D8 #x8233) + (#xE7D9 #x8240) + (#xE7DA #x8259) + (#xE7DB #x8258) + (#xE7DC #x825D) + (#xE7DD #x825A) + (#xE7DE #x825F) + (#xE7DF #x8264) + (#xE7E0 #x8262) + (#xE7E1 #x8268) + (#xE7E2 #x826A) + (#xE7E3 #x826B) + (#xE7E4 #x822E) + (#xE7E5 #x8271) + (#xE7E6 #x8277) + (#xE7E7 #x8278) + (#xE7E8 #x827E) + (#xE7E9 #x828D) + (#xE7EA #x8292) + (#xE7EB #x82AB) + (#xE7EC #x829F) + (#xE7ED #x82BB) + (#xE7EE #x82AC) + (#xE7EF #x82E1) + (#xE7F0 #x82E3) + (#xE7F1 #x82DF) + (#xE7F2 #x82D2) + (#xE7F3 #x82F4) + (#xE7F4 #x82F3) + (#xE7F5 #x82FA) + (#xE7F6 #x8393) + (#xE7F7 #x8303) + (#xE7F8 #x82FB) + (#xE7F9 #x82F9) + (#xE7FA #x82DE) + (#xE7FB #x8306) + (#xE7FC #x82DC) + (#xE7FD #x8309) + (#xE7FE #x82D9) + (#xE8A1 #x8335) + (#xE8A2 #x8334) + (#xE8A3 #x8316) + (#xE8A4 #x8332) + (#xE8A5 #x8331) + (#xE8A6 #x8340) + (#xE8A7 #x8339) + (#xE8A8 #x8350) + (#xE8A9 #x8345) + (#xE8AA #x832F) + (#xE8AB #x832B) + (#xE8AC #x8317) + (#xE8AD #x8318) + (#xE8AE #x8385) + (#xE8AF #x839A) + (#xE8B0 #x83AA) + (#xE8B1 #x839F) + (#xE8B2 #x83A2) + (#xE8B3 #x8396) + (#xE8B4 #x8323) + (#xE8B5 #x838E) + (#xE8B6 #x8387) + (#xE8B7 #x838A) + (#xE8B8 #x837C) + (#xE8B9 #x83B5) + (#xE8BA #x8373) + (#xE8BB #x8375) + (#xE8BC #x83A0) + (#xE8BD #x8389) + (#xE8BE #x83A8) + (#xE8BF #x83F4) + (#xE8C0 #x8413) + (#xE8C1 #x83EB) + (#xE8C2 #x83CE) + (#xE8C3 #x83FD) + (#xE8C4 #x8403) + (#xE8C5 #x83D8) + (#xE8C6 #x840B) + (#xE8C7 #x83C1) + (#xE8C8 #x83F7) + (#xE8C9 #x8407) + (#xE8CA #x83E0) + (#xE8CB #x83F2) + (#xE8CC #x840D) + (#xE8CD #x8422) + (#xE8CE #x8420) + (#xE8CF #x83BD) + (#xE8D0 #x8438) + (#xE8D1 #x8506) + (#xE8D2 #x83FB) + (#xE8D3 #x846D) + (#xE8D4 #x842A) + (#xE8D5 #x843C) + (#xE8D6 #x855A) + (#xE8D7 #x8484) + (#xE8D8 #x8477) + (#xE8D9 #x846B) + (#xE8DA #x84AD) + (#xE8DB #x846E) + (#xE8DC #x8482) + (#xE8DD #x8469) + (#xE8DE #x8446) + (#xE8DF #x842C) + (#xE8E0 #x846F) + (#xE8E1 #x8479) + (#xE8E2 #x8435) + (#xE8E3 #x84CA) + (#xE8E4 #x8462) + (#xE8E5 #x84B9) + (#xE8E6 #x84BF) + (#xE8E7 #x849F) + (#xE8E8 #x84D9) + (#xE8E9 #x84CD) + (#xE8EA #x84BB) + (#xE8EB #x84DA) + (#xE8EC #x84D0) + (#xE8ED #x84C1) + (#xE8EE #x84C6) + (#xE8EF #x84D6) + (#xE8F0 #x84A1) + (#xE8F1 #x8521) + (#xE8F2 #x84FF) + (#xE8F3 #x84F4) + (#xE8F4 #x8517) + (#xE8F5 #x8518) + (#xE8F6 #x852C) + (#xE8F7 #x851F) + (#xE8F8 #x8515) + (#xE8F9 #x8514) + (#xE8FA #x84FC) + (#xE8FB #x8540) + (#xE8FC #x8563) + (#xE8FD #x8558) + (#xE8FE #x8548) + (#xE9A1 #x8541) + (#xE9A2 #x8602) + (#xE9A3 #x854B) + (#xE9A4 #x8555) + (#xE9A5 #x8580) + (#xE9A6 #x85A4) + (#xE9A7 #x8588) + (#xE9A8 #x8591) + (#xE9A9 #x858A) + (#xE9AA #x85A8) + (#xE9AB #x856D) + (#xE9AC #x8594) + (#xE9AD #x859B) + (#xE9AE #x85EA) + (#xE9AF #x8587) + (#xE9B0 #x859C) + (#xE9B1 #x8577) + (#xE9B2 #x857E) + (#xE9B3 #x8590) + (#xE9B4 #x85C9) + (#xE9B5 #x85BA) + (#xE9B6 #x85CF) + (#xE9B7 #x85B9) + (#xE9B8 #x85D0) + (#xE9B9 #x85D5) + (#xE9BA #x85DD) + (#xE9BB #x85E5) + (#xE9BC #x85DC) + (#xE9BD #x85F9) + (#xE9BE #x860A) + (#xE9BF #x8613) + (#xE9C0 #x860B) + (#xE9C1 #x85FE) + (#xE9C2 #x85FA) + (#xE9C3 #x8606) + (#xE9C4 #x8622) + (#xE9C5 #x861A) + (#xE9C6 #x8630) + (#xE9C7 #x863F) + (#xE9C8 #x864D) + (#xE9C9 #x4E55) + (#xE9CA #x8654) + (#xE9CB #x865F) + (#xE9CC #x8667) + (#xE9CD #x8671) + (#xE9CE #x8693) + (#xE9CF #x86A3) + (#xE9D0 #x86A9) + (#xE9D1 #x86AA) + (#xE9D2 #x868B) + (#xE9D3 #x868C) + (#xE9D4 #x86B6) + (#xE9D5 #x86AF) + (#xE9D6 #x86C4) + (#xE9D7 #x86C6) + (#xE9D8 #x86B0) + (#xE9D9 #x86C9) + (#xE9DA #x8823) + (#xE9DB #x86AB) + (#xE9DC #x86D4) + (#xE9DD #x86DE) + (#xE9DE #x86E9) + (#xE9DF #x86EC) + (#xE9E0 #x86DF) + (#xE9E1 #x86DB) + (#xE9E2 #x86EF) + (#xE9E3 #x8712) + (#xE9E4 #x8706) + (#xE9E5 #x8708) + (#xE9E6 #x8700) + (#xE9E7 #x8703) + (#xE9E8 #x86FB) + (#xE9E9 #x8711) + (#xE9EA #x8709) + (#xE9EB #x870D) + (#xE9EC #x86F9) + (#xE9ED #x870A) + (#xE9EE #x8734) + (#xE9EF #x873F) + (#xE9F0 #x8737) + (#xE9F1 #x873B) + (#xE9F2 #x8725) + (#xE9F3 #x8729) + (#xE9F4 #x871A) + (#xE9F5 #x8760) + (#xE9F6 #x875F) + (#xE9F7 #x8778) + (#xE9F8 #x874C) + (#xE9F9 #x874E) + (#xE9FA #x8774) + (#xE9FB #x8757) + (#xE9FC #x8768) + (#xE9FD #x876E) + (#xE9FE #x8759) + (#xEAA1 #x8753) + (#xEAA2 #x8763) + (#xEAA3 #x876A) + (#xEAA4 #x8805) + (#xEAA5 #x87A2) + (#xEAA6 #x879F) + (#xEAA7 #x8782) + (#xEAA8 #x87AF) + (#xEAA9 #x87CB) + (#xEAAA #x87BD) + (#xEAAB #x87C0) + (#xEAAC #x87D0) + (#xEAAD #x96D6) + (#xEAAE #x87AB) + (#xEAAF #x87C4) + (#xEAB0 #x87B3) + (#xEAB1 #x87C7) + (#xEAB2 #x87C6) + (#xEAB3 #x87BB) + (#xEAB4 #x87EF) + (#xEAB5 #x87F2) + (#xEAB6 #x87E0) + (#xEAB7 #x880F) + (#xEAB8 #x880D) + (#xEAB9 #x87FE) + (#xEABA #x87F6) + (#xEABB #x87F7) + (#xEABC #x880E) + (#xEABD #x87D2) + (#xEABE #x8811) + (#xEABF #x8816) + (#xEAC0 #x8815) + (#xEAC1 #x8822) + (#xEAC2 #x8821) + (#xEAC3 #x8831) + (#xEAC4 #x8836) + (#xEAC5 #x8839) + (#xEAC6 #x8827) + (#xEAC7 #x883B) + (#xEAC8 #x8844) + (#xEAC9 #x8842) + (#xEACA #x8852) + (#xEACB #x8859) + (#xEACC #x885E) + (#xEACD #x8862) + (#xEACE #x886B) + (#xEACF #x8881) + (#xEAD0 #x887E) + (#xEAD1 #x889E) + (#xEAD2 #x8875) + (#xEAD3 #x887D) + (#xEAD4 #x88B5) + (#xEAD5 #x8872) + (#xEAD6 #x8882) + (#xEAD7 #x8897) + (#xEAD8 #x8892) + (#xEAD9 #x88AE) + (#xEADA #x8899) + (#xEADB #x88A2) + (#xEADC #x888D) + (#xEADD #x88A4) + (#xEADE #x88B0) + (#xEADF #x88BF) + (#xEAE0 #x88B1) + (#xEAE1 #x88C3) + (#xEAE2 #x88C4) + (#xEAE3 #x88D4) + (#xEAE4 #x88D8) + (#xEAE5 #x88D9) + (#xEAE6 #x88DD) + (#xEAE7 #x88F9) + (#xEAE8 #x8902) + (#xEAE9 #x88FC) + (#xEAEA #x88F4) + (#xEAEB #x88E8) + (#xEAEC #x88F2) + (#xEAED #x8904) + (#xEAEE #x890C) + (#xEAEF #x890A) + (#xEAF0 #x8913) + (#xEAF1 #x8943) + (#xEAF2 #x891E) + (#xEAF3 #x8925) + (#xEAF4 #x892A) + (#xEAF5 #x892B) + (#xEAF6 #x8941) + (#xEAF7 #x8944) + (#xEAF8 #x893B) + (#xEAF9 #x8936) + (#xEAFA #x8938) + (#xEAFB #x894C) + (#xEAFC #x891D) + (#xEAFD #x8960) + (#xEAFE #x895E) + (#xEBA1 #x8966) + (#xEBA2 #x8964) + (#xEBA3 #x896D) + (#xEBA4 #x896A) + (#xEBA5 #x896F) + (#xEBA6 #x8974) + (#xEBA7 #x8977) + (#xEBA8 #x897E) + (#xEBA9 #x8983) + (#xEBAA #x8988) + (#xEBAB #x898A) + (#xEBAC #x8993) + (#xEBAD #x8998) + (#xEBAE #x89A1) + (#xEBAF #x89A9) + (#xEBB0 #x89A6) + (#xEBB1 #x89AC) + (#xEBB2 #x89AF) + (#xEBB3 #x89B2) + (#xEBB4 #x89BA) + (#xEBB5 #x89BD) + (#xEBB6 #x89BF) + (#xEBB7 #x89C0) + (#xEBB8 #x89DA) + (#xEBB9 #x89DC) + (#xEBBA #x89DD) + (#xEBBB #x89E7) + (#xEBBC #x89F4) + (#xEBBD #x89F8) + (#xEBBE #x8A03) + (#xEBBF #x8A16) + (#xEBC0 #x8A10) + (#xEBC1 #x8A0C) + (#xEBC2 #x8A1B) + (#xEBC3 #x8A1D) + (#xEBC4 #x8A25) + (#xEBC5 #x8A36) + (#xEBC6 #x8A41) + (#xEBC7 #x8A5B) + (#xEBC8 #x8A52) + (#xEBC9 #x8A46) + (#xEBCA #x8A48) + (#xEBCB #x8A7C) + (#xEBCC #x8A6D) + (#xEBCD #x8A6C) + (#xEBCE #x8A62) + (#xEBCF #x8A85) + (#xEBD0 #x8A82) + (#xEBD1 #x8A84) + (#xEBD2 #x8AA8) + (#xEBD3 #x8AA1) + (#xEBD4 #x8A91) + (#xEBD5 #x8AA5) + (#xEBD6 #x8AA6) + (#xEBD7 #x8A9A) + (#xEBD8 #x8AA3) + (#xEBD9 #x8AC4) + (#xEBDA #x8ACD) + (#xEBDB #x8AC2) + (#xEBDC #x8ADA) + (#xEBDD #x8AEB) + (#xEBDE #x8AF3) + (#xEBDF #x8AE7) + (#xEBE0 #x8AE4) + (#xEBE1 #x8AF1) + (#xEBE2 #x8B14) + (#xEBE3 #x8AE0) + (#xEBE4 #x8AE2) + (#xEBE5 #x8AF7) + (#xEBE6 #x8ADE) + (#xEBE7 #x8ADB) + (#xEBE8 #x8B0C) + (#xEBE9 #x8B07) + (#xEBEA #x8B1A) + (#xEBEB #x8AE1) + (#xEBEC #x8B16) + (#xEBED #x8B10) + (#xEBEE #x8B17) + (#xEBEF #x8B20) + (#xEBF0 #x8B33) + (#xEBF1 #x97AB) + (#xEBF2 #x8B26) + (#xEBF3 #x8B2B) + (#xEBF4 #x8B3E) + (#xEBF5 #x8B28) + (#xEBF6 #x8B41) + (#xEBF7 #x8B4C) + (#xEBF8 #x8B4F) + (#xEBF9 #x8B4E) + (#xEBFA #x8B49) + (#xEBFB #x8B56) + (#xEBFC #x8B5B) + (#xEBFD #x8B5A) + (#xEBFE #x8B6B) + (#xECA1 #x8B5F) + (#xECA2 #x8B6C) + (#xECA3 #x8B6F) + (#xECA4 #x8B74) + (#xECA5 #x8B7D) + (#xECA6 #x8B80) + (#xECA7 #x8B8C) + (#xECA8 #x8B8E) + (#xECA9 #x8B92) + (#xECAA #x8B93) + (#xECAB #x8B96) + (#xECAC #x8B99) + (#xECAD #x8B9A) + (#xECAE #x8C3A) + (#xECAF #x8C41) + (#xECB0 #x8C3F) + (#xECB1 #x8C48) + (#xECB2 #x8C4C) + (#xECB3 #x8C4E) + (#xECB4 #x8C50) + (#xECB5 #x8C55) + (#xECB6 #x8C62) + (#xECB7 #x8C6C) + (#xECB8 #x8C78) + (#xECB9 #x8C7A) + (#xECBA #x8C82) + (#xECBB #x8C89) + (#xECBC #x8C85) + (#xECBD #x8C8A) + (#xECBE #x8C8D) + (#xECBF #x8C8E) + (#xECC0 #x8C94) + (#xECC1 #x8C7C) + (#xECC2 #x8C98) + (#xECC3 #x621D) + (#xECC4 #x8CAD) + (#xECC5 #x8CAA) + (#xECC6 #x8CBD) + (#xECC7 #x8CB2) + (#xECC8 #x8CB3) + (#xECC9 #x8CAE) + (#xECCA #x8CB6) + (#xECCB #x8CC8) + (#xECCC #x8CC1) + (#xECCD #x8CE4) + (#xECCE #x8CE3) + (#xECCF #x8CDA) + (#xECD0 #x8CFD) + (#xECD1 #x8CFA) + (#xECD2 #x8CFB) + (#xECD3 #x8D04) + (#xECD4 #x8D05) + (#xECD5 #x8D0A) + (#xECD6 #x8D07) + (#xECD7 #x8D0F) + (#xECD8 #x8D0D) + (#xECD9 #x8D10) + (#xECDA #x9F4E) + (#xECDB #x8D13) + (#xECDC #x8CCD) + (#xECDD #x8D14) + (#xECDE #x8D16) + (#xECDF #x8D67) + (#xECE0 #x8D6D) + (#xECE1 #x8D71) + (#xECE2 #x8D73) + (#xECE3 #x8D81) + (#xECE4 #x8D99) + (#xECE5 #x8DC2) + (#xECE6 #x8DBE) + (#xECE7 #x8DBA) + (#xECE8 #x8DCF) + (#xECE9 #x8DDA) + (#xECEA #x8DD6) + (#xECEB #x8DCC) + (#xECEC #x8DDB) + (#xECED #x8DCB) + (#xECEE #x8DEA) + (#xECEF #x8DEB) + (#xECF0 #x8DDF) + (#xECF1 #x8DE3) + (#xECF2 #x8DFC) + (#xECF3 #x8E08) + (#xECF4 #x8E09) + (#xECF5 #x8DFF) + (#xECF6 #x8E1D) + (#xECF7 #x8E1E) + (#xECF8 #x8E10) + (#xECF9 #x8E1F) + (#xECFA #x8E42) + (#xECFB #x8E35) + (#xECFC #x8E30) + (#xECFD #x8E34) + (#xECFE #x8E4A) + (#xEDA1 #x8E47) + (#xEDA2 #x8E49) + (#xEDA3 #x8E4C) + (#xEDA4 #x8E50) + (#xEDA5 #x8E48) + (#xEDA6 #x8E59) + (#xEDA7 #x8E64) + (#xEDA8 #x8E60) + (#xEDA9 #x8E2A) + (#xEDAA #x8E63) + (#xEDAB #x8E55) + (#xEDAC #x8E76) + (#xEDAD #x8E72) + (#xEDAE #x8E7C) + (#xEDAF #x8E81) + (#xEDB0 #x8E87) + (#xEDB1 #x8E85) + (#xEDB2 #x8E84) + (#xEDB3 #x8E8B) + (#xEDB4 #x8E8A) + (#xEDB5 #x8E93) + (#xEDB6 #x8E91) + (#xEDB7 #x8E94) + (#xEDB8 #x8E99) + (#xEDB9 #x8EAA) + (#xEDBA #x8EA1) + (#xEDBB #x8EAC) + (#xEDBC #x8EB0) + (#xEDBD #x8EC6) + (#xEDBE #x8EB1) + (#xEDBF #x8EBE) + (#xEDC0 #x8EC5) + (#xEDC1 #x8EC8) + (#xEDC2 #x8ECB) + (#xEDC3 #x8EDB) + (#xEDC4 #x8EE3) + (#xEDC5 #x8EFC) + (#xEDC6 #x8EFB) + (#xEDC7 #x8EEB) + (#xEDC8 #x8EFE) + (#xEDC9 #x8F0A) + (#xEDCA #x8F05) + (#xEDCB #x8F15) + (#xEDCC #x8F12) + (#xEDCD #x8F19) + (#xEDCE #x8F13) + (#xEDCF #x8F1C) + (#xEDD0 #x8F1F) + (#xEDD1 #x8F1B) + (#xEDD2 #x8F0C) + (#xEDD3 #x8F26) + (#xEDD4 #x8F33) + (#xEDD5 #x8F3B) + (#xEDD6 #x8F39) + (#xEDD7 #x8F45) + (#xEDD8 #x8F42) + (#xEDD9 #x8F3E) + (#xEDDA #x8F4C) + (#xEDDB #x8F49) + (#xEDDC #x8F46) + (#xEDDD #x8F4E) + (#xEDDE #x8F57) + (#xEDDF #x8F5C) + (#xEDE0 #x8F62) + (#xEDE1 #x8F63) + (#xEDE2 #x8F64) + (#xEDE3 #x8F9C) + (#xEDE4 #x8F9F) + (#xEDE5 #x8FA3) + (#xEDE6 #x8FAD) + (#xEDE7 #x8FAF) + (#xEDE8 #x8FB7) + (#xEDE9 #x8FDA) + (#xEDEA #x8FE5) + (#xEDEB #x8FE2) + (#xEDEC #x8FEA) + (#xEDED #x8FEF) + (#xEDEE #x9087) + (#xEDEF #x8FF4) + (#xEDF0 #x9005) + (#xEDF1 #x8FF9) + (#xEDF2 #x8FFA) + (#xEDF3 #x9011) + (#xEDF4 #x9015) + (#xEDF5 #x9021) + (#xEDF6 #x900D) + (#xEDF7 #x901E) + (#xEDF8 #x9016) + (#xEDF9 #x900B) + (#xEDFA #x9027) + (#xEDFB #x9036) + (#xEDFC #x9035) + (#xEDFD #x9039) + (#xEDFE #x8FF8) + (#xEEA1 #x904F) + (#xEEA2 #x9050) + (#xEEA3 #x9051) + (#xEEA4 #x9052) + (#xEEA5 #x900E) + (#xEEA6 #x9049) + (#xEEA7 #x903E) + (#xEEA8 #x9056) + (#xEEA9 #x9058) + (#xEEAA #x905E) + (#xEEAB #x9068) + (#xEEAC #x906F) + (#xEEAD #x9076) + (#xEEAE #x96A8) + (#xEEAF #x9072) + (#xEEB0 #x9082) + (#xEEB1 #x907D) + (#xEEB2 #x9081) + (#xEEB3 #x9080) + (#xEEB4 #x908A) + (#xEEB5 #x9089) + (#xEEB6 #x908F) + (#xEEB7 #x90A8) + (#xEEB8 #x90AF) + (#xEEB9 #x90B1) + (#xEEBA #x90B5) + (#xEEBB #x90E2) + (#xEEBC #x90E4) + (#xEEBD #x6248) + (#xEEBE #x90DB) + (#xEEBF #x9102) + (#xEEC0 #x9112) + (#xEEC1 #x9119) + (#xEEC2 #x9132) + (#xEEC3 #x9130) + (#xEEC4 #x914A) + (#xEEC5 #x9156) + (#xEEC6 #x9158) + (#xEEC7 #x9163) + (#xEEC8 #x9165) + (#xEEC9 #x9169) + (#xEECA #x9173) + (#xEECB #x9172) + (#xEECC #x918B) + (#xEECD #x9189) + (#xEECE #x9182) + (#xEECF #x91A2) + (#xEED0 #x91AB) + (#xEED1 #x91AF) + (#xEED2 #x91AA) + (#xEED3 #x91B5) + (#xEED4 #x91B4) + (#xEED5 #x91BA) + (#xEED6 #x91C0) + (#xEED7 #x91C1) + (#xEED8 #x91C9) + (#xEED9 #x91CB) + (#xEEDA #x91D0) + (#xEEDB #x91D6) + (#xEEDC #x91DF) + (#xEEDD #x91E1) + (#xEEDE #x91DB) + (#xEEDF #x91FC) + (#xEEE0 #x91F5) + (#xEEE1 #x91F6) + (#xEEE2 #x921E) + (#xEEE3 #x91FF) + (#xEEE4 #x9214) + (#xEEE5 #x922C) + (#xEEE6 #x9215) + (#xEEE7 #x9211) + (#xEEE8 #x925E) + (#xEEE9 #x9257) + (#xEEEA #x9245) + (#xEEEB #x9249) + (#xEEEC #x9264) + (#xEEED #x9248) + (#xEEEE #x9295) + (#xEEEF #x923F) + (#xEEF0 #x924B) + (#xEEF1 #x9250) + (#xEEF2 #x929C) + (#xEEF3 #x9296) + (#xEEF4 #x9293) + (#xEEF5 #x929B) + (#xEEF6 #x925A) + (#xEEF7 #x92CF) + (#xEEF8 #x92B9) + (#xEEF9 #x92B7) + (#xEEFA #x92E9) + (#xEEFB #x930F) + (#xEEFC #x92FA) + (#xEEFD #x9344) + (#xEEFE #x932E) + (#xEFA1 #x9319) + (#xEFA2 #x9322) + (#xEFA3 #x931A) + (#xEFA4 #x9323) + (#xEFA5 #x933A) + (#xEFA6 #x9335) + (#xEFA7 #x933B) + (#xEFA8 #x935C) + (#xEFA9 #x9360) + (#xEFAA #x937C) + (#xEFAB #x936E) + (#xEFAC #x9356) + (#xEFAD #x93B0) + (#xEFAE #x93AC) + (#xEFAF #x93AD) + (#xEFB0 #x9394) + (#xEFB1 #x93B9) + (#xEFB2 #x93D6) + (#xEFB3 #x93D7) + (#xEFB4 #x93E8) + (#xEFB5 #x93E5) + (#xEFB6 #x93D8) + (#xEFB7 #x93C3) + (#xEFB8 #x93DD) + (#xEFB9 #x93D0) + (#xEFBA #x93C8) + (#xEFBB #x93E4) + (#xEFBC #x941A) + (#xEFBD #x9414) + (#xEFBE #x9413) + (#xEFBF #x9403) + (#xEFC0 #x9407) + (#xEFC1 #x9410) + (#xEFC2 #x9436) + (#xEFC3 #x942B) + (#xEFC4 #x9435) + (#xEFC5 #x9421) + (#xEFC6 #x943A) + (#xEFC7 #x9441) + (#xEFC8 #x9452) + (#xEFC9 #x9444) + (#xEFCA #x945B) + (#xEFCB #x9460) + (#xEFCC #x9462) + (#xEFCD #x945E) + (#xEFCE #x946A) + (#xEFCF #x9229) + (#xEFD0 #x9470) + (#xEFD1 #x9475) + (#xEFD2 #x9477) + (#xEFD3 #x947D) + (#xEFD4 #x945A) + (#xEFD5 #x947C) + (#xEFD6 #x947E) + (#xEFD7 #x9481) + (#xEFD8 #x947F) + (#xEFD9 #x9582) + (#xEFDA #x9587) + (#xEFDB #x958A) + (#xEFDC #x9594) + (#xEFDD #x9596) + (#xEFDE #x9598) + (#xEFDF #x9599) + (#xEFE0 #x95A0) + (#xEFE1 #x95A8) + (#xEFE2 #x95A7) + (#xEFE3 #x95AD) + (#xEFE4 #x95BC) + (#xEFE5 #x95BB) + (#xEFE6 #x95B9) + (#xEFE7 #x95BE) + (#xEFE8 #x95CA) + (#xEFE9 #x6FF6) + (#xEFEA #x95C3) + (#xEFEB #x95CD) + (#xEFEC #x95CC) + (#xEFED #x95D5) + (#xEFEE #x95D4) + (#xEFEF #x95D6) + (#xEFF0 #x95DC) + (#xEFF1 #x95E1) + (#xEFF2 #x95E5) + (#xEFF3 #x95E2) + (#xEFF4 #x9621) + (#xEFF5 #x9628) + (#xEFF6 #x962E) + (#xEFF7 #x962F) + (#xEFF8 #x9642) + (#xEFF9 #x964C) + (#xEFFA #x964F) + (#xEFFB #x964B) + (#xEFFC #x9677) + (#xEFFD #x965C) + (#xEFFE #x965E) + (#xF0A1 #x965D) + (#xF0A2 #x965F) + (#xF0A3 #x9666) + (#xF0A4 #x9672) + (#xF0A5 #x966C) + (#xF0A6 #x968D) + (#xF0A7 #x9698) + (#xF0A8 #x9695) + (#xF0A9 #x9697) + (#xF0AA #x96AA) + (#xF0AB #x96A7) + (#xF0AC #x96B1) + (#xF0AD #x96B2) + (#xF0AE #x96B0) + (#xF0AF #x96B4) + (#xF0B0 #x96B6) + (#xF0B1 #x96B8) + (#xF0B2 #x96B9) + (#xF0B3 #x96CE) + (#xF0B4 #x96CB) + (#xF0B5 #x96C9) + (#xF0B6 #x96CD) + (#xF0B7 #x894D) + (#xF0B8 #x96DC) + (#xF0B9 #x970D) + (#xF0BA #x96D5) + (#xF0BB #x96F9) + (#xF0BC #x9704) + (#xF0BD #x9706) + (#xF0BE #x9708) + (#xF0BF #x9713) + (#xF0C0 #x970E) + (#xF0C1 #x9711) + (#xF0C2 #x970F) + (#xF0C3 #x9716) + (#xF0C4 #x9719) + (#xF0C5 #x9724) + (#xF0C6 #x972A) + (#xF0C7 #x9730) + (#xF0C8 #x9739) + (#xF0C9 #x973D) + (#xF0CA #x973E) + (#xF0CB #x9744) + (#xF0CC #x9746) + (#xF0CD #x9748) + (#xF0CE #x9742) + (#xF0CF #x9749) + (#xF0D0 #x975C) + (#xF0D1 #x9760) + (#xF0D2 #x9764) + (#xF0D3 #x9766) + (#xF0D4 #x9768) + (#xF0D5 #x52D2) + (#xF0D6 #x976B) + (#xF0D7 #x9771) + (#xF0D8 #x9779) + (#xF0D9 #x9785) + (#xF0DA #x977C) + (#xF0DB #x9781) + (#xF0DC #x977A) + (#xF0DD #x9786) + (#xF0DE #x978B) + (#xF0DF #x978F) + (#xF0E0 #x9790) + (#xF0E1 #x979C) + (#xF0E2 #x97A8) + (#xF0E3 #x97A6) + (#xF0E4 #x97A3) + (#xF0E5 #x97B3) + (#xF0E6 #x97B4) + (#xF0E7 #x97C3) + (#xF0E8 #x97C6) + (#xF0E9 #x97C8) + (#xF0EA #x97CB) + (#xF0EB #x97DC) + (#xF0EC #x97ED) + (#xF0ED #x9F4F) + (#xF0EE #x97F2) + (#xF0EF #x7ADF) + (#xF0F0 #x97F6) + (#xF0F1 #x97F5) + (#xF0F2 #x980F) + (#xF0F3 #x980C) + (#xF0F4 #x9838) + (#xF0F5 #x9824) + (#xF0F6 #x9821) + (#xF0F7 #x9837) + (#xF0F8 #x983D) + (#xF0F9 #x9846) + (#xF0FA #x984F) + (#xF0FB #x984B) + (#xF0FC #x986B) + (#xF0FD #x986F) + (#xF0FE #x9870) + (#xF1A1 #x9871) + (#xF1A2 #x9874) + (#xF1A3 #x9873) + (#xF1A4 #x98AA) + (#xF1A5 #x98AF) + (#xF1A6 #x98B1) + (#xF1A7 #x98B6) + (#xF1A8 #x98C4) + (#xF1A9 #x98C3) + (#xF1AA #x98C6) + (#xF1AB #x98E9) + (#xF1AC #x98EB) + (#xF1AD #x9903) + (#xF1AE #x9909) + (#xF1AF #x9912) + (#xF1B0 #x9914) + (#xF1B1 #x9918) + (#xF1B2 #x9921) + (#xF1B3 #x991D) + (#xF1B4 #x991E) + (#xF1B5 #x9924) + (#xF1B6 #x9920) + (#xF1B7 #x992C) + (#xF1B8 #x992E) + (#xF1B9 #x993D) + (#xF1BA #x993E) + (#xF1BB #x9942) + (#xF1BC #x9949) + (#xF1BD #x9945) + (#xF1BE #x9950) + (#xF1BF #x994B) + (#xF1C0 #x9951) + (#xF1C1 #x9952) + (#xF1C2 #x994C) + (#xF1C3 #x9955) + (#xF1C4 #x9997) + (#xF1C5 #x9998) + (#xF1C6 #x99A5) + (#xF1C7 #x99AD) + (#xF1C8 #x99AE) + (#xF1C9 #x99BC) + (#xF1CA #x99DF) + (#xF1CB #x99DB) + (#xF1CC #x99DD) + (#xF1CD #x99D8) + (#xF1CE #x99D1) + (#xF1CF #x99ED) + (#xF1D0 #x99EE) + (#xF1D1 #x99F1) + (#xF1D2 #x99F2) + (#xF1D3 #x99FB) + (#xF1D4 #x99F8) + (#xF1D5 #x9A01) + (#xF1D6 #x9A0F) + (#xF1D7 #x9A05) + (#xF1D8 #x99E2) + (#xF1D9 #x9A19) + (#xF1DA #x9A2B) + (#xF1DB #x9A37) + (#xF1DC #x9A45) + (#xF1DD #x9A42) + (#xF1DE #x9A40) + (#xF1DF #x9A43) + (#xF1E0 #x9A3E) + (#xF1E1 #x9A55) + (#xF1E2 #x9A4D) + (#xF1E3 #x9A5B) + (#xF1E4 #x9A57) + (#xF1E5 #x9A5F) + (#xF1E6 #x9A62) + (#xF1E7 #x9A65) + (#xF1E8 #x9A64) + (#xF1E9 #x9A69) + (#xF1EA #x9A6B) + (#xF1EB #x9A6A) + (#xF1EC #x9AAD) + (#xF1ED #x9AB0) + (#xF1EE #x9ABC) + (#xF1EF #x9AC0) + (#xF1F0 #x9ACF) + (#xF1F1 #x9AD1) + (#xF1F2 #x9AD3) + (#xF1F3 #x9AD4) + (#xF1F4 #x9ADE) + (#xF1F5 #x9ADF) + (#xF1F6 #x9AE2) + (#xF1F7 #x9AE3) + (#xF1F8 #x9AE6) + (#xF1F9 #x9AEF) + (#xF1FA #x9AEB) + (#xF1FB #x9AEE) + (#xF1FC #x9AF4) + (#xF1FD #x9AF1) + (#xF1FE #x9AF7) + (#xF2A1 #x9AFB) + (#xF2A2 #x9B06) + (#xF2A3 #x9B18) + (#xF2A4 #x9B1A) + (#xF2A5 #x9B1F) + (#xF2A6 #x9B22) + (#xF2A7 #x9B23) + (#xF2A8 #x9B25) + (#xF2A9 #x9B27) + (#xF2AA #x9B28) + (#xF2AB #x9B29) + (#xF2AC #x9B2A) + (#xF2AD #x9B2E) + (#xF2AE #x9B2F) + (#xF2AF #x9B32) + (#xF2B0 #x9B44) + (#xF2B1 #x9B43) + (#xF2B2 #x9B4F) + (#xF2B3 #x9B4D) + (#xF2B4 #x9B4E) + (#xF2B5 #x9B51) + (#xF2B6 #x9B58) + (#xF2B7 #x9B74) + (#xF2B8 #x9B93) + (#xF2B9 #x9B83) + (#xF2BA #x9B91) + (#xF2BB #x9B96) + (#xF2BC #x9B97) + (#xF2BD #x9B9F) + (#xF2BE #x9BA0) + (#xF2BF #x9BA8) + (#xF2C0 #x9BB4) + (#xF2C1 #x9BC0) + (#xF2C2 #x9BCA) + (#xF2C3 #x9BB9) + (#xF2C4 #x9BC6) + (#xF2C5 #x9BCF) + (#xF2C6 #x9BD1) + (#xF2C7 #x9BD2) + (#xF2C8 #x9BE3) + (#xF2C9 #x9BE2) + (#xF2CA #x9BE4) + (#xF2CB #x9BD4) + (#xF2CC #x9BE1) + (#xF2CD #x9C3A) + (#xF2CE #x9BF2) + (#xF2CF #x9BF1) + (#xF2D0 #x9BF0) + (#xF2D1 #x9C15) + (#xF2D2 #x9C14) + (#xF2D3 #x9C09) + (#xF2D4 #x9C13) + (#xF2D5 #x9C0C) + (#xF2D6 #x9C06) + (#xF2D7 #x9C08) + (#xF2D8 #x9C12) + (#xF2D9 #x9C0A) + (#xF2DA #x9C04) + (#xF2DB #x9C2E) + (#xF2DC #x9C1B) + (#xF2DD #x9C25) + (#xF2DE #x9C24) + (#xF2DF #x9C21) + (#xF2E0 #x9C30) + (#xF2E1 #x9C47) + (#xF2E2 #x9C32) + (#xF2E3 #x9C46) + (#xF2E4 #x9C3E) + (#xF2E5 #x9C5A) + (#xF2E6 #x9C60) + (#xF2E7 #x9C67) + (#xF2E8 #x9C76) + (#xF2E9 #x9C78) + (#xF2EA #x9CE7) + (#xF2EB #x9CEC) + (#xF2EC #x9CF0) + (#xF2ED #x9D09) + (#xF2EE #x9D08) + (#xF2EF #x9CEB) + (#xF2F0 #x9D03) + (#xF2F1 #x9D06) + (#xF2F2 #x9D2A) + (#xF2F3 #x9D26) + (#xF2F4 #x9DAF) + (#xF2F5 #x9D23) + (#xF2F6 #x9D1F) + (#xF2F7 #x9D44) + (#xF2F8 #x9D15) + (#xF2F9 #x9D12) + (#xF2FA #x9D41) + (#xF2FB #x9D3F) + (#xF2FC #x9D3E) + (#xF2FD #x9D46) + (#xF2FE #x9D48) + (#xF3A1 #x9D5D) + (#xF3A2 #x9D5E) + (#xF3A3 #x9D64) + (#xF3A4 #x9D51) + (#xF3A5 #x9D50) + (#xF3A6 #x9D59) + (#xF3A7 #x9D72) + (#xF3A8 #x9D89) + (#xF3A9 #x9D87) + (#xF3AA #x9DAB) + (#xF3AB #x9D6F) + (#xF3AC #x9D7A) + (#xF3AD #x9D9A) + (#xF3AE #x9DA4) + (#xF3AF #x9DA9) + (#xF3B0 #x9DB2) + (#xF3B1 #x9DC4) + (#xF3B2 #x9DC1) + (#xF3B3 #x9DBB) + (#xF3B4 #x9DB8) + (#xF3B5 #x9DBA) + (#xF3B6 #x9DC6) + (#xF3B7 #x9DCF) + (#xF3B8 #x9DC2) + (#xF3B9 #x9DD9) + (#xF3BA #x9DD3) + (#xF3BB #x9DF8) + (#xF3BC #x9DE6) + (#xF3BD #x9DED) + (#xF3BE #x9DEF) + (#xF3BF #x9DFD) + (#xF3C0 #x9E1A) + (#xF3C1 #x9E1B) + (#xF3C2 #x9E1E) + (#xF3C3 #x9E75) + (#xF3C4 #x9E79) + (#xF3C5 #x9E7D) + (#xF3C6 #x9E81) + (#xF3C7 #x9E88) + (#xF3C8 #x9E8B) + (#xF3C9 #x9E8C) + (#xF3CA #x9E92) + (#xF3CB #x9E95) + (#xF3CC #x9E91) + (#xF3CD #x9E9D) + (#xF3CE #x9EA5) + (#xF3CF #x9EA9) + (#xF3D0 #x9EB8) + (#xF3D1 #x9EAA) + (#xF3D2 #x9EAD) + (#xF3D3 #x9761) + (#xF3D4 #x9ECC) + (#xF3D5 #x9ECE) + (#xF3D6 #x9ECF) + (#xF3D7 #x9ED0) + (#xF3D8 #x9ED4) + (#xF3D9 #x9EDC) + (#xF3DA #x9EDE) + (#xF3DB #x9EDD) + (#xF3DC #x9EE0) + (#xF3DD #x9EE5) + (#xF3DE #x9EE8) + (#xF3DF #x9EEF) + (#xF3E0 #x9EF4) + (#xF3E1 #x9EF6) + (#xF3E2 #x9EF7) + (#xF3E3 #x9EF9) + (#xF3E4 #x9EFB) + (#xF3E5 #x9EFC) + (#xF3E6 #x9EFD) + (#xF3E7 #x9F07) + (#xF3E8 #x9F08) + (#xF3E9 #x76B7) + (#xF3EA #x9F15) + (#xF3EB #x9F21) + (#xF3EC #x9F2C) + (#xF3ED #x9F3E) + (#xF3EE #x9F4A) + (#xF3EF #x9F52) + (#xF3F0 #x9F54) + (#xF3F1 #x9F63) + (#xF3F2 #x9F5F) + (#xF3F3 #x9F60) + (#xF3F4 #x9F61) + (#xF3F5 #x9F66) + (#xF3F6 #x9F67) + (#xF3F7 #x9F6C) + (#xF3F8 #x9F6A) + (#xF3F9 #x9F77) + (#xF3FA #x9F72) + (#xF3FB #x9F76) + (#xF3FC #x9F95) + (#xF3FD #x9F9C) + (#xF3FE #x9FA0) + (#xF4A1 #x582F) + (#xF4A2 #x69C7) + (#xF4A3 #x9059) + (#xF4A4 #x7464) + (#xF4A5 #x51DC) + (#xF4A6 #x7199) + ))) + + (dolist (i `((,cp932-only + ,*cp932-to-ucs-hash* + ,*ucs-to-cp932-hash*) + (,eucjp-only + ,*eucjp-to-ucs-hash* + ,*ucs-to-eucjp-hash*) + (,eucjp + ,*eucjp-to-ucs-hash* + ,*ucs-to-eucjp-hash*))) + (dolist (j (first i)) + (setf (gethash (car j) (second i)) (cadr j)) + (setf (gethash (cadr j) (third i)) (car j)))) + + (flet ((euc-cp932 (x) + (let ((high (ash x -16)) + (mid (logand (ash x -8) 255)) + (low (logand x 255))) + (cond ((not (zerop high)) + nil) + ((= mid #x8e) + (logand x 255)) + ((zerop mid) + x) + ((decf mid #xa1) + (decf low #x80) + (incf low (if (zerop (logand mid 1)) #x1f #x7e)) + (incf low (if (<= #x7f low #x9d) 1 0)) + (setq mid (ash mid -1)) + (incf mid (if (<= mid #x1e) #x81 #xc1)) + (+ (ash mid 8) low)))))) + (dolist (i eucjp) + (let ((cp932 (euc-cp932 (first i)))) + (setf (gethash cp932 *cp932-to-ucs-hash*) (second i)) + (setf (gethash (second i) *ucs-to-cp932-hash*) cp932)))) + +;; ascii + (loop for i from #x00 to #x7f + do + (setf (gethash i *cp932-to-ucs-hash*) i) + (setf (gethash i *eucjp-to-ucs-hash*) i) + (setf (gethash i *ucs-to-eucjp-hash*) i) + (setf (gethash i *ucs-to-cp932-hash*) i)) + +;; half-width katakana + (loop for i from #xa1 to #xdf + do + (setf (gethash i *cp932-to-ucs-hash*) (+ #xff61 #x-a1 i)) + (setf (gethash (+ #xff61 #x-a1 i) *ucs-to-cp932-hash*) i) + (setf (gethash (+ #x8e00 i) *eucjp-to-ucs-hash*) (+ #xff61 #x-a1 i)) + (setf (gethash (+ #xff61 #x-a1 i) *ucs-to-eucjp-hash*) (+ #x8e00 i)))) + +(defun eucjp-to-ucs (code) + (values (gethash code *eucjp-to-ucs-hash*))) + +(defun ucs-to-eucjp (code) + (values (gethash code *ucs-to-eucjp-hash*))) + +(defun cp932-to-ucs (code) + (values (gethash code *cp932-to-ucs-hash*))) + +(defun ucs-to-cp932 (code) + (values (gethash code *ucs-to-cp932-hash*))) + + +(defmacro define-jp-encoding (name docstring aliases max-units-per-char + from-ucs + to-ucs + length-by-code + length-by-1st-unit) + `(define-character-encoding ,name + ,docstring + :aliases ,aliases + :native-endianness nil + :max-units-per-char ,max-units-per-char + :stream-encode-function + (lambda (char write-function stream) + (let ((code (,from-ucs (char-code char)))) + (cond ((null code) + (funcall write-function stream #.(char-code #\?)) + 1) + ((< code #x100) + (funcall write-function stream code) + 1) + ((< code #x10000) + (funcall write-function stream (logand #xff (ash code -8))) + (funcall write-function stream (logand code #xff)) + 2) + (t + (funcall write-function stream (logand #xff (ash code -16))) + (funcall write-function stream (logand #xff (ash code -8))) + (funcall write-function stream (logand code #xff)) + 3)))) + :stream-decode-function + (lambda (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 8) 1st-unit)) + (let ((code + (case ,length-by-1st-unit + (3 (let ((2nd-unit (funcall next-unit-function stream))) + (if (eq 2nd-unit :eof) + :eof + (let ((3rd-unit (funcall next-unit-function stream))) + (if (eq 3rd-unit :eof) + :eof + (logior #x8f0000 + (ash 2nd-unit 8) + 3rd-unit)))))) + (2 (let ((2nd-unit (funcall next-unit-function stream))) + (if (eq 2nd-unit :eof) + :eof + (logior (ash 1st-unit 8) + 2nd-unit)))) + (1 1st-unit)))) + (if (eq code :eof) + :eof + (let ((ucs (,to-ucs code))) + (if ucs + (code-char ucs) + #\?))))) + :vector-encode-function + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (,from-ucs (char-code char)))) + (cond ((null code) + (setf (aref vector idx) #.(char-code #\?)) + (incf idx)) + ((< code #x100) + (setf (aref vector idx) code) + (incf idx)) + ((< code #x10000) + (setf (aref vector idx) (logand #xff (ash code -8))) + (setf (aref vector (the fixnum (1+ idx))) (logand code #xff)) + (incf idx 2)) + (t + (setf (aref vector idx) (logand #xff (ash code -16))) + (setf (aref vector (the fixnum (1+ idx))) + (logand #xff (ash code -8))) + (setf (aref vector (the fixnum (+ idx 2))) (logand code #xff)) + (incf idx 3)))))) + :vector-decode-function + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((= index end) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((code (,to-ucs + (case ,length-by-1st-unit + (3 (logior + #x8f0000 + (ash (aref vector (incf index)) 8) + (aref vector (incf index)))) + (2 (logior + (ash 1st-unit 8) + (aref vector (incf index)))) + (1 1st-unit)))) + (char (and code (code-char code)))) + (setf (schar string i) (or char #\?)))))) + :memory-encode-function + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (,from-ucs (char-code (schar string i))))) + (cond ((null code) + (setf (%get-unsigned-byte pointer idx) #.(char-code #\?)) + (incf idx)) + ((< code #x100) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx)) + ((< code #x10000) + (setf (%get-unsigned-byte pointer idx) + (logand #xff (ash code -8))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logand code #xff)) + (incf idx 2)) + (t + (setf (%get-unsigned-byte pointer idx) + (logand #xff (ash code -16))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logand #xff (ash code -8))) + (setf (%get-unsigned-byte pointer (the fixnum (+ 2 idx))) + (logand code #xff)) + (incf idx 3)))))) + :memory-decode-function + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) (if (= index end) index 0)) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((code + (,to-ucs + (case ,length-by-1st-unit + (3 (logior + #x8f0000 + (ash (%get-unsigned-byte + pointer (incf index)) 8) + (%get-unsigned-byte pointer (incf index)))) + (2 (logior + (ash 1st-unit 8) + (%get-unsigned-byte pointer (incf index)))) + (1 1st-unit)))) + (char (if code (code-char code) #\?))) + (setf (schar string i) char))))) + :octets-in-string-function + (lambda (string start end) + (if (>= end start) + (do* ((noctets 0) + (i start (1+ i))) + ((= i end) noctets) + (declare (fixnum noctets)) + (let* ((code (,from-ucs (char-code (schar string i))))) + (if code + (incf noctets ,length-by-code) + (incf noctets)))) + 0)) + :length-of-vector-encoding-function + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i start) + (nchars 0)) + ((>= i end) + (values nchars i)) + (declare (fixnum i)) + (let* ((1st-unit (aref vector i)) + (nexti (+ i ,length-by-1st-unit))) + (declare (type (unsigned-byte 8) 1st-unit)) + (if (> nexti end) + (return (values nchars i)) + (setq nchars (1+ nchars) i nexti))))) + :length-of-memory-encoding-function + (lambda (pointer noctets start) + (do* ((i start) + (end (+ start noctets)) + (nchars 0 (1+ nchars))) + ((= i end) (values nchars (- i start))) + (let* ((1st-unit (%get-unsigned-byte pointer i)) + (nexti (+ i ,length-by-1st-unit))) + (declare (type (unsigned-byte 8) 1st-unit)) + (if (> nexti end) + (return (values nchars (- i start))) + (setq i nexti))))) + :decode-literal-code-unit-limit #x80 + :encode-literal-char-code-limit #x80 + :character-size-in-octets-function + (lambda (c) + (let ((code (,from-ucs (char-code c)))) + (if code + ,length-by-code + 1))))) + + +(define-jp-encoding :euc-jp + "An 8-bit, variable-length character encoding in which +character code points in the range #x00-#x7f can be encoded in a +single octet; characters with larger code values can be encoded +in 2 to 3 bytes." + '(:eucjp) + 3 + ucs-to-eucjp + eucjp-to-ucs + (cond ((< code #x100) 1) + ((< code #x10000) 2) + (t 3)) + (cond ((= 1st-unit #x8f) + 3) + ((or (= 1st-unit #x8e) + (< #xa0 1st-unit #xff)) + 2) + (t 1))) + +(define-jp-encoding :windows-31j + "An 8-bit, variable-length character encoding in which +character code points in the range #x00-#x7f can be encoded in a +single octet; characters with larger code values can be encoded +in 2 bytes." + '(:cp932 :csWindows31J) + 2 + ucs-to-cp932 + cp932-to-ucs + (cond ((< code #x100) 1) + (t 2)) + (cond ((or (<= #x81 1st-unit #x9f) + (<= #xe0 1st-unit #xfc)) + 2) + (t 1))) Index: /branches/qres/ccl/library/leaks.lisp =================================================================== --- /branches/qres/ccl/library/leaks.lisp (revision 13564) +++ /branches/qres/ccl/library/leaks.lisp (revision 13564) @@ -0,0 +1,462 @@ +;;;-*-Mode: LISP; Package: ccl -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; leaks.lisp +; A few functions to help in finding memory leaks + +(in-package :ccl) + +(export '(find-referencers + transitive-referencers + map-heap-objects + #+linux-target parse-proc-maps + #+linux-target proc-maps-diff + )) + +(defun map-heap-objects (fn &key area) + (flet ((mapper (thing) + (when (eq (typecode thing) target::subtag-function) + (setq thing (function-vector-to-function thing))) + (when (eq (typecode thing) target::subtag-symbol) + (setq thing (symvector->symptr thing))) + (funcall fn thing))) + (declare (dynamic-extent #'mapper)) + (%map-areas #'mapper area))) + +;; Returns all objects that satisfy predicate of one of the types in +;; ccl::*heap-utilization-vector-type-names* +;; Note that these can contain stack-consed objects that are dead. +;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objects +;; (ccl::heap-utilization) prints a useful list of object counts and sizes +;; per type. +(defun all-objects-of-type (type &optional predicate) + (let ((typecode (position type ccl::*heap-utilization-vector-type-names*)) + (res nil)) + (when typecode + (flet ((mapper (thing) + (when (and (eq typecode (ccl::typecode thing)) + (or (null predicate) (funcall predicate thing))) + (push thing res)))) + (declare (dynamic-extent #'mapper)) + (ccl::%map-areas #'mapper)) + res))) + +;; Counts objects that satisfy predicate of one of the types in +;; ccl::*heap-utilization-vector-type-names* +(defun count-objects-of-type (type &optional predicate) + (let ((typecode (position type ccl::*heap-utilization-vector-type-names*)) + (res 0)) + (when typecode + (flet ((mapper (thing) + (when (and (eq typecode (ccl::typecode thing)) + (or (null predicate) (funcall predicate thing))) + (incf res)))) + (declare (dynamic-extent #'mapper)) + (ccl::%map-areas #'mapper)) + res))) + +(defun count-conses () + (let ((res 0)) + (flet ((mapper (thing) + (when (consp thing) (incf res)))) + (declare (dynamic-extent #'mapper)) + (ccl::%map-areas #'mapper)) + res)) + +;; Like set-difference, but uses a hash table to go faster. +(defun fast-set-difference (list1 list2 &optional (test #'eq)) + (let ((hash (make-hash-table :test test)) + (res nil)) + (dolist (e1 list1) (setf (gethash e1 hash) t)) + (dolist (e2 list2) (remhash e2 hash)) + (maphash (lambda (k v) + (declare (ignore v)) + (push k res)) + hash) + res)) + +;; Returns all heap references to object. By default, includes +;; includes references from readonly, static and dynamic areas. +(defun find-referencers (object &optional area) + (let ((res nil)) + (ccl::%map-areas + (lambda (thing) + (cond ((and (not (eq thing object)) + (ccl::uvectorp thing) + (not (ccl::ivectorp thing))) + (dotimes (i (ccl::uvsize thing)) + (when (eq object (ccl::uvref thing i)) + (push thing res) + (return)))) + ((consp thing) + (when(or (eq object (car thing)) + (eq object (cdr thing))) + (push thing res))))) + area) + res)) + +;; Return true if P is heap-consed +(defun pointer-in-some-dynamic-area-p (p) + (block found + (do-gc-areas (a) + (when (eql (%fixnum-ref a target::area.code) ccl::area-dynamic) + (when (ccl::%ptr-in-area-p p a) + (return-from found t)))))) + +;; Find all transitive referencers to any object in the list +;; Returns a hash table with the references as keys. +(defun transitive-referencers (list-of-objects &key area (verbose t)) + (let ((found (make-hash-table :test 'eq)) + (objects (if (atom list-of-objects) (list list-of-objects) list-of-objects))) + (loop for cons on objects + do (setf (gethash cons found) t + (gethash (car cons) found) t)) + (ccl:gc) + (when verbose (format t "Searching") (finish-output)) + (loop + (let ((added-one nil)) + (when verbose (format t " ~d" (hash-table-count found)) (finish-output)) + (ccl::%map-areas + (lambda (thing) + (unless (gethash thing found) + (when (cond ((eq (typecode thing) target::subtag-function) + (lfunloop for object in (function-vector-to-function thing) + thereis (gethash object found))) + ((and (gvectorp thing) + (not (eq thing (ccl::nhash.vector found))) + (not (eq thing found)) + (not (packagep thing))) + (dotimes (i (ccl::uvsize thing)) + (when (gethash (%svref thing i) found) (return t)))) + ((consp thing) + (or (gethash (%car thing) found) + (gethash (%cdr thing) found)))) + (setf (gethash thing found) t + added-one t) + (when (eq (typecode thing) target::subtag-function) + (setf (gethash (function-vector-to-function thing) found) t)) + (when (eq (typecode thing) target::subtag-symbol) + (setf (gethash (symvector->symptr thing) found) t))))) + area) + (unless added-one + (return)))) + (when verbose (format t " done.~%") (finish-output)) + ;; Eliminate any cons that is referenced by another cons. + ;; Also eliminate or replace objects that nobody will want to see. + (let ((cons-refs (make-hash-table :test 'eq))) + (loop for cons being the hash-keys of found + when (consp cons) + do + (when (consp (car cons)) + (setf (gethash (car cons) cons-refs) t)) + (when (consp (cdr cons)) + (setf (gethash (cdr cons) cons-refs) t))) + (loop for key being the hash-keys of found + when (or (and (consp key) (gethash key cons-refs)) + (and (consp key) (eq (car key) '%function-source-note)) + (typep key 'hash-table-vector) + (and (typep key 'slot-vector) + (gethash (slot-vector.instance key) found)) + #+x8664-target (typep key 'symbol-vector) + #+x8664-target (typep key 'function-vector) + ) + do + (remhash key found)) + (loop for cons on objects + do + (remhash cons found) + (remhash (car cons) found))) + found)) + +;; One convenient way to print the hash table returned by transitive-referencers +(defun print-referencers (hash &key + predicate + (pause-period 20) + (print-circle t) + (print-length 20) + (print-level 5)) + (let ((cnt 0) + (*print-circle* print-circle) + (*print-length* print-length) + (*print-level* print-level)) + (maphash (lambda (key value) + (declare (ignore value)) + (when (or (null predicate) (funcall predicate key)) + (format t "~s~%" key) + (when (> (incf cnt) pause-period) + (format t "Continue (Y/N)? ") + (unless (equalp (read-line) "Y") + (return-from print-referencers)) + (setq cnt 0)))) + hash))) + +;; Returns all the obsolete CLOS instances, those whose class has been +;; changed since they were created. Each will be updated as soon as +;; method dispatch is done on it." +(defun obsolete-instances (list) + (let ((res nil)) + (dolist (i list) + (when (eq 0 (ccl::%wrapper-hash-index (ccl::instance-class-wrapper i))) + (push i res))) + res)) + +;; Linux-only malloc leak finding +#+linux-target +(progn + +;; (ccl::start-mtrace LOGFILE) +;; Do some work. +;; (ccl::stop-mtrace) +;; (ccl::parse-mtrace-log LOGFILE) +(defun start-mtrace (log-file &key gc-first) + (delete-file log-file) + (touch log-file) + (setenv "MALLOC_TRACE" (native-translated-namestring (truename log-file))) + (when gc-first (gc)) + (#_mtrace)) + +(defun stop-mtrace (&key gc-first) + (when gc-first (gc)) + (#_muntrace)) + +(defun parse-mtrace-log (log-file &key (duplicate-alloc :show) + (unmatched-free :collect) + (failed-realloc :show) + (hash (make-hash-table :test 'eql)) + (id nil)) + (let ((errors nil)) + (with-open-file (stream log-file) + (loop for line = (read-line stream nil nil) while line + as pos = (if (and (> (length line) 2) (eql (aref line 0) #\@) (eql (aref line 1) #\space)) + (1+ (position #\space line :start 2)) + 0) + as address = (let ((npos (+ pos 2))) + (when (and (< (+ npos 2) (length line)) + (eql (aref line npos) #\0) + (eql (aref line (1+ npos)) #\x)) + (parse-integer line :radix 16 + :start (+ npos 2) + :end (position #\space line :start npos)))) + as last-data = (gethash address hash) + do (ecase (aref line pos) + ((#\+ #\>) + (let ((this-data (if id (cons id line) line))) + (if last-data + (ecase duplicate-alloc + (:collect (push (list :duplicate + (if (eq (aref line pos) #\+) :alloc :realloc) + last-data this-data) + errors)) + ((:show nil) (format t "Duplicate ~a:~%~a~%~a~%" + (if (eq (aref line pos) #\+) "alloc" "realloc") + last-data this-data)) + (:ignore nil)) + (setf (gethash address hash) this-data)))) + ((#\- #\<) + (if last-data + (remhash address hash) + (let ((this-data (if id (cons id line) line))) + (ecase unmatched-free + (:collect (push (list :unmatched + (if (eq (aref line pos) #\-) :free :realloc) + this-data) + errors)) + ((:show nil) (format t "Unmatched ~a: ~a~%" + (if (eq (aref line pos) #\-) "free" "realloc") + this-data)) + (:ignore nil))))) + ((#\=) ;; ignore start/end + ;; (format t "~&~a" line) + nil) + ((#\!) + (let ((this-data (if id (cons id line) line))) + (ecase failed-realloc + (:collect (push (list :failed :realloc this-data) errors)) + ((:show nil) (format t "Failed realloc: ~a" this-data)) + (:ignore nil))))))) + (values (nreverse errors) hash))) + +(defun pretty-print-mtrace-summary (log-file) + (multiple-value-bind (errors malloc-hash) (parse-mtrace-log log-file) + (let* ((malloc-sum 0) + (malloc-count 0) + (free-count 0)) + (when (> (hash-table-count malloc-hash) 0) + (format t "~&Malloced but not freed:~%") + (loop for line being the hash-value of malloc-hash + do (let* ((plus-pos (or (search " + " line) (search " > " line))) + (size-pos (position #\space line :start (+ plus-pos 3)))) + (incf malloc-count) + (incf malloc-sum (parse-integer line :radix 16 :start (+ size-pos 3))) + (format t "~& ~A" line)))) + (when (find :unmatched errors :key #'car) + (format t "~&Freed but not malloced:~%") + (loop for (type nil line) in errors + do (when (eq type :unmatched) + (incf free-count) + (format t " ~a" line)))) + (format t "~&~aK in ~a mallocs not freed, ~A frees not malloced" + (/ malloc-sum 1024.0) + malloc-count + free-count))) + (values)) + + +;; Return the total number of bytes allocated by malloc() +(defun mallinfo () + (ccl:rlet ((mallinfo :mallinfo)) + (#_mallinfo mallinfo) + (ccl::rref mallinfo :mallinfo.uordblks))) + +#|| +http://www.gnu.org/s/libc/manual/html_node/Statistics-of-Malloc.html + +int arena + This is the total size of memory allocated with sbrk by malloc, in bytes. +int ordblks + This is the number of chunks not in use. (The memory allocator internally gets chunks of memory from the operating system, and then carves them up to satisfy individual malloc requests; see Efficiency and Malloc.) +int smblks + This field is unused. +int hblks + This is the total number of chunks allocated with mmap. +int hblkhd + This is the total size of memory allocated with mmap, in bytes. +int usmblks + This field is unused. +int fsmblks + This field is unused. +int uordblks + This is the total size of memory occupied by chunks handed out by malloc. +int fordblks + This is the total size of memory occupied by free (not in use) chunks. +int keepcost + This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space's data segment). +||# + +(defun show-malloc-info () + (rlet ((info :mallinfo)) + (#_mallinfo info) ;struct return invisible arg. + (let* ((arena (pref info :mallinfo.arena)) + (ordblks (pref info :mallinfo.ordblks)) + (hblks (pref info :mallinfo.hblks)) + (hblkhd (pref info :mallinfo.hblkhd)) + (uordblks (pref info :mallinfo.uordblks)) + (fordblks (pref info :mallinfo.fordblks)) + (keepcost (pref info :mallinfo.keepcost))) + (format t "~& arena size: ~d (#x~x)" arena arena) + (format t "~& number of unused chunks = ~d" ordblks) + (format t "~& number of mmap'ed chunks = ~d" hblks) + (format t "~& total size of mmap'ed chunks = ~d (#x~x)" hblkhd hblkhd) + (format t "~& total size of malloc'ed chunks = ~d (#x~x)" uordblks uordblks) + (format t "~& total size of free chunks = ~d (#x~x)" fordblks fordblks) + (format t "~& size of releaseable chunk = ~d (#x~x)" keepcost keepcost)))) + + + +;; Parse /proc//maps +;; returns a list of (address perms name total-size clean-size dirty-size) +(defun parse-proc-maps (&optional (pid (ccl::getpid))) + (let ((perm-cache ()) + (name-cache ())) + (with-open-file (s (or (probe-file (format nil "/proc/~d/smaps" pid)) + (format nil "/proc/~d/maps" pid))) + (loop with current = nil + for line = (read-line s nil) while line + if (find #\- line) + collect (let* ((low-end (position #\- line)) + (high-end (position #\space line :start (1+ low-end))) + (perms-end (position #\space line :start (1+ high-end))) + (offset-end (position #\space line :start (1+ perms-end))) + (device-end (position #\space line :start (1+ offset-end))) + (inode-end (position #\space line :start (1+ device-end))) + (name-start (position #\space line :start inode-end :test-not #'eql)) + (low (parse-integer line :start 0 :end low-end :radix 16)) + (high (parse-integer line :start (1+ low-end) :end high-end :radix 16)) + (perms (let ((p (subseq line (1+ high-end) perms-end))) + (or (find p perm-cache :test #'equal) + (car (setq perm-cache (cons p perm-cache)))))) + (name (and name-start + (let ((f (subseq line name-start))) + (or (find f name-cache :test #'equal) + (car (setq name-cache (cons f name-cache)))))))) + (setq current (list low perms name (- high low) nil nil))) + else do (let* ((key-end (position #\: line)) + (size-start (position #\space line :start (1+ key-end) :test-not #'eql)) + (size-end (position #\space line :start (1+ size-start))) + (size (parse-integer line :start size-start :end size-end :radix 10))) + (assert (string-equal " kB" line :start2 size-end)) + (assert current) + (setq size (* size 1024)) + (macrolet ((is (string) + `(and (eql key-end ,(length string)) + (string-equal ,string line :end2 key-end)))) + (cond ((or (is "Shared_Clean") (is "Private_Clean")) + (setf (nth 4 current) (+ (or (nth 4 current) 0) size))) + ((or (is "Shared_Dirty") (is "Private_Dirty")) + (setf (nth 5 current) (+ (or (nth 5 current) 0) size)))))))))) + +(defun proc-maps-diff (map1 map2) + ;; Compute change from map1 to map2, return a list of (old-sect . new-sect) + (let ((added (copy-list map2)) + (changed nil)) + (loop for m1 in map1 as match = (find (car m1) added :key #'car) + do (when match + (if (and (equal (nth 1 m1) (nth 1 match)) (equal (nth 2 m1) (nth 2 match))) + (setq added (delete match added)) + (setq match nil))) + do (unless (equalp m1 match) + (push (list m1 match) changed))) + (loop for new in added do (push (list nil new) changed)) + changed)) + +) ;; end of linux-only code + +(defun get-allocation-sentinel (&key (gc-first t)) + ;; Return the object with the highest address that can be guaranteed to be at a lower + ;; address than any newer objects. + ;; If gc-first is true, can also conversely guarantee that all older objects are at a + ;; lower address than the sentinel. If gc-first is false, than there may be some + ;; already-allocated objects at higher addresses, though no more than the size of the + ;; youngest generation (and usually even less than that). Second value returned is the + ;; size of the active region above the sentinel. + (with-other-threads-suspended + (when gc-first (gc)) ;; get rid of thread allocation chunks. Wish could just egc... + ;; This mustn't cons. + (let* ((first-area (%normalize-areas)) ;; youngest generation + (min-base (loop with current = (%current-tcr) + for tcr = (%fixnum-ref current target::tcr.next) + then (%fixnum-ref tcr target::tcr.next) + as base fixnum = (%fixnum-ref tcr target::tcr.save-allocbase) + when (> base 0) + minimize base + until (eql tcr current))) + (active (%fixnum-ref first-area target::area.active)) + (limit (if (eql min-base 0) active min-base)) + (last-obj nil)) + ;; Normally will find it in the youngest generation, but loop in case limit = area.low. + (block walk + (flet ((skip (obj) + (declare (optimize (speed 3) (safety 0))) ;; lie + (unless (%i< obj limit) + (return-from walk)) + (setq last-obj obj))) + (declare (dynamic-extent #'skip)) + (loop for area = first-area then (%fixnum-ref area target::area.succ) + until (neq (%fixnum-ref area target::area.code) area-dynamic) + when (< (%fixnum-ref area target::area.low) (%fixnum-ref area target::area.active)) + do (walk-static-area area #'skip)))) + (values last-obj (%i- active limit))))) + Index: /branches/qres/ccl/library/lisp-package.lisp =================================================================== --- /branches/qres/ccl/library/lisp-package.lisp (revision 13564) +++ /branches/qres/ccl/library/lisp-package.lisp (revision 13564) @@ -0,0 +1,1650 @@ +;;;-*-Mode: LISP; Package: ccl -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; lisp-package.lisp +; Define a lisp package that attempts to behave like CLTL-1. + +(in-package "CCL") + +(defpackage "LISP" + (:use ) + (:import-from "COMMON-LISP" + "&ALLOW-OTHER-KEYS" + "&AUX" + "&BODY" + "&ENVIRONMENT" + "&KEY" + "&OPTIONAL" + "&REST" + "&WHOLE" + "*" + "**" + "***" + "*DEBUG-IO*" + "*DEFAULT-PATHNAME-DEFAULTS*" + "*ERROR-OUTPUT*" + "*FEATURES*" + "*LOAD-VERBOSE*" + "*MACROEXPAND-HOOK*" + "*PACKAGE*" + "*PRINT-ARRAY*" + "*PRINT-BASE*" + "*PRINT-CASE*" + "*PRINT-CIRCLE*" + "*PRINT-ESCAPE*" + "*PRINT-GENSYM*" + "*PRINT-LENGTH*" + "*PRINT-LEVEL*" + "*PRINT-PRETTY*" + "*PRINT-RADIX*" + "*QUERY-IO*" + "*RANDOM-STATE*" + "*READ-BASE*" + "*READ-DEFAULT-FLOAT-FORMAT*" + "*READ-SUPPRESS*" + "*READTABLE*" + "*STANDARD-INPUT*" + "*STANDARD-OUTPUT*" + "*TERMINAL-IO*" + "*TRACE-OUTPUT*" + "+" + "++" + "+++" + "-" + "/" + "//" + "///" + "/=" + "1+" + "1-" + "<" + "<=" + "=" + ">" + ">=" + "ABS" + "ACONS" + "ACOS" + "ACOSH" + "ADJOIN" + "ADJUST-ARRAY" + "ADJUSTABLE-ARRAY-P" + "ALPHA-CHAR-P" + "ALPHANUMERICP" + "AND" + "APPEND" + "APPLY" + "APROPOS" + "APROPOS-LIST" + "AREF" + "ARRAY" + "ARRAY-DIMENSION" + "ARRAY-DIMENSION-LIMIT" + "ARRAY-DIMENSIONS" + "ARRAY-ELEMENT-TYPE" + "ARRAY-HAS-FILL-POINTER-P" + "ARRAY-IN-BOUNDS-P" + "ARRAY-RANK" + "ARRAY-RANK-LIMIT" + "ARRAY-ROW-MAJOR-INDEX" + "ARRAY-TOTAL-SIZE" + "ARRAY-TOTAL-SIZE-LIMIT" + "ARRAYP" + "ASH" + "ASIN" + "ASINH" + "ASSERT" + "ASSOC" + "ASSOC-IF" + "ASSOC-IF-NOT" + "ATAN" + "ATANH" + "ATOM" + "BIGNUM" + "BIT" + "BIT-AND" + "BIT-ANDC1" + "BIT-ANDC2" + "BIT-EQV" + "BIT-IOR" + "BIT-NAND" + "BIT-NOR" + "BIT-NOT" + "BIT-ORC1" + "BIT-ORC2" + "BIT-VECTOR" + "BIT-VECTOR-P" + "BIT-XOR" + "BLOCK" + "BOOLE" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "BOTH-CASE-P" + "BOUNDP" + "BREAK" + "BUTLAST" + "BYTE" + "BYTE-POSITION" + "BYTE-SIZE" + "CAAAAR" + "CAAADR" + "CAAAR" + "CAADAR" + "CAADDR" + "CAADR" + "CAAR" + "CADAAR" + "CADADR" + "CADAR" + "CADDAR" + "CADDDR" + "CADDR" + "CADR" + "CALL-ARGUMENTS-LIMIT" + "CAR" + "CASE" + "CATCH" + "CCASE" + "CDAAAR" + "CDAADR" + "CDAAR" + "CDADAR" + "CDADDR" + "CDADR" + "CDAR" + "CDDAAR" + "CDDADR" + "CDDAR" + "CDDDAR" + "CDDDDR" + "CDDDR" + "CDDR" + "CDR" + "CEILING" + "CERROR" + "CHAR" + "CHAR-CODE" + "CHAR-CODE-LIMIT" + "CHAR-DOWNCASE" + "CHAR-EQUAL" +; "CHAR-FONT" + "CHAR-GREATERP" + "CHAR-INT" + "CHAR-LESSP" + "CHAR-NAME" + "CHAR-NOT-EQUAL" + "CHAR-NOT-GREATERP" + "CHAR-NOT-LESSP" + "CHAR-UPCASE" + "CHAR/=" + "CHAR<" + "CHAR<=" + "CHAR=" + "CHAR>" + "CHAR>=" + "CHARACTER" + "CHARACTERP" + "CHECK-TYPE" + "CIS" + "CLEAR-INPUT" + "CLEAR-OUTPUT" + "CLOSE" + "CLRHASH" + "CODE-CHAR" + "COERCE" + "COMPILATION-SPEED" + "COMPILE" + "COMPILE-FILE" + "COMPILED-FUNCTION" + "COMPILED-FUNCTION-P" + "COMPLEX" + "COMPLEXP" + "CONCATENATE" + "COND" + "CONJUGATE" + "CONS" + "CONSP" + "CONSTANTP" + "COPY-ALIST" + "COPY-LIST" + "COPY-READTABLE" + "COPY-SEQ" + "COPY-SYMBOL" + "COPY-TREE" + "COS" + "COSH" + "COUNT" + "COUNT-IF" + "COUNT-IF-NOT" + "CTYPECASE" + "DECF" + "DECLARATION" + "DECLARE" + "DECODE-FLOAT" + "DECODE-UNIVERSAL-TIME" + "DEFCONSTANT" + "DEFINE-MODIFY-MACRO" + "DEFMACRO" + "DEFPARAMETER" + "DEFSETF" + "DEFSTRUCT" + "DEFTYPE" + "DEFUN" + "DEFVAR" + "DELETE" + "DELETE-DUPLICATES" + "DELETE-FILE" + "DELETE-IF" + "DELETE-IF-NOT" + "DENOMINATOR" + "DEPOSIT-FIELD" + "DESCRIBE" + "DIGIT-CHAR-P" + "DIRECTORY" + "DIRECTORY-NAMESTRING" + "DISASSEMBLE" + "DO" + "DO*" + "DO-ALL-SYMBOLS" + "DO-EXTERNAL-SYMBOLS" + "DO-SYMBOLS" + "DOCUMENTATION" + "DOLIST" + "DOTIMES" + "DOUBLE-FLOAT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "DPB" + "DRIBBLE" + "ECASE" + "ED" + "EIGHTH" + "ELT" + "ENCODE-UNIVERSAL-TIME" + "ENDP" + "ENOUGH-NAMESTRING" + "EQ" + "EQL" + "EQUAL" + "EQUALP" + "ERROR" + "ETYPECASE" + "EVAL" + "EVAL-WHEN" + "EVENP" + "EVERY" + "EXP" + "EXPT" + "FBOUNDP" + "FCEILING" + "FFLOOR" + "FIFTH" + "FILE-AUTHOR" + "FILE-LENGTH" + "FILE-NAMESTRING" + "FILE-POSITION" + "FILE-WRITE-DATE" + "FILL" + "FILL-POINTER" + "FIND" + "FIND-ALL-SYMBOLS" + "FIND-IF" + "FIND-IF-NOT" + "FIND-PACKAGE" + "FIND-SYMBOL" + "FINISH-OUTPUT" + "FIRST" + "FIXNUM" + "FLET" + "FLOAT" + "FLOAT-DIGITS" + "FLOAT-PRECISION" + "FLOAT-RADIX" + "FLOAT-SIGN" + "FLOATP" + "FLOOR" + "FMAKUNBOUND" + "FORCE-OUTPUT" + "FORMAT" + "FOURTH" + "FRESH-LINE" + "FROUND" + "FTRUNCATE" + "FTYPE" + "FUNCALL" + "FUNCTION" + "GCD" + "GENSYM" + "GENTEMP" + "GET" + "GET-DECODED-TIME" + "GET-DISPATCH-MACRO-CHARACTER" + "GET-INTERNAL-REAL-TIME" + "GET-INTERNAL-RUN-TIME" + "GET-MACRO-CHARACTER" + "GET-OUTPUT-STREAM-STRING" + "GET-PROPERTIES" + "GET-UNIVERSAL-TIME" + "GETF" + "GETHASH" + "GO" + "GRAPHIC-CHAR-P" + "HASH-TABLE" + "HASH-TABLE-COUNT" + "HASH-TABLE-P" + "HOST-NAMESTRING" + "IDENTITY" + "IF" + "IGNORE" + "IMAGPART" + "INCF" + "INLINE" + "INPUT-STREAM-P" + "INSPECT" + "INTEGER" + "INTEGER-DECODE-FLOAT" + "INTEGER-LENGTH" + "INTEGERP" + "INTERN" + "INTERNAL-TIME-UNITS-PER-SECOND" + "INTERSECTION" + "ISQRT" + "KEYWORD" + "KEYWORDP" + "LABELS" + "LAMBDA" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LAST" + "LCM" + "LDB" + "LDB-TEST" + "LDIFF" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LENGTH" + "LET" + "LET*" + "LISP-IMPLEMENTATION-TYPE" + "LISP-IMPLEMENTATION-VERSION" + "LIST" + "LIST*" + "LIST-ALL-PACKAGES" + "LIST-LENGTH" + "LISTEN" + "LISTP" + "LOAD" + "LOCALLY" + "LOG" + "LOGAND" + "LOGANDC1" + "LOGANDC2" + "LOGBITP" + "LOGCOUNT" + "LOGEQV" + "LOGIOR" + "LOGNAND" + "LOGNOR" + "LOGNOT" + "LOGORC1" + "LOGORC2" + "LOGTEST" + "LOGXOR" + "LONG-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "LONG-SITE-NAME" + "LOOP" + "LOWER-CASE-P" + "MACHINE-INSTANCE" + "MACHINE-TYPE" + "MACHINE-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" + "MACROEXPAND-1" + "MACROLET" + "MAKE-ARRAY" + "MAKE-BROADCAST-STREAM" + "MAKE-CONCATENATED-STREAM" + "MAKE-DISPATCH-MACRO-CHARACTER" + "MAKE-ECHO-STREAM" + "MAKE-HASH-TABLE" + "MAKE-LIST" + "MAKE-PATHNAME" + "MAKE-RANDOM-STATE" + "MAKE-SEQUENCE" + "MAKE-STRING" + "MAKE-STRING-INPUT-STREAM" + "MAKE-STRING-OUTPUT-STREAM" + "MAKE-SYMBOL" + "MAKE-SYNONYM-STREAM" + "MAKE-TWO-WAY-STREAM" + "MAKUNBOUND" + "MAP" + "MAPC" + "MAPCAN" + "MAPCAR" + "MAPCON" + "MAPHASH" + "MAPL" + "MAPLIST" + "MASK-FIELD" + "MAX" + "MEMBER" + "MEMBER-IF" + "MEMBER-IF-NOT" + "MERGE" + "MERGE-PATHNAMES" + "MIN" + "MINUSP" + "MISMATCH" + "MOD" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MULTIPLE-VALUE-BIND" + "MULTIPLE-VALUE-CALL" + "MULTIPLE-VALUE-LIST" + "MULTIPLE-VALUE-PROG1" + "MULTIPLE-VALUE-SETQ" + "MULTIPLE-VALUES-LIMIT" + "NAME-CHAR" + "NAMESTRING" + "NBUTLAST" + "NCONC" + "NIL" + "NINTERSECTION" + "NINTH" + "NOT" + "NOTANY" + "NOTEVERY" + "NOTINLINE" + "NRECONC" + "NREVERSE" + "NSET-DIFFERENCE" + "NSET-EXCLUSIVE-OR" + "NSTRING-CAPITALIZE" + "NSTRING-DOWNCASE" + "NSTRING-UPCASE" + "NSUBLIS" + "NSUBST" + "NSUBST-IF" + "NSUBST-IF-NOT" + "NSUBSTITUTE" + "NSUBSTITUTE-IF" + "NSUBSTITUTE-IF-NOT" + "NTH" + "NTHCDR" + "NULL" + "NUMBER" + "NUMBERP" + "NUMERATOR" + "NUNION" + "ODDP" + "OPEN" + "OPTIMIZE" + "OR" + "OTHERWISE" + "OUTPUT-STREAM-P" + "PACKAGE" + "PACKAGE-NAME" + "PACKAGE-NICKNAMES" + "PACKAGE-SHADOWING-SYMBOLS" + "PACKAGE-USE-LIST" + "PACKAGE-USED-BY-LIST" + "PACKAGEP" + "PAIRLIS" + "PARSE-INTEGER" + "PARSE-NAMESTRING" + "PATHNAME" + "PATHNAME-DEVICE" + "PATHNAME-DIRECTORY" + "PATHNAME-HOST" + "PATHNAME-NAME" + "PATHNAME-TYPE" + "PATHNAME-VERSION" + "PATHNAMEP" + "PEEK-CHAR" + "PHASE" + "PI" + "PLUSP" + "POP" + "POSITION" + "POSITION-IF" + "POSITION-IF-NOT" + "PPRINT" + "PRIN1" + "PRIN1-TO-STRING" + "PRINC" + "PRINC-TO-STRING" + "PRINT" + "PROBE-FILE" + "PROCLAIM" + "PROG" + "PROG*" + "PROG1" + "PROG2" + "PROGN" + "PROGV" + "PSETF" + "PSETQ" + "PUSH" + "PUSHNEW" + "QUOTE" + "RANDOM" + "RANDOM-STATE" + "RANDOM-STATE-P" + "RASSOC" + "RASSOC-IF" + "RASSOC-IF-NOT" + "RATIO" + "RATIONAL" + "RATIONALIZE" + "RATIONALP" + "READ" + "READ-BYTE" + "READ-CHAR" + "READ-CHAR-NO-HANG" + "READ-DELIMITED-LIST" + "READ-FROM-STRING" + "READ-LINE" + "READ-PRESERVING-WHITESPACE" + "READTABLE" + "READTABLEP" + "REALPART" + "REDUCE" + "REM" + "REMF" + "REMHASH" + "REMOVE" + "REMOVE-DUPLICATES" + "REMOVE-IF" + "REMOVE-IF-NOT" + "REMPROP" + "RENAME-FILE" + "RENAME-PACKAGE" + "REPLACE" + "REST" + "RETURN" + "RETURN-FROM" + "REVAPPEND" + "REVERSE" + "ROOM" + "ROTATEF" + "ROUND" + "RPLACA" + "RPLACD" + "SAFETY" + "SATISFIES" + "SBIT" + "SCALE-FLOAT" + "SCHAR" + "SEARCH" + "SECOND" + "SEQUENCE" + "SET" +; "SET-CHAR-BIT" + "SET-DIFFERENCE" + "SET-DISPATCH-MACRO-CHARACTER" + "SET-EXCLUSIVE-OR" + "SET-MACRO-CHARACTER" + "SET-SYNTAX-FROM-CHAR" + "SETF" + "SETQ" + "SEVENTH" + "SHIFTF" + "SHORT-FLOAT" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SHORT-SITE-NAME" + "SIGNED-BYTE" + "SIGNUM" + "SIMPLE-ARRAY" + "SIMPLE-BIT-VECTOR" + "SIMPLE-BIT-VECTOR-P" + "SIMPLE-STRING" + "SIMPLE-STRING-P" + "SIMPLE-VECTOR" + "SIMPLE-VECTOR-P" + "SIN" + "SINGLE-FLOAT" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" + "SINH" + "SIXTH" + "SLEEP" + "SOFTWARE-TYPE" + "SOFTWARE-VERSION" + "SOME" + "SORT" + "SPACE" + "SPECIAL" + "SPEED" + "SQRT" + "STABLE-SORT" + "STANDARD-CHAR" + "STANDARD-CHAR-P" + "STEP" + "STREAM" + "STREAM-ELEMENT-TYPE" + "STREAMP" + "STRING" + "STRING-CAPITALIZE" +; "STRING-CHAR" +; "STRING-CHAR-P" + "STRING-DOWNCASE" + "STRING-EQUAL" + "STRING-GREATERP" + "STRING-LEFT-TRIM" + "STRING-LESSP" + "STRING-NOT-EQUAL" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP" + "STRING-RIGHT-TRIM" + "STRING-TRIM" + "STRING-UPCASE" + "STRING/=" + "STRING<" + "STRING<=" + "STRING=" + "STRING>" + "STRING>=" + "STRINGP" + "STRUCTURE" + "SUBLIS" + "SUBSEQ" + "SUBSETP" + "SUBST" + "SUBST-IF" + "SUBST-IF-NOT" + "SUBSTITUTE" + "SUBSTITUTE-IF" + "SUBSTITUTE-IF-NOT" + "SUBTYPEP" + "SVREF" + "SXHASH" + "SYMBOL" + "SYMBOL-FUNCTION" + "SYMBOL-NAME" + "SYMBOL-PACKAGE" + "SYMBOL-PLIST" + "SYMBOL-VALUE" + "SYMBOLP" + "T" + "TAGBODY" + "TAILP" + "TAN" + "TANH" + "TENTH" + "TERPRI" + "THE" + "THIRD" + "THROW" + "TIME" + "TRACE" + "TREE-EQUAL" + "TRUENAME" + "TRUNCATE" + "TYPE" + "TYPE-OF" + "TYPECASE" + "TYPEP" + "UNINTERN" + "UNION" + "UNLESS" + "UNREAD-CHAR" + "UNSIGNED-BYTE" + "UNTRACE" + "UNWIND-PROTECT" + "UPPER-CASE-P" + "USER-HOMEDIR-PATHNAME" + "VALUES" + "VALUES-LIST" + "VARIABLE" + "VECTOR" + "VECTOR-POP" + "VECTOR-PUSH" + "VECTOR-PUSH-EXTEND" + "VECTORP" + "WARN" + "WHEN" + "WITH-INPUT-FROM-STRING" + "WITH-OPEN-FILE" + "WITH-OPEN-STREAM" + "WITH-OUTPUT-TO-STRING" + "WRITE" + "WRITE-BYTE" + "WRITE-CHAR" + "WRITE-LINE" + "WRITE-STRING" + "WRITE-TO-STRING" + "Y-OR-N-P" + "YES-OR-NO-P" + "ZEROP" + "*MODULES*" + "PROVIDE" + "REQUIRE") + (:import-from "CCL" + "*BREAK-ON-WARNINGS*" + "COMPILER-LET" + "*APPLYHOOK*" + "*EVALHOOK*" + "APPLYHOOK" + "EVALHOOK" + "SPECIAL-FORM-P" + "GET-SETF-METHOD" + "GET-SETF-METHOD-MULTIPLE-VALUE" + "DEFINE-SETF-METHOD" +) + (:shadow "IN-PACKAGE" + "FUNCTIONP" + "MAKE-PACKAGE" + "SHADOW" + "SHADOWING-IMPORT" + "EXPORT" + "UNEXPORT" + "USE-PACKAGE" + "UNUSE-PACKAGE" + "IMPORT") + (:export + "&ALLOW-OTHER-KEYS" + "&AUX" + "&BODY" + "&ENVIRONMENT" + "&KEY" + "&OPTIONAL" + "&REST" + "&WHOLE" + "*" + "**" + "***" + "*APPLYHOOK*" + "*BREAK-ON-WARNINGS*" + "*DEBUG-IO*" + "*DEFAULT-PATHNAME-DEFAULTS*" + "*ERROR-OUTPUT*" + "*EVALHOOK*" + "*FEATURES*" + "*LOAD-VERBOSE*" + "*MODULES*" + "*MACROEXPAND-HOOK*" + "*PACKAGE*" + "*PRINT-ARRAY*" + "*PRINT-BASE*" + "*PRINT-CASE*" + "*PRINT-CIRCLE*" + "*PRINT-ESCAPE*" + "*PRINT-GENSYM*" + "*PRINT-LENGTH*" + "*PRINT-LEVEL*" + "*PRINT-PRETTY*" + "*PRINT-RADIX*" + "*QUERY-IO*" + "*RANDOM-STATE*" + "*READ-BASE*" + "*READ-DEFAULT-FLOAT-FORMAT*" + "*READ-SUPPRESS*" + "*READTABLE*" + "*STANDARD-INPUT*" + "*STANDARD-OUTPUT*" + "*TERMINAL-IO*" + "*TRACE-OUTPUT*" + "+" + "++" + "+++" + "-" + "/" + "//" + "///" + "/=" + "1+" + "1-" + "<" + "<=" + "=" + ">" + ">=" + "ABS" + "ACONS" + "ACOS" + "ACOSH" + "ADJOIN" + "ADJUST-ARRAY" + "ADJUSTABLE-ARRAY-P" + "ALPHA-CHAR-P" + "ALPHANUMERICP" + "AND" + "APPEND" + "APPLY" + "APPLYHOOK" + "APROPOS" + "APROPOS-LIST" + "AREF" + "ARRAY" + "ARRAY-DIMENSION" + "ARRAY-DIMENSION-LIMIT" + "ARRAY-DIMENSIONS" + "ARRAY-ELEMENT-TYPE" + "ARRAY-HAS-FILL-POINTER-P" + "ARRAY-IN-BOUNDS-P" + "ARRAY-RANK" + "ARRAY-RANK-LIMIT" + "ARRAY-ROW-MAJOR-INDEX" + "ARRAY-TOTAL-SIZE" + "ARRAY-TOTAL-SIZE-LIMIT" + "ARRAYP" + "ASH" + "ASIN" + "ASINH" + "ASSERT" + "ASSOC" + "ASSOC-IF" + "ASSOC-IF-NOT" + "ATAN" + "ATANH" + "ATOM" + "BIGNUM" + "BIT" + "BIT-AND" + "BIT-ANDC1" + "BIT-ANDC2" + "BIT-EQV" + "BIT-IOR" + "BIT-NAND" + "BIT-NOR" + "BIT-NOT" + "BIT-ORC1" + "BIT-ORC2" + "BIT-VECTOR" + "BIT-VECTOR-P" + "BIT-XOR" + "BLOCK" + "BOOLE" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "BOTH-CASE-P" + "BOUNDP" + "BREAK" + "BUTLAST" + "BYTE" + "BYTE-POSITION" + "BYTE-SIZE" + "CAAAAR" + "CAAADR" + "CAAAR" + "CAADAR" + "CAADDR" + "CAADR" + "CAAR" + "CADAAR" + "CADADR" + "CADAR" + "CADDAR" + "CADDDR" + "CADDR" + "CADR" + "CALL-ARGUMENTS-LIMIT" + "CAR" + "CASE" + "CATCH" + "CCASE" + "CDAAAR" + "CDAADR" + "CDAAR" + "CDADAR" + "CDADDR" + "CDADR" + "CDAR" + "CDDAAR" + "CDDADR" + "CDDAR" + "CDDDAR" + "CDDDDR" + "CDDDR" + "CDDR" + "CDR" + "CEILING" + "CERROR" + "CHAR" + "CHAR-BIT" + "CHAR-BITS" + "CHAR-BITS-LIMIT" + "CHAR-CODE" + "CHAR-CODE-LIMIT" + "CHAR-CONTROL-BIT" + "CHAR-DOWNCASE" + "CHAR-EQUAL" + "CHAR-FONT" + "CHAR-FONT-LIMIT" + "CHAR-GREATERP" + "CHAR-HYPER-BIT" + "CHAR-INT" + "CHAR-LESSP" + "CHAR-META-BIT" + "CHAR-NAME" + "CHAR-NOT-EQUAL" + "CHAR-NOT-GREATERP" + "CHAR-NOT-LESSP" + "CHAR-SUPER-BIT" + "CHAR-UPCASE" + "CHAR/=" + "CHAR<" + "CHAR<=" + "CHAR=" + "CHAR>" + "CHAR>=" + "CHARACTER" + "CHARACTERP" + "CHECK-TYPE" + "CIS" + "CLEAR-INPUT" + "CLEAR-OUTPUT" + "CLOSE" + "CLRHASH" + "CODE-CHAR" + "COERCE" + "COMMON" + "COMMONP" + "COMPILATION-SPEED" + "COMPILE" + "COMPILE-FILE" + "COMPILED-FUNCTION" + "COMPILED-FUNCTION-P" + "COMPILER-LET" + "COMPLEX" + "COMPLEXP" + "CONCATENATE" + "COND" + "CONJUGATE" + "CONS" + "CONSP" + "CONSTANTP" + "COPY-ALIST" + "COPY-LIST" + "COPY-READTABLE" + "COPY-SEQ" + "COPY-SYMBOL" + "COPY-TREE" + "COS" + "COSH" + "COUNT" + "COUNT-IF" + "COUNT-IF-NOT" + "CTYPECASE" + "DECF" + "DECLARATION" + "DECLARE" + "DECODE-FLOAT" + "DECODE-UNIVERSAL-TIME" + "DEFCONSTANT" + "DEFINE-MODIFY-MACRO" + "DEFINE-SETF-METHOD" + "DEFMACRO" + "DEFPARAMETER" + "DEFSETF" + "DEFSTRUCT" + "DEFTYPE" + "DEFUN" + "DEFVAR" + "DELETE" + "DELETE-DUPLICATES" + "DELETE-FILE" + "DELETE-IF" + "DELETE-IF-NOT" + "DENOMINATOR" + "DEPOSIT-FIELD" + "DESCRIBE" + "DIGIT-CHAR" + "DIGIT-CHAR-P" + "DIRECTORY" + "DIRECTORY-NAMESTRING" + "DISASSEMBLE" + "DO" + "DO*" + "DO-ALL-SYMBOLS" + "DO-EXTERNAL-SYMBOLS" + "DO-SYMBOLS" + "DOCUMENTATION" + "DOLIST" + "DOTIMES" + "DOUBLE-FLOAT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "DPB" + "DRIBBLE" + "ECASE" + "ED" + "EIGHTH" + "ELT" + "ENCODE-UNIVERSAL-TIME" + "ENDP" + "ENOUGH-NAMESTRING" + "EQ" + "EQL" + "EQUAL" + "EQUALP" + "ERROR" + "ETYPECASE" + "EVAL" + "EVAL-WHEN" + "EVALHOOK" + "EVENP" + "EVERY" + "EXP" + "EXPORT" + "EXPT" + "FBOUNDP" + "FCEILING" + "FFLOOR" + "FIFTH" + "FILE-AUTHOR" + "FILE-LENGTH" + "FILE-NAMESTRING" + "FILE-POSITION" + "FILE-WRITE-DATE" + "FILL" + "FILL-POINTER" + "FIND" + "FIND-ALL-SYMBOLS" + "FIND-IF" + "FIND-IF-NOT" + "FIND-PACKAGE" + "FIND-SYMBOL" + "FINISH-OUTPUT" + "FIRST" + "FIXNUM" + "FLET" + "FLOAT" + "FLOAT-DIGITS" + "FLOAT-PRECISION" + "FLOAT-RADIX" + "FLOAT-SIGN" + "FLOATP" + "FLOOR" + "FMAKUNBOUND" + "FORCE-OUTPUT" + "FORMAT" + "FOURTH" + "FRESH-LINE" + "FROUND" + "FTRUNCATE" + "FTYPE" + "FUNCALL" + "FUNCTION" + "FUNCTIONP" + "GCD" + "GENSYM" + "GENTEMP" + "GET" + "GET-DECODED-TIME" + "GET-DISPATCH-MACRO-CHARACTER" + "GET-INTERNAL-REAL-TIME" + "GET-INTERNAL-RUN-TIME" + "GET-MACRO-CHARACTER" + "GET-OUTPUT-STREAM-STRING" + "GET-PROPERTIES" + "GET-SETF-METHOD" + "GET-SETF-METHOD-MULTIPLE-VALUE" + "GET-UNIVERSAL-TIME" + "GETF" + "GETHASH" + "GO" + "GRAPHIC-CHAR-P" + "HASH-TABLE" + "HASH-TABLE-COUNT" + "HASH-TABLE-P" + "HOST-NAMESTRING" + "IDENTITY" + "IF" + "IGNORE" + "IMAGPART" + "IMPORT" + "IN-PACKAGE" + "INCF" + "INLINE" + "INPUT-STREAM-P" + "INSPECT" + "INT-CHAR" + "INTEGER" + "INTEGER-DECODE-FLOAT" + "INTEGER-LENGTH" + "INTEGERP" + "INTERN" + "INTERNAL-TIME-UNITS-PER-SECOND" + "INTERSECTION" + "ISQRT" + "KEYWORD" + "KEYWORDP" + "LABELS" + "LAMBDA" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LAST" + "LCM" + "LDB" + "LDB-TEST" + "LDIFF" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LENGTH" + "LET" + "LET*" + "LISP-IMPLEMENTATION-TYPE" + "LISP-IMPLEMENTATION-VERSION" + "LIST" + "LIST*" + "LIST-ALL-PACKAGES" + "LIST-LENGTH" + "LISTEN" + "LISTP" + "LOAD" + "LOCALLY" + "LOG" + "LOGAND" + "LOGANDC1" + "LOGANDC2" + "LOGBITP" + "LOGCOUNT" + "LOGEQV" + "LOGIOR" + "LOGNAND" + "LOGNOR" + "LOGNOT" + "LOGORC1" + "LOGORC2" + "LOGTEST" + "LOGXOR" + "LONG-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "LONG-SITE-NAME" + "LOOP" + "LOWER-CASE-P" + "MACHINE-INSTANCE" + "MACHINE-TYPE" + "MACHINE-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" + "MACROEXPAND-1" + "MACROLET" + "MAKE-ARRAY" + "MAKE-BROADCAST-STREAM" + "MAKE-CHAR" + "MAKE-CONCATENATED-STREAM" + "MAKE-DISPATCH-MACRO-CHARACTER" + "MAKE-ECHO-STREAM" + "MAKE-HASH-TABLE" + "MAKE-LIST" + "MAKE-PACKAGE" + "MAKE-PATHNAME" + "MAKE-RANDOM-STATE" + "MAKE-SEQUENCE" + "MAKE-STRING" + "MAKE-STRING-INPUT-STREAM" + "MAKE-STRING-OUTPUT-STREAM" + "MAKE-SYMBOL" + "MAKE-SYNONYM-STREAM" + "MAKE-TWO-WAY-STREAM" + "MAKUNBOUND" + "MAP" + "MAPC" + "MAPCAN" + "MAPCAR" + "MAPCON" + "MAPHASH" + "MAPL" + "MAPLIST" + "MASK-FIELD" + "MAX" + "MEMBER" + "MEMBER-IF" + "MEMBER-IF-NOT" + "MERGE" + "MERGE-PATHNAMES" + "MIN" + "MINUSP" + "MISMATCH" + "MOD" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MULTIPLE-VALUE-BIND" + "MULTIPLE-VALUE-CALL" + "MULTIPLE-VALUE-LIST" + "MULTIPLE-VALUE-PROG1" + "MULTIPLE-VALUE-SETQ" + "MULTIPLE-VALUES-LIMIT" + "NAME-CHAR" + "NAMESTRING" + "NBUTLAST" + "NCONC" + "NIL" + "NINTERSECTION" + "NINTH" + "NOT" + "NOTANY" + "NOTEVERY" + "NOTINLINE" + "NRECONC" + "NREVERSE" + "NSET-DIFFERENCE" + "NSET-EXCLUSIVE-OR" + "NSTRING-CAPITALIZE" + "NSTRING-DOWNCASE" + "NSTRING-UPCASE" + "NSUBLIS" + "NSUBST" + "NSUBST-IF" + "NSUBST-IF-NOT" + "NSUBSTITUTE" + "NSUBSTITUTE-IF" + "NSUBSTITUTE-IF-NOT" + "NTH" + "NTHCDR" + "NULL" + "NUMBER" + "NUMBERP" + "NUMERATOR" + "NUNION" + "ODDP" + "OPEN" + "OPTIMIZE" + "OR" + "OTHERWISE" + "OUTPUT-STREAM-P" + "PACKAGE" + "PACKAGE-NAME" + "PACKAGE-NICKNAMES" + "PACKAGE-SHADOWING-SYMBOLS" + "PACKAGE-USE-LIST" + "PACKAGE-USED-BY-LIST" + "PACKAGEP" + "PAIRLIS" + "PARSE-INTEGER" + "PARSE-NAMESTRING" + "PATHNAME" + "PATHNAME-DEVICE" + "PATHNAME-DIRECTORY" + "PATHNAME-HOST" + "PATHNAME-NAME" + "PATHNAME-TYPE" + "PATHNAME-VERSION" + "PATHNAMEP" + "PEEK-CHAR" + "PHASE" + "PI" + "PLUSP" + "POP" + "POSITION" + "POSITION-IF" + "POSITION-IF-NOT" + "PPRINT" + "PRIN1" + "PRIN1-TO-STRING" + "PRINC" + "PRINC-TO-STRING" + "PRINT" + "PROBE-FILE" + "PROCLAIM" + "PROG" + "PROG*" + "PROG1" + "PROG2" + "PROGN" + "PROGV" + "PROVIDE" + "PSETF" + "PSETQ" + "PUSH" + "PUSHNEW" + "QUOTE" + "RANDOM" + "RANDOM-STATE" + "RANDOM-STATE-P" + "RASSOC" + "RASSOC-IF" + "RASSOC-IF-NOT" + "RATIO" + "RATIONAL" + "RATIONALIZE" + "RATIONALP" + "READ" + "READ-BYTE" + "READ-CHAR" + "READ-CHAR-NO-HANG" + "READ-DELIMITED-LIST" + "READ-FROM-STRING" + "READ-LINE" + "READ-PRESERVING-WHITESPACE" + "READTABLE" + "READTABLEP" + "REALPART" + "REDUCE" + "REM" + "REMF" + "REMHASH" + "REMOVE" + "REMOVE-DUPLICATES" + "REMOVE-IF" + "REMOVE-IF-NOT" + "REMPROP" + "RENAME-FILE" + "RENAME-PACKAGE" + "REPLACE" + "REQUIRE" + "REST" + "RETURN" + "RETURN-FROM" + "REVAPPEND" + "REVERSE" + "ROOM" + "ROTATEF" + "ROUND" + "RPLACA" + "RPLACD" + "SAFETY" + "SATISFIES" + "SBIT" + "SCALE-FLOAT" + "SCHAR" + "SEARCH" + "SECOND" + "SEQUENCE" + "SET" + "SET-CHAR-BIT" + "SET-DIFFERENCE" + "SET-DISPATCH-MACRO-CHARACTER" + "SET-EXCLUSIVE-OR" + "SET-MACRO-CHARACTER" + "SET-SYNTAX-FROM-CHAR" + "SETF" + "SETQ" + "SEVENTH" + "SHADOW" + "SHADOWING-IMPORT" + "SHIFTF" + "SHORT-FLOAT" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SHORT-SITE-NAME" + "SIGNED-BYTE" + "SIGNUM" + "SIMPLE-ARRAY" + "SIMPLE-BIT-VECTOR" + "SIMPLE-BIT-VECTOR-P" + "SIMPLE-STRING" + "SIMPLE-STRING-P" + "SIMPLE-VECTOR" + "SIMPLE-VECTOR-P" + "SIN" + "SINGLE-FLOAT" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" + "SINH" + "SIXTH" + "SLEEP" + "SOFTWARE-TYPE" + "SOFTWARE-VERSION" + "SOME" + "SORT" + "SPACE" + "SPECIAL" + "SPEED" + "SQRT" + "STABLE-SORT" + "STANDARD-CHAR" + "STANDARD-CHAR-P" + "STEP" + "STREAM" + "STREAM-ELEMENT-TYPE" + "STREAMP" + "STRING" + "STRING-CAPITALIZE" + "STRING-CHAR" + "STRING-CHAR-P" + "STRING-DOWNCASE" + "STRING-EQUAL" + "STRING-GREATERP" + "STRING-LEFT-TRIM" + "STRING-LESSP" + "STRING-NOT-EQUAL" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP" + "STRING-RIGHT-TRIM" + "STRING-TRIM" + "STRING-UPCASE" + "STRING/=" + "STRING<" + "STRING<=" + "STRING=" + "STRING>" + "STRING>=" + "STRINGP" + "STRUCTURE" + "SUBLIS" + "SUBSEQ" + "SUBSETP" + "SUBST" + "SUBST-IF" + "SUBST-IF-NOT" + "SUBSTITUTE" + "SUBSTITUTE-IF" + "SUBSTITUTE-IF-NOT" + "SUBTYPEP" + "SVREF" + "SXHASH" + "SYMBOL" + "SYMBOL-FUNCTION" + "SYMBOL-NAME" + "SYMBOL-PACKAGE" + "SYMBOL-PLIST" + "SYMBOL-VALUE" + "SYMBOLP" + "T" + "TAGBODY" + "TAILP" + "TAN" + "TANH" + "TENTH" + "TERPRI" + "THE" + "THIRD" + "THROW" + "TIME" + "TRACE" + "TREE-EQUAL" + "TRUENAME" + "TRUNCATE" + "TYPE" + "TYPE-OF" + "TYPECASE" + "TYPEP" + "UNEXPORT" + "UNINTERN" + "UNION" + "UNLESS" + "UNREAD-CHAR" + "UNSIGNED-BYTE" + "UNTRACE" + "UNUSE-PACKAGE" + "UNWIND-PROTECT" + "UPPER-CASE-P" + "USE-PACKAGE" + "USER-HOMEDIR-PATHNAME" + "VALUES" + "VALUES-LIST" + "VARIABLE" + "VECTOR" + "VECTOR-POP" + "VECTOR-PUSH" + "VECTOR-PUSH-EXTEND" + "VECTORP" + "WARN" + "WHEN" + "WITH-INPUT-FROM-STRING" + "WITH-OPEN-FILE" + "WITH-OPEN-STREAM" + "WITH-OUTPUT-TO-STRING" + "WRITE" + "WRITE-BYTE" + "WRITE-CHAR" + "WRITE-LINE" + "WRITE-STRING" + "WRITE-TO-STRING" + "Y-OR-N-P" + "YES-OR-NO-P" + "ZEROP" + )) + +(%resize-package (find-package "LISP")) + +(defpackage "USER" + (:use "LISP" "CCL")) + +(defconstant lisp:char-control-bit 0) +(defconstant lisp:char-meta-bit 0) +(defconstant lisp:char-super-bit 0) +(defconstant lisp:char-hyper-bit 0) +(defconstant lisp:char-bits-limit 1) +(defconstant lisp:char-font-limit 1) + +(defun lisp:int-char (i) + (cl:code-char i)) + +(defun lisp:char-bits (c) + (require-type c 'character) + 0) + +(defun lisp:char-font (c) + (require-type c 'character) + 0) + +(defun lisp:digit-char (weight &optional (radix 10) font) + (when (and font (not (eql font 0))) + (error "Non-zero ~S (~S) not supported" 'font font)) + (cl:digit-char weight radix)) + +; 'It is an error to give char-bit the name of a bit not supported by the +; implementation' +(defun lisp:char-bit (char name) + (declare (ignore char)) + (error "Unsupported character bit name ~S." name)) + +(defun lisp:set-char-bit (char name newvalue) + (declare (ignore char newvalue)) + (error "Unsupported character bit name ~S." name)) + +(defun lisp:make-char (char &optional bits font) + (flet ((non-supported (argname argval) + (if (and argval (not (eql argval 0))) + (error "Non-zero ~S argument (~S) not supported." argname argval)))) + (non-supported 'bits bits) + (non-supported 'font font) + (require-type char 'character))) + +; A tragic waste of precious silicon. +(define-setf-method char-bit (place bit-name &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values `(,@dummies ,btemp) + `(,@vals ,bit-name) + (list gnuval) + `(let ((,(car newval) + (set-char-bit ,getter ,btemp ,gnuval))) + ,setter + ,gnuval) + `(char-bit ,getter ,btemp))))) + +(defun lisp:in-package (package-name &rest rest &key + nicknames use internal-size external-size) + (declare (ignore nicknames use internal-size external-size)) + (declare (dynamic-extent rest)) + (apply 'old-in-package package-name rest)) + +(defun lisp:functionp (x) + (or (symbolp x) + (and (consp x) (eq (ccl::%car x) 'lambda)) + (cl:functionp x))) + +(setf (cl:find-class 'lisp:string-char) (cl:find-class 'cl:base-char) + (symbol-function 'lisp:string-char-p) #'cl:characterp) + +(dolist (sym '(lisp:make-package lisp:in-package lisp:shadow lisp:shadowing-import + lisp:export lisp:unexport lisp:use-package lisp:unuse-package + lisp:import)) + (unless (eq sym 'lisp:in-package) + (setf (symbol-function sym) + (symbol-function (find-symbol (symbol-name sym) "COMMON-LISP")))) + (pushnew sym *fcomp-eval-always-functions*)) + +(provide :lisp-package) Index: /branches/qres/ccl/library/lispequ.lisp =================================================================== --- /branches/qres/ccl/library/lispequ.lisp (revision 13564) +++ /branches/qres/ccl/library/lispequ.lisp (revision 13564) @@ -0,0 +1,1605 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; LispEqu.lisp + +(in-package "CCL") + +(defconstant $flags_Normal 0) +(defconstant $flags_DisposeRecursiveLock 1) +(defconstant $flags_DisposPtr 2) +(defconstant $flags_DisposeRwlock 3) +(defconstant $flags_DisposeSemaphore 4) + +(defconstant $system-lock-type-recursive 0) +(defconstant $system-lock-type-rwlock 1) + +;;; this stuff is really ppc specific at the moment +(defconstant $population_weak-list 0) +(defconstant $population_weak-alist 1) +(defconstant $population_termination-bit 16) + +;;; type of 0 is a weak-list +;;; Note that this evals its args in the wrong order. +(defmacro %cons-population (data &optional (type 0) (termination? nil)) + (if termination? + `(gvector :population 0 (logior (ash 1 $population_termination-bit) ,type) ,data nil) + `(gvector :population 0 ,type ,data))) + +(defmacro %cons-terminatable-alist (&optional data) + `(%cons-population ,data $population_weak-alist t)) + +;;; The GC assumes that this structure is laid out exactly as below. +;;; It also assumes that if the $population_termination-bit is set in the +;;; population.type slot, the vector is of length 4, otherwise 3. +(def-accessors (population) %svref + population.gclink + population.type + population.data + population.termination-list) + +(def-accessors () uvref + nil + nil + population-data ; type-checked + population-termination-list) + +(defmacro %cons-pool (&optional data) + `(gvector :pool ,data)) + +(def-accessors (pool) %svref + pool.data) + +(def-accessors (resource) %svref + nil ; 'resource + resource.constructor + resource.destructor + resource.initializer + resource.pool + resource.lock) + +(defmacro gvector (type-keyword &rest initial-values) + `(%gvector ,(type-keyword-code type-keyword) ,@initial-values)) + + +(defmacro allocate-typed-vector (type-keyword elements &optional (init nil init-p)) + `(%alloc-misc ,elements ,(type-keyword-code type-keyword) + ,@(if init-p `(,init)))) + + +(def-accessors (semaphore) %svref + nil ;'semaphore + semaphore.value) + + +(defmacro %istruct (istruct-name &rest initial-values) + `(gvector :ISTRUCT (register-istruct-cell ,istruct-name) ,@initial-values)) + + +(defmacro %cons-resource (constructor &optional destructor initializer) + `(%istruct 'resource ,constructor ,destructor ,initializer (%cons-pool) (make-lock))) + + + +;;; Symbol [f,v]bits. + +(defconstant $sym_bit_bound 0) ;Proclaimed bound. +(defconstant $sym_bit_const 1) +(defconstant $sym_bit_global 2) ;Should never be lambda-bound. +(defconstant $sym_bit_special 4) +(defconstant $sym_vbit_typeppred 5) +(defconstant $sym_bit_indirect 6) +(defconstant $sym_bit_defunct 7) + +(defconstant $sym_vbit_bound $sym_bit_bound) +(defconstant $sym_vbit_const $sym_bit_const) +(defconstant $sym_vbit_global $sym_bit_global) +(defconstant $sym_vbit_special $sym_bit_special) +(defconstant $sym_vbit_indirect $sym_bit_indirect) +(defconstant $sym_vbit_defunct $sym_bit_defunct) + +(defconstant $sym_fbit_frozen (+ 8 $sym_bit_bound)) +(defconstant $sym_fbit_special (+ 8 $sym_bit_special)) +(defconstant $sym_fbit_indirect (+ 8 $sym_bit_indirect)) +(defconstant $sym_fbit_defunct (+ 8 $sym_bit_defunct)) + +(defconstant $sym_fbit_constant_fold (+ 8 $sym_bit_const)) +(defconstant $sym_fbit_fold_subforms (+ 8 $sym_bit_global)) + +(def-accessors () %svref + nil ;'destructure-state + destructure-state.current + destructure-state.whole + destructure-state.lambda + ) + +;Lfun bits. +;Assumed to be a fixnum, so if you ever assign a bit number > 28, +;change lfun-bits and its callers. +(defconstant $lfbits-nonnullenv-bit 0) +(defconstant $lfbits-keys-bit 1) +(defconstant $lfbits-numopt (byte 5 2)) +(defconstant $lfbits-restv-bit 7) +(defconstant $lfbits-numreq (byte 6 8)) +(defconstant $lfbits-optinit-bit 14) +(defconstant $lfbits-rest-bit 15) +(defconstant $lfbits-aok-bit 16) +(defconstant $lfbits-numinh (byte 6 17)) +(defconstant $lfbits-info-bit 23) +(defconstant $lfbits-trampoline-bit 24) +(defconstant $lfbits-code-coverage-bit 25) +(defconstant $lfbits-cm-bit 26) ; combined-method +(defconstant $lfbits-nextmeth-bit 26) ; or call-next-method with method-bit +(defconstant $lfbits-gfn-bit 27) ; generic-function +(defconstant $lfbits-nextmeth-with-args-bit 27) ; or call-next-method-with-args with method-bit +(defconstant $lfbits-method-bit 28) ; method function +(defconstant $lfbits-noname-bit 29) + + +(defconstant $lfbits-args-mask + (%ilogior (dpb -1 $lfbits-numreq 0) + (dpb -1 $lfbits-numopt 0) + (%ilsl $lfbits-rest-bit 1) + (%ilsl $lfbits-keys-bit 1) + (%ilsl $lfbits-aok-bit 1))) + +;Bits in $arh_bits. +(defconstant $arh_adjp_bit 7) ;adjustable-p +(defconstant $arh_fill_bit 6) ;fill-pointer-p +(defconstant $arh_disp_bit 5) ;displaced to another array header -p +(defconstant $arh_simple_bit 4) ;not adjustable, no fill-pointer and + ; not user-visibly displaced -p +(defconstant $arh_exp_disp_bit 3) ;explicitly-displaced -p + +(def-accessors (lexical-environment) %svref + () ; 'lexical-environment + lexenv.parent-env + lexenv.functions + lexenv.variables + lexenv.fdecls ; function-binding decls, e.g., [NOT]INLINE, FTYPE + lexenv.vdecls ; variable-binding decls, e.g., SPECIAL, TYPE + lexenv.mdecls ; misc decls, e.g., OPTIMIZE + lexenv.lambda ; unique id (e.g., afunc) of containing lambda expression. + ) + +(def-accessors (definition-environment) %svref + () ; 'definition-environment + defenv.type ; must be LIST, match lexenv.parent-env + defenv.functions ; compile-time macros, same structure as lexenv.functions + defenv.constants ; definition-time constants, shadows lexenv.variables + defenv.fdecls ; shadows lexenv.fdecls + defenv.vdecls ; shadows lexenv.vdecls + defenv.mdecls ; shadows lexenv.mdecls +;;; extended info + defenv.types ; compile-time deftype info, shadows lexenv.function + defenv.defined ; functions defined in compilation unit. + defenv.specials + defenv.classes ; classed defined in compilation unit + defenv.structrefs ; compile-time DEFSTRUCT accessor info + defenv.structures ; compile-time DEFSTRUCT info + defenv.symbol-macros ; compile-time SYMBOL-MACROS. +) + +(def-accessors (var) %svref + nil ; 'var + var-name ; symbol + (var-bits var-parent) ; fixnum or ptr to parent + (var-ea var-expansion) ; p2 address (or symbol-macro expansion) + var-ref-forms ; in intermediate-code + var-inittype + var-binding-info + var-refs + var-nvr + var-declared-type +) + +(def-accessors (package) %svref + pkg.itab + pkg.etab + pkg.used + pkg.used-by + pkg.names + pkg.shadowed + pkg.lock + pkg.intern-hook + ) + +(defmacro package-deleted-marker () + `(%unbound-marker)) + + + + +(defmacro %cons-fake-stack-frame (&optional sp next-sp fn lr vsp xp link) + `(%istruct 'fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,xp ,link)) + +(def-accessors () svref + bt.dialog + bt.youngest + bt.oldest + bt.tcr + bt.restarts + bt.top-catch + bt.break-condition + bt.current + bt.fake-frames + bt.db-link + bt.break-level) + +(defconstant bt.sg bt.tcr) +(setf (macro-function 'bt.sg) (macro-function 'bt.tcr)) + + +(def-accessors (lock) %svref + lock.value + lock.name) + + + + + + + +;contents of pkg.itab/pkg.etab. +(defmacro pkgtab-table (htab) `(car (the list ,htab))) +#| +(defmacro pkgtab-hcount (htab) `(car (the list (cdr (the list ,htab))))) (mkint acc))) +(defmacro pkgtab-hlimit (htab) `(cdr (the list (cdr (the list ,htab))))) +|# + + + +(def-accessors (pathname) %svref + () ; 'pathname + %pathname-directory + %pathname-name + %pathname-type + %physical-pathname-version + %physical-pathname-device) + +(def-accessors (logical-pathname) %svref + () ; 'logical-pathname + nil ; %pathname-directory + nil ; %pathname-name + nil ; %pathname-type + %logical-pathname-host + %logical-pathname-version) + +(defmacro %cons-pathname (directory name type &optional version device) + `(%istruct 'pathname ,directory ,name ,type ,version ,device)) + +(defmacro %cons-logical-pathname (directory name type host version) + `(%istruct 'logical-pathname ,directory ,name ,type ,host ,version)) + +(def-accessors (restart) %svref + () ; 'restart + %restart-name + %restart-action + %restart-report + %restart-interactive + %restart-test) + +;;; %cons-restart now in level-2.lisp + + +(def-accessors %svref + nil ; 'periodic-task + ptask.state + ptask.name + ptask.function +) + +;;;;;; CMU type system. + + + +(def-accessors (type-class) %svref + nil ; 'type-class + type-class-name ; name + + ;; Dyadic type methods. If the classes of the two types are EQ, then we call + ;; the SIMPLE-xxx method. If the classes are not EQ, and either type's class + ;; has a COMPLEX-xxx method, then we call it. + ;; + ;; Although it is undefined which method will get precedence when both types + ;; have a complex method, the complex method can assume that the second arg + ;; always is in its class, and the first always is not. The arguments to + ;; commutative operations will be swapped if the first argument has a complex + ;; method. + ;; + ;; Since SUBTYPEP is not commutative, we have two complex methods. the ARG1 + ;; method is only called when the first argument is in its class, and the + ;; ARG2 method is only called when called when the second type is. If either + ;; is specified, both must be. + type-class-simple-subtypep + type-class-complex-subtypep-arg1 + type-class-complex-subtypep-arg2 + ;; + ;; SIMPLE-UNION combines two types of the same class into a single type of + ;; that class. If the result is a two-type union, then return NIL. + ;; VANILLA-UNION returns whichever argument is a supertype of the other, or + ;; NIL. + type-class-simple-union + type-class-complex-union + ;; The default intersection methods assume that if one type is a subtype of + ;; the other, then that type is the intersection. + type-class-simple-intersection + type-class-complex-intersection + ;; + type-class-simple-= + type-class-complex-= + type-class-unparse +) + +;; This istruct (and its subtypes) are used to define types. +(def-accessors (ctype) %svref + nil ; 'ctype or a subtype + ctype-class-info ; a type-class + ;; True if this type has a fixed number of members, and as such could + ;; possibly be completely specified in a MEMBER type. This is used by the + ;; MEMBER type methods. + ctype-enumerable +) + +;; args-ctype is a subtype of ctype +(def-accessors (args-ctype) %svref + nil ; 'args-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; Lists of the type for each required and optional argument. + args-ctype-required + args-ctype-optional + ;; + ;; The type for the rest arg. NIL if there is no rest arg. + args-ctype-rest + ;; True if keyword arguments are specified. + args-ctype-keyp + ;; List of key-info structures describing the keyword arguments. + args-ctype-keywords + ;; True if other keywords are allowed. + args-ctype-allowp +) + +(def-accessors (key-info) %svref + nil ; 'key-info + key-info-name ; Name of &key arg + key-info-type ; type (ctype) of this &key arg +) + +;;; VALUES-ctype is a subtype of ARGS-ctype. +(def-accessors (values-ctype) %svref + nil ; 'values-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; Lists of the type for each required and optional argument. + values-ctype-required + values-ctype-optional + ;; + ;; The type for the rest arg. NIL if there is no rest arg. + values-ctype-rest + ;; True if keyword arguments are specified. + values-ctype-keyp + ;; List of key-info structures describing the keyword arguments. + values-ctype-keywords + ;; True if other keywords are allowed. + values-ctype-allowp +) + +;;; FUNCTION-ctype is a subtype of ARGS-ctype. +(def-accessors (args-ctype) %svref + nil ; 'function-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + function-ctype-required ; args-ctype-required + function-ctype-optional ; args-ctype-optional + function-ctype-rest ; args-ctype-rest + function-ctype-keyp ; args-ctype-keyp + function-ctype-keywords ; args-ctype-keywords + function-ctype-allowp ; args-ctype-allowp +;; True if the arguments are unrestrictive, i.e. *. + function-ctype-wild-args + ;; + ;; Type describing the return values. This is a values type + ;; when multiple values were specified for the return. + function-ctype-returns +) + +;;; The CONSTANT-ctype structure represents a use of the CONSTANT-ARGUMENT "type +;;; specifier", which is only meaningful in function argument type specifiers +;;; used within the compiler. +;;; + + +(def-accessors (constant-ctype) %svref + nil ; 'constant-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; The type which the argument must be a constant instance of for this type + ;; specifier to win. + constant-ctype-type +) + +;;; The NAMED-ctype is used to represent *, T and NIL. These types must be +;;; super or sub types of all types, not just classes and * & NIL aren't +;;; classes anyway, so it wouldn't make much sense to make them built-in +;;; classes. +;;; + +(def-accessors (named-ctype) %svref + nil ; 'named-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + named-ctype-name +) + +;;; The Hairy-ctype represents anything too wierd to be described +;;; reasonably or to be useful, such as SATISFIES. We just remember +;;; the original type spec. +;;; + +(def-accessors (hairy-ctype) %svref + nil ; 'hairy-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; The type which the argument must be a constant instance of for this type + ;; specifier to win. + hairy-ctype-specifier +) + +;;; An UNKNOWN-ctype is a type not known to the type system (not yet defined). +;;; We make this distinction since we don't want to complain about types that +;;; are hairy but defined. +;;; + +;;; This means that UNKNOWN-ctype is a HAIRY-ctype. +(def-accessors (unknown-ctype) %svref + nil ; 'unknown-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + unknown-ctype-specifier +) + +;;; CONS-ctype is a subclass of CTYPE +(def-accessors (cons-ctype) %svref + nil ; 'cons-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + cons-ctype-car-ctype ; ctype of the car + cons-ctype-cdr-ctype ; ctype of the cdr + ) + +;;; NUMERIC-ctype is a subclass of CTYPE +(def-accessors (numeric-ctype) %svref + nil ; numeric-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The kind of numeric type we have. NIL if not specified (just NUMBER or + ;; COMPLEX). + numeric-ctype-class + ;; Format for a float type. NIL if not specified or not a float. Formats + ;; which don't exist in a given implementation don't appear here. + numeric-ctype-format + ;; Is this a complex numeric type? Null if unknown (only in NUMBER.) + numeric-ctype-complexp + ;; The upper and lower bounds on the value. If null, there is no bound. If + ;; a list of a number, the bound is exclusive. Integer types never have + ;; exclusive bounds. + numeric-ctype-low + numeric-ctype-high + numeric-ctype-predicate +) + +;;; ARRAY-ctype is a subclass of CTYPE. +(def-accessors (array-ctype) %svref + nil ; 'array-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The dimensions of the array. * if unspecified. If a dimension is + ;; unspecified, it is *. + array-ctype-dimensions + ;; + ;; Is this not a simple array type? + array-ctype-complexp + ;; + ;; The element type as originally specified. + array-ctype-element-type + ;; + ;; The element type as it is specialized in this implementation. + array-ctype-specialized-element-type + ;; The typecode of the specialize element type, or NIL. + array-ctype-typecode +) + +;;; MEMBER-ctype is a direct subclass of CTYPE. +(def-accessors (member-ctype) %svref + nil ; 'member-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The things in the set, with no duplications. + member-ctype-members +) + +;;; UNION-ctype is a direct subclass of CTYPE. +(def-accessors (union-ctype) %svref + nil ; 'union-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The types in the union. + union-ctype-types +) + +;;; INTERSECTION-ctype is a direct subclass of CTYPE. +(def-accessors (intersection-ctype) %svref + nil ; 'intersection-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The types in the intersection + intersection-ctype-types +) + +(def-accessors (negation-ctype) %svref + nil ; 'negation-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; The type of what we're not: + negation-ctype-type + ) + + + + +;;; It'd be nice to integrate "foreign" types into the type system +(def-accessors (foreign-ctype) %svref + nil ; 'foreign-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + foreign-ctype-foreign-type +) + +;;; Most "real" CLOS objects have one of these in their %class.ctype slot + +(def-accessors (class-ctype) %svref + nil ; 'class-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + class-ctype-class ; backptr to class. + class-ctype-translation ; ctype for some built-in-classes. +) + + + +;;;;;;; +;; +;; state for with-package-iterator +;; +(def-accessors %svref + pkg-iter-step.pkg ; package + pkg-iter-step.type ; keyword + pkg-iter-step.table + pkg-iter-step.shadowed + pkg-iter-step.vector + pkg-iter-step.index) + +(def-accessors %svref + pkg-iter.step ; current step + pkg-iter.remaining-steps ; steps to be processed +) + +;;;;;;;;;;;;; + +;;; Bits in *gc-event-status-bits* +(defconstant $gc-retain-pages-bit 0) +(defconstant $gc-integrity-check-bit 2) +(defconstant $gc-allow-stack-overflows-bit 5) +(defconstant $egc-verbose-bit 3) +(defconstant $gc-verbose-bit 4) +(defconstant $gc-postgc-pending-bit 26) + + + +;;; Values for the flags arg to %install-periodic-task +(defconstant $ptask_draw-flag 1) ; set for tasks that do drawing +(defconstant $ptask_event-dispatch-flag 2) ; set for tasks that do event processing + + + + + +(defconstant struct.type 0) +(defconstant istruct.type 0) + +(def-accessors (readtable) %svref + () ; 'readtable + rdtab.ttab ; type table + rdtab.alist ; macro-char alist + rdtab.case) ; gratuitous braindeath + +;character types in readtables +(defconstant $cht_ill 0) ;Illegal char +(defconstant $cht_wsp 1) ;Whitespace +(defconstant $cht_sesc 4) ;Single escape (\) +(defconstant $cht_mesc 5) ;Multiple escape (|) +(defconstant $cht_cnst 6) ;Atom constituent +(defconstant $cht_tmac 8) ;Terminating macro +(defconstant $cht_ntmac 9) ;Non-terminating macro + +(defconstant $cht_macbit 3) ;This bit on in CHT_TMAC and CHT_NTMAC + +;;; quantifiers + +(defconstant $some 0) +(defconstant $notany 1) +(defconstant $every 2) +(defconstant $notevery 3) + +;;; Error string constants. As accurate as constants.i ... + +(defconstant $XVUNBND 1) +;(defconstant $XNOCDR 2) +(defconstant $xbadvec 6) +(defconstant $XTMINPS 3) +(defconstant $XNEINPS 4) +(defconstant $XWRNGINP 5) +(defconstant $err-bad-input 5) +(defconstant $XFUNBND 6) +;;(defconstant $err-fundefined 6) +;;(defconstant $XNOCAR 7) +(defconstant $xsetbadvec 7) +(defconstant $xcoerce 8) +(defconstant $xnofinfunction 9) +(defconstant $xnomem 10) +(defconstant $xnotranslation 12) +(defconstant $XNOTFUN 13) +(defconstant $XNOTsymlam 14) +(defconstant $Xdeclpos 15) +(defconstant $Xsetconstant 16) +(defconstant $Xoddsetq 17) +(defconstant $Xbadsetq 18) +(defconstant $Xnotsym 19) +(defconstant $Xisconstant 20) +(defconstant $Xbadinit 21) +(defconstant $Xsmacspec 22) +(defconstant $X2manyargs 23) +(defconstant $XNolexvar 24) +(defconstant $XNolexfunc 25) +(defconstant $XNolextag 26) +(defconstant $XNolexblock 27) +(defconstant $XNotag 28) +(defconstant $Xduplicatetag 29) +(defconstant $XNoblock 30) +(defconstant $XBadLambdaList 31) +(defconstant $XBadLambda 32) +(defconstant $XNOCTAG 33) +(defconstant $XOBJBadType 34) +(defconstant $XFuncLexMacro 35) +(defconstant $xumrpr 41) +(defconstant $xnotsamevol 42) +(defconstant $xbadfilenamechar 43) +(defconstant $xillwild 44) +(defconstant $xnotfaslortext 45) +(defconstant $xrenamedir 46) +(defconstant $xdirnotfile 47) +(defconstant $xnocopydir 48) +(defconstant $XBADTOK 49) +(defconstant $err-long-pstr 49) +(defconstant $xnocreate 50) +(defconstant $XFLOVFL 64) +(defconstant $XDIVZRO 66) +(defconstant $XFLDZRO 66) +(defconstant $XSTKOVER 75) +(defconstant $XMEMFULL 76) +(defconstant $xarrlimit 77) +(defconstant $err-printer 94) +(defconstant $err-printer-load 95) +(defconstant $err-printer-params 96) +(defconstant $err-printer-start 97) +(defconstant $XFLEXC 98) +(defconstant $xfileof 111) +(defconstant $XARROOB 112) +(defconstant $err-arroob 112) +(defconstant $xunread 113) +(defconstant $xbadmac 114) +(defconstant $XCONST 115) +(defconstant $xillchr 116) +(defconstant $xbadsym 117) +(defconstant $xdoterr 118) +(defconstant $xbadrdx 119) +(defconstant $XNOSPREAD 120) +(defconstant $XFASLVERS 121) +(defconstant $XNOTFASL 122) +(defconstant $xudfcall 123) + +(defconstant $xusecX 127) +(defconstant $ximprtcx 128) +(defconstant $xbadnum 129) ;Bad arg to #b/#o/#x/#r... +(defconstant $XNOPKG 130) +(defconstant $xnoesym 131) +(defconstant $XBADFASL 132) +(defconstant $ximprtc 133) +(defconstant $xunintc 134) +(defconstant $XSYMACC 135) +(defconstant $XEXPRTC 136) +(defconstant $xusec 137) +(defconstant $xduppkg 138) +(defconstant $xrmactx 139) +(defconstant $xnordisp 140) +(defconstant $xrdnoarg 141) +(defconstant $xrdndarg 142) +(defconstant $xmacrdx 143) +(defconstant $xduprdlbl 144) +(defconstant $xnordlbl 145) +(defconstant $xrdfont 146) +(defconstant $xrdname 147) +(defconstant $XNDIMS 148) +(defconstant $err-disp-size 149) +(defconstant $XNARGS 150) +(defconstant $xdifdim 151) +(defconstant $xkeyconflict 152) +(defconstant $XBADKEYS 153) +(defconstant $xtoofew 154) +(defconstant $xtoomany 155) +(defconstant $XWRONGTYPE 157) +(defconstant $XBADSTRUCT 158) +(defconstant $XSTRUCTBOUNDS 159) +(defconstant $XCALLNOTLAMBDA 160) +(defconstant $XTEMPFLT 161) +(defconstant $xrdfeature 163) +(defconstant $err-no-file 164) +(defconstant $err-bad-named-arg 165) +(defconstant $err-bad-named-arg-2 166) +(defconstant $XCALLTOOMANY 167) +(defconstant $XCALLTOOFEW 168) +(defconstant $XCALLNOMATCH 169) +(defconstant $XIMPROPERLIST 170) +(defconstant $XNOFILLPTR 171) +(defconstant $XMALADJUST 172) +(defconstant $XACCESSNTH 173) +(defconstant $XNOTELT 174) +(defconstant $XSGEXHAUSTED 175) +(defconstant $XSGNARGS 176) +(defconstant $XTOOMANYVALUES 177) +(defconstant $XFOREIGNEXCEPTION 200) + +(defconstant $cons-area.gspace-start 0) +(defconstant $cons-area.gspace-end 4) +(defconstant $cons-area.ispace-start 8) +(defconstant $cons-area.ispace-end 12) +(defconstant $cons-area.pgc-count 16) +(defconstant $cons-area.pgc-time 20) +(defconstant $cons-area.total 24) + + +;; Values returned by %number-check. + +(defconstant $Num1Dfloat 0) +(defconstant $Num1Int 2) +(defconstant $Num1Sfloat 4) +(defconstant $Num1Ratio 6) +(defconstant $Num1CR 8) +(defconstant $Num1CF 10) +(defconstant $Num1CS 12) + +(defconstant %numeric-type-names-alist% + `((double-float . ,$Num1Dfloat) + (integer . ,$Num1Int) + (short-float . ,$Num1Sfloat) + (ratio . ,$Num1Ratio) + ((complex rational) . ,$Num1CR) + ((complex double-float) . ,$Num1CF) + ((complex short-float) . ,$Num1CS))) + +(defmacro numeric-dispatch (numform &body cases) + (flet ((numtype (name) + (if (memq name '(t otherwise)) + name + (dolist (pair %numeric-type-names-alist% (error "Unknown numeric type name ~s" name)) + (when (subtypep name (car pair)) (return (cdr pair))))))) + (flet ((numify (case) + (destructuring-bind (types &body body) case + (if (atom types) + `(,(numtype types) ,@body) + `(,(mapcar #'numtype types) ,@body))))) + `(case (%number-check ,numform) + ,@(mapcar #'numify cases))))) + +(def-accessors (random-state) %svref + () + random.mrg31k3p-state) + +;;; IEEE-floating-point constants. + +(defconstant IEEE-single-float-bias 126) +(defconstant IEEE-single-float-exponent-offset 23) +(defconstant IEEE-single-float-exponent-width 8) +(defconstant IEEE-single-float-mantissa-offset 0) +(defconstant IEEE-single-float-mantissa-width 23) +(defconstant IEEE-single-float-hidden-bit 23) +(defconstant IEEE-single-float-signalling-NAN-bit 22) +(defconstant IEEE-single-float-normal-exponent-min 1) +(defconstant IEEE-single-float-normal-exponent-max 254) +(defconstant IEEE-single-float-digits (1+ IEEE-single-float-mantissa-width)) + +;;; Double-floats are IEEE DOUBLE-FLOATs in both MCL implementations. + +(defconstant IEEE-double-float-bias 1022) +(defconstant IEEE-double-float-exponent-offset 52) +(defconstant IEEE-double-float-exponent-width 11) +(defconstant IEEE-double-float-mantissa-offset 0) +(defconstant IEEE-double-float-mantissa-width 52) +(defconstant IEEE-double-float-hidden-bit 52) +(defconstant IEEE-double-float-signalling-NAN-bit 51) +(defconstant IEEE-double-float-normal-exponent-min 1) +(defconstant IEEE-double-float-normal-exponent-max 2046) +(defconstant IEEE-double-float-digits (1+ IEEE-double-float-mantissa-width)) + + + + +(def-accessors (ptaskstate) %svref + nil ;ptaskstate + ptaskstate.nexttick + ptaskstate.interval + ptaskstate.privatedata + ptaskstate.flags) + + + + + + + +;;;;;; clos instance and class layout. + +;;; All standard-instances (classes, instances other than funcallable +;;; instances) consist of a vector of slot values and a pointer to the +;;; class wrapper. +(def-accessors (instance) %svref + instance.hash ; a fixnum for EQ-based hashing + instance.class-wrapper + instance.slots ; a slot-vector +) +;;; Doing this via %SLOT-REF traps if the slot is unbound +(defmacro standard-instance-instance-location-access (instance location) + `(%slot-ref (instance-slots ,instance) ,location)) + +;;; Get the "raw" contents of the slot, even if it's %SLOT-UNBOUND-MARKER. +(defmacro %standard-instance-instance-location-access (instance location) + `(%svref (instance-slots ,instance) ,location)) + +(defmacro set-standard-instance-instance-location-access (instance location new) + `(setf (%svref (instance-slots ,instance) ,location) ,new)) + +(defsetf standard-instance-instance-location-access + set-standard-instance-instance-location-access) + +(defmacro standard-generic-function-instance-location-access (sgf location) + `(%slot-ref (gf.slots ,sgf) ,location)) + +(defmacro %standard-generic-function-instance-location-access (sgf location) + `(%svref (gf.slots ,sgf) ,location)) + +(defmacro set-standard-generic-function-instance-location-access (sgf location new) + `(setf (%svref (gf.slots ,sgf) ,location) ,new)) + +(defsetf standard-generic-function-instance-location-access + set-standard-generic-function-instance-location-access) + +;;; Slot vectors contain the instance they "belong" to (or NIL) in +;;; their 0th element, and the instance's slots in elements 1 .. n. + +(def-accessors (slot-vector) %svref + slot-vector.instance + ) + +(def-accessors (class-wrapper) %svref + nil ; 'class-wrapper + %wrapper-hash-index ; for generic-function dispatch tables + %wrapper-class ; the class itself + %wrapper-instance-slots ; vector of instance slot names + %wrapper-class-slots ; alist of (name . value-cell) pairs + %wrapper-slot-id->slotd ; map slot-id to slotd, or NIL + %wrapper-slot-id-map ; (vector (mod nslots) next-slot-id-index) + %wrapper-slot-definition-table ; vector of nil || slot-definitions + %wrapper-slot-id-value ; "fast" SLOT-VALUE function + %wrapper-set-slot-id-value ; "fast" (SETF SLOT-VALUE) function + %wrapper-cpl ; cached cpl of %wrapper-class or NIL + %wrapper-class-ordinal ; cached copy of class-ordinal + %wrapper-cpl-bits ; bitvector representation of cpl +) + +;; Use the wrapper-class-slots for info on obsolete & forwarded instances +;; Note: none of this xx-forwarding-xx or xx-forwarded-xx is valid unless +;; (%wrapper-instance-slots ...) is 0. +(defmacro %wrapper-forwarding-info (instance) + `(%wrapper-class-slots ,instance)) + +(defmacro %forwarding-instance-slots (info) + `(%car ,info)) +(defmacro %forwarding-class-slots (info) + `(%cdr ,info)) + + +(defmacro %wrapper-forwarded-instance-slots (instance) + `(%forwarding-instance-slots (%wrapper-forwarding-info ,instance))) +(defmacro %wrapper-forwarded-class-slots (instance) + `(%forwarding-class-slots (%wrapper-forwarding-info ,instance))) + + +(defmacro %cons-forwarding-info (instance-slots class-slots) + `(cons ,instance-slots ,class-slots)) + + +(defmacro %cons-wrapper (class &optional + (hash-index '(new-class-wrapper-hash-index))) + (let* ((c (gensym))) + `(let* ((,c ,class)) + (%istruct 'class-wrapper ,hash-index ,c nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing nil (%class-ordinal ,c t) nil)))) + + +(defmacro %instance-class (instance) + `(%wrapper-class (instance.class-wrapper ,instance))) + +(def-accessors standard-instance-instance-location-access ;A specializer + nil ; backptr + specializer.direct-methods +) + +(def-accessors (class) standard-instance-instance-location-access ;Slots of any class + nil ; backptr + %class.direct-methods ; aka specializer.direct-methods + %class.prototype ; prototype instance + %class.name + %class.cpl ; class-precedence-list + %class.own-wrapper ; own wrapper (or nil) + %class.local-supers ; class-direct-superclasses + %class.subclasses ; class-direct-subclasses + %class.dependents ; arbitrary dependents + %class.ctype + %class.direct-slots ; local slots + %class.slots ; all slots + %class.info ; cons of kernel-p, proper-name + %class.local-default-initargs ; local default initargs alist + %class.default-initargs ; all default initargs if initialized. +) + + +(def-accessors () standard-instance-instance-location-access ; any standard class + nil ; slot-vector backptr + nil ; usual class stuff: direct-methods, + nil ; prototype, + nil ; name, + nil ; cpl, + nil ; own-wrapper, + nil ; local-supers, + nil ; subclasses, + nil ; dependents, + nil ; ctype. + nil ; local slots + nil ; all slots + nil ; true if a non-redefinable class + nil ; local default initargs alist + nil ; all default initargs if initialized. + %class.alist ; other stuff about the class. + %class.make-instance-initargs ; (vector of) valid initargs to make-instance + %class.reinit-initargs ; valid initargs to reinitialize-instance + %class.redefined-initargs ; valid initargs to update-instance-for-redefined-class + %class.changed-initargs ; valid initargs to update-instance-for-changed-class + ) + + + + + +(defmacro %instance-vector (wrapper &rest slots) + (let ((instance (gensym)) + (slots-vector (gensym))) + `(let* ((,instance (gvector :instance 0 ,wrapper nil)) + (,slots-vector (gvector :slot-vector ,instance ,@slots))) + (setf (instance.slots ,instance) ,slots-vector + (instance.hash ,instance) (strip-tag-to-fixnum ,instance)) + ,instance))) + + + + +(defmacro %cons-built-in-class (name) + `(%instance-vector *built-in-class-wrapper* + nil ;direct-methods + nil ;prototype + ,name ;name + nil ;precedence-list + nil ;own-wrapper + nil ;direct-superclasses + nil ;direct-subclasses + nil ;dependents + nil ;class-ctype + nil ;direct-slots + nil ;slots + (cons nil nil) ;info + nil ;direct-default-initargs + nil ;default-initargs + )) + +(defmacro %cons-standard-class (name &optional + (metaclass-wrapper '*standard-class-wrapper*)) + `(%instance-vector ,metaclass-wrapper + nil ;direct-methods + nil ;prototype + ,name ;name + nil ;precedence-list + nil ;own-wrapper + nil ;direct-superclasses + nil ;direct-subclasses + nil ;dependents + nil ;class-ctype + nil ;direct-slots + nil ;slots + (cons nil nil) ;info + nil ;direct-default-initargs + nil ;default-initargs + nil ;alist + nil ;make-instance-initargs + nil ;reinit-initargs + nil ;redefined-initargs + nil ;changed-initargs + ) +) + + + +(defconstant max-class-ordinal (ash 1 20)) + + +(def-accessors () standard-instance-instance-location-access + nil ; backptr + standard-slot-definition.name + standard-slot-definition.type + standard-slot-definition.initfunction + standard-slot-definition.initform + standard-slot-definition.initargs + standard-slot-definition.allocation + standard-slot-definition.documentation + standard-slot-definition.class + ) + +(def-accessors () standard-instance-instance-location-access + nil + standard-effective-slot-definition.name + standard-effective-slot-definition.type + standard-effective-slot-definition.initfunction + standard-effective-slot-definition.initform + standard-effective-slot-definition.initargs + standard-effective-slot-definition.allocation + standard-effective-slot-definition.documentation + standard-effective-slot-definition.class + standard-effective-slot-definition.location + standard-effective-slot-definition.slot-id + standard-effective-slot-definition.type-predicate + ) + + +(def-accessors () standard-instance-instance-location-access + nil + standard-direct-slot-definition.name + standard-direct-slot-definition.type + standard-direct-slot-definition.initfunction + standard-direct-slot-definition.initform + standard-direct-slot-definition.initargs + standard-direct-slot-definition.allocation + standard-direct-slot-definition.documentation + standard-direct-slot-definition.class + standard-direct-slot-definition.readers + standard-direct-slot-definition.writers + ) + +;; Methods +(defmacro %cons-method (name qualifiers specializers function &optional + (class '*standard-method-class*)) + `(%instance-vector + (%class.own-wrapper ,class) + ,qualifiers + ,specializers + ,function + nil + ,name)) + + +(def-accessors standard-instance-instance-location-access ; method + nil ; backptr + %method.qualifiers + %method.specializers + %method.function + %method.gf + %method.name + %method.lambda-list) + +;;; Painful, but seems to be necessary. +(def-accessors standard-instance-instance-location-access ; standard-accessor-method + nil ; backptr + nil ;%method.qualifiers + nil ;%method.specializers + nil ;%method.function + nil ;%method.gf + nil ;%method.name + nil ;%method.lambda-list + %accessor-method.slot-definition) + + + + + +;; Generic Function Dispatch tables. +;; These accessors are at the beginning of the table. +;; rest of the table is alternating wrappers & combined-methods. + +(def-accessors %svref + %gf-dispatch-table-methods ; List of methods + %gf-dispatch-table-precedence-list ; List of argument numbers in precedence order + %gf-dispatch-table-keyvect ; keyword vector, set by E-G-F. + %gf-dispatch-table-argnum ; argument number + %gf-dispatch-table-gf ; back pointer to gf - NEW + %gf-dispatch-table-mask ; mask for rest of table + %gf-dispatch-table-first-data) ; offset to first data. Must follow mask. + +(defmacro %gf-dispatch-table-size (dt) + `(%i- (uvsize ,dt) ,(+ 2 %gf-dispatch-table-first-data))) + +(defmacro %gf-dispatch-table-ref (table index) + `(%svref ,table (%i+ ,index %gf-dispatch-table-first-data))) + +(defmacro %cons-gf-dispatch-table (size) + `(make-array (%i+ ,size ,(%i+ 2 %gf-dispatch-table-first-data)) + :initial-element nil)) + + +;;; method-combination info +(def-accessors svref + mci.class ; short-method-combination or long-method-combination + mci.options ; short-form-options or long-form function + mci.instances ; a population of instances + mci.gfs ; a population of generic-functions + ) + +(defmacro %cons-mci (&optional class options) + `(vector ,class ,options (%cons-population nil) (%cons-population nil))) + +;;; slot accessor info for primary classes +(def-accessors %svref + %slot-accessor-info.class + (%slot-accessor-info.accessor %slot-accessor-info.slot-name) + %slot-accessor-info.offset + ) + +(defmacro %cons-slot-accessor-info (class accessor-or-slot-name &optional offset) + `(vector ,class ,accessor-or-slot-name ,offset)) + +(def-accessors (combined-method) nth-immediate + combined-method.code-vector ; trampoline code vector + combined-method.thing ; arbitrary arg to dcode + combined-method.dcode ; discriminator function + combined-method.gf ; gf + combined-method.bits ; lfun-bits + ) +;;; The structure of a generic-function object (funcallable instance). +(def-accessors (generic-function) nth-immediate + gf.code-vector ; trampoline code-vector + gf.instance.class-wrapper ; instance class-wrapper + gf.slots ; slots vector + gf.dispatch-table ; effective-method cache + gf.dcode ; discriminating code + gf.hash ; hashing identity + gf.bits ; + ) + +;;; The slots of STANDARD-GENERIC-FUNCTION. +(def-accessors (standard-generic-function) standard-generic-function-instance-location-access + nil ; backptr + sgf.name ; generic-function-name + sgf.method-combination ; generic-function-method-combination + sgf.method-class ; generic-function-method-class + sgf.methods ; generic-function-methods + sgf.decls ; generic-function-declarations + sgf.%lambda-list ; explicit lambda-list + sgf.dependents ; dependents for MAP-DEPENDENTS et al. + ) + +(def-accessors (slot-id) %svref + nil ;'slot-id + slot-id.name ; slot name (symbol) + slot-id.index ; index (integer) + ) + +(def-accessors (foreign-object-domain) %svref + nil ; foreign-object-domain + foreign-object-domain-index ; 1..n + foreign-object-domain-name ; + foreign-object-domain-recognize ; function: is object one of ours ? + foreign-object-domain-class-of ; function: returns class of object + foreign-object-domain-classp ; function: true if object is a class + foreign-object-domain-instance-class-wrapper ; function: returns wrapper of object's class + foreign-object-domain-class-own-wrapper ; function: returns class own wrapper if class + foreign-object-domain-slots-vector ; returns slots vector of object or nil + foreign-object-domain-class-ordinal ; returns class ordinal if class + foreign-object-domain-set-class-ordinal ; sets class ordinal if class + ) + +;;; Hash table accessors. +(def-accessors (hash-table) %svref + nil ; 'HASH-TABLE + nhash.keytransF ; transform key into (values primary addressp) + nhash.compareF ; comparison function: 0 -> eq, -1 ->eql, else function + nhash.rehash-bits ; bitset (array (unsigned-byte 32)) for rehash + nhash.vector ; N pairs; n relatively prime to & larger than all secondary keys + nhash.lock ; flag: non-zero if lock-free + nhash.owner ; tcr of "owning" thread, else NIL. + nhash.grow-threshold ; Max # entries before grow + nhash.rehash-ratio ; inverted rehash-threshold + nhash.rehash-size ; rehash-size from user + nhash.puthash-count ; number of times table has been rehashed or grown + nhash.exclusion-lock ; read-write lock for access + nhash.find ; function: find vector-index + nhash.find-new ; function: find vector-index on put + nhash.read-only ; boolean: true when read-only + ) + +(def-accessors (lock-acquisition) %svref + nil ; 'lock-acquisition + lock-acquisition.status + ) + +(defmacro make-lock-acquisition () + `(%istruct 'lock-acquisition nil)) + +(def-accessors (semaphore-notification) %svref + nil ; 'semaphore-notification + semaphore-notification.status + ) + +(defmacro make-semaphore-notification () + `(%istruct 'semaphore-notification nil)) + +;;; Why were these ever in architecture-dependent packages ? +(defenum (:prefix "AREA-") + void ; list header + cstack ; a control stack + vstack ; a value stack + tstack ; (dynamic-extent) temp stack + readonly ; readonly section + watched ; static area containing a single object + managed-static ; growable static area + static ; static data in application + dynamic ; dynmaic (heap) data in application +) + +;;; areas are sorted such that (in the "succ" direction) codes are >=. +;;; If you think that you're looking for a stack (instead of a heap), look +;;; in the "pred" direction from the all-areas header. +(defconstant max-stack-area-code area-tstack) +(defconstant min-heap-area-code area-readonly) + + +;;; Lisp threads, which barely need to exist and aren't worth burning +;;; a separate tag on ... +(def-accessors (lisp-thread) %svref + nil ;'lisp-thread + lisp-thread.tcr + lisp-thread.name + lisp-thread.cs-size + lisp-thread.vs-size + lisp-thread.ts-size + lisp-thread.initial-function.args + lisp-thread.interrupt-functions + lisp-thread.interrupt-lock + lisp-thread.startup-function + lisp-thread.state + lisp-thread.state-change-lock + ) + +;;; "basic" (e.g., builtin, non-extensible) streams. +(def-accessors (basic-stream) %svref + basic-stream.wrapper ; a class wrapper object + basic-stream.flags ; fixnum; bits. + basic-stream.state ; typically an ioblock + basic-stream.info ; a plist for less-often-used things. +) + +(def-accessors (basic-file-stream) %svref + basic-file-stream.class ; a class object + basic-file-stream.flags ; fixnum; bits. + basic-file-stream.state ; typically an ioblock + basic-file-stream.info ; a plist for less-often-used things. + basic-file-stream.filename + basic-file-stream.actual-filename + basic-file-stream.external-format + ) + +;;; Bits in basic-stream.flags +(defenum (:prefix "BASIC-STREAM-FLAG.") + open-input + open-output + open-character + open-binary + file-stream) + + +(def-accessors (class-cell) %svref + nil ; 'class-cell + class-cell-name + class-cell-class + class-cell-instantiate + class-cell-extra ; wrapper in some cases + ) + +(defmacro make-class-cell (name) `(%istruct 'class-cell ,name nil '%make-instance nil)) + +;;; Map between TYPE-SPECIFIERS and CTYPEs +(def-accessors (type-cell) %svref + nil + type-cell-type-specifier + type-cell-ctype) + +(defmacro make-type-cell (specifier) `(%istruct 'type-cell ,specifier nil)) + +;;; Map between package names and packages, sometimes. +(def-accessors (package-ref) %svref + nil + package-ref.name ; a string + package-ref.pkg ; a package or NIL + ) + +(defmacro make-package-ref (name) `(%istruct 'package-ref (string ,name) nil)) + + +(def-accessor-macros %svref + nil ; 'external-entry-point + eep.address + eep.name + eep.container) + +(defmacro %cons-external-entry-point (name &optional container) + `(%istruct 'external-entry-point nil ,name ,container)) + +(def-accessor-macros %svref + nil ;'foreign-variable + fv.addr ; a MACPTR, or nil + fv.name ; a string + fv.type ; a foreign type + fv.container ; containing library + ) + + +(def-accessor-macros %svref + nil ;'shlib + shlib.soname + shlib.pathname + shlib.handle ; if explicitly opened + shlib.map + shlib.base + shlib.opencount) + +(defmacro %cons-shlib (soname pathname map base) + `(%istruct 'shlib ,soname ,pathname nil ,map ,base 0)) + +(def-accessors uvref ; %svref + () ;'entry + entry-test ;predicate function or count of higher priority others. + entry-fn ;pprint function + entry-full-spec ;list of priority and type specifier + ) + +;;; MacOS toolbox routines were once written mostly in Pascal, so some +;;; code still refers to callbacks from foreign code as "pascal-callable +;;; functions". + +; %Pascal-Functions% Entry +(def-accessor-macros %svref + pfe.routine-descriptor + pfe.proc-info + pfe.lisp-function + pfe.sym + pfe.without-interrupts + pfe.trace-p) + +(defmacro %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts) + `(vector ,routine-descriptor ,proc-info ,lisp-function ,sym ,without-interrupts nil)) + + +(def-accessors %svref + () ; 'xp-structure + xp-base-stream ;;The stream io eventually goes to. + xp-linel ;;The line length to use for formatting. + xp-line-limit ;;If non-NIL the max number of lines to print. + xp-line-no ;;number of next line to be printed. + xp-char-mode ;;NIL :UP :DOWN :CAP0 :CAP1 :CAPW + xp-char-mode-counter ;depth of nesting of ~(...~) + xp-depth-in-blocks ;;Number of logical blocks at QRIGHT that + ;;are started but not ended. + xp-block-stack + xp-block-stack-ptr + ;;This stack is pushed and popped in accordance with the way blocks are + ;;nested at the moment they are entered into the queue. It contains the + ;;following block specific value. + ;;SECTION-START total position where the section (see AIM-1102) + ;;that is rightmost in the queue started. + xp-buffer + xp-charpos + xp-buffer-ptr + xp-buffer-offset + ;;This is a vector of characters (eg a string) that builds up the + ;;line images that will be printed out. BUFFER-PTR is the + ;;buffer position where the next character should be inserted in + ;;the string. CHARPOS is the output character position of the + ;;first character in the buffer (non-zero only if a partial line + ;;has been output). BUFFER-OFFSET is used in computing total lengths. + ;;It is changed to reflect all shifting and insertion of prefixes so that + ;;total length computes things as they would be if they were + ;;all on one line. Positions are kept three different ways + ;; Buffer position (eg BUFFER-PTR) + ;; Line position (eg (+ BUFFER-PTR CHARPOS)). Indentations are stored in this form. + ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET)) + ;; Positions are stored in this form. + xp-queue + xp-qleft + xp-qright + ;;This holds a queue of action descriptors. QLEFT and QRIGHT + ;;point to the next entry to dequeue and the last entry enqueued + ;;respectively. The queue is empty when + ;;(> QLEFT QRIGHT). The queue entries have several parts: + ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK + ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH + ;; or :BLOCK/:CURRENT + ;;QPOS total position corresponding to this entry + ;;QDEPTH depth in blocks of this entry. + ;;QEND offset to entry marking end of section this entry starts. (NIL until known.) + ;; Only :start-block and non-literal :newline entries can start sections. + ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known). + ;;QARG for :IND indentation delta + ;; for :START-BLOCK suffix in the block if any. + ;; or if per-line-prefix then cons of suffix and + ;; per-line-prefix. + ;; for :END-BLOCK suffix for the block if any. + xp-prefix + ;;this stores the prefix that should be used at the start of the line + xp-prefix-stack + xp-prefix-stack-ptr + ;;This stack is pushed and popped in accordance with the way blocks + ;;are nested at the moment things are taken off the queue and printed. + ;;It contains the following block specific values. + ;;PREFIX-PTR current length of PREFIX. + ;;SUFFIX-PTR current length of pending suffix + ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix. + ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block. + ;;SECTION-START-LINE line-no value at last non-literal break at this level. + xp-suffix + ;;this stores the suffixes that have to be printed to close of the current + ;;open blocks. For convenient in popping, the whole suffix + ;;is stored in reverse order. + xp-stream ;;; the xp-stream containing this structure + xp-string-stream ;; string-stream for output until first circularity (in case none) + ) + +(def-accessors (afunc) %svref + () ; 'afunc + afunc-acode + afunc-parent + afunc-vars + afunc-inherited-vars + afunc-blocks + afunc-tags + afunc-inner-functions + afunc-name + afunc-bits + afunc-lfun + afunc-environment + afunc-lambdaform + afunc-argsword + afunc-ref-form + afunc-warnings + afunc-fn-refcount + afunc-fn-downward-refcount + afunc-all-vars + afunc-callers + afunc-vcells + afunc-fcells + afunc-fwd-refs + afunc-lfun-info + afunc-linkmap) + +(defmacro %make-afunc () + `(%istruct 'afunc + nil ;afunc-acode + nil ;afunc-parent + nil ;afunc-vars + nil ;afunc-inherited-vars + nil ;afunc-blocks + nil ;afunc-tags + nil ;afunc-inner-functions + nil ;afunc-name + nil ;afunc-bits + nil ;afunc-lfun + nil ;afunc-environment + nil ;afunc-lambdaform + nil ;afunc-argsword + nil ;afunc-ref-form + nil ;afunc-warnings + nil ;afunc-fn-refcount + nil ;afunc-fn-downward-refcount + nil ;afunc-all-vars + nil ;afunc-callers + nil ;afunc-vcells + nil ;afunc-fcells + nil ;afunc-fwd-refs + nil ;afunc-lfun-info + nil ;afunc-linkmap + )) + + +(def-accessors (compiler-policy) uvref + nil ; 'compiler-policy + policy.allow-tail-recursion-elimination + policy.inhibit-register-allocation + policy.trust-declarations + policy.open-code-inline + policy.inhibit-safety-checking + policy.declarations-typecheck + policy.inline-self-calls + policy.allow-transforms + policy.force-boundp-checks + policy.allow-constant-substitution + policy.misc) + + +(def-accessors (deferred-warnings) %svref + nil + deferred-warnings.parent + deferred-warnings.warnings + deferred-warnings.defs + deferred-warnings.last-file +) + +;;; loader framework istruct +(def-accessors (faslapi) %svref + () + ;; these represent all users of faslstate.iobuffer, .bufcount, and + ;; .faslfd -- I think these are all the important file- and + ;; buffer-IO-specific slots in faslstate; encapsulating these allows + ;; sophisticated users to load fasl data from nonstandard sources + ;; without too much trouble + faslapi.fasl-open + faslapi.fasl-close + faslapi.fasl-init-buffer + faslapi.fasl-set-file-pos + faslapi.fasl-get-file-pos + faslapi.fasl-read-buffer + faslapi.fasl-read-byte + faslapi.fasl-read-n-bytes) + + +(defmacro istruct-cell-name (cell) + `(car ,cell)) + +(defmacro istruct-cell-info (cell) + `(cdr ,cell)) + +(provide "LISPEQU") + +;;; End of lispequ.lisp Index: /branches/qres/ccl/library/loop.lisp =================================================================== --- /branches/qres/ccl/library/loop.lisp (revision 13564) +++ /branches/qres/ccl/library/loop.lisp (revision 13564) @@ -0,0 +1,2129 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (ANSI-LOOP "COMMON-LISP"); Base: 10; Lowercase:T -*- +;;;> +;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. +;;;> 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 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. +;;;> +;;;> Massachusetts Institute of Technology +;;;> 77 Massachusetts Avenue +;;;> Cambridge, Massachusetts 02139 +;;;> United States of America +;;;> +1-617-253-1000 +;;;> +;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc. +;;;> 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 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. +;;;> +;;;> Symbolics, Inc. +;;;> 8 New England Executive Park, East +;;;> Burlington, Massachusetts 01803 +;;;> United States of America +;;;> +1-617-221-1000 + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Modification History +;;; +;;; 07/28/92 bill loop-bind-block now does destructuring correctly. +;;; 07/07/92 bill Prevent one more warning in loop-hash-table-iteration-path +;;; 04/23/92 bill loop-do-finally now supports "finally return expr" +;;; and "finally [do | doing] {expr}*" instead of just +;;; "finally {expr}*". +;;; 03/23/92 gb Use IGNORABLE declarations when (if (multiple-value-setq (...) ...) ...) +;;; involved. +;;; ------------- 2.0 +;;; 03/12/92 bill gb's patches to prevent compiler warnings +;;; for hash-values, hash-types, and symbols + +;;;; LOOP Iteration Macro + +(defpackage ANSI-LOOP (:use "COMMON-LISP")) + +(in-package :ansi-loop) + +;;; Technology. +;;; +;;; The LOOP iteration macro is one of a number of pieces of code +;;; originally developed at MIT for which free distribution has been +;;; permitted, as long as the code is not sold for profit, and as long +;;; as notification of MIT's interest in the code is preserved. +;;; +;;; This version of LOOP, which is almost entirely rewritten both as +;;; clean-up and to conform with the ANSI Lisp LOOP standard, started +;;; life as MIT LOOP version 829 (which was a part of NIL, possibly +;;; never released). +;;; +;;; A "light revision" was performed by me (Glenn Burke) while at +;;; Palladian Software in April 1986, to make the code run in Common +;;; Lisp. This revision was informally distributed to a number of +;;; people, and was sort of the "MIT" version of LOOP for running in +;;; Common Lisp. +;;; +;;; A later more drastic revision was performed at Palladian perhaps a +;;; year later. This version was more thoroughly Common Lisp in style, +;;; with a few miscellaneous internal improvements and extensions. I +;;; have lost track of this source, apparently never having moved it to +;;; the MIT distribution point. I do not remember if it was ever +;;; distributed. +;;; +;;; This revision for the ANSI standard is based on the code of my April +;;; 1986 version, with almost everything redesigned and/or rewritten. + + + +;;; The design of this LOOP is intended to permit, using mostly the same +;;; kernel of code, up to three different "loop" macros: +;;; +;;; (1) The unextended, unextensible ANSI standard LOOP; +;;; +;;; (2) A clean "superset" extension of the ANSI LOOP which provides +;;; functionality similar to that of the old LOOP, but "in the style of" +;;; the ANSI LOOP. For instance, user-definable iteration paths, with a +;;; somewhat cleaned-up interface. +;;; +;;; (3) Extensions provided in another file which can make this LOOP +;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, +;;; with only a small addition of code (instead of two whole, separate, +;;; LOOP macros). +;;; +;;; Each of the above three LOOP variations can coexist in the same LISP +;;; environment. +;;; + + + +;;;; Miscellaneous Environment Things + +;;; The uses of this macro are retained in the CL version of loop, in +;;; case they are needed in a particular implementation. Originally +;;; dating from the use of the Zetalisp COPYLIST* function, this is used +;;; in situations where, were cdr-coding in use, having cdr-NIL at the +;;; end of the list might be suboptimal because the end of the list will +;;; probably be RPLACDed and so cdr-normal should be used instead. +(defmacro loop-copylist* (l) + `(copy-list ,l)) + +(defvar *loop-gentemp* + nil) + +(defun loop-gentemp (&optional (pref 'loopvar-)) + (if *loop-gentemp* + (gentemp (string pref)) + (gensym (string pref)))) + +(defvar *loop-real-data-type* 'real) + +(defun loop-optimization-quantities (env) + ;;@@@@ The ANSI conditionalization here is for those lisps that implement + ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). + ;; It is really commentary on how this code could be written. I don't + ;; actually expect there to be an ANSI #+-conditional -- it should be + ;; replaced with the appropriate conditional name for your + ;; implementation/dialect. + ;; Uhh, DECLARATION-INFORMATION isn't ANSI-CL anymore + (let ((stuff (ccl:declaration-information 'optimize env))) + (values (or (cadr (assoc 'speed stuff)) 1) + (or (cadr (assoc 'space stuff)) 1) + (or (cadr (assoc 'safety stuff)) 1) + (or (cadr (assoc 'compilation-speed stuff)) 1) + (or (cadr (assoc 'debug stuff)) 1)))) + + +;;;@@@@ The following form takes a list of variables and a form which presumably +;;; references those variables, and wraps it somehow so that the compiler does not +;;; consider those variables have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). +(defun hide-variable-references (variable-list form) + (declare (ignore variable-list)) + form) + +;;;@@@@ The following function takes a flag, a variable, and a form which presumably +;;; references that variable, and wraps it somehow so that the compiler does not +;;; consider that variable to have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). +;;;Certain cases require that the "invisibility" of the reference be conditional upon +;;; something. This occurs in cases of "named" variables (the USING clause). For instance, +;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) +;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is +;;; not referenced. However, if no USING clause is present, we definitely do not +;;; want to be informed that some random gensym is not used. +;;;It is easier for the caller to do this conditionally by passing a flag (which +;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than +;;; for all callers to contain the conditional invisibility construction. +(defun hide-variable-reference (really-hide variable form) + (declare (ignore really-hide variable)) + form) + + + +;;;; List Collection Macrology + + +(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) + &body body) + (let ((l (and user-head-var (list (list user-head-var nil))))) + `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) + ,@body))) + + +(defmacro loop-collect-rplacd (&environment env + (head-var tail-var &optional user-head-var) form) + (setq form (macroexpand form env)) + (flet ((cdr-wrap (form n) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) + (let ((tail-form form) (ncdrs nil)) + ;;Determine if the form being constructed is a list of known length. + (when (consp form) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form)))) + ;;@@@@ Because the last element is going to be RPLACDed, + ;; we don't want the cdr-coded implementations to use + ;; cdr-nil at the end (which would just force copying + ;; the whole list again). + ) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) + (let ((answer + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;;@@@@ Here we have a choice of two idioms: + ;; (rplacd tail (setq tail tail-form)) + ;; (setq tail (setf (cdr tail) tail-form)). + ;;Genera and most others I have seen do better with the former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) + ncdrs)))))) + ;;If not using locatives or something similar to update the user's + ;; head variable, we've got to set it... It's harmless to repeatedly set it + ;; unconditionally, and probably faster than checking. + (when user-head-var + (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) + answer)))) + + +(defmacro loop-collect-answer (head-var &optional user-head-var) + (or user-head-var + (progn + ;;If we use locatives to get tail-updating to update the head var, + ;; then the head var itself contains the answer. Otherwise we + ;; have to cdr it. + `(cdr ,head-var)))) + + + +;;;; Maximization Technology + + +#| +The basic idea of all this minimax randomness here is that we have to +have constructed all uses of maximize and minimize to a particular +"destination" before we can decide how to code them. The goal is to not +have to have any kinds of flags, by knowing both that (1) the type is +something which we can provide an initial minimum or maximum value for +and (2) know that a MAXIMIZE and MINIMIZE are not being combined. + +SO, we have a datastructure which we annotate with all sorts of things, +incrementally updating it as we generate loop body code, and then use +a wrapper and internal macros to do the coding when the loop has been +constructed. +|# + + +(defstruct (loop-minimax + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) + answer-variable + type + temp-variable + flag-variable + operations + infinity-data) + + +(defvar *loop-minimax-type-infinities-alist* + '((fixnum most-positive-fixnum most-negative-fixnum)) + ) + + +(defun make-loop-minimax (answer-variable type) + (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) + (make-loop-minimax-internal + :answer-variable answer-variable + :type type + :temp-variable (loop-gentemp 'loop-maxmin-temp-) + :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-)) + :operations nil + :infinity-data infinity-data))) + + +(defun loop-note-minimax-operation (operation minimax) + (pushnew (the symbol operation) (loop-minimax-operations minimax)) + (when (and (cdr (loop-minimax-operations minimax)) + (not (loop-minimax-flag-variable minimax))) + (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-))) + operation) + + +(defmacro with-minimax-value (lm &body body) + (let ((init (loop-typed-init (loop-minimax-type lm))) + (which (car (loop-minimax-operations lm))) + (infinity-data (loop-minimax-infinity-data lm)) + (answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (type (loop-minimax-type lm))) + (if flag-var + `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body) + `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) + (,temp-var ,init)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body)))) + + +(defmacro loop-accumulate-minimax-value (lm operation form) + (let* ((answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (test + (hide-variable-reference + t (loop-minimax-answer-variable lm) + `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var)))) + `(progn + (setq ,temp-var ,form) + (when ,(if flag-var `(or (not ,flag-var) ,test) test) + (setq ,@(and flag-var `(,flag-var t)) + ,answer-var ,temp-var))))) + + + + +;;;; Loop Keyword Tables + + +#| +LOOP keyword tables are hash tables string keys and a test of EQUAL. + +The actual descriptive/dispatch structure used by LOOP is called a "loop +universe" contains a few tables and parameterizations. The basic idea is +that we can provide a non-extensible ANSI-compatible loop environment, +an extensible ANSI-superset loop environment, and (for such environments +as CLOE) one which is "sufficiently close" to the old Genera-vintage +LOOP for use by old user programs without requiring all of the old LOOP +code to be loaded. +|# + + +;;;; Token Hackery + + +;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, +;;; the second a symbol to check against. +(defun loop-tequal (x1 x2) + (and (symbolp x1) (string= x1 x2))) + + +(defun loop-tassoc (kwd alist) + (and (symbolp kwd) (assoc kwd alist :test #'string=))) + + +(defun loop-tmember (kwd list) + (and (symbolp kwd) (member kwd list :test #'string=))) + + +(defun loop-lookup-keyword (loop-token table) + (and (symbolp loop-token) + (values (gethash (symbol-name loop-token) table)))) + + +(defmacro loop-store-table-data (symbol table datum) + `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) + + +(defstruct (loop-universe + (:print-function print-loop-universe) + (:copier nil) + (:predicate nil)) + keywords ;hash table, value = (fn-name . extra-data). + iteration-keywords ;hash table, value = (fn-name . extra-data). + for-keywords ;hash table, value = (fn-name . extra-data). + path-keywords ;hash table, value = (fn-name . extra-data). + type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. + type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. + ansi ;NIL, T, or :EXTENDED. + implicit-for-required ;see loop-hack-iteration + ) + + +(defun print-loop-universe (u stream level) + (declare (ignore level)) + (let ((str (case (loop-universe-ansi u) + ((nil) "Non-ANSI") + ((t) "ANSI") + (:extended "Extended-ANSI") + (t (loop-universe-ansi u))))) + (print-unreadable-object (u stream :type t :identity t) + (princ str stream)))) + + +;;;This is the "current" loop context in use when we are expanding a +;;;loop. It gets bound on each invocation of LOOP. +(defvar *loop-universe*) + + +(defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords + type-keywords type-symbols ansi) + (check-type ansi (member nil t :extended)) + (flet ((maketable (entries) + (let* ((size (length entries)) + (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal))) + (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x))) + ht))) + (make-loop-universe + :keywords (maketable keywords) + :for-keywords (maketable for-keywords) + :iteration-keywords (maketable iteration-keywords) + :path-keywords (maketable path-keywords) + :ansi ansi + :implicit-for-required (not (null ansi)) + :type-keywords (maketable type-keywords) + :type-symbols (let* ((size (length type-symbols)) + (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq))) + (dolist (x type-symbols) + (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x)))) + ht)))) + + + +;;;; Setq Hackery + + +(defvar *loop-destructuring-hooks* + nil + "If not NIL, this must be a list of two things: +a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") + + +(defun loop-make-psetq (frobs) + (and frobs + (loop-make-desetq + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) + + +(defun loop-make-desetq (var-val-pairs) + (if (null var-val-pairs) + nil + (cons (if *loop-destructuring-hooks* + (cadr *loop-destructuring-hooks*) + 'loop-really-desetq) + var-val-pairs))) + + +(defvar *loop-desetq-temporary* + (make-symbol "LOOP-DESETQ-TEMP")) + + +(defmacro loop-really-desetq (&environment env &rest var-val-pairs) + (labels ((find-non-null (var) + ;; see if there's any non-null thing here + ;; recurse if the list element is itself a list + (do ((tail var)) ((not (consp tail)) tail) + (when (find-non-null (pop tail)) (return t)))) + (loop-desetq-internal (var val &optional temp) + ;; returns a list of actions to be performed + (typecase var + (null + (when (consp val) + ;; don't lose possible side-effects + (if (eq (car val) 'prog1) + ;; these can come from psetq or desetq below. + ;; throw away the value, keep the side-effects. + ;;Special case is for handling an expanded POP. + (mapcan #'(lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (macroexpand x env))))) + (cons x nil))) + (cdr val)) + `(,val)))) + (cons + (let* ((car (car var)) + (cdr (cdr var)) + (car-non-null (find-non-null car)) + (cdr-non-null (find-non-null cdr))) + (when (or car-non-null cdr-non-null) + (if cdr-non-null + (let* ((temp-p temp) + (temp (or temp *loop-desetq-temporary*)) + (body `(,@(loop-desetq-internal car `(car ,temp)) + (setq ,temp (cdr ,temp)) + ,@(loop-desetq-internal cdr temp temp)))) + (if temp-p + `(,@(unless (eq temp val) + `((setq ,temp ,val))) + ,@body) + `((let ((,temp ,val)) + ,@body)))) + ;; no cdring to do + (loop-desetq-internal car `(car ,val) temp))))) + (otherwise + (unless (eq var val) + `((setq ,var ,val))))))) + (do ((actions)) + ((null var-val-pairs) + (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) + (setq actions (revappend + (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) + actions))))) + + + +;;;; LOOP-local variables + +;;;This is the "current" pointer into the LOOP source code. +(defvar *loop-source-code*) + + +;;;This is the pointer to the original, for things like NAMED that +;;;insist on being in a particular position +(defvar *loop-original-source-code*) + + +;;;This is *loop-source-code* as of the "last" clause. It is used +;;;primarily for generating error messages (see loop-error, loop-warn). +(defvar *loop-source-context*) + + +;;;List of names for the LOOP, supplied by the NAMED clause. +(defvar *loop-names*) + +;;;The macroexpansion environment given to the macro. +(defvar *loop-macro-environment*) + +;;;This holds variable names specified with the USING clause. +;;; See LOOP-NAMED-VARIABLE. +(defvar *loop-named-variables*) + +;;; LETlist-like list being accumulated for one group of parallel bindings. +(defvar *loop-variables*) + +;;;List of declarations being accumulated in parallel with +;;;*loop-variables*. +(defvar *loop-declarations*) + +;;;Used by LOOP for destructuring binding, if it is doing that itself. +;;; See loop-make-variable. +(defvar *loop-desetq-crocks*) + +;;; List of wrapping forms, innermost first, which go immediately inside +;;; the current set of parallel bindings being accumulated in +;;; *loop-variables*. The wrappers are appended onto a body. E.g., +;;; this list could conceivably has as its value ((with-open-file (g0001 +;;; g0002 ...))), with g0002 being one of the bindings in +;;; *loop-variables* (this is why the wrappers go inside of the variable +;;; bindings). +(defvar *loop-wrappers*) + +;;;This accumulates lists of previous values of *loop-variables* and the +;;;other lists above, for each new nesting of bindings. See +;;;loop-bind-block. +(defvar *loop-bind-stack*) + +;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause +;;;which inhibits LOOP from actually outputting a type declaration for +;;;an iteration (or any) variable. +(defvar *loop-nodeclare*) + +;;;This is simply a list of LOOP iteration variables, used for checking +;;;for duplications. +(defvar *loop-iteration-variables*) + + +;;;List of prologue forms of the loop, accumulated in reverse order. +(defvar *loop-prologue*) + +(defvar *loop-before-loop*) +(defvar *loop-body*) +(defvar *loop-after-body*) + +;;;This is T if we have emitted any body code, so that iteration driving +;;;clauses can be disallowed. This is not strictly the same as +;;;checking *loop-body*, because we permit some clauses such as RETURN +;;;to not be considered "real" body (so as to permit the user to "code" +;;;an abnormal return value "in loop"). +(defvar *loop-emitted-body*) + + +;;;List of epilogue forms (supplied by FINALLY generally), accumulated +;;; in reverse order. +(defvar *loop-epilogue*) + +;;;List of epilogue forms which are supplied after the above "user" +;;;epilogue. "normal" termination return values are provide by putting +;;;the return form in here. Normally this is done using +;;;loop-emit-final-value, q.v. +(defvar *loop-after-epilogue*) + +;;;The "culprit" responsible for supplying a final value from the loop. +;;;This is so loop-emit-final-value can moan about multiple return +;;;values being supplied. +(defvar *loop-final-value-culprit*) + +;;;If not NIL, we are in some branch of a conditional. Some clauses may +;;;be disallowed. +(defvar *loop-inside-conditional*) + +;;;If not NIL, this is a temporary bound around the loop for holding the +;;;temporary value for "it" in things like "when (f) collect it". It +;;;may be used as a supertemporary by some other things. +(defvar *loop-when-it-variable*) + +;;;Sometimes we decide we need to fold together parts of the loop, but +;;;some part of the generated iteration code is different for the first +;;;and remaining iterations. This variable will be the temporary which +;;;is the flag used in the loop to tell whether we are in the first or +;;;remaining iterations. +(defvar *loop-never-stepped-variable*) + +;;;List of all the value-accumulation descriptor structures in the loop. +;;; See loop-get-collection-info. +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) + + + +;;;; Code Analysis Stuff + + +(defun loop-constant-fold-if-possible (form &optional expected-type) + (let ((new-form form) (constantp nil) (constant-value nil)) + (when (setq constantp (constantp new-form)) + (setq constant-value (eval new-form))) + (when (and constantp expected-type) + (unless (typep constant-value expected-type) + (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." + form constant-value expected-type) + (setq constantp nil constant-value nil))) + (values new-form constantp constant-value))) + + +(defun loop-constantp (form) + (constantp form)) + + + +;;;; LOOP Iteration Optimization + +(defvar *loop-duplicate-code* + nil) + + +(defvar *loop-iteration-flag-variable* + (make-symbol "LOOP-NOT-FIRST-TIME")) + + +(defun loop-code-duplication-threshold (env) + (multiple-value-bind (speed space) (loop-optimization-quantities env) + (+ 40 (* (- speed space) 10)))) + + +(defmacro loop-body (&environment env + prologue + before-loop + main-body + after-loop + epilogue + &aux rbefore rafter flagvar) + (unless (= (length before-loop) (length after-loop)) + (loop-error "LOOP-BODY called with non-synched before- and after-loop lists.")) + ;;All our work is done from these copies, working backwards from the end: + (setq rbefore (reverse before-loop) rafter (reverse after-loop)) + (labels ((psimp (l) + (let ((ans nil)) + (dolist (x l) + (when x + (push x ans) + (when (and (consp x) (member (car x) '(go return return-from))) + (return nil)))) + (nreverse ans))) + (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) + (makebody () + (let ((form `(tagbody + ,@(psimp (append prologue (nreverse rbefore))) + next-loop + ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) + (if flagvar `(let ((,flagvar nil)) ,form) form)))) + (when (or *loop-duplicate-code* (not rbefore)) + (return-from loop-body (makebody))) + ;; This outer loop iterates once for each not-first-time flag test generated + ;; plus once more for the forms that don't need a flag test + (do ((threshold (loop-code-duplication-threshold env))) (nil) + (declare (fixnum threshold)) + ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent + ;; forms into the body. + (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) + (push (pop rbefore) main-body) + (pop rafter)) + (unless rbefore (return (makebody))) + ;; The first forms in rbefore & rafter (which are the chronologically + ;; last forms in the list) differ, therefore they cannot be moved + ;; into the main body. If everything that chronologically precedes + ;; them either differs or is equal but is okay to duplicate, we can + ;; just put all of rbefore in the prologue and all of rafter after + ;; the body. Otherwise, there is something that is not okay to + ;; duplicate, so it and everything chronologically after it in + ;; rbefore and rafter must go into the body, with a flag test to + ;; distinguish the first time around the loop from later times. + ;; What chronologically precedes the non-duplicatable form will + ;; be handled the next time around the outer loop. + (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) + ((null bb) (return-from loop-body (makebody))) ;Did it. + (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) + ((or (not (setq inc (estimate-code-size (car bb) env))) + (> (incf count inc) threshold)) + ;; Ok, we have found a non-duplicatable piece of code. Everything + ;; chronologically after it must be in the central body. + ;; Everything chronologically at and after lastdiff goes into the + ;; central body under a flag test. + (let ((then nil) (else nil)) + (do () (nil) + (push (pop rbefore) else) + (push (pop rafter) then) + (when (eq rbefore (cdr lastdiff)) (return))) + (unless flagvar + (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) + (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) + main-body)) + ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) + ;; is the same in rbefore and rafter so just copy it into the body + (do () (nil) + (pop rafter) + (push (pop rbefore) main-body) + (when (eq rbefore (cdr bb)) (return))) + (return))))))) + + + + +(defun duplicatable-code-p (expr env) + (if (null expr) 0 + (let ((ans (estimate-code-size expr env))) + (declare (fixnum ans)) + ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of + ;; optimize quantities back to help quantify how much code we are willing to + ;; duplicate. + ans))) + + +(defvar *special-code-sizes* + '((return 0) (progn 0) + (null 1) (not 1) (eq 1) (car 1) (cdr 1) + (when 1) (unless 1) (if 1) + (caar 2) (cadr 2) (cdar 2) (cddr 2) + (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) + (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) + (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) + (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) + (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) + + +(defvar *estimate-code-size-punt* + '(block + do do* dolist + flet + labels lambda let let* locally + macrolet multiple-value-bind + prog prog* + symbol-macrolet + tagbody + unwind-protect + with-open-file)) + + +(defun destructuring-size (x) + (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) + ((atom x) (+ n (if (null x) 0 1))))) + + +(defun estimate-code-size (x env) + (catch 'estimate-code-size + (estimate-code-size-1 x env))) + + +(defun estimate-code-size-1 (x env) + (flet ((list-size (l) + (let ((n 0)) + (declare (fixnum n)) + (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) + ;;@@@@ ???? (declare (function list-size (list) fixnum)) + (cond ((constantp x) 1) + ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p (estimate-code-size-1 new-form env) 1))) + ((atom x) 1) ;??? self-evaluating??? + ((symbolp (car x)) + (let ((fn (car x)) (tem nil) (n 0)) + (declare (symbol fn) (fixnum n)) + (macrolet ((f (overhead &optional (args nil args-p)) + `(the fixnum (+ (the fixnum ,overhead) + (the fixnum (list-size ,(if args-p args '(cdr x)))))))) + (cond ((setq tem (get fn 'estimate-code-size)) + (typecase tem + (fixnum (f tem)) + (t (funcall tem x env)))) + ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) + ((eq fn 'cond) + (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) + ((eq fn 'desetq) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) + ((member fn '(setq psetq)) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) + ((eq fn 'go) 1) + ((eq fn 'function) + ;;This skirts the issue of implementationally-defined lambda macros + ;; by recognizing CL function names and nothing else. + (if (or (symbolp (cadr x)) + (ccl::setf-function-name-p (cadr x))) + 1 + (throw 'duplicatable-code-p nil))) + ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) + ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) + ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) + (throw 'estimate-code-size nil)) + (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + (f 3)))))))) + (t (throw 'estimate-code-size nil))))) + + + +;;;; Loop Errors + + +(defun loop-context () + (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) + ((eq l (cdr *loop-source-code*)) (nreverse new)))) + + +(defun loop-error (format-string &rest format-args) + (ccl::signal-program-error "~?~%Current LOOP context:~{ ~S~}." + format-string format-args (loop-context))) + + +(defun loop-warn (format-string &rest format-args) + (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) + +(pushnew '(loop-error . 0) ccl::*format-arg-functions* :test #'equal) +(pushnew '(loop-warn . 0) ccl::*format-arg-functions* :test #'equal) + + +(defun loop-check-data-type (specified-type required-type + &optional (default-type required-type)) + (if (null specified-type) + default-type + (multiple-value-bind (a b) (subtypep specified-type required-type) + (cond ((not b) + (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." + specified-type required-type)) + ((not a) + (loop-error "Specified data type ~S is not a subtype of ~S." + specified-type required-type))) + specified-type))) + + + +;;;INTERFACE: Traditional, ANSI, Lucid. +(defmacro loop-finish () + "Cause the iteration to terminate \"normally\", the same as implicit +termination by an iteration driving clause, or by use of WHILE or +UNTIL -- the epilogue code (if any) will be run, and any implicitly +collected result will be returned as the value of the LOOP." + '(go end-loop)) + + + + +(defun subst-gensyms-for-nil (tree) + (declare (special *ignores*)) + (cond + ((null tree) (car (push (loop-gentemp) *ignores*))) + ((atom tree) tree) + (t (cons (subst-gensyms-for-nil (car tree)) + (subst-gensyms-for-nil (cdr tree)))))) + +(defun loop-build-destructuring-bindings (crocks forms) + (if crocks + (let ((*ignores* ())) + (declare (special *ignores*)) + `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) + ,(cadr crocks) + (declare (ignore ,@*ignores*)) + ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) + forms)) + +(defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) + (let ((*loop-original-source-code* *loop-source-code*) + (*loop-source-context* nil) + (*loop-iteration-variables* nil) + (*loop-variables* nil) + (*loop-nodeclare* nil) + (*loop-named-variables* nil) + (*loop-declarations* nil) + (*loop-desetq-crocks* nil) + (*loop-bind-stack* nil) + (*loop-prologue* nil) + (*loop-wrappers* nil) + (*loop-before-loop* nil) + (*loop-body* nil) + (*loop-emitted-body* nil) + (*loop-after-body* nil) + (*loop-epilogue* nil) + (*loop-after-epilogue* nil) + (*loop-final-value-culprit* nil) + (*loop-inside-conditional* nil) + (*loop-when-it-variable* nil) + (*loop-never-stepped-variable* nil) + (*loop-names* nil) + (*loop-collection-cruft* nil)) + (loop-iteration-driver) + (loop-bind-block) + (let ((answer `(loop-body + ,(nreverse *loop-prologue*) + ,(nreverse *loop-before-loop*) + ,(nreverse *loop-body*) + ,(nreverse *loop-after-body*) + ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) + (dolist (entry *loop-bind-stack*) + (let ((vars (first entry)) + (dcls (second entry)) + (crocks (third entry)) + (wrappers (fourth entry))) + (dolist (w wrappers) + (setq answer (append w (list answer)))) + (when (or vars dcls crocks) + (let ((forms (list answer))) + ;;(when crocks (push crocks forms)) + (when dcls (push `(declare ,@dcls) forms)) + (setq answer `(,(cond ((not vars) 'locally) + (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) + (t 'let)) + ,vars + ,@(loop-build-destructuring-bindings crocks forms))))))) + (if *loop-names* + (do () ((null (car *loop-names*)) answer) + (setq answer `(block ,(pop *loop-names*) ,answer))) + `(block nil ,answer))))) + + +(defun loop-iteration-driver () + (do () ((null *loop-source-code*)) + (let ((keyword (car *loop-source-code*)) (tem nil)) + (cond ((not (symbolp keyword)) + (loop-error "~S found where LOOP keyword expected." keyword)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) + ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) + (apply (symbol-function (first tem)) (rest tem))) + ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; Alternative is to ignore it, ie let it go around to the next keyword... + (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." + keyword (car *loop-source-code*) (cadr *loop-source-code*))) + (t (loop-error "~S is an unknown keyword in LOOP macro." keyword)))))))) + + + + +(defun loop-pop-source () + (if *loop-source-code* + (pop *loop-source-code*) + (loop-error "LOOP source code ran out when another token was expected."))) + + +(defun loop-get-compound-form () + (let ((form (loop-get-form))) + (unless (consp form) + (loop-error "Compound form expected, but found ~A." form)) + form)) + +(defun loop-get-progn () + (do ((forms (list (loop-get-compound-form)) + (cons (loop-get-compound-form) forms)) + (nextform (car *loop-source-code*) + (car *loop-source-code*))) + ((atom nextform) + (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) + + +(defun loop-get-form () + (if *loop-source-code* + (loop-pop-source) + (loop-error "LOOP code ran out where a form was expected."))) + + +(defun loop-construct-return (form) + `(return-from ,(car *loop-names*) ,form)) + + +(defun loop-pseudo-body (form) + (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + +(defun loop-emit-body (form) + (setq *loop-emitted-body* t) + (loop-pseudo-body form)) + +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) + (when *loop-final-value-culprit* + (loop-warn "LOOP clause is providing a value for the iteration,~@ + however one was already established by a ~S clause." + *loop-final-value-culprit*)) + (setq *loop-final-value-culprit* (car *loop-source-context*))) + + +(defun loop-disallow-conditional (&optional kwd) + (when *loop-inside-conditional* + (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + +(defun loop-disallow-anonymous-collectors () + (when (find-if-not 'loop-collector-name *loop-collection-cruft*) + (loop-error "This LOOP clause is not permitted with anonymous collectors."))) + +(defun loop-disallow-aggregate-booleans () + (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) + (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) + + + + +;;;; Loop Types + + +(defun loop-typed-init (data-type) + (when data-type + (let ((val (if (subtypep data-type 'number) + (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) + (coerce 0 data-type) + 0) + (if (subtypep data-type 'character) + #\Null + nil)))) + (and val (typep val data-type) val)))) + + +(defun loop-optional-type (&optional variable) + ;;No variable specified implies that no destructuring is permissible. + (and *loop-source-code* ;Don't get confused by NILs... + (let ((z (car *loop-source-code*))) + (cond ((loop-tequal z 'of-type) + ;;This is the syntactically unambigous form in that the form of the + ;; type specifier does not matter. Also, it is assumed that the + ;; type specifier is unambiguously, and without need of translation, + ;; a common lisp type specifier or pattern (matching the variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;;This is the (sort of) "old" syntax, even though we didn't used to support all of + ;; these type symbols. + (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, + ;; so we will be compulsive (should we really be?) and require that we in fact be + ;; doing variable destructuring here. We must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) + (loop-error + "Destructuring type pattern ~S contains unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "Destructuring type pattern ~S doesn't match variable pattern ~S." + z variable)) + (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) + (replicate (typ v) + (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) + (translate z variable))))))) + + + + +;;;; Loop Variables + + +(defun loop-bind-block () + (when (or *loop-variables* *loop-declarations* *loop-wrappers*) + (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) + *loop-bind-stack*) + (setq *loop-variables* nil + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) + +(defun loop-variable-p (name) + (do ((entry *loop-bind-stack* (cdr entry))) (nil) + (cond ((null entry) + (return nil)) + ((assoc name (caar entry) :test #'eq) + (return t))))) + +(defun loop-make-variable (name initialization dtype &optional iteration-variable-p) + (cond ((null name) + (cond ((not (null initialization)) + (push (list (setq name (loop-gentemp 'loop-ignore-)) + initialization) + *loop-variables*) + (push `(ignore ,name) *loop-declarations*)))) + ((atom name) + (cond (iteration-variable-p + (if (member name *loop-iteration-variables*) + (loop-error "Duplicated LOOP iteration variable ~S." name) + (push name *loop-iteration-variables*))) + ((assoc name *loop-variables*) + (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) + (unless (symbolp name) + (loop-error "Bad variable ~S somewhere in LOOP." name)) + (unless initialization (setq initialization (loop-typed-init dtype))) + (when (and dtype + (null initialization) + (not (typep nil dtype))) + (if (eq dtype 'complex) + (setq initialization 0 dtype 'number) + (when iteration-variable-p + (setq dtype `(or null ,dtype))))) + (loop-declare-variable name dtype) + ;; We use ASSOC on this list to check for duplications (above), + ;; so don't optimize out this list: + (push (list name initialization) *loop-variables*)) + (initialization + (cond (*loop-destructuring-hooks* + (loop-declare-variable name dtype) + (push (list name initialization) *loop-variables*)) + (t (let ((newvar (loop-gentemp 'loop-destructure-))) + (loop-declare-variable name dtype) + (push (list newvar initialization) *loop-variables*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)))))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-variable (car name) nil tcar iteration-variable-p) + (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) + name) + + +(defun loop-make-iteration-variable (name initialization dtype) + (loop-make-variable name initialization dtype t)) + + +(defun loop-declare-variable (name dtype) + (cond ((or (null name) (null dtype) (eq dtype t)) nil) + ((symbolp name) + (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) + (push `(type ,dtype ,name) *loop-declarations*))) + ((consp name) + (cond ((consp dtype) + (loop-declare-variable (car name) (car dtype)) + (loop-declare-variable (cdr name) (cdr dtype))) + (t (loop-declare-variable (car name) dtype) + (loop-declare-variable (cdr name) dtype)))) + (t (loop-error "Invalid LOOP variable passed in: ~S." name)))) + + +(defun loop-maybe-bind-form (form data-type) + (if (loop-constantp form) + form + (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) + + + + +(defun loop-do-if (for negatep) + (let ((form (loop-get-form)) + (*loop-inside-conditional* t) + (it-p nil) + (first-clause-p t)) + (flet ((get-clause (for) + (do ((body nil)) (nil) + (let ((key (car *loop-source-code*)) (*loop-body* nil) data) + (cond ((not (symbolp key)) + (loop-error + "~S found where keyword expected getting LOOP clause after ~S." + key for)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (when (and (loop-tequal (car *loop-source-code*) 'it) + first-clause-p) + (setq *loop-source-code* + (cons (or it-p (setq it-p (loop-when-it-variable))) + (cdr *loop-source-code*)))) + (cond ((or (not (setq data (loop-lookup-keyword + key (loop-universe-keywords *loop-universe*)))) + (progn (apply (symbol-function (car data)) (cdr data)) + (null *loop-body*))) + (loop-error + "~S does not introduce a LOOP clause that can follow ~S." + key for)) + (t (setq body (nreconc *loop-body* body))))))) + (setq first-clause-p nil) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) + (let ((then (get-clause for)) + (else (when (loop-tequal (car *loop-source-code*) :else) + (loop-pop-source) + (list (get-clause :else))))) + (when (loop-tequal (car *loop-source-code*) :end) + (loop-pop-source)) + (when it-p (setq form `(setq ,it-p ,form))) + (loop-pseudo-body + `(if ,(if negatep `(not ,form) form) + ,then + ,@else)))))) + + +(defun loop-do-initially () + (loop-disallow-conditional :initially) + (push (loop-get-progn) *loop-prologue*)) + +(defun loop-do-finally () + (loop-disallow-conditional :finally) + (push (loop-get-progn) *loop-epilogue*)) + +(defun loop-do-do () + (loop-emit-body (loop-get-progn))) + +(defun loop-do-named () + (let ((name (loop-pop-source))) + (unless (symbolp name) + (loop-error "~S is an invalid name for your LOOP." name)) + (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) + (loop-error "The NAMED ~S clause occurs too late." name)) + (when *loop-names* + (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." + (car *loop-names*) name)) + (setq *loop-names* (list name nil)))) + +(defun loop-do-return () + (loop-emit-body (loop-construct-return (loop-get-form)))) + + + +;;;; Value Accumulation: List + + +(defstruct (loop-collector + (:copier nil) + (:predicate nil)) + name + class + (history nil) + (tempvars nil) + dtype + (data nil)) ;collector-specific data + + +(defun loop-get-collection-info (collector class default-type) + (let ((form (loop-get-form)) + (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) + (name (when (loop-tequal (car *loop-source-code*) 'into) + (loop-pop-source) + (loop-pop-source)))) + (when (not (symbolp name)) + (loop-error "Value accumulation recipient name, ~S, is not a symbol." name)) + (unless name + (loop-disallow-aggregate-booleans)) + (unless dtype + (setq dtype (or (loop-optional-type) default-type))) + (let ((cruft (find (the symbol name) *loop-collection-cruft* + :key #'loop-collector-name))) + (cond ((not cruft) + (when (and name (loop-variable-p name)) + (loop-error "Variable ~S cannot be used in INTO clause" name)) + (push (setq cruft (make-loop-collector + :name name :class class + :history (list collector) :dtype dtype)) + *loop-collection-cruft*)) + (t (unless (eq (loop-collector-class cruft) class) + (loop-error + "Incompatible kinds of LOOP value accumulation specified for collecting~@ + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." + name (car (loop-collector-history cruft)) collector)) + (unless (equal dtype (loop-collector-dtype cruft)) + (loop-warn + "Unequal datatypes specified in different LOOP value accumulations~@ + into ~S: ~S and ~S." + name dtype (loop-collector-dtype cruft)) + (when (eq (loop-collector-dtype cruft) t) + (setf (loop-collector-dtype cruft) dtype))) + (push collector (loop-collector-history cruft)))) + (values cruft form)))) + + +(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND + (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list* (loop-gentemp 'loop-list-head-) + (loop-gentemp 'loop-list-tail-) + (and (loop-collector-name lc) + (list (loop-collector-name lc)))))) + (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) + (unless (loop-collector-name lc) + (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) + (ecase specifically + (list (setq form `(list ,form))) + (nconc nil) + (append (unless (and (consp form) (eq (car form) 'list)) + (setq form `(loop-copylist* ,form))))) + (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) + + + +;;;; Value Accumulation: max, min, sum, count. + + + +(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'sum default-type) + (loop-check-data-type (loop-collector-dtype lc) required-type) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list (loop-make-variable + (or (loop-collector-name lc) + (loop-gentemp 'loop-sum-)) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (loop-emit-body + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) + `(setq ,(car tempvars) + (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) + ,form))))))) + + + +(defun loop-maxmin-collection (specifically) + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'maxmin *loop-real-data-type*) + (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) + (let ((data (loop-collector-data lc))) + (unless data + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-)) + (loop-collector-dtype lc)))) + (unless (loop-collector-name lc) + (loop-emit-final-value (loop-minimax-answer-variable data)))) + (loop-note-minimax-operation specifically data) + (push `(with-minimax-value ,data) *loop-wrappers*) + (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form)) + ))) + + + +;;;; Value Accumulation: Aggregate Booleans + +;;;ALWAYS and NEVER. +;;; Under ANSI these are not permitted to appear under conditionalization. +(defun loop-do-always (restrictive negate) + (let ((form (loop-get-form))) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-body `(,(if negate 'when 'unless) ,form + ,(loop-construct-return nil))) + (loop-emit-final-value t))) + + + +;;;THERIS. +;;; Under ANSI this is not permitted to appear under conditionalization. +(defun loop-do-thereis (restrictive) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-final-value) + (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) + ,(loop-construct-return *loop-when-it-variable*)))) + + + +(defun loop-do-while (negate kwd &aux (form (loop-get-form))) + (loop-disallow-conditional kwd) + (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) + + +(defun loop-do-with () + (loop-disallow-conditional :with) + (do ((var) (val) (dtype)) (nil) + (setq var (loop-pop-source) + dtype (loop-optional-type var) + val (cond ((loop-tequal (car *loop-source-code*) :=) + (loop-pop-source) + (loop-get-form)) + (t nil))) + (when (and var (loop-variable-p var)) + (loop-error "Variable ~S has already been used" var)) + (loop-make-variable var val dtype) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (loop-bind-block))))) + + + +;;;; The iteration driver + +(defun loop-hack-iteration (entry) + (flet ((make-endtest (list-of-forms) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) + (do ((pre-step-tests nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) + ;; Note we collect endtests in reverse order, but steps in correct + ;; order. MAKE-ENDTEST does the nreverse for us. + (setq tem (setq data (apply (symbol-function (first entry)) (rest entry)))) + (and (car tem) (push (car tem) pre-step-tests)) + (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) + (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) + (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (setq tem (cdr tem)) + (when *loop-emitted-body* + (loop-error "Iteration in LOOP follows body code.")) + (unless tem (setq tem data)) + (when (car tem) (push (car tem) pre-loop-pre-step-tests)) + (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) + (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) + (unless (loop-tequal (car *loop-source-code*) :and) + (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*) + *loop-after-body* (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source) ; flush the "AND" + (when (and (not (loop-universe-implicit-for-required *loop-universe*)) + (setq tem (loop-lookup-keyword + (car *loop-source-code*) + (loop-universe-iteration-keywords *loop-universe*)))) + ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. + (loop-pop-source) + (setq entry tem))))) + + + +;;;; Main Iteration Drivers + + +;FOR variable keyword ..args.. +(defun loop-do-for () + (let* ((var (loop-pop-source)) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) + (setq first-arg (loop-get-form)) + (unless (and (symbolp keyword) + (setq tem (loop-lookup-keyword + keyword + (loop-universe-for-keywords *loop-universe*)))) + (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword)) + (apply (car tem) var first-arg data-type (cdr tem)))) + +(defun loop-do-repeat () + (loop-disallow-conditional :repeat) + (let ((form (loop-get-form)) + (type 'real)) + (let ((var (loop-make-variable (loop-gentemp) form type))) + (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*) + (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*) + ;; FIXME: What should + ;; (loop count t into a + ;; repeat 3 + ;; count t into b + ;; finally (return (list a b))) + ;; return: (3 3) or (4 3)? PUSHes above are for the former + ;; variant, L-P-B below for the latter. + ))) + +(defun loop-when-it-variable () + (or *loop-when-it-variable* + (setq *loop-when-it-variable* + (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) + + + +;;;; Various FOR/AS Subdispatches + + +;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN +;;; is omitted (other than being more stringent in its placement), and like +;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first +;;; initialization occurs in the loop body (first-step), not in the variable binding +;;; phase. +(defun loop-ansi-for-equals (var val data-type) + (loop-make-iteration-variable var nil data-type) + (cond ((loop-tequal (car *loop-source-code*) :then) + ;;Then we are the same as "FOR x FIRST y THEN z". + (loop-pop-source) + `(() (,var ,(loop-get-form)) () () + () (,var ,val) () ())) + (t ;;We are the same as "FOR x = y". + `(() (,var ,val) () ())))) + + +(defun loop-for-across (var val data-type) + (loop-make-iteration-variable var nil data-type) + (let ((vector-var (loop-gentemp 'loop-across-vector-)) + (index-var (loop-gentemp 'loop-across-index-))) + (multiple-value-bind (vector-form constantp vector-value) + (loop-constant-fold-if-possible val 'vector) + (loop-make-variable + vector-var vector-form + (if (and (consp vector-form) (eq (car vector-form) 'the)) + (cadr vector-form) + 'vector)) + (loop-make-variable index-var 0 'fixnum) + (let* ((length 0) + (length-form (cond ((not constantp) + (let ((v (loop-gentemp 'loop-across-limit-))) + (push `(setq ,v (length ,vector-var)) *loop-prologue*) + (loop-make-variable v 0 'fixnum))) + (t (setq length (length vector-value))))) + (first-test `(>= ,index-var ,length-form)) + (other-test first-test) + (step `(,var (aref ,vector-var ,index-var))) + (pstep `(,index-var (1+ ,index-var)))) + (declare (fixnum length)) + (when constantp + (setq first-test (= length 0)) + (when (<= length 1) + (setq other-test t))) + `(,other-test ,step () ,pstep + ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) + + + + +;;;; List Iteration + + +(defun loop-list-step (listvar) + ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any + ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used + ;; as the stepping function. + ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not + ;; recognizing FOO may defeat some LOOP optimizations. + (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) + (loop-pop-source) + (loop-get-form)) + (t '(function cdr))))) + (cond ((and (consp stepper) (eq (car stepper) 'quote)) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + (values `(funcall ,stepper ,listvar) nil)) + ((and (consp stepper) (eq (car stepper) 'function)) + (values (list (cadr stepper) listvar) (cadr stepper))) + (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function) + ,listvar) + nil))))) + + +(defun loop-for-on (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar var)) + (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) + (t (loop-make-variable (setq listvar (loop-gentemp)) list nil) + (loop-make-iteration-variable var nil data-type))) + (multiple-value-bind (list-step step-function) (loop-list-step `(the cons ,listvar)) + (declare (ignore step-function)) + ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. + (let* ((first-endtest + (hide-variable-reference + (eq var listvar) + listvar + ;; the following should use `atom' instead of `endp', per + ;; [bug2428] + `(atom ,listvar))) + (other-endtest first-endtest)) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + (cond ((eq var listvar) + ;;Contour of the loop is different because we use the user's variable... + `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest + () () () ,first-endtest ())) + (t (let ((step `(,var (the cons ,listvar))) (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) + + +(defun loop-for-in (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar (loop-gentemp 'loop-list-))) + (loop-make-iteration-variable var nil data-type) + (loop-make-variable listvar list 'list) + (multiple-value-bind (list-step step-function) (loop-list-step listvar) + (declare (ignore step-function)) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) + + + +;;;; Iteration Paths + + +(defstruct (loop-path + (:copier nil) + (:predicate nil)) + names + preposition-groups + inclusive-permitted + function + user-data) + + +(defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) + (unless (listp names) (setq names (list names))) + ;; Can't do this due to CLOS bootstrapping problems. + (check-type universe loop-universe) + (let ((ht (loop-universe-path-keywords universe)) + (lp (make-loop-path + :names (mapcar #'symbol-name names) + :function function + :user-data user-data + :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups) + :inclusive-permitted inclusive-permitted))) + (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) + lp)) + + + +;;; Note: path functions are allowed to use loop-make-variable, hack +;;; the prologue, etc. +(defun loop-for-being (var val data-type) + ;; FOR var BEING each/the pathname prep-phrases using-stuff... + ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. + (let ((path nil) + (data nil) + (inclusive nil) + (stuff nil) + (initial-prepositions nil)) + (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) + ((loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (setq inclusive t) + (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) + (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." + (car *loop-source-code*))) + (loop-pop-source) + (setq path (loop-pop-source)) + (setq initial-prepositions `((:in ,val)))) + (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) + (cond ((not (symbolp path)) + (loop-error "~S found where a LOOP iteration path name was expected." path)) + ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) + (loop-error "~S is not the name of a LOOP iteration path." path)) + ((and inclusive (not (loop-path-inclusive-permitted data))) + (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) + (let ((fun (loop-path-function data)) + (preps (nconc initial-prepositions + (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) + (user-data (loop-path-user-data data))) + (when (symbolp fun) (setq fun (symbol-function fun))) + (setq stuff (if inclusive + (apply fun var data-type preps :inclusive t user-data) + (apply fun var data-type preps user-data)))) + (when *loop-named-variables* + (loop-error "Unused USING variables: ~S." *loop-named-variables*)) + ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user + ;; and the user from himself. + (unless (member (length stuff) '(6 10)) + (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." + path)) + (do ((l (car stuff) (cdr l)) (x)) ((null l)) + (if (atom (setq x (car l))) + (loop-make-iteration-variable x nil nil) + (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) + (cddr stuff))) + + + + +;;;INTERFACE: Lucid, exported. +;;; i.e., this is part of our extended ansi-loop interface. +(defun named-variable (name) + (let ((tem (loop-tassoc name *loop-named-variables*))) + (declare (list tem)) + (cond ((null tem) (values (loop-gentemp) nil)) + (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (values (cdr tem) t))))) + + +(defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) + (flet ((in-group-p (x group) (car (loop-tmember x group)))) + (do ((token nil) + (prepositional-phrases initial-phrases) + (this-group nil nil) + (this-prep nil nil) + (disallowed-prepositions + (mapcan #'(lambda (x) + (loop-copylist* + (find (car x) preposition-groups :test #'in-group-p))) + initial-phrases)) + (used-prepositions (mapcar #'car initial-phrases))) + ((null *loop-source-code*) (nreverse prepositional-phrases)) + (declare (symbol this-prep)) + (setq token (car *loop-source-code*)) + (dolist (group preposition-groups) + (when (setq this-prep (in-group-p token group)) + (return (setq this-group group)))) + (cond (this-group + (when (member this-prep disallowed-prepositions) + (loop-error + (if (member this-prep used-prepositions) + "A ~S prepositional phrase occurs multiply for some LOOP clause." + "Preposition ~S used when some other preposition has subsumed it.") + token)) + (setq used-prepositions (if (listp this-group) + (append this-group used-prepositions) + (cons this-group used-prepositions))) + (loop-pop-source) + (push (list this-prep (loop-get-form)) prepositional-phrases)) + ((and USING-allowed (loop-tequal token 'using)) + (loop-pop-source) + (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) + (when (cadr z) + (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) + (loop-error + "The variable substitution for ~S occurs twice in a USING phrase,~@ + with ~S and ~S." + (car z) (cadr z) (cadr tem)) + (push (cons (car z) (cadr z)) *loop-named-variables*))) + (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) + (return nil)))) + (t (return (nreverse prepositional-phrases))))))) + + + +;;;; Master Sequencer Function + + +(defun loop-sequencer (indexv indexv-type indexv-user-specified-p + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) + (let ((endform nil) ;Form (constant or variable) with limit value. + (sequencep nil) ;T if sequence arg has been provided. + (testfn nil) ;endtest function + (test nil) ;endtest form. + (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. + (stepby-constantp t) + (step nil) ;step form. + (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. + (inclusive-iteration nil) ;T if include last index. + (start-given nil) ;T when prep phrase has specified start + (start-value nil) + (start-constantp nil) + (limit-given nil) ;T when prep phrase has specified end + (limit-constantp nil) + (limit-value nil) + ) + (when variable (loop-make-iteration-variable variable nil variable-type)) + (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) + (setq prep (caar l) form (cadar l)) + (case prep + ((:of :in) + (setq sequencep t) + (loop-make-variable sequence-variable form sequence-type)) + ((:from :downfrom :upfrom) + (setq start-given t) + (cond ((eq prep :downfrom) (setq dir ':down)) + ((eq prep :upfrom) (setq dir ':up))) + (multiple-value-setq (form start-constantp start-value) + (loop-constant-fold-if-possible form indexv-type)) + (setq indexv (loop-make-iteration-variable indexv form indexv-type))) + ((:upto :to :downto :above :below) + (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) + ((loop-tequal prep :to) (setq inclusive-iteration t)) + ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) + ((loop-tequal prep :above) (setq dir ':down)) + ((loop-tequal prep :below) (setq dir ':up))) + (setq limit-given t) + (multiple-value-setq (form limit-constantp limit-value) + (loop-constant-fold-if-possible form indexv-type)) + (setq endform (if limit-constantp + `',limit-value + (loop-make-variable + (loop-gentemp 'loop-limit-) form indexv-type)))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form indexv-type)) + (unless stepby-constantp + (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path.~@ + Invalid prepositions specified in iteration path descriptor or something?" + prep))) + (when (and odir dir (not (eq dir odir))) + (loop-error "Conflicting stepping directions in LOOP sequencing path")) + (setq odir dir)) + (when (and sequence-variable (not sequencep)) + (loop-error "Missing OF or IN phrase in sequence path")) + ;; Now fill in the defaults. + (unless start-given + (loop-make-iteration-variable + indexv + (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) + indexv-type)) + (cond ((member dir '(nil :up)) + (when (or limit-given default-top) + (unless limit-given + (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) + nil indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "Don't know where to start stepping.")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) + (when step-hack + (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) + (let ((first-test test) (remaining-tests test)) + (when (and stepby-constantp start-constantp limit-constantp) + (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack + () () ,first-test ,step-hack)))) + + + +;;;; Interfaces to the Master Sequencer + + + +(defun loop-for-arithmetic (var val data-type kwd) + (loop-sequencer + var (loop-check-data-type data-type 'number) t + nil nil nil nil nil nil + (loop-collect-prepositional-phrases + '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) + nil (list (list kwd val))))) + + +(defun loop-sequence-elements-path (variable data-type prep-phrases + &key fetch-function size-function sequence-type element-type) + (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) + (let ((sequencev (named-variable 'sequence))) + (list* nil nil ; dummy bindings and prologue + (loop-sequencer + indexv 'fixnum indexv-user-specified-p + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) + prep-phrases))))) + + + +;;;; Builtin LOOP Iteration Paths + + +#|| +(loop for v being the hash-values of ht do (print v)) +(loop for k being the hash-keys of ht do (print k)) +(loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) +(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) +||# + +(defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) + (check-type which (member hash-key hash-value)) + (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Too many prepositions!")) + ((null prep-phrases) (loop-error "Missing OF or IN in iteration path." ))) + (let ((ht-var (loop-gentemp 'loop-hashtab-)) + (next-fn (loop-gentemp 'loop-hashtab-next-)) + (dummy-predicate-var nil) + (post-steps nil)) + (multiple-value-bind (other-var other-p) + (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) + ;;@@@@ named-variable returns a second value of T if the name was actually + ;; specified, so clever code can throw away the gensym'ed up variable if + ;; it isn't really needed. + (unless other-p (push `(ignorable ,other-var) *loop-declarations*)) + ;;The following is for those implementations in which we cannot put dummy NILs + ;; into multiple-value-setq variable lists. + (setq other-p t + dummy-predicate-var (loop-when-it-variable)) + (setq variable (or variable (loop-gentemp 'ignore-))) + (let ((key-var nil) + (val-var nil) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (if (eq which 'hash-key) + (setq key-var variable val-var (and other-p other-var)) + (setq key-var (and other-p other-var) val-var variable)) + (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) + (when (or (consp key-var) data-type) + (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) + ,@post-steps)) + (push `(,key-var nil) bindings)) + (when (or (consp val-var) data-type) + (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) + ,@post-steps)) + (push `(,val-var nil) bindings)) + (push `(ignorable ,dummy-predicate-var) *loop-declarations*) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) (,next-fn))) ;post-test + ,post-steps))))) + + +(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) + (cond ((and prep-phrases (cdr prep-phrases)) + (loop-error "Too many prepositions!")) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Unknown preposition ~S" (caar prep-phrases)))) + (unless (symbolp variable) + (loop-error "Destructuring is not valid for package symbol iteration.")) + (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) + (next-fn (loop-gentemp 'loop-pkgsym-next-)) + (variable (or variable (loop-gentemp 'ignore-))) + (pkg (or (cadar prep-phrases) '*package*))) + (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) + (push `(ignorable ,(loop-when-it-variable)) *loop-declarations*) + + `(((,variable nil ,data-type) (,pkg-var ,pkg)) + () + () + () + (not (multiple-value-setq (,(progn + ;;@@@@ If an implementation can get away without actually + ;; using a variable here, so much the better. + (loop-when-it-variable)) + ,variable) + (,next-fn))) + ()))) + + +;;;; ANSI Loop + +(defun make-ansi-loop-universe (extended-p) + (let ((w (make-standard-loop-universe + :keywords `((named (loop-do-named)) + (initially (loop-do-initially)) + (finally (loop-do-finally)) + (do (loop-do-do)) + (doing (loop-do-do)) + (return (loop-do-return)) + (collect (loop-list-collection list)) + (collecting (loop-list-collection list)) + (append (loop-list-collection append)) + (appending (loop-list-collection append)) + (nconc (loop-list-collection nconc)) + (nconcing (loop-list-collection nconc)) + (count (loop-sum-collection count ,*loop-real-data-type* fixnum)) + (counting (loop-sum-collection count ,*loop-real-data-type* fixnum)) + (sum (loop-sum-collection sum number number)) + (summing (loop-sum-collection sum number number)) + (maximize (loop-maxmin-collection max)) + (minimize (loop-maxmin-collection min)) + (maximizing (loop-maxmin-collection max)) + (minimizing (loop-maxmin-collection min)) + (always (loop-do-always t nil)) ; Normal, do always + (never (loop-do-always t t)) ; Negate the test on always. + (thereis (loop-do-thereis t)) + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ; Negate the test on while + (when (loop-do-if when nil)) ; Normal, do when + (if (loop-do-if if nil)) ; synonymous + (unless (loop-do-if unless t)) ; Negate the test on when + (with (loop-do-with)) + (repeat (loop-do-repeat))) + :for-keywords '((= (loop-ansi-for-equals)) + (across (loop-for-across)) + (in (loop-for-in)) + (on (loop-for-on)) + (from (loop-for-arithmetic :from)) + (downfrom (loop-for-arithmetic :downfrom)) + (upfrom (loop-for-arithmetic :upfrom)) + (below (loop-for-arithmetic :below)) + (above (loop-for-arithmetic :above)) + (by (loop-for-arithmetic :by)) + (to (loop-for-arithmetic :to)) + (upto (loop-for-arithmetic :upto)) + (downto (loop-for-arithmetic :downto)) + (being (loop-for-being))) + :iteration-keywords '((for (loop-do-for)) + (as (loop-do-for))) + :type-symbols '(array atom bignum bit bit-vector character compiled-function + complex cons double-float fixnum float + function hash-table integer keyword list long-float + nil null number package pathname random-state + ratio rational readtable sequence short-float + simple-array simple-bit-vector simple-string + simple-vector single-float standard-char + stream string base-char + symbol t vector) + :type-keywords nil + :ansi (if extended-p :extended t)))) + (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which hash-key)) + (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which hash-value)) + (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal :external :inherited))) + (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:external))) + (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal :external))) + w)) + + +(defparameter *loop-ansi-universe* + (make-ansi-loop-universe nil)) + + +(defun loop-standard-expansion (keywords-and-forms environment universe) + (if (and keywords-and-forms (symbolp (car keywords-and-forms))) + (loop-translate keywords-and-forms environment universe) + (let ((tag (gensym))) + `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) + + +(fmakunbound 'loop) ; Avoid redefinition warning + +;;;INTERFACE: ANSI +(defmacro loop (&environment env &rest keywords-and-forms) + (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) + +(cl:provide "LOOP") Index: /branches/qres/ccl/library/mac-file-io.lisp =================================================================== --- /branches/qres/ccl/library/mac-file-io.lisp (revision 13564) +++ /branches/qres/ccl/library/mac-file-io.lisp (revision 13564) @@ -0,0 +1,161 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Opensourced MCL. +;;; +;;; Opensourced MCL 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; either +;;; version 2.1 of the License, or (at your option) any later version. +;;; +;;; Opensourced MCL 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; mac-file-io.lisp +;; + +;; This file implements something similar to the high-level file I/O +;; primitives in Inside Macintosh. +;; It does NOT support asynchronous I/O (and neither does the Macintosh, really). + +;; Routines that take an errorp parameter will signal an error if +;; the parameter is unspecified or true, otherwise, if there is an +;; error they return two values: NIL & the error number. +;; If there is no error, routines return one or more values the +;; first of which is non-NIL. + +;;;;;;;;;;;;; +;; +;; Modification History +;; + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require 'sysequ)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(with-FSOpen-file FSOpen FSClose FSRead FSWrite setFPos getFPos getEOF))) + +(defmacro with-FSOpen-file ((pb filename &optional read-write-p (vrefnum 0)) + &body body) + `(let ((,pb (FSOpen ,filename ,read-write-p ,vrefnum))) + (unwind-protect + (progn ,@body) + (FSClose ,pb)))) + +(defmacro with-FSOpen-file-noerr ((pb filename &optional read-write-p (vrefnum 0)) + &body body) + `(let ((,pb (ignore-errors + (FSOpen ,filename ,read-write-p ,vrefnum)))) + (when ,pb + (unwind-protect + (progn ,@body) + (FSClose ,pb))))) + +; Returns a paramBlock for doing furthur I/O with the file +(defun FSOpen (filename &optional read-write-p (vrefnum 0) (errorp t) + (resolve-aliases-p t)) + (when resolve-aliases-p (setq filename (truename filename))) + (let ((paramBlock (make-record :hparamblockrec)) + ok) + (unwind-protect + (with-pstrs ((pname (mac-namestring filename))) + (setf (pref paramblock :hparamblockrec.ioNameptr) pname + (pref paramblock :hparamblockrec.ioVrefnum) vrefnum + (pref paramblock :hparamblockrec.ioVersNum) 0 + (pref paramblock :hparamblockrec.ioPermssn) (if read-write-p #$fsRdWrPerm #$fsRdPerm) + (pref paramblock :hparamblockrec.ioMisc) (%null-ptr)) + (#_PBOpenSync paramBlock) + (let ((res (pref paramBlock :hparamblockrec.ioResult))) + (if (eql #$NoErr res) + (progn + (setf (pref paramblock :hparamblockrec.ioPosOffSet) 0 + (pref paramblock :hparamblockrec.ioPosMode) #$fsAtMark) + (setq ok t) + paramBlock) + (maybe-file-error errorp res filename)))) + (unless ok + (#_DisposePtr paramBlock))))) + +(defun FSClose (paramBlock &optional (errorp t)) + (#_PBCloseSync paramBlock) + (let ((errnum (pref paramBlock :hparamblockrec.ioResult))) + (#_DisposePtr paramBlock) + (or (eql errnum #$noErr) + (maybe-file-error errorp errnum)))) + +; Returns two values: the number of bytes actually read, and the +; location of the file mark. +(defun fsRead (paramBlock count buffer &optional (offset 0) (errorp t)) + (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset) + (pref paramBlock :hparamblockrec.ioReqCount) count) + (#_PBReadSync paramBlock) + (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark) + (let ((errnum (pref paramBlock :hparamblockrec.ioResult))) + (if (or (eql #$noErr errnum) (eql #$eofErr errnum)) + (values (pref paramBlock :hparamblockrec.ioActCount) + (pref paramBlock :hparamblockrec.ioPosOffset)) + (maybe-file-error errorp errnum)))) + +; Returns two values: the number of bytes actually written, and the +; location of the file mark. +(defun fsWrite (paramBlock count buffer &optional (offset 0) (errorp t)) + (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset) + (pref paramBlock :hparamblockrec.ioReqCount) count) + (#_PBWriteSync paramBlock) + (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark) + (let ((errnum (pref paramBlock :hparamblockrec.ioResult))) + (if (or (eql #$noErr errnum) (eql #$eofErr errnum)) + (values (pref paramBlock :hparamblockrec.ioActCount) + (pref paramBlock :hparamblockrec.ioPosOffset)) + (maybe-file-error errorp errnum)))) + +(defun setFPos (paramBlock pos) + (setf (pref paramBlock :hparamblockrec.ioPosOffset) pos + (pref paramblock :hparamblockrec.ioPosMode) #$fsFromStart) + pos) + +(defun getFPos (paramBlock) + (pref paramBlock :hparamblockrec.ioPosOffset)) + +(defun getEOF (paramBlock &optional (errorp t)) + (let* ((errnum (#_PBGetEOFSync paramBlock))) + (if (eql #$noErr errnum) + (%ptr-to-int (pref paramblock :hparamblockrec.ioMisc)) + (maybe-file-error errorp errnum)))) + +(defun GetVInfo (&key (volName "") (vRefNum 0)) + (let* ((vol-pathname (truename (make-pathname :type nil :name nil :defaults volName))) + (directory (pathname-directory vol-pathname))) + (assert (and directory (eq :absolute (car directory)))) + (rlet ((paramBlock :hparamblockrec)) + (with-returned-pstrs ((pname (cadr directory))) + (setf (pref paramblock :hparamblockrec.ioCompletion) (%null-ptr) + (pref paramblock :hparamblockrec.ioNamePtr) pname + (pref paramblock :hparamblockrec.ioVRefNum) vRefNum + (pref paramblock :hparamblockrec.ioVolIndex) 0) + (values (#_PBHGetVInfoSync paramBlock) + (* (%get-unsigned-long paramblock $ioVAlBlkSiz) ; see IM:Files 2-46 + (pref paramblock :hparamblockrec.ioVFrBlk)) + (pref paramblock :hparamblockrec.ioVRefNum) + (%get-string (pref paramblock :hparamblockrec.ioNamePtr))))))) + +(defun maybe-file-error (errorp errnum &optional filename) + (if errorp + (%err-disp errnum filename) + (values nil errnum))) + +(provide :mac-file-io) + +; End of mac-file-io.lisp Index: /branches/qres/ccl/library/mach-o-symbols.lisp =================================================================== --- /branches/qres/ccl/library/mach-o-symbols.lisp (revision 13564) +++ /branches/qres/ccl/library/mach-o-symbols.lisp (revision 13564) @@ -0,0 +1,216 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; String tables: used both for symbol names and for section names. +(defstruct mach-o-string-table + (hash (make-hash-table :test #'equal)) + (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t))) + +;;; Collect info about Mach-O symbols. +(defstruct mach-o-symbol-table + (strings (make-mach-o-string-table)) + data ; foreign pointer + nsyms + ) + +(defun mach-o-lisp-function-name (f) + (let* ((name (format nil "~s" f))) + (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1))) + +(defun mach-o-register-string (string table) + (let* ((hash (mach-o-string-table-hash table)) + (s (mach-o-string-table-string table))) + (when (gethash string hash) + (format t "~& duplicate: ~s" string)) + (or (gethash string hash) + (setf (gethash string hash) + (let* ((n (length s))) + (dotimes (i (length string) (progn (vector-push-extend 0 s) n)) + (let* ((code (char-code (char string i)))) + (declare (type (mod #x110000 code))) + (if (> code 255) + (vector-push-extend (char-code #\sub) s) + (vector-push-extend code s))))))))) + +(defun readonly-area-bounds () + (ccl::do-gc-areas (a) + (when (eql (ccl::%fixnum-ref a target::area.code) + ccl::area-readonly) + (return + (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift) + (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))) + +#+ppc-target +(defun collect-mach-o-static-functions () + (purify) + (multiple-value-bind (readonly-low readonly-high) + (readonly-area-bounds) + (let* ((hash (make-hash-table :test #'eq))) + (ccl::%map-lfuns #'(lambda (f) + (let* ((code-vector (ccl:uvref f 0)) + (startaddr (+ (ccl::%address-of code-vector) + target::misc-data-offset))) + (when (and (>= startaddr readonly-low) + (< startaddr readonly-high)) + (push f (gethash code-vector hash)))))) + (collect ((functions)) + (maphash #'(lambda (k v) + (declare (ignore k)) + (if (null (cdr v)) + (functions (car v)))) + hash) + (values (sort (functions) + #'(lambda (x y) + (< (ccl::%address-of (uvref x 0)) + (ccl::%address-of (uvref y 0))))) + readonly-low + (- readonly-high readonly-low)))))) + +(defun register-mach-o-functions (functions section-number) + (let* ((n (length functions)) + (nlist-len #+64-bit-target (record-length :nlist_64) + #+32-bit-target (record-length :nlist)) + (data (#_calloc n nlist-len)) + (string-table (make-mach-o-string-table))) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (p (%inc-ptr data 0) (progn (%incf-ptr p nlist-len) p)) + (f (pop functions) (pop functions))) + ((= i n) + (make-mach-o-symbol-table :strings string-table :data data :nsyms n)) + (declare (fixnum i)) + (let* ((namidx (mach-o-register-string (mach-o-lisp-function-name f) string-table)) + (value (%address-of #+ppc-target (uvref f 0) #-ppc-target g)) + (type #$N_SECT)) + #+32-bit-target + (setf (pref p :nlist.n_un.n_strx) namidx + (pref p :nlist.n_value) value + (pref p :nlist.n_type) type + (pref p :nlist.n_other) section-number) + #+64-bit-target + (setf (pref p :nlist_64.n_un.n_strx) namidx + (pref p :nlist_64.n_value) value + (pref p :nlist_64.n_type) type + (pref p :nlist_64.n_sect) section-number))))) + +(defun write-mach-o-symbol-info (fd symtab) + (let* ((symoff *host-page-size*) + (nsyms (mach-o-symbol-table-nsyms symtab)) + (symsize (* nsyms (record-length #+64-bit-target :nlist_64 + #+32-bit-target :nlist))) + (stroff (+ symoff symsize)) + (string (mach-o-string-table-string (mach-o-symbol-table-strings symtab))) + (strsize (length string)) + (bytes (array-data-and-offset string)) + (strbuf (#_malloc strsize))) + (%copy-ivector-to-ptr bytes 0 strbuf 0 strsize) + (fd-lseek fd symoff #$SEEK_SET) + (fd-write fd (mach-o-symbol-table-data symtab) symsize) + (fd-write fd strbuf strsize) + (values symoff nsyms stroff strsize))) + +(defun write-mach-o-load-commands (fd pos) + (multiple-value-bind (functions start length) + (collect-mach-o-static-functions) + (let* ((symbols (register-mach-o-functions functions 1))) + (multiple-value-bind (symoff nsyms stroff strsize) + (write-mach-o-symbol-info fd symbols) + (rlet ((symtab :symtab_command + :cmd #$LC_SYMTAB + :cmdsize (record-length :symtab_command) + :symoff symoff + :nsyms nsyms + :stroff stroff + :strsize strsize)) + (let* ((segsize (record-length #+64-bit-target :segment_command_64 + #+32-bit-target :segment_command)) + (sectsize (record-length #+64-bit-target :section_64 + #+32-bit-target :section)) + (totalsize (+ segsize sectsize))) + (%stack-block ((segment totalsize :clear t)) + (let* ((section (%inc-ptr segment segsize))) + #+64-bit-target + (progn + (setf (pref segment :segment_command_64.cmd) #$LC_SEGMENT_64 + (pref segment :segment_command_64.cmdsize) totalsize) + (%cstr-pointer #$SEG_DATA + (pref segment :segment_command_64.segname) + nil) + (setf (pref segment :segment_command_64.vmaddr) start + (pref segment :segment_command_64.vmsize) length + (pref segment :segment_command_64.fileoff) 0 + (pref segment :segment_command_64.filesize) 0 + (pref segment :segment_command_64.maxprot) 0 + (pref segment :segment_command_64.initprot) 0 + (pref segment :segment_command_64.nsects) 1) + (%cstr-pointer "__lisp" (pref section :section_64.sectname) nil) + (%cstr-pointer #$SEG_DATA (pref section :section_64.segname) nil) + (setf (pref section :section_64.addr) start + (pref section :section_64.size) length + (pref section :section_64.align) 12)) + #+32-bit-target + (progn + (setf (pref segment :segment_command.cmd) #$LC_SEGMENT + (pref segment :segment_command.cmdsize) totalsize) + (%cstr-pointer #$SEG_DATA + (pref segment :segment_command.segname) + nil) + (setf (pref segment :segment_command.vmaddr) start + (pref segment :segment_command.vmsize) length + (pref segment :segment_command.fileoff) 0 + (pref segment :segment_command.filesize) 0 + (pref segment :segment_command.maxprot) 0 + (pref segment :segment_command.initprot) 0 + (pref segment :segment_command.nsects) 1) + (%cstr-pointer "__lisp" (pref section :section.sectname) nil) + (%cstr-pointer #$SEG_DATA (pref section :section.segname) nil) + (setf (pref section :section.addr) start + (pref section :section.size) length + (pref section :section.align) 12)) + (fd-lseek fd pos #$SEEK_SET) + (fd-write fd segment totalsize) + (fd-write fd symtab (record-length :symtab_command)) + (values 2 + (+ totalsize (record-length :symtab_command))))))))))) + + +(defun write-mach-header (fd) + (let* ((n (record-length #+64-bit-target :mach_header_64 + #+32-bit-target :mach_header))) + (multiple-value-bind (ncmds cmd-size) + (write-mach-o-load-commands fd n) + (rlet ((header #+64-bit-target :mach_header_64 #+32-bit-target :mach_header + :magic #+64-bit-target #$#$MH_MAGIC_64 #+32-bit-target #$MH_MAGIC + :cputype (logior #+64-bit-target #$CPU_ARCH_ABI64 + #+32-bit-target 0 + #+ppc-target #$CPU_TYPE_POWERPC + #+x86-target #$CPU_TYPE_X86) + :cpusubtype #+x86-target #$CPU_SUBTYPE_X86_ALL #+ppc-target #$CPU_SUBTYPE_POWERPC_ALL + :filetype #$MH_BUNDLE + :ncmds ncmds + :sizeofcmds cmd-size + :flags (logior #$MH_NOUNDEFS))) + (fd-lseek fd 0 #$SEEK_SET) + (let* ((res (fd-write fd header n))) + (unless (eql res n) + (%errno-disp res))) + (fd-close fd))))) + + + + + + Index: /branches/qres/ccl/library/mach-o.lisp =================================================================== --- /branches/qres/ccl/library/mach-o.lisp (revision 13564) +++ /branches/qres/ccl/library/mach-o.lisp (revision 13564) @@ -0,0 +1,133 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defstruct mach-o-file + header + load-commands + segments + symbols + strings) + +(defmethod print-object ((m mach-o-file) stream) + (print-unreadable-object (m stream :type t :identity t))) + + +(defstruct mach-o-string-table + (hash (make-hash-table :test #'equal)) + (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t))) + +(defstruct mach-o-symbol + string-index + type + sect + desc + value) + +(defun init-mach-o-string-table (fd symtab-command) + (fd-lseek fd (pref symtab-command #>symtab_command.stroff) #$SEEK_SET) + (let* ((strsize (pref symtab-command #>symtab_command.strsize)) + (nbytes (+ strsize strsize)) + (bytes (make-array nbytes :element-type '(unsigned-byte 8))) + (out 0)) + (declare (fixnum nbytes strsize out)) + (%stack-block ((buf 32768)) + (do* ((n strsize)) + ((= n 0)) + (let* ((bufsize (fd-read fd buf (min n 32768)))) + (%copy-ptr-to-ivector buf 0 bytes out bufsize) + (incf out bufsize) + (decf n bufsize)))) + (make-mach-o-string-table + :string (make-array nbytes + :element-type '(unsigned-byte 8) + :displaced-to bytes + :fill-pointer strsize + :adjustable t)))) + +(defun init-mach-o-symbols64 (fd symtab-command) + (fd-lseek fd (pref symtab-command #>symtab_command.symoff) #$SEEK_SET) + (rlet ((nlist #>nlist_64)) + (let* ((nsyms (pref symtab-command #>symtab_command.nsyms)) + (nentries (* nsyms 2)) + (vec (make-array nentries))) + (declare (fixnum nsyms nentries)) + (flet ((read-nlist () + (fd-read fd nlist (record-length #>nlist_64)) + (make-mach-o-symbol :string-index (pref nlist #>nlist_64.n_un.n_strx) + :type (pref nlist #>nlist_64.n_type) + :sect (pref nlist #>nlist_64.n_sect) + :desc (pref nlist #>nlist_64.n_desc) + :value (pref nlist #>nlist_64.n_value)))) + (dotimes (i nsyms (make-array nentries + :displaced-to vec + :fill-pointer nsyms + :adjustable t)) + (setf (svref vec i) (read-nlist))))))) + + +(defun read-header-and-load-commands64 (fd) + (fd-lseek fd 0 #$SEEK_SET) + (let* ((mh (make-record :mach_header_64)) + (mach-o (make-mach-o-file :header mh))) + (when (= (fd-read fd mh (record-length :mach_header_64)) + (record-length :mach_header_64)) + (collect ((commands)) + (flet ((read-command () + (rlet ((cmd :load_command)) + (fd-read fd cmd (record-length :load_command)) + (let* ((n (pref cmd :load_command.cmdsize)) + (p (#_malloc n)) + (q (%inc-ptr p (record-length :load_command)))) + (#_memcpy p cmd (record-length :load_command)) + (fd-read fd q (- n (record-length :load_command))) + (let* ((lcmd (pref cmd :load_command.cmd)) + (ftype + (cond ((= lcmd #$LC_SEGMENT_64) + (load-record #>segment_command_64)) + ((= lcmd #$LC_SYMTAB) + (load-record #>symtab_command)) + ((= lcmd #$LC_DYSYMTAB) + (load-record #>dysymtab_command)) + ((= lcmd #$LC_LOAD_DYLINKER) + (load-record #>dylinker_command)) + ((= lcmd #$LC_UUID) + (load-record #>uuid_command)) + ((= lcmd #$LC_LOAD_DYLIB) + (load-record #>dylib_command)) + ((= lcmd #$LC_UNIXTHREAD) + (load-record #>thread_command))))) + + (if ftype + (%set-macptr-type p (foreign-record-type-ordinal ftype)) + (format t "~&~x" lcmd))) + p)))) + (dotimes (i (pref mh :mach_header_64.ncmds)) + (commands (read-command))) + (setf (mach-o-file-load-commands mach-o) (commands)) + (dolist (cmd (mach-o-file-load-commands mach-o)) + (when (= #$LC_SYMTAB (pref cmd #>load_command.cmd)) + (setf (mach-o-file-strings mach-o) + (init-mach-o-string-table fd cmd) + (mach-o-file-symbols mach-o) + (init-mach-o-symbols64 fd cmd)))) + mach-o))))) + +(defun mach-o-string-index (mo string) + (let* ((bytes (make-array (the fixnum (+ (length string) 2)) :element-type '(unsigned-byte 8)))) + (declare (dynamic-extent bytes)) + (dotimes (i (length string)) + (setf (aref bytes (1+ i)) (char-code (char string i)))) + (let* ((pos (search bytes (mach-o-string-table-string (mach-o-file-strings mo))))) + (when pos (1+ pos))))) + Index: /branches/qres/ccl/library/macptr-termination.lisp =================================================================== --- /branches/qres/ccl/library/macptr-termination.lisp (revision 13564) +++ /branches/qres/ccl/library/macptr-termination.lisp (revision 13564) @@ -0,0 +1,480 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; macptr-termination.lisp +;;; +;;; Allows you to associate a termination function with a macptr. +;;; The termination function will be called with the macptr as +;;; its single arg when the macptr is no longer accessible in the +;;; mac heap (i.e. when the garbage collector decides that its +;;; storage can be recycled). +;;; +;;; This file is provided primarily for backward compatibility. +;;; You can use terminate-when-unreachable for new code. + +;; Modification History +;; +;; 11/26/96 bill Remove cons-terminable-macptr from the PPC version of the code. +;; It referenced undefined $macptr-size and it was not used. +;; ------------- 4.0 +;; 09/12/96 bill *slave-macptrs-table* is for non-terminable slaves. +;; *terminable-slaves-table* is for terminable slaves. +;; *terminable-slaves-table* is not weak, *slave-macptrs-table* still is. +;; *terminable-slaves-table* is an EQL hash table which maps a copy of the +;; slave to the master. +;; When a slave is terminated, its entry is explicitly removed from *terminable-slaves-table*. +;; This means that a master will be removed on the next GC after all of +;; its slaves are terminated. Not optimal, but it guarantees that all the slaves are +;; disposed before the master. +;; 08/23/96 bill A *save-exit-function* to clear-terminable-macptrs +;; 08/21/96 bill add the SK8 register-slave-macptr & teminable-macptr-p functions +;; and the :deactivate-only keyword to deactivate-macptr +;; ------------- 4.0b1 +;; 02/28/96 bill Make it work in PPC MCL +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Documentation +;;; + +#| + +SET-POST-EGC-HOOK-ENABLED-P value + This package works by setting MCL's undocumented ccl::*post-gc-hook*. +The hook is normally called only after a full GC. If you want it to +be called after each ephemeral GC as well, call this with a true value. + +POST-EGC-HOOK-ENABLED-P + Returns true if the post gc hook will be called after EGC as well as +after full GC.¬ + +ADD-PRE-GC-HOOK hook +DELETE-PRE-GC-HOOK hook +ADD-POST-GC-HOOK hook +DELETE-POST-GC-HOOK hook + MCL's ccl::*pre-gc-hook* and ccl::*post-gc-hook* can each contain +either a function or NIL. These four functions extend that functionality +by maintaining a list of functions for each of the two hooks. Hooks are +compared with EQ, so it is best to pass a symbol that has a global +definition (see the last form in this file). + +MAKE-TERMINABLE-MACPTR macptr termination-function &key master + Creates and returns a terminable macptr. It will point at the same Mac +Heap address as the macptr arg. When the return value becomes scavengeable +(e.g. no longer accessible in the Lisp heap), will call the +termination-function with a single arg, the returned macptr. If the +termination-function's return value is non-NIL, will free the macptr. +Otherwise, will assume that you decided not to terminate it, and will +call the termination-function again the next time the GC runs and +it is scavengeable. If master is supplied, then +initialize the new terminable macptr as a slave to the given master. +All slave terminable macptrs are terminated before their master is terminated. +Raise an error if macptr is not a macptr or the supplied master +is not a terminable macptr. + +REGISTER-SLAVE-MACPTR slave-macptr master-macptr + Registers a macptr as the slave of a terminable macptr. +A master terminable macptr is not terminated until all of its slaves +have been GC'ed (and terminated if appropriate). +Raise an error if master-macptr is not a terminable macptr. + +TERMINABLE-MACPTR-P thing +returns t if thing is an active terminable or gcable macptr; +otherwise returns nil. + +DEACTIVATE-MACPTR macptr &key deactivate-only + If macptr has an associated termination action, +cancel that action. If deactivate-only is nil, call the +termination action before canceling it, and change +the macptr to a dead macptr. Raise an error if macptr +is not a macptr. Return nil if not a terminable macptr +or if deactivate-only is nil and disposal function returns +nil; otherwise return true. + +|# + +(in-package "CCL") + +(provide "MACPTR-TERMINATION") + +(export '(set-post-egc-hook-enabled-p post-egc-hook-enabled-p + add-pre-gc-hook delete-pre-gc-hook add-post-gc-hook delete-post-gc-hook + make-terminable-macptr register-slave-macptr terminable-macptr-p deactivate-macptr)) + +; Map slave-macptr to master-macptr +; This holds on to the master until the slave is GC'd +(defvar *slave-macptrs-table* + (make-hash-table :test 'eq :weak :key)) + +; Map a copy of a terminable slave to its master +; This holds on to the master until the slave is terminated +(defvar *terminable-slaves-table* + (make-hash-table :test 'eql)) + +(defun register-slave-macptr (slave-macptr master-macptr) + (unless (terminable-macptr-p master-macptr) + (error "~s is not a terminable macptr" master-macptr)) + (unless (macptrp slave-macptr) + (setq slave-macptr (require-type slave-macptr 'macptr))) + (if (terminable-macptr-p slave-macptr) + (setf (gethash (%inc-ptr slave-macptr 0) *terminable-slaves-table*) master-macptr) + (setf (gethash slave-macptr *slave-macptrs-table*) master-macptr))) + +(defun dispose-gcable-macptr (macptr) + (let ((flags (macptr-flags macptr))) + ; we set to $flags_normal before calling the dispose function. + ; (client code can and does depend on this). + ; hence, if it aborts a memory leak results. + ; if we were to wait until after the user function returns + ; to put in the $flags_normal, then it will get called again + ; and might try to free something twice: crash! + (setf (macptr.flags macptr) #.$flags_normal) + (case flags + (#.$flags_normal nil) + (#.$flags_DisposHandle (#_DisposeHandle macptr) t) + (#.$flags_DisposPtr (#_DisposePtr macptr) t) + (#.$flags_DisposWindow (#_DisposeWindow macptr) t) + (#.$flags_DisposGWorld (#_DisposeGWorld macptr) t) + (otherwise (error "Macptr has bogus flags"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The PPC version uses the new general termination support +;;; + +#+ppc-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "LISPEQU")) + +(defvar *macptr-termination-population* + (%cons-terminatable-alist)) + +(defun make-terminable-macptr (macptr termination-function &key master) + (let* ((p (%inc-ptr macptr 0)) + (cell (list (cons p termination-function))) + (population *macptr-termination-population*)) + (without-interrupts + (setf (cdr cell) (population-data population) + (population-data population) cell)) + (when master + (register-slave-macptr p master)) + p)) + +(defun terminable-macptr-p (thing) + (or (not (eql $flags_normal (macptr-flags thing))) + (member thing (population-data *macptr-termination-population*) + :key 'car))) + +(defun deactivate-macptr (macptr &key (deactivate-only t)) + (unless (macptrp macptr) + (setq macptr (require-type macptr 'macptr))) + (let ((termination-function nil) + (population *macptr-termination-population*)) + (flet ((test (macptr cell) (and (eq macptr (car cell)) (setq termination-function (cdr cell))))) + (declare (dynamic-extent #'test)) + (without-interrupts + (setf (population-data population) + (delete macptr (population-data population) + :test #'test + :count 1)))) + (when termination-function + (remhash macptr *terminable-slaves-table*)) + (if deactivate-only + termination-function + (prog1 + (if termination-function + (funcall termination-function macptr) + (progn + (dispose-gcable-macptr macptr) + (remhash macptr *slave-macptrs-table*))) + (macptr->dead-macptr macptr))))) + +; The post GC hook +(defun terminate-macptrs () + (let ((population *macptr-termination-population*) + list cell) + (loop + (without-interrupts + (setq list (population-termination-list population)) + (unless list (return)) + (setf cell (car list) + (population-termination-list population) (cdr list) + (cdr list) nil)) + (let ((macptr (car cell))) + (if (funcall (cdr cell) macptr) + (remhash macptr *terminable-slaves-table*) + (without-interrupts + (setf (cdr list) (population-data population) + (population-data population) list))))))) + +(defun macptr->dead-macptr (macptr) + (if (macptrp macptr) + (%macptr->dead-macptr macptr) + (macptr->dead-macptr (require-type macptr 'macptr)))) + + + +; Call this before save-application. +; It makes no sense to keep terminable macptrs around after that. +; They'll be dead-macptr's then causing lots of grief. +(defun clear-terminable-macptrs () + (let ((population *macptr-termination-population*)) + (setf (population-data population) nil + (population-termination-list population) nil) + (clrhash *slave-macptrs-table*))) + +) ; end of #+ppc-target progn + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The 68K version needs to work harder. +;;; It also requires a kernel patch. +;;; It won't work in a vanilla MCL 3.0 (or 2.0). +;;; + +#-ppc-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "LAPMACROS") + + (defconstant $flags_terminable 5) + (defconstant $flags_terminate_when_ready 6) + + (defconstant $gc-finalize-macptrs-bit (- 26 $fixnumshift)) + (defconstant $gc-post-egc-hook-p (- 25 $fixnumshift)) + + (def-accessors () %svref + nil ; macptr.ptr + nil ; macptr.flags + macptr.link + macptr.id + macptr-size) + + ; This is not exported from the kernel. In future MCL versions, it + ; will be and this definition will not be necessary. + ; This value came from the lisp-8.map file for the new kernel + (defconstant $gcable_ptrs (- #xD84 #x1000)) + ) + +(defun gcable-ptrs-head () + (lap-inline () + (move.l (a5 $gcable_ptrs) acc))) + +(defun (setf macptr-flags) (value p) + (setq p (require-type p 'macptr)) + (setq value (require-type value 'fixnum)) + (lap-inline (value p) + (move.l arg_z atemp0) + (getint arg_y) + (move.l arg_y (atemp0 $macptr.flags))) + value) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; cons-terminable-macptr & map-over-terminated-macptrs +;;; are the low-level interface to this package. +;;; + +; Create a terminable macptr from another macptr +(defun cons-terminable-macptr (macptr &optional (id 0)) + (setq macptr (require-type macptr 'macptr)) + (setq id (require-type id 'fixnum)) + (let ((p (make-uvector macptr-size $v_macptr :initial-element 0))) + (%setf-macptr p macptr) + (setf (macptr-flags p) $flags_terminable + (macptr.id p) id) + (lap-inline (p) + (move.l arg_z atemp0) + (move.l (a5 $gcable_ptrs) (svref atemp0 macptr.link)) + (move.l atemp0 (a5 $gcable_ptrs))) + p)) + +; Calls function with each terminated macptr. +; If function returns NIL, will not reap the macptr; +; it will reappear in the list of terminated macptrs after the next GC +; (assuming FUNCTION didn't store it somewhere). +(defun map-over-terminated-macptrs (function) + (declare (fixnum *gc-event-status-bits*)) + (when (logbitp $gc-finalize-macptrs-bit *gc-event-status-bits*) + (let ((done? nil)) + (unwind-protect + (let ((p (gcable-ptrs-head))) + (setq *gc-event-status-bits* + (the fixnum + (bitclr $gc-finalize-macptrs-bit *gc-event-status-bits*))) + (loop + (when (eql 0 p) + (return)) + (when (eql $flags_terminate_when_ready (macptr-flags p)) + ; We set to $flags_normal BEFORE calling the user function. + ; Hence, if it aborts a memory leak results. + ; If we were to wait until after the user function returns + ; to put in the $flags_normal, then it will get called again + ; and might try to free something twice: CRASH! + (setf (macptr-flags p) $flags_normal) + (unless (funcall function p) + (setf (macptr-flags p) $flags_terminable))) + (setq p (macptr.link p))) + (setq done? t)) + (unless done? + (setq *gc-event-status-bits* + (the fixnum + (bitset $gc-finalize-macptrs-bit *gc-event-status-bits*)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; make-terminable-macptr is the user entry point. +;;; + +; This table cannot be weak on key since hash tables are reaped before gcable-macptrs. +(defvar *termination-functions-table* (make-hash-table :test 'eql)) + +(defvar *terminable-macptr-max-id* most-negative-fixnum) +(defvar *free-terminable-macptr-ids* nil) + +(defun make-terminable-macptr (macptr termination-function &key master) + (let* ((id (or (pop *free-terminable-macptr-ids*) + (incf *terminable-macptr-max-id*))) + (p (cons-terminable-macptr macptr id))) + (setf (gethash id *termination-functions-table*) termination-function + (gethash nil *termination-functions-table*) nil) ; clear cache + (when master + (register-slave-macptr p master)) + p)) + +(defun terminable-macptr-p (thing) + (not (eql $flags_normal (macptr-flags thing)))) + +(defun terminate-macptrs () + (map-over-terminated-macptrs + #'(lambda (p) + (let* ((id (macptr.id p)) + (termination-function (gethash id *termination-functions-table*))) + (if termination-function + (when (funcall termination-function p) + (remhash id *termination-functions-table*) + (remhash p *terminable-slaves-table*) + (push id *free-terminable-macptr-ids*) + t) + (progn + (cerror "Continue." "Can't find ~s in ~s" + p '*termination-functions-table*) + t)))))) + +(defun deactivate-macptr (macptr &key (deactivate-only t)) + (setq macptr (require-type macptr 'macptr)) + (let ((flags (macptr-flags macptr)) + (termination-function nil)) + (unless (eql $flags_normal flags) + (when (or (eql flags $flags_terminable) + (eql flags $flags_terminate_when_ready)) + (setf (macptr-flags macptr) $flags_normal) + (let ((id (macptr.id macptr))) + (setq termination-function + (if deactivate-only + t + (gethash id *termination-functions-table*))) + (remhash id *termination-functions-table*) + (push id *free-terminable-macptr-ids*) + (remhash macptr *terminable-slaves-table*))) + (if deactivate-only + termination-function + (prog1 + (if termination-function + (funcall termination-function macptr) + (progn + (dispose-gcable-macptr macptr) + (remhash macptr *slave-macptrs-table*))) + (macptr->dead-macptr macptr)))))) + +#+ccl-3 +(defun macptr->dead-macptr (macptrObject) + (require-type macptrObject 'macptr) + (lap-inline () + (:variable macptrobject) + (move.l (varg macptrObject) atemp0) + (set_vsubtype ($ $v_badptr) atemp0 da)) + macptrObject) + +#-ccl-3 +(defun macptr->dead-macptr (macptrObject) + (require-type macptrObject 'macptr) + (lap + (move.l (varg macptrObject) atemp0) + (move.b ($ $v_badptr) (atemp0 $v_subtype))) + macptrObject) + +; Call this before save-application. +; It makes no sense to keep terminable macptrs around after that. +; They'll be dead-macptr's then causing lots of grief. +(defun clear-terminable-macptrs () + (clrhash *termination-functions-table*) + (clrhash *slave-macptrs-table*)) + +) ; End of #-ppc-target progn + +(pushnew 'clear-terminable-macptrs *save-exit-functions*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Backward compatibility for the gc-hook maintenance functions. +;;; + +(defun add-pre-gc-hook (hook) + (add-gc-hook hook :pre-gc)) + +(defun delete-pre-gc-hook (hook) + (remove-gc-hook hook :pre-gc)) + +(defun add-post-gc-hook (hook) + (add-gc-hook hook :post-gc)) + +(defun delete-post-gc-hook (hook) + (remove-gc-hook hook :post-gc)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Enabling the ccl::*post-gc-hook* after EGC +;;; + +#| ; These are built in now + +(defun post-egc-hook-enabled-p () + (declare (fixnum *gc-event-status-bits*)) + (logbitp $gc-post-egc-hook-p *gc-event-status-bits*)) + +(defun set-post-egc-hook-enabled-p (value) + (declare (fixnum *gc-event-status-bits*)) + (setq *gc-event-status-bits* + (if (setq value (not (null value))) + (the fixnum (bitset $gc-post-egc-hook-p *gc-event-status-bits*)) + (the fixnum (bitclr $gc-post-egc-hook-p *gc-event-status-bits*)))) + value) + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Install the hook +;;; + +(add-post-gc-hook 'terminate-macptrs) Index: /branches/qres/ccl/library/openmcl-gtk-support.lisp =================================================================== --- /branches/qres/ccl/library/openmcl-gtk-support.lisp (revision 13564) +++ /branches/qres/ccl/library/openmcl-gtk-support.lisp (revision 13564) @@ -0,0 +1,73 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Opensourced MCL 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; either +;;; version 2.1 of the License, or (at your option) any later version. +;;; +;;; Opensourced MCL 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :GTK2)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (open-shared-library "libgnomeui-2.so")) + + +;;; All arguments (including the first, required one) should +;;; be strings. This is supposed to be called from a C main +;;; function; it picks off gtk+-specific arguments from the +;;; caller's argv and deletes them from that C string vector. +;;; I don't know how to suppress any messages that this call +;;; might generate. +(defun gtk-init (arg &rest args) + (declare (dynamic-extent args)) + (push arg args) + (with-string-vector (argv args) + (rlet ((argvp (* t)) + (argcp :signed)) + (setf (%get-ptr argvp) argv + (%get-long argcp) (length args)) + (#_gtk_init argcp argvp)))) + +;;; Run this every 10 ticks. (There seem to be about 100 ticks +;;; per second.) +#-openmcl-native-threads +(def-load-pointers gtk-task () + (%install-periodic-task 'gtk-task + #'(lambda () + (do* () + ((eql (#_gtk_events_pending) 0)) + (#_gtk_main_iteration))) + 10)) + +;;; Ensure that GTK's initialized whenever this file's loaded +;;; and whenever a saved image starts up. (If an application +;;; needs to defer GTK initialization, *GTK-AUTO-INITIALIZE* +;;; can be set to nil to suppress this behavior.) + +;;; Used in error reporting and to provide default window titles +(defvar *gtk-init-application-name* "Clozure CL") + +(defvar *gtk-init-arguments* ()) +(defvar *gtk-auto-initialize* t) + +(def-load-pointers initialize-gtk () + (when *gtk-auto-initialize* + (apply #'gtk-init *gtk-init-application-name* *gtk-init-arguments*))) + Index: /branches/qres/ccl/library/parse-ffi.lisp =================================================================== --- /branches/qres/ccl/library/parse-ffi.lisp (revision 13564) +++ /branches/qres/ccl/library/parse-ffi.lisp (revision 13564) @@ -0,0 +1,1485 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defvar *parse-ffi-target-ftd* *target-ftd*) +(defvar *ffi-lisp-readtable* (copy-readtable nil)) +(defvar *ffi-ordinal* -1) +(defpackage "C" (:use)) +(defvar *lparen-symbol* (intern "(" (find-package "C"))) +(defvar *rparen-symbol* (intern ")" (find-package "C"))) +(defvar *leftbracket-symbol* (intern "[" (find-package "C"))) +(defvar *rightbracket-symbol* (intern "]" (find-package "C"))) +(defvar *sharp-symbol* (intern "#" (find-package "C"))) +(defvar *sharp-sharp-symbol* (intern "##" (find-package "C"))) +(defvar *comma-symbol* (intern "," (find-package "C"))) + + +(defstruct (ffi-macro (:include ffi-type)) + args + expansion + disposition + tokens + expression ) + +(defstruct (ffi-enum (:include ffi-type))) + +(defvar *ffi-typedefs*) +(defvar *ffi-global-typedefs* nil) +(defvar *ffi-unions*) +(defvar *ffi-global-unions* nil) +(defvar *ffi-transparent-unions* nil) +(defvar *ffi-global-transparent-unions* nil) +(defvar *ffi-structs*) +(defvar *ffi-global-structs* nil) +(defvar *ffi-functions*) +(defvar *ffi-global-functions* nil) +(defvar *ffi-global-constants* nil) +(defvar *ffi-global-vars* nil) +(defvar *ffi-objc-classes* nil) +(defvar *ffi-global-objc-classes* nil) +(defvar *ffi-global-objc-messages* nil) +;;; Some things are just too hard to parse, but are important. +;;; Override those things with simpler versions. +(defvar *ffi-macro-overrides* + '((:macro ("{override}" 0) "_IOC_TYPECHECK ( t )" "sizeof(t)"))) + +(defvar *ffi-void-reference* '(:primitive :void)) + + + +(defun find-or-create-ffi-struct (string) + (or (gethash string *ffi-structs*) + (setf (gethash string *ffi-structs*) + (make-ffi-struct :string string + :name (unless (digit-char-p (schar string 0)) + (escape-foreign-name string)))))) + +(defun find-or-create-ffi-union (string) + (or (gethash string *ffi-unions*) + (setf (gethash string *ffi-unions*) + (make-ffi-union :string string + :name (unless (digit-char-p (schar string 0)) + (escape-foreign-name string)))))) + +(defun find-or-create-ffi-transparent-union (string) + (or (gethash string *ffi-transparent-unions*) + (setf (gethash string *ffi-transparent-unions*) + (make-ffi-transparent-union :string string + :name (unless (digit-char-p (schar string 0)) + (escape-foreign-name string)))))) + +(defun find-or-create-ffi-objc-class (string) + (or (gethash string *ffi-objc-classes*) + (setf (gethash string *ffi-objc-classes*) + (make-ffi-objc-class :string string + :name (escape-foreign-name string))))) + +(defun find-or-create-ffi-objc-message (string) + (or (gethash string *ffi-global-objc-messages*) + (setf (gethash string *ffi-global-objc-messages*) + (make-ffi-objc-message :string string)))) + +(defun find-or-create-ffi-typedef (string) + (or (gethash string *ffi-typedefs*) + (setf (gethash string *ffi-typedefs*) + (make-ffi-typedef :string string + :name (escape-foreign-name string))))) + +(defun eval-complex-c-expression (string constant-alist) + (declare (ignore string constant-alist))) + +(defun eval-c-float-string (string) + (setq string (nstring-upcase string)) + ;; Make the c float string (which may contain trailing garbage) + ;; look enough like a lisp float string that READ-FROM-STRING will + ;; work. + ;; There can be some trailing garbage on the string, or it might + ;; end in a decimal point. + ;; The trailing garbage might be a size specifier : #\L or #\F, + ;; to denote a LONG-DOUBLE or a (single) FLOAT. + ;; MCL can't deal with LONG-DOUBLEs, and will assume that an + ;; unqualified float constant is a SINGLE-FLOAT (or whatever + ;; *READ-DEFAULT-FLOAT-FORMAT* says. We may have to add or + ;; change an exponent marker. + (let* ((lastpos (1- (length string))) + (lastchar (schar string lastpos)) + (size :double)) + (case lastchar + (#\L (setq size :long-double) (setf (schar string lastpos) #\Space)) + (#\F (setq size :single) (setf (schar string lastpos) #\Space)) + (#\. (setq string (concatenate 'string string "0")))) + (unless (eq size :long-double) + (let* ((epos (position #\E string)) + (dpos (position #\D string))) + (if (eq size :double) + (if epos + (setf (schar string epos) #\d) + (setq string (concatenate 'string string "d0"))) + (if dpos + (setf (schar string dpos) #\e)))) + (values (ignore-errors (let* ((*readtable* *ffi-lisp-readtable*)) + (read-from-string string))))))) + +(defun read-c-number (stream char) + (loop collect char into chars + with class = :integer + with hex = nil + with octal = (eql char #\0) + do (setq char (read-char stream nil nil)) + while (or (find char "0123456789abcdefABCDEFxulXUL.") + (and (find char "+-") + (char-equal (car (last chars)) #\e))) ;signed exponent + do (cond ((char-equal char #\x) + (setq hex t octal nil)) + ((and (not hex) (or (char-equal char #\.) (char-equal char #\e))) + (setq class :float))) + finally + (when char (unread-char char stream)) + (setq chars (coerce chars 'string)) + (if (eq class :integer) + (return + (values + (ignore-errors + (parse-integer chars + :start (if hex 2 0) + :radix (if hex 16 (if octal 8 10)) + :junk-allowed t)))) + (return (eval-c-float-string chars))))) + +(defun eval-c-number (string char) + (loop collect char into chars + with class = :integer + with hex = nil + with octal = (eql char #\0) + with len = (length string) + with i = 0 + do (setq char (if (< (incf i) len) (schar string i))) + while (or (find char "0123456789abcdefABCDEFxulXUL.") + (and (find char "+-") + (char-equal (car (last chars)) #\e))) ;signed exponent + do (cond ((char-equal char #\x) + (setq hex t octal nil)) + ((and (not hex) (or (char-equal char #\.) (char-equal char #\e))) + (setq class :float))) + finally + (setq chars (coerce chars 'string)) + (if (eq class :integer) + (return + (values + (ignore-errors + (parse-integer chars + :start (if hex 2 0) + :radix (if hex 16 (if octal 8 10)) + :junk-allowed t)))) + (return (eval-c-float-string chars))))) + +;;; For our purposes (evaluating constant expressions in C macros), +;;; we don't have to get this exactly right (since the result is +;;; only going to be used in a size-of or cast operation.) +;;; All pointer types would therefore look identical. + +(defvar *the-ffi-pointer-type* (parse-foreign-type '(* t))) + +;;; If we don't get this right the first time, we never will; +;;; if there's nothing better, just return the void type. + +(defvar *the-ffi-void-type* (parse-foreign-type :void)) + +(defun parse-c-ffi-type (spec) + (flet ((parse-it-or-lose (spec) + (or (ignore-errors (parse-foreign-type spec)) + *the-ffi-void-type*)) + (make-type-name (name) + (escape-foreign-name (string name)))) + (cond ((eq (car (last spec)) 'c::*) *the-ffi-pointer-type*) + ((member (car spec) '(c::|struct| c::|union|)) + (parse-it-or-lose (mapcar #'make-type-name spec))) + ((null (cdr spec)) + (parse-it-or-lose (make-type-name (car spec)))) + (t + ;;; A qualified primitive type + (let* ((primitive (parse-it-or-lose (make-type-name (car (last spec)))))) + (if (eq primitive *the-ffi-void-type*) + primitive + (let* ((long 0) + (explicitly-signed nil)) + (declare (fixnum long)) + (if + (dolist (token (butlast spec) t) + (case token + (c::|unsigned| (setq explicitly-signed :unsigned)) + (c::|signed| (setq explicitly-signed :signed)) + (c::|long| (incf long)) + (c::|short| (decf long)) + (t (return nil)))) + (cond ((typep primitive 'foreign-integer-type) + (let* ((prim-bits (foreign-type-bits primitive)) + (prim-signed (foreign-integer-type-signed primitive))) + (if (> long 1) + (make-foreign-integer-type :bits 64 + :signed (or (not explicitly-signed) + (eq explicitly-signed :signed))) + (if (< long 0) + (make-foreign-integer-type :bits 16 + :signed (or (not explicitly-signed) + (eq explicitly-signed :signed))) + (if (= long 1) + (make-foreign-integer-type :bits 32 + :signed (or (not explicitly-signed) + (eq explicitly-signed :signed))) + (make-foreign-integer-type :bits prim-bits + :signed + (case explicitly-signed + (:signed t) + (:unsigned nil) + (t prim-signed)))))))) + ((and (= long 1) + (typep primitive 'foreign-double-float-type)) + (parse-it-or-lose :long-double)) + (t *the-ffi-void-type*)) + *the-ffi-void-type*)))))))) + +(defun eval-parsed-c-expression (expression constant-alist) + (if (atom expression) + (if (identifierp expression) + (find-constant expression constant-alist) + (if (typep expression 'character) + (char-code expression) + expression)) + (let* ((operator (car expression)) + (operands (cdr expression)) + (noperands (length operands))) + (case operator + (c::resolve-type (let* ((foreign-type (ignore-errors (parse-c-ffi-type (car operands))))) + (when foreign-type + (setf (cdr expression) nil + (car expression) foreign-type) + ))) + (c::curly-bracketed-list ()) + (t + (if (typep operator 'foreign-type) + operator + (when (do* ((tail (cdr expression) (cdr tail))) + ((null tail) t) + (let* ((expr (car tail)) + (value (eval-parsed-c-expression expr constant-alist))) + (unless value (return)) + (unless (eq expr value) + (rplaca tail value)))) + (case noperands + (1 + (let* ((operand (cadr expression))) + (case operator + (c::! (if (zerop operand) 1 0)) + (c::- (- operand)) + (c::+ operand) + (c::~ (lognot operand)) + (c::size-of + (let* ((bits (ignore-errors (ensure-foreign-type-bits operand)))) + (when bits + (ash (+ bits 7) -3)))) + (t + ;(break "~s" expression) + nil)))) + (2 + (let* ((a (car operands)) + (b (cadr operands))) + (case operator + (c::<< (ash a b)) + (c::>> (ash a (- b))) + (c::* (* a b)) + (c::/ (if (zerop b) 0 (values (floor a b)))) ; or maybe TRUNCATE ? + (c::+ (+ a b)) + (c::- (- a b)) + (c::\| (logior a b)) + (c::\& (logand a b)) + (c::cast (if (foreign-typep (setq b (eval-parsed-c-expression b constant-alist)) a) + b + (if (and (typep a 'foreign-integer-type) + (not (foreign-integer-type-signed a)) + (typep b 'integer) + (not (> (integer-length b) + (foreign-integer-type-bits a)))) + (logand b (1- (ash 1 (foreign-integer-type-bits a)))) + (if (and (typep a 'foreign-pointer-type) + (typep b 'integer) + (<= (integer-length b) 16)) + (progn + (%int-to-ptr (logand b #xffffffff))))))) + + + (t + ;(break "binary op = ~s ~s ~s" operator a b) + nil)))) + (t + ;(break "expression = ~s" expression) + nil))))))))) + +(defun eval-c-expression (macro constant-alist macro-table) + (let* ((string (ffi-macro-expansion macro)) + (len (length string))) + (if (= len 0) + 1 + (progn + (unless (ffi-macro-tokens macro) + (let* ((transitive (gethash (ffi-macro-expansion macro) macro-table))) + (if transitive + (setf (ffi-macro-tokens macro) transitive + (gethash (ffi-macro-name macro) macro-table) transitive) + (multiple-value-bind (tokens error) (ignore-errors (string-to-tokens string)) + (if error + (setf (ffi-macro-disposition macro) :bad-tokenize) + (setf (ffi-macro-tokens macro) tokens)))))) + (unless (ffi-macro-expression macro) + (let* ((tokens (ffi-macro-tokens macro))) + (when tokens + (multiple-value-bind (expression error) + (ignore-errors (parse-c-expression tokens + :constants constant-alist + :expand-macros macro-table )) + (if (or error (null expression)) + (progn + ;(format t "~& parse failed: ~s ~s" (ffi-macro-name macro) string) + ;(format t "~& tokens = ~s, error = ~a" tokens error) + (setf (ffi-macro-disposition macro) :bad-parse)) + (setf (ffi-macro-expression macro) expression)))))) + (let* ((expression (ffi-macro-expression macro))) + (when expression (values (eval-parsed-c-expression expression constant-alist) t))))))) + +;;; Repeatedly iterate over the macros until nothing new's defined. +(defun process-defined-macros (ffi-macros constant-alist parameterized-macros) + (let* ((new-def ())) + (loop + (setq new-def nil) + (dolist (macro ffi-macros) + (unless (ffi-macro-disposition macro) + (let* ((expansion (ffi-macro-expansion macro)) + (name (ffi-macro-name macro)) + (value nil)) + (if (string= name expansion) + (setf (ffi-macro-disposition macro) t) + (when (setq value (eval-c-expression macro constant-alist parameterized-macros)) + (push (cons name value) constant-alist) + (setf (ffi-macro-disposition macro) t) + (setq new-def t)))))) + (unless new-def + (return (values (reverse constant-alist) nil)))))) + +(defun reference-ffi-type (spec) + (case (car spec) + (:typedef (list :typedef (find-or-create-ffi-typedef (cadr spec)))) + (:struct-ref (list :struct (find-or-create-ffi-struct (cadr spec)))) + (:union-ref (list :union (find-or-create-ffi-union (cadr spec)))) + (:transparent-union-ref + (list :transparent-union (find-or-create-ffi-transparent-union (cadr spec)))) + (:enum-ref `(:primitive :signed)) + (:function `(:primitive (* t))) + (:pointer (list :pointer (reference-ffi-type (cadr spec)))) + (:array (list :array (cadr spec) (reference-ffi-type (caddr spec)))) + (:void *ffi-void-reference*) + (t + (list :primitive + (ecase (car spec) + (:char (if (getf (ftd-attributes *parse-ffi-target-ftd*) + :signed-char) + '(:signed 8) + '(:unsigned 8))) + (:signed-char '(:signed 8)) + (:unsigned-char '(:unsigned 8)) + (:short '(:signed 16)) + (:unsigned-short '(:unsigned 16)) + ((:vec128 :unsigned-long-long-long) '(:unsigned 128)) + (:signed-long-long-long '(:signed 128)) + (:int '(:signed 32)) + (:long (ecase (or + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-long) + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-word)) + (32 '(:signed 32)) + (64 '(:signed 64)))) + (:unsigned '(:unsigned 32)) + (:unsigned-long (ecase (or + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-long) + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-word)) + (32 '(:unsigned 32)) + (64 '(:unsigned 64)))) + (:long-long '(:signed 64)) + ((:vec64 :unsigned-long-long) '(:unsigned 64)) + (:float :float) + (:double :double) + (:long-double :long-float) + (:complex-int :complex-int) + (:complex-float :complex-float) + (:complex-double :complex-double) + (:complex-long-double :complex-long-float) + (:long-long-long :long-long-long) + #|(:void :void)|#))))) + + +(defun process-ffi-fieldlist (fields) + (let* ((parsed-fields ())) + (dolist (field fields (nreverse parsed-fields)) + (let* ((field-name (escape-foreign-name (car field))) + (field-descr (cadr field))) + (destructuring-bind (field-type offset width) + (cdr field-descr) + (push (cons field-name + (ecase (car field-descr) + (:field `(,(reference-ffi-type field-type) ,(ash offset 3) ,(ash width 3))) + (:bitfield `((:primitive (:unsigned ,width)) ,offset ,width)))) + parsed-fields)))))) + +(defun process-ffi-union (form) + (destructuring-bind (source-info string fields &optional alignform) + (cdr form) + (declare (ignore source-info)) + (let* ((union (find-or-create-ffi-union string))) + (setf (ffi-union-ordinal union) (incf *ffi-ordinal*)) + (when alignform + (setf (ffi-union-alt-alignment-bits union) (cadr alignform))) + (unless (ffi-union-fields union) + (setf (ffi-union-fields union) + (process-ffi-fieldlist fields))) + union))) + +(defun process-ffi-transparent-union (form) + (destructuring-bind (source-info string fields &optional alignform) + (cdr form) + (declare (ignore source-info)) + (let* ((union (find-or-create-ffi-transparent-union string))) + (setf (ffi-transparent-union-ordinal union) (incf *ffi-ordinal*)) + (when alignform + (setf (ffi-transparent-union-alt-alignment-bits union) (cadr alignform))) + (unless (ffi-transparent-union-fields union) + (setf (ffi-transparent-union-fields union) + (process-ffi-fieldlist fields))) + union))) + +(defun process-ffi-struct (form) + (destructuring-bind (source-info string fields &optional alignform) + (cdr form) + (declare (ignore source-info)) + (let* ((struct (find-or-create-ffi-struct string))) + (setf (ffi-struct-ordinal struct) (incf *ffi-ordinal*)) + (when alignform + (setf (ffi-struct-alt-alignment-bits struct) (cadr alignform))) + (unless (ffi-struct-fields struct) + (setf (ffi-struct-fields struct) + (process-ffi-fieldlist fields))) + struct))) + +(defun process-ffi-objc-class (form) + (destructuring-bind (source-info class-name superclass-form protocols ivars) (cdr form) + (declare (ignore source-info)) + (let* ((class (find-or-create-ffi-objc-class class-name))) + (setf (ffi-objc-class-ordinal class) (incf *ffi-ordinal*)) + (unless (ffi-objc-class-super-foreign-name class) + (let* ((super-name (car superclass-form))) + (unless (eq super-name :void) + (setf (ffi-objc-class-super-foreign-name class) + super-name)))) + (unless (ffi-objc-class-protocol-names class) + (setf (ffi-objc-class-protocol-names class) protocols)) + (unless (ffi-objc-class-own-ivars class) + (setf (ffi-objc-class-own-ivars class) + (process-ffi-fieldlist ivars))) + class))) + +(defun process-ffi-objc-method (form) + (destructuring-bind (method-type source-info class-name category-name message-name arglist result-type) form + (declare (ignore source-info category-name)) + (let* ((flags ())) + (if (or (eq method-type :objc-class-method) + (eq method-type :objc-protocol-class-method)) + (setf (getf flags :class) t)) + (if (or (eq method-type :objc-protocol-class-method) + (eq method-type :objc-protocol-instance-method)) + (setf (getf flags :protocol) t)) + (let* ((message (find-or-create-ffi-objc-message message-name)) + (class-method-p (getf flags :class)) + (method + (make-ffi-objc-method :class-name class-name + :arglist (mapcar #'reference-ffi-type + arglist) + :result-type (reference-ffi-type + result-type) + :flags flags))) + (unless (dolist (m (ffi-objc-message-methods message)) + (when (and (equal (ffi-objc-method-class-name m) + class-name) + (eq (getf (ffi-objc-method-flags m) :class) + class-method-p)) + (return t))) + (push method (ffi-objc-message-methods message))))))) + +(defun process-ffi-typedef (form) + (let* ((string (caddr form)) + (def (find-or-create-ffi-typedef string))) + (setf (ffi-typedef-ordinal def) (incf *ffi-ordinal*)) + (unless (ffi-typedef-type def) + (setf (ffi-typedef-type def) (reference-ffi-type (cadddr form)))) + def)) + + +(defun process-ffi-function (form) + (let* ((name (caddr form)) + (ftype (cadddr form))) + (make-ffi-function :string name + :arglist (mapcar #'reference-ffi-type (cadr ftype)) + :return-value (reference-ffi-type (caddr ftype))))) + +(defun process-ffi-macro (form) + (let* ((name-form (caddr form)) + (expansion (cadddr form)) + (name name-form) + (args nil) + (space-pos (position #\space name-form))) + (when space-pos + (setq name (subseq name-form 0 space-pos)) + (let* ((open-pos (position #\( name-form)) + (close-pos (position #\) name-form))) + (when (and open-pos close-pos (> close-pos open-pos)) + (let* ((arg-string (subseq name-form open-pos close-pos)) + (arg-tokens (ignore-errors (string-to-tokens arg-string))) + (arg-names (let* ((l ())) + (dolist (arg-token arg-tokens (nreverse l)) + (unless (or (eq arg-token 'c::|,|) + (eq arg-token *lparen-symbol*)) + (push arg-token l))))) + (body-tokens (ignore-errors (string-to-tokens expansion)))) + (when (and arg-names body-tokens) + (setq args (list arg-names body-tokens) + expansion name)))))) + (make-ffi-macro :name name :args args :expansion expansion))) + +(defun process-ffi-enum (form) + (declare (ignore form))) + +(defun process-ffi-var (form) + (let* ((name (caddr form)) + (type (cadddr form))) + (cons name (reference-ffi-type type)))) + +(defun process-ffi-enum-ident (form) + (cons (caddr form) (cadddr form))) + +(defun ensure-referenced-type-defined (spec) + (declare (ignorable spec)) + (when nil + (ecase (car spec) + (:primitive) + (:typedef (define-typedef-from-ffi-info (cadr spec))) + (:struct (ensure-struct-defined (cadr spec))) + (:union (ensure-union-defined (cadr spec))) + (:transparent-union (ensure-transparent-union-defined (cadr spec))) + (:pointer (ensure-referenced-type-defined (cadr spec))) + (:array (ensure-referenced-type-defined (caddr spec))) + (:function (dolist (arg (ffi-function-arglist (cadr spec))) + (ensure-referenced-type-defined arg)) + (ensure-referenced-type-defined (ffi-function-return-value (cadr spec)))) + ))) + + +(defun ensure-fields-defined (fields) + (dolist (f fields) + (let* ((ftype (cadr f))) + (ensure-referenced-type-defined ftype)))) + +(defun record-global-objc-class (c) + (when *ffi-global-objc-classes* + (setf (gethash (ffi-objc-class-string c) *ffi-global-objc-classes*) c))) + +(defun define-objc-class-from-ffi-info (c) + (unless (ffi-objc-class-defined c) + (setf (ffi-objc-class-defined c) t) + (record-global-objc-class c) + (ensure-fields-defined (ffi-objc-class-own-ivars c)))) + +(defun record-global-union (u) + (when (and *ffi-global-unions* (ffi-union-fields u)) + (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u))) + +(defun record-global-transparent-union (u) + (when (and *ffi-global-transparent-unions* (ffi-transparent-union-fields u)) + (setf (gethash (ffi-transparent-union-reference u) *ffi-global-transparent-unions*) u))) + +(defun define-union-from-ffi-info (u) + (unless (ffi-union-defined u) + (setf (ffi-union-defined u) t) + (record-global-union u) + (when (ffi-union-name u) + (let* ((fields (ffi-union-fields u))) + (ensure-fields-defined fields))))) + +(defun define-transparent-union-from-ffi-info (u) + (unless (ffi-transparent-union-defined u) + (setf (ffi-transparent-union-defined u) t) + (record-global-transparent-union u) + (when (ffi-transparent-union-name u) + (let* ((fields (ffi-transparent-union-fields u))) + (ensure-fields-defined fields))))) + +(defun ensure-union-defined (u) + (let* ((name (ffi-union-name u))) + (if name + (define-union-from-ffi-info u) + (ensure-fields-defined (ffi-union-fields u))))) + +(defun ensure-transparent-union-defined (u) + (let* ((name (ffi-transparent-union-name u))) + (if name + (define-transparent-union-from-ffi-info u) + (ensure-fields-defined (ffi-transparent-union-fields u))))) + +(defun record-global-struct (s) + (when (and *ffi-global-structs* (ffi-struct-fields s)) + (setf (gethash (ffi-struct-reference s) *ffi-global-structs*) s))) + +(defun define-struct-from-ffi-info (s) + (unless (ffi-struct-defined s) + (setf (ffi-struct-defined s) t) + (record-global-struct s) + (when (typep (ffi-struct-name s) 'keyword) + (let* ((fields (ffi-struct-fields s))) + (ensure-fields-defined fields))))) + +(defun ensure-struct-defined (s) + (let* ((name (ffi-struct-name s))) + (if (typep name 'keyword) + (define-struct-from-ffi-info s) + (ensure-fields-defined (ffi-struct-fields s))))) + +(defun record-global-typedef (def) + (when *ffi-global-typedefs* + (setf (gethash (ffi-typedef-string def) *ffi-global-typedefs*) def))) + +(defun define-typedef-from-ffi-info (def) + (unless (ffi-typedef-defined def) + (setf (ffi-typedef-defined def) t) + (record-global-typedef def) + (let* ((target (ffi-typedef-type def))) + (unless (and (consp target) + (member (car target) '(:struct :union :transparent-union :primitive))) + (ensure-referenced-type-defined target))))) + +(defun record-global-constant (name val) + (when *ffi-global-constants* + (setf (gethash name *ffi-global-constants*) val))) + +(defun emit-ffi-constant (name val) + (record-global-constant name val)) + +(defun record-global-var (name type) + (when *ffi-global-vars* + (setf (gethash name *ffi-global-vars*) type))) + +(defun emit-ffi-var (name type) + (record-global-var name type)) + + +(defun ffi-record-type-p (typeref) + (case (car typeref) + ((:struct :union :transparent-union) t) + (:typedef (ffi-record-type-p (ffi-typedef-type (cadr typeref)))) + (t nil))) + +(defun record-global-function (ffi-function) + (when *ffi-global-functions* + (setf (gethash (ffi-function-string ffi-function) *ffi-global-functions*) + ffi-function))) + +(defun emit-function-decl (ffi-function) + (let* ((args (ffi-function-arglist ffi-function)) + (retval (ffi-function-return-value ffi-function))) + (if (eq (car (last args)) *ffi-void-reference*) + (setq args (butlast args))) + (dolist (arg args) (ensure-referenced-type-defined arg)) + (ensure-referenced-type-defined retval) + (record-global-function ffi-function))) + + +(defun read-ffi-toplevel-form (stream eof-value) + (loop + (let* ((ch (peek-char nil stream nil eof-value))) + (cond ((eq ch eof-value) (return eof-value)) + ((eql ch #\() (return (read stream nil eof-value))) + (t (read-line stream)))))) + +(defun parse-ffi (inpath) + (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) + (argument-macros (make-hash-table :test 'equal))) + (let* ((defined-types ()) + (defined-constants ()) + (defined-macros ()) + (defined-functions ()) + (defined-vars ())) + (with-open-file (in inpath) + (let* ((*ffi-ordinal* -1)) + (let* ((*package* (find-package "KEYWORD"))) + (do* ((form (read-ffi-toplevel-form in :eof) + (read-ffi-toplevel-form in :eof))) + ((eq form :eof)) + (case (car form) + (:struct (push (process-ffi-struct form) defined-types)) + (:objc-class (push (process-ffi-objc-class form) defined-types)) + ((:objc-class-method + :objc-instance-method + :objc-protocol-class-method + :objc-protocol-instance-method + ) + (process-ffi-objc-method form)) + (:function (push (process-ffi-function form) defined-functions)) + (:macro (let* ((m (process-ffi-macro form)) + (args (ffi-macro-args m))) + (if args + (setf (gethash (string (ffi-macro-name m)) argument-macros) args) + (push m defined-macros)))) + (:type (push (process-ffi-typedef form) defined-types)) + (:var (push (process-ffi-var form) defined-vars)) + (:enum-ident (push (process-ffi-enum-ident form) defined-constants)) + (:enum (process-ffi-enum form)) + (:union (push (process-ffi-union form) defined-types)) + (:transparent-union (push (process-ffi-transparent-union form) defined-types))))) + (dolist (override *ffi-macro-overrides*) + (let* ((m (process-ffi-macro override)) + (args (ffi-macro-args m))) + (if args + (setf (gethash (string (ffi-macro-name m)) argument-macros) args) + (push m defined-macros)))) + (multiple-value-bind (new-constants new-macros) + (process-defined-macros defined-macros (reverse defined-constants) argument-macros) + ;; If we're really lucky, we might be able to turn some C macros + ;; into lisp macros. We can probably turn some C macros into + ;; lisp constants. + (declare (ignore new-macros)) + (dolist (x (reverse new-constants)) + (emit-ffi-constant (car x) (cdr x))) + (dolist (x defined-vars) + (emit-ffi-var (car x) (cdr x))) + (dolist (x (sort defined-types #'< :key #'ffi-type-ordinal)) + (typecase x + (ffi-struct (define-struct-from-ffi-info x)) + (ffi-union (define-union-from-ffi-info x)) + (ffi-transparent-union (define-transparent-union-from-ffi-info x)) + (ffi-typedef (define-typedef-from-ffi-info x)) + (ffi-objc-class (define-objc-class-from-ffi-info x)))) + (dolist (f defined-functions) (emit-function-decl f)))))))) + +(defun parse-standard-ffi-files (dirname &optional target) + (let* ((backend (if target (find-backend target) *target-backend*)) + (ftd (backend-target-foreign-type-data backend)) + (*parse-ffi-target-ftd* ftd) + (*target-ftd* ftd) + (*target-backend* backend) + (d (use-interface-dir dirname ftd)) + (interface-dir (merge-pathnames + (interface-dir-subdir d) + (ftd-interface-db-directory ftd))) + (*prepend-underscores-to-ffi-function-names* + (getf (ftd-attributes ftd) :prepend-underscores)) + (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-objc-messages* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-functions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-constants* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-vars* (make-hash-table :test 'string= :hash-function 'sxhash))) + + (dolist (f (directory (merge-pathnames ";C;**;*.ffi" + interface-dir))) + (format t "~&~s ..." f) + (parse-ffi f ) + (format t "~&")) + (with-new-db-file (constants-cdbm (merge-pathnames + "new-constants.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (db-define-constant constants-cdbm name def)) + *ffi-global-constants*)) + (with-new-db-file (types-cdbm (merge-pathnames + "new-types.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-typedef types-cdbm def)) + *ffi-global-typedefs*)) + (with-new-db-file (records-cdbm (merge-pathnames + "new-records.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-union records-cdbm def)) + *ffi-global-unions*) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-transparent-union records-cdbm def)) + *ffi-global-transparent-unions*) + + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-struct records-cdbm def)) + *ffi-global-structs*)) + (with-new-db-file (function-cdbm (merge-pathnames + "new-functions.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-function function-cdbm def)) + *ffi-global-functions*)) + (with-new-db-file (class-cdbm (merge-pathnames + "new-objc-classes.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-objc-class class-cdbm def)) + *ffi-global-objc-classes*)) + (with-new-db-file (vars-cdbm (merge-pathnames + "new-vars.cdb" + interface-dir)) + (maphash #'(lambda (name type) + (db-define-var vars-cdbm name type)) + *ffi-global-vars*)) + (with-new-db-file (methods-cdbm (merge-pathnames + "new-objc-methods.cdb" + interface-dir)) + (maphash #'(lambda (name message) + (declare (ignore name)) + (save-ffi-objc-message methods-cdbm message)) + *ffi-global-objc-messages*)) + (install-new-db-files ftd d))) + +(defvar *c-readtable* (copy-readtable nil)) +(setf (readtable-case *c-readtable*) :preserve) + + +;;; Each element of operators can be a symbol or a list of a symbol, a +;;; function, and args All the symbols must start with the character +;;; for which this is the macro-character fcn The entries must be in +;;; the right order, e.g. dictionary order, so any two symbols with a +;;; common prefix are adjacent in the list. Furthermore each symbol +;;; in the list must be preceded by every non-empty leading substring +;;; of that symbol, since we only have one character of look-ahead in +;;; the stream. +(defun operator-macro (operators) + ;; The tree is an alist keyed by character (with a nil key at the end for the default) + ;; The cdr of each entry is either a symbol to produce, another decision tree, + ;; or a list of a function to call and additional arguments for the function + (let ((decision-tree (make-decision-tree operators))) + (labels ((read-c-operator (stream char) + (declare (ignore char)) + (loop with decision-tree = decision-tree + as char = (read-char stream nil nil) ; eof => nil which works too + as elem = (assoc char decision-tree) + do (unless elem + (unread-char char stream) + (setq elem (assoc nil decision-tree))) + (setq elem (cdr elem)) + (cond ((symbolp elem) + (return elem)) + ((symbolp (car elem)) + (return (apply (car elem) stream (cdr elem)))) + (t (setq decision-tree elem))))) + (read-c-singleton-operator (stream char) + (declare (ignore stream char)) + (first operators)) + (read-c-macro-character (stream char) + (declare (ignore char)) + (apply (car decision-tree) stream (cdr decision-tree)))) + (cond ((symbolp decision-tree) #'read-c-singleton-operator) + ((consp (car decision-tree)) #'read-c-operator) + (t #'read-c-macro-character))))) + +(defun make-decision-tree (operators) + (labels ((recurse (operators chars-so-far) ;returns new operators and decision tree element + (let ((next-char (aref (key (first operators)) + (length chars-so-far))) + (alist nil)) + (setq chars-so-far (append chars-so-far (list next-char))) + (loop while operators + as key = (key (first operators)) + while (every #'char= key chars-so-far) + do (if (= (length key) (length chars-so-far)) + (push (cons nil (val (pop operators))) alist) + (multiple-value-bind (remaining-operators elem) + (recurse operators chars-so-far) + (push elem alist) + (setq operators remaining-operators)))) + (values operators + (cons next-char (if (cdr alist) alist (cdar alist)))))) + (key (operator) + (string (if (atom operator) operator (car operator)))) + (val (operator) + (if (atom operator) operator (cdr operator)))) + (multiple-value-bind (left-over elem) (recurse operators nil) + (when left-over + (error "Malformed operators list ~S:~S" (ldiff operators left-over) left-over)) + (cdr elem)))) + +;;; Doesn't support the L prefix for wide characters. What a complete kludge! +(defun c-read-string (stream single-quote) + (loop with delimiter = (if single-quote #\' #\") + as char = (read-char stream nil nil) + do (cond ((null char) + (c-parse-error stream "Unmatched ~A" delimiter)) + ((char= char delimiter) + + (return (if single-quote + (char-code (car chars)) + (coerce chars 'string)))) + ((char= char #\\) + (setq char (read-char stream nil nil)) + (unless char (c-parse-error stream "EOF after backslash in string")) + (let ((tem (assoc char '((#\n . #\newline) + (#\t . #\tab) + (#\v . #\^K) + (#\b . #\backspace) + (#\r . #\return) + (#\f . #\page) + (#\a . #\bell) + (#\\ . #\\) + (#\? . #\?) + (#\' . #\') + (#\" . #\"))))) + (cond (tem (setq char (cdr tem))) + ((char<= #\0 char #\7) + (setq char (loop while (char<= #\0 char #\7) for count from 1 + with sum = 0 + do (setq sum (+ (* sum 8) (digit-char-p char))) + (setq char (read-char stream nil nil)) + until (= count 3) + finally + (unread-char char stream) + (return (code-char sum))))) + ((char= char #\x) + (setq char (loop with sum = 0 + as char = (read-char stream) + while (or (char<= #\0 char #\9) + (char<= #\A char #\F) + (char<= #\a char #\f)) + do (setq sum (+ (* sum 16) (digit-char-p char 16))) + finally + (unread-char char stream) + (return (code-char sum))))))))) + collect char into chars)) + +(dolist (char '(#\_)) + (set-syntax-from-char char #\A *c-readtable*)) + +(dolist (op '( (c::! c::!=) + ((\" c-read-string nil)) + (|#| |##|) ; # and ## are pre-processor operators + (c::% c::%=) + (c::& c::&= c::&&) + ((\' c-read-string t)) + (c::\() + (c::\)) + (c::* c::*=) + (c::+ c::+= c::++) + (c::- c::-= c::-- c::->) + (c::\,) + (c::|.| c::|.*| c::|..| c::|...|) ; .01 will fail to parse as 0.01 + (c::/ c::/= (// c-read-line-comment) (/* c-read-block-comment)) + (c::\: c::\:\:) + (c::\;) + (c::< c::<= c::<< c::<<=) + (c::= c::==) + (c::> c::>= c::>> c::>>=) + (c::?) + (c::[) + (c::\\) + (c::]) + (c::^ c::^=) + (c::{) + (c::\| c::\|= c::\|\|) + (c::}) + (c::~) + ;; C++ doesn't define any meaning for these, treat them as operators + (c::\$) + (c::\@) + (c::\`) + )) + (set-macro-character (char (string (if (atom (car op)) (car op) (caar op))) 0) + (operator-macro op) + nil ;token-terminating + *c-readtable*)) + +(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (set-macro-character char 'read-c-number t *c-readtable*)) + + +(defvar *backslash-symbol* 'c::|\\|) + +(defvar *pending-tokens* ()) + +(defun unread-token (token) + (push token *pending-tokens*) + token) + +(defun next-token (stream) + (if *pending-tokens* + (pop *pending-tokens*) + (do* ((tok (read-preserving-whitespace stream nil :eof) + (read-preserving-whitespace stream nil :eof))) + ((or (not (eq tok *backslash-symbol*)) + (not (eq (peek-char nil stream nil nil) #\Newline))) + tok) + ;; Consume the #\newline that followed #\\. Yecch. + (read-char stream nil nil)))) + +(defun string-to-tokens (string) + (with-input-from-string (stream string) + (let* ((*package* (find-package "C")) + (*readtable* *c-readtable*) + (tokens ())) + (loop + (let* ((token (next-token stream))) + (when (eq token :eof) + (return (nreverse tokens))) + (push token tokens)))))) + + +(defun identifierp (token) + (and (symbolp token) + (let ((char (char (symbol-name token) 0))) + (or (alpha-char-p char) (char= char #\_))))) + + +(defun evaluate-type-name (x) + (let* ((name (car x))) + (if (and (atom name) nil (null (cdr x))) + name))) + + +(defun find-constant (x constants) + (when (symbolp x) + (cdr (assoc (string x) constants :test #'string=)))) + +(defun find-user-or-primitive-type (x) + x + nil) + +(defun macro-definition (id table) + (gethash (string id) table)) + +(defun expand-c-macro (name parameters arguments body stream macros-not-to-expand macro-table) + (let ((expansion nil)) + (unless (= (length arguments) (length parameters)) + (c-parse-error stream "Expected ~D argument~:P to macro ~A but got ~D argument~:P." + (length parameters) name (length arguments))) + (loop while body + as token = (pop body) + as next = (first body) + as argno = (position token parameters) do + (cond ((and argno (eq next *sharp-sharp-symbol*)) ; parameter ## token/parameter + (pop body) + (setq next (pop body)) + (let ((next-argno (position next parameters))) + (push (intern (concatenate 'string (c-stringize-token-list (nth argno arguments)) + (if next-argno + (c-stringize-token-list (nth next-argno arguments)) + (c-stringize-token next)))) + expansion))) + (argno ; normal parameter substitution + (setq expansion (nreconc (expand-c-macros-in-token-list (nth argno arguments) + stream macros-not-to-expand + macro-table) + expansion))) + ((and (eq token *sharp-sharp-symbol*) ; token ## parameter + (setq argno (position next parameters))) + (pop body) + (push (intern (concatenate 'string (c-stringize-token (pop expansion)) + (c-stringize-token-list (nth argno arguments)))) + expansion)) + ((and (eq token *sharp-symbol*) ; # parameter + (setq argno (position next parameters))) + (pop body) + (push (c-stringize-token-list (nth argno arguments)) expansion)) + (t (push token expansion)))) + (expand-c-macros-in-token-list (nreverse expansion) stream + (adjoin name macros-not-to-expand) + macro-table))) + +(defun expand-c-macros-in-token-list (tokens stream macros-not-to-expand macro-table) + (loop + while tokens + as token = (pop tokens) + as macro = (and (symbolp token) + (not (member token macros-not-to-expand)) + (macro-definition token macro-table)) + if macro + nconc (if (eq (first macro) :none) + (expand-c-macros-in-token-list (second macro) stream + (adjoin token macros-not-to-expand) macro-table) + (expand-c-macro token (first macro) + (let ((open (pop tokens))) + (unless (eq open *lparen-symbol*) + (c-parse-error + stream + "~A where open parenthesis expected after macro name ~A" + open token)) + (loop with done = nil + collect + (loop as token = (if tokens (pop tokens) + (c-parse-error stream + "Unexpected impossible EOF")) + with level = 0 + do (cond ((eq token *lparen-symbol*) (incf level)) + ((eq token *rparen-symbol*) + (if (plusp level) (decf level) (setq done t)))) + until (or done (and (zerop level) + (eq token *comma-symbol*))) + collect token) + until done)) + (second macro) stream macros-not-to-expand macro-table)) + else collect token)) + +(defun parse-c-expression (token-list &key constants additional-constants + expand-macros) + (labels ((next () + (unless token-list + (fail "Unterminated expression or unbalanced parentheses")) + (pop token-list)) + (peek () + (car token-list)) + (unread (token) + (push token token-list)) + (collect-parenthesized () + (loop with level = 0 + as token = (next) + until (and (eq token *rparen-symbol*) (= level 0)) + collect token + do (case token + (#.*lparen-symbol* (incf level)) + (#.*rparen-symbol* (decf level))))) + (fail (format-string &rest format-arguments) + (apply #'c-parse-error nil format-string format-arguments)) + (parse-expression () + (parse-assignment)) + (parse-assignment () + (let ((left (parse-conditional))) + (if (eq (peek) 'c::|=|) + (let ((right (progn (next) (parse-assignment)))) + (list 'setf left right)) + left))) + (parse-conditional () + (let ((left (parse-logical-or))) + (if (eq (peek) 'c::|?|) + (let ((then (progn (next) (parse-expression))) + (else (if (eq (peek) 'c::|:|) + (progn (next) (parse-conditional)) + (fail "~A where : was expected" (peek))))) + (list 'if left then else)) + left))) + (parse-logical-or () + (let ((left (parse-logical-and))) + (loop while (eq (peek) 'c::|\|\||) + do (setq left (list (next) left (parse-logical-and)))) + left)) + (parse-logical-and () + (let ((left (parse-bitwise-ior))) + (loop while (eq (peek) 'c::|&&|) + do (setq left (list (next) left (parse-bitwise-ior)))) + left)) + (parse-bitwise-ior () + (let ((left (parse-bitwise-xor))) + (loop while (eq (peek) 'c::|\||) + do (setq left (list (next) left (parse-bitwise-xor)))) + left)) + (parse-bitwise-xor () + (let ((left (parse-bitwise-and))) + (loop while (eq (peek) 'c::|\^|) + do (setq left (list (next) left (parse-bitwise-and)))) + left)) + (parse-bitwise-and () + (let ((left (parse-equality))) + (loop while (eq (peek) 'c::|&|) + do (setq left (list (next) left (parse-equality)))) + left)) + (parse-equality () + (let ((left (parse-relational))) + (loop while (member (peek) '(c::|==| c::|!=|)) + do (setq left (list (next) left (parse-relational)))) + left)) + (parse-relational () + (let ((left (parse-shift))) + (loop while (member (peek) '(c::|<| c::|>| c::|<=| c::|>=|)) + do (setq left (list (next) left (parse-shift)))) + left)) + (parse-shift () + (let ((left (parse-additive))) + (loop while (member (peek) '(c::|<<| c::|>>|)) + do (setq left (list (next) left (parse-additive)))) + left)) + (parse-additive () + (let ((left (parse-multiplicative))) + (loop while (member (peek) '(c::|+| c::|-|)) + do (setq left (list (next) left (parse-multiplicative)))) + left)) + (parse-multiplicative () + (let ((left (parse-pointer-to-member))) + (loop while (member (peek) '(c::|*| c::|/| c::|%|)) + do (setq left (list (next) left (parse-pointer-to-member)))) + left)) + (parse-pointer-to-member () + (let ((left (parse-unary))) + (loop while (member (peek) '(c::|.*| c::|->*|)) + do (setq left (list (next) left (parse-unary)))) + left)) + (parse-unary () ; subsumes parse-cast, thus accepting some invalid programs + (let ((token (next))) ; --- doesn't support new and delete yet + (cond ((member token '(c::|+| c::|-| c::|!| c::|~| c::|++| c::|--|)) + ;;--- doesn't yet have special support for calling destructors... + (list token (parse-unary))) + ((eq token 'c::|*|) + (list 'c::indirect (parse-unary))) + ((eq token 'c::|&|) + (list 'c::address-of (parse-unary))) + ((eq token 'c::|sizeof|) + (unless (eq (peek) *lparen-symbol*) ; Require open paren, maybe it's really optional + (fail "~A where ( was expected after sizeof" (peek))) + (next) ; Swallow open parenthesis + `(c::size-of (c::resolve-type ,(loop as token = (next) + until (eq token *rparen-symbol*) + collect token)))) + (t (parse-postfix token))))) + (parse-postfix (token) + (loop with left = (parse-primary token) + as right = (peek) do + (setq left + (cond ((eq right *leftbracket-symbol*) + (next) ; swallow [ + (let ((subscript (parse-expression)) + (delimiter (next))) + (unless (eq delimiter *rightbracket-symbol*) + (fail "~A where ] expected after subscript" delimiter)) + `(c::aref ,left ,subscript))) + ((eq right *lparen-symbol*) + (next) ; swallow open parenthesis + (let ((macro (and expand-macros + (identifierp left) + (macro-definition left expand-macros)))) + (cond ((and macro (not (eq (first macro) ':none))) + ;; Function-like macro - constant-like was alraedy handled + (let ((more-tokens + (expand-c-macro left (first macro) + (collect-macro-arguments) + (second macro) nil '() + expand-macros))) + (setq token-list (append more-tokens token-list)) + (parse-expression))) + ((valid-type-name? (list left)) + ;; This is an explicit type conversion + `(c::cast ,(evaluate-type-name (list left)) + ,@(parse-argument-list))) + (t nil #|`(c::call ,left ,@(parse-argument-list))|#)))) + ((memq right '(c::|.| c::|->|)) + (next) ; swallow operator + `(,right ,left ,(parse-primary (next)))) ; parse-name, really + ((eq right 'c::|++|) + (next) ; swallow operator + `(c::postfix++ ,left)) + ((eq right 'c::|--|) + (next) ; swallow operator + `(c::postfix-- ,left)) + (t (return left)))))) + (parse-primary (token) + (cond ((identifierp token) + ;; nonqualified name + (let ((value (find-constant token constants))) + (cond (value + (setq value (list value) token-list `(,@value #.*rparen-symbol* ,@token-list)) + (parse-parenthesized)) + ((setq value (assoc token additional-constants)) + (cdr value)) + ((and expand-macros + (setq value (macro-definition-of-token token)) + (eq (first value) ':none)) + (setq token-list (append (expand-c-macros-in-token-list + (second value) nil (list token) expand-macros) + token-list )) + (parse-primary (next))) + (t token)))) + ((eq token *lparen-symbol*) + (let* ((save-token-list token-list) + (type-name (collect-parenthesized)) + (type (valid-type-name? type-name))) + (cond (type + ;; This is a cast + ;; Doing cast here is easier but accepts some invalid programs + (progn + `(c::cast (,type) ,(parse-unary)))) + (t + ;; These are ordinary grouping parentheses + (setq token-list save-token-list) + (parse-parenthesized))))) + ((eq token 'c::|{|) + (cons 'c::curly-bracketed-list + (loop as token = (next) + until (eq token 'c::|}|) + do (unread token) + collect (parse-expression) + do (let ((delimiter (peek))) + (case delimiter + (c::|,| (next)) + (c::|}| ) + (otherwise + (fail "~A where , or } was expected" delimiter))))))) + ((numberp token) token) + ((stringp token) token) + ((eq token 'c::|::|) + (fail "Unary :: is not supported yet")) + (t (fail "~A is unrecognized syntax in an expression" token)))) + (parse-parenthesized () + (prog1 (parse-expression) + (let ((close (next))) + (unless (eq close *rparen-symbol*) + (fail "~A where ) was expected" close))))) + (parse-argument-list () + (if (eq (peek) *rparen-symbol*) + (progn (next) '()) + (loop as arg = (parse-expression) + as delimiter = (next) + collect arg + do (unless (or (eq delimiter 'c::|,|) (eq delimiter *rparen-symbol*)) + (fail "~A where , or ) expected in function arguments" + delimiter)) + while (eq delimiter 'c::|,|)))) + (collect-macro-arguments () + (loop with done = nil with first = t + collect (loop as token = (next) with level = 0 + do (cond ((eq token *lparen-symbol*) (incf level)) + ((eq token *rparen-symbol*) + (when first ; () has to be treated as a special case + (return-from collect-macro-arguments '())) + (if (plusp level) (decf level) (setq done t)))) + (setq first nil) + until (or done (and (zerop level) (eq token 'c::|,|))) + collect token) + until done)) + + ;;--- The following type-name routines don't support the full C++ syntax + ;;--- Maybe we will add ::, arrays, functions, and God knows what later + (valid-type-name? (token-list &optional tailp) + (let* ((type (ignore-errors (parse-c-ffi-type token-list)))) + tailp + (return-from valid-type-name? + (if (and type (not (eq type *the-ffi-void-type*))) + type))) + + ;; At least one type-specifier followed by an optional abstract-declarator + ;; For now the type-specifier cannot contain :: and the only + ;; abstract-declarators we accept are stars (not functions, arrays) + (cond ((null token-list) tailp) + ((member (car token-list) '(c::|long| c::|short| c::|signed| c::|unsigned|)) + (valid-type-name? (cdr token-list) t)) + ((and (identifierp (car token-list)) + (find-user-or-primitive-type (car token-list))) + (valid-type-name? (cdr token-list) t)) + ;((eq (car token-list) '|::|) (valid-type-name? (cdr token-list))) + ((and tailp (eq (car token-list) 'c::|*|)) + (valid-type-name? (cdr token-list) t)) + (t nil)))) + (prog1 (parse-expression) + (when token-list + (fail "~{~A ~} left over after expression" token-list))))) + +(defun c-parse-error (stream format &rest args) + (declare (ignore stream)) + (apply #'error format args)) + +(pushnew '(c-parse-error . 1) ccl::*format-arg-functions* :test #'equal) + +(defun macro-definition-of-token (x) + (declare (ignore x))) + +(defun c-stringize-token-list (tokens) + (apply #'concatenate 'string (mapcar #'c-stringize-token tokens))) + +(defun c-stringize-token (token) + (etypecase token + (symbol (string token)) + (string token) + (number (princ-to-string token)))) + +(defun install-new-db-files (ftd d) + (let* ((dir (merge-pathnames (interface-dir-subdir d) + (ftd-interface-db-directory ftd)))) + (flet ((rename-and-reopen (was-open path newpath) + (let* ((path (merge-pathnames path dir)) + (newpath (merge-pathnames newpath dir))) + (when was-open + (cdb-close was-open)) + (when (probe-file path) + (rename-file path + (concatenate 'string (namestring (truename path)) "-BAK") + :if-exists :supersede)) + (rename-file newpath path) + (when was-open + (cdb-open path))))) + (without-interrupts + (setf (interface-dir-constants-interface-db-file d) + (rename-and-reopen + (interface-dir-constants-interface-db-file d) + "constants.cdb" + "new-constants.cdb")) + (setf (interface-dir-functions-interface-db-file d) + (rename-and-reopen + (interface-dir-functions-interface-db-file d) + "functions.cdb" + "new-functions.cdb")) + (setf (interface-dir-records-interface-db-file d) + (rename-and-reopen + (interface-dir-records-interface-db-file d) + "records.cdb" + "new-records.cdb")) + (setf (interface-dir-types-interface-db-file d) + (rename-and-reopen + (interface-dir-types-interface-db-file d) + "types.cdb" + "new-types.cdb")) + (setf (interface-dir-vars-interface-db-file d) + (rename-and-reopen + (interface-dir-vars-interface-db-file d) + "vars.cdb" + "new-vars.cdb")) + (setf (interface-dir-objc-classes-interface-db-file d) + (rename-and-reopen + (interface-dir-objc-classes-interface-db-file d) + "objc-classes.cdb" + "new-objc-classes.cdb")) + (setf (interface-dir-objc-methods-interface-db-file d) + (rename-and-reopen + (interface-dir-objc-methods-interface-db-file d) + "objc-methods.cdb" + "new-objc-methods.cdb"))))) + t) + + Index: /branches/qres/ccl/library/pascal-strings.lisp =================================================================== --- /branches/qres/ccl/library/pascal-strings.lisp (revision 13564) +++ /branches/qres/ccl/library/pascal-strings.lisp (revision 13564) @@ -0,0 +1,107 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2003-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;; Utilities for dealing with Pascal strings +;;; +;;; In 68K Mac Pascal, strings were represented by a pointer to a +;;; "length byte", which indicated the number of data bytes immediately +;;; following. + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; What else should be exported ? What else should be added + ;; to this file ? + (export '(with-pstrs with-returned-pstrs %get-string))) + +(defun %pstr-pointer (string pointer) + (multiple-value-bind (s o n) (dereference-base-string string) + (declare (fixnum o n)) + (%copy-ivector-to-ptr s o pointer 1 n) + (setf (%get-byte pointer 0) n)) + nil) + +(defun %pstr-segment-pointer (string pointer start end) + (declare (fixnum start end)) + (let* ((n (- end start))) + (multiple-value-bind (s o) (dereference-base-string string) + (declare (fixnum o)) + (%copy-ivector-to-ptr s (the fixnum (+ o start)) pointer 1 n) + (setf (%get-byte pointer 0) n) + nil))) + +(defun %get-string (pointer) + (let* ((len (%get-unsigned-byte pointer))) + (%copy-ptr-to-ivector + pointer + 1 + (make-string len :element-type 'base-char) + 0 + len))) + +(defun (setf %get-string) (lisp-string pointer) + (let* ((len (length lisp-string))) + (multiple-value-bind (string offset) + (dereference-base-string lisp-string) + (setf (%get-unsigned-byte pointer) len) + (%copy-ivector-to-ptr string offset pointer 1 len)) + lisp-string)) + +(defmacro with-pstr ((sym str &optional start end) &rest body &environment env) + (multiple-value-bind (body decls) (parse-body body env nil) + (if (and (base-string-p str) (null start) (null end)) + (let ((strlen (%i+ (length str) 1))) + `(%stack-block ((,sym ,strlen)) + ,@decls + (%pstr-pointer ,str ,sym) + ,@body)) + (let ((strname (gensym)) + (start-name (gensym)) + (end-name (gensym))) + `(let ((,strname ,str) + ,@(if (or start end) + `((,start-name ,(or start 0)) + (,end-name ,(or end `(length ,strname)))))) + (%vstack-block (,sym + (the fixnum + (1+ + (the fixnum + ,(if (or start end) + `(byte-length + ,strname ,start-name ,end-name) + `(length ,strname)))))) + ,@decls + ,(if (or start end) + `(%pstr-segment-pointer ,strname ,sym ,start-name ,end-name) + `(%pstr-pointer ,strname ,sym)) + ,@body)))))) + + +(defmacro with-returned-pstr ((sym str &optional start end) &body body) + `(%stack-block ((,sym 256)) + ,(if (or start end) + `(%pstr-segment-pointer ,str ,sym ,start ,end) + `(%pstr-pointer ,str ,sym)) + ,@body)) + +(defmacro with-pstrs (speclist &body body) + (with-specs-aux 'with-pstr speclist body)) + +(defmacro with-returned-pstrs (speclist &body body) + (with-specs-aux 'with-returned-pstr speclist body)) + + Index: /branches/qres/ccl/library/ppc-linux-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/ppc-linux-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/ppc-linux-syscalls.lisp (revision 13564) @@ -0,0 +1,234 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + + + + + + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::exit 1 (:signed-fullword) :void) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fork 2 () :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::read 3 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::write 4 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::waitpid 7 (:unsigned-fullword :address :signed-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::creat 8 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::link 9 (:address :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::unlink 10 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::execve 11 (:address :address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chdir 12 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::time 13 (:address) :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::lchown 16 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +;(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::oldstat 18 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::lseek 19 (:unsigned-fullword :signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpid 20 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mount 21 (:address + :address + :address + :unsigned-fullword + :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::umount 22 (:address) :signed-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getuid 24 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::stime 25 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ptrace 26 (:unsigned-fullword + :unsigned-fullword + :address + :address) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::alarm 27 (:unsigned-fullword) :unsigned-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pause 29 () :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::utime 30 (:address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::access 33 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::nice 34 (:signed-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sync 36 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rename 38 (:address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mkdir 39 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rmdir 40 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pipe 42 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::times 43 (:address) :unsigned-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::brk 45 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setgid 46 (:unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getgid 47 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::signal 48 (:unsigned-fullword :address) :address ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::geteuid 49 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getegid 50 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::acct 51 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::umount2 52 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fcntl 55 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setpgid 57 (:signed-fullword :signed-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::umask 60 (:unsigned-fullword) :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chroot 61 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ustat 62 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::dup2 63 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getppid 64 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpgrp 65 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setsid 66 () :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigaction 67 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getrusage 77 (:signed-fullword :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::gettimeofday 78 (:address :address) :void) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ftruncate 93 (:unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fchmod 94 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::socketcall 102 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::stat 106 (:address :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::lstat 107 (:address :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fstat 108 (:unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fsync 118 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::uname 122 (:address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fchdir 133 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::_llseek 140 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::select 142 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getcwd 182 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::poll 167 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setreuid 70 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setregid 71 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigpending 73 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sethostname 74 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getgroups 80 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setgroups 81 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::symlink 83 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::readlink 85 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::uselib 86 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::swapon 87 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::reboot 88 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::readdir 89 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mmap 90 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::munmap 91 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::truncate 92 () ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fchown 95 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpriority 96 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setpriority 97 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::statfs 99 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ioperm 101 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::syslog 103 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setitimer 104 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getitimer 105 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::olduname 109 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::iopl 110 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::vhangup 111 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::idle 112 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::vm86 113 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::wait4 114 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::swapoff 115 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ipc 117 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::clone 120 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mprotect 125 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::create_module 127 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::init_module 128 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::delete_module 129 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::quotactl 131 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpgid 132 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::bdflush 134 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sysfs 135 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::personality 136 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getdents 141 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::_newselect 142 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::flock 143 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::msync 144 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::readv 145 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::writev 146 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getsid 147 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mlock 150 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::munlock 151 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mlockall 152 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::munlockall 153 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_yield 158 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::nanosleep 162 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mremap 163 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setresuid 164 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getresuid 165 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::query_module 166 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::poll 167 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setresgid 169 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getresgid 170 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::prctl 171 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigreturn 172 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigaction 173 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigprocmask 174 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pread 179 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pwrite 180 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::capget 183 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::capset 184 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sendfile 186 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::vfork 189 () ) + +) Index: /branches/qres/ccl/library/pty.lisp =================================================================== --- /branches/qres/ccl/library/pty.lisp (revision 13564) +++ /branches/qres/ccl/library/pty.lisp (revision 13564) @@ -0,0 +1,143 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2002-2009 Clozure Associates. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; (very) preliminary support for dealing with TTYs (and PTYs). + +(in-package "CCL") + +;;; Open a (connected) pair of pty file descriptors, such that anything +;;; written to one can be read from the other. +#+linuxppc-target +(eval-when (:load-toplevel :execute) + (open-shared-library "libutil.so")) + +(defun open-pty-pair () + (rlet ((alphap :unsigned 0) + (betap :unsigned 0)) + (let* ((status (#_openpty alphap betap (%null-ptr) (%null-ptr) (%null-ptr)))) + (if (eql status 0) + (values (pref alphap :unsigned) (pref betap :unsigned)) + (%errno-disp (%get-errno)))))) + + +(defun %get-tty-attributes (tty-fd &optional control-chars) + (if (and control-chars + (not (and (typep control-chars 'simple-string) + (= (length control-chars) #$NCCS)))) + (report-bad-arg control-chars '(or null (simple-string #.#$NCCS)))) + (rlet ((attr :termios)) + (let* ((result (#_tcgetattr tty-fd attr))) + (if (< result 0) + (values nil nil nil nil nil nil nil) + (progn + (if control-chars + (%str-from-ptr (pref attr :termios.c_cc) #$NCCS control-chars)) + (values + (pref attr :termios.c_iflag) + (pref attr :termios.c_oflag) + (pref attr :termios.c_cflag) + (pref attr :termios.c_lflag) + #+darwin-target 0 + #-darwin-target + (pref attr :termios.c_line) + control-chars + (pref attr :termios.c_ispeed) + (pref attr :termios.c_ospeed))))))) + +(defun %set-tty-attributes (tty &key + input-modes + output-modes + control-modes + local-modes + control-chars + input-speed + output-speed) + (if (and control-chars + (not (and (typep control-chars 'simple-string) + (= (length control-chars) #$NCCS)))) + (report-bad-arg control-chars '(or null (simple-string #.#$NCCS)))) + (rlet ((attr :termios)) + (let* ((get-ok (#_tcgetattr tty attr)) + (write-back nil)) + (when (eql 0 get-ok) + (when input-modes + (setf (pref attr :termios.c_iflag) input-modes) + (setq write-back t)) + (when output-modes + (setf (pref attr :termios.c_oflag) output-modes) + (setq write-back t)) + (when control-modes + (setf (pref attr :termios.c_cflag) control-modes) + (setq write-back t)) + (when local-modes + (setf (pref attr :termios.c_lflag) local-modes) + (setq write-back t)) + (when control-chars + (%cstr-pointer control-chars (pref attr :termios.c_cc) nil) + (setq write-back t)) + (when input-speed + (setf (pref attr :termios.c_ispeed) input-speed) + (setq write-back t)) + (when output-speed + (setf (pref attr :termios.c_ospeed) output-speed) + (setq write-back t)) + (and write-back + (eql 0 (#_tcsetattr tty #$TCSAFLUSH attr))))))) + +(defun enable-tty-input-modes (tty mask) + (let* ((old (nth-value 0 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :input-modes (logior old mask))))) + +(defun disable-tty-input-modes (tty mask) + (let* ((old (nth-value 0 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :input-modes (logand old (lognot mask)))))) + +(defun enable-tty-output-modes (tty mask) + (let* ((old (nth-value 1 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :output-modes (logior old mask))))) + +(defun disable-tty-output-modes (tty mask) + (let* ((old (nth-value 1 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :output-modes (logand old (lognot mask)))))) + +(defun enable-tty-control-modes (tty mask) + (let* ((old (nth-value 2 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :control-modes (logior old mask))))) + +(defun disable-tty-control-modes (tty mask) + (let* ((old (nth-value 2 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :control-modes (logand old (lognot mask)))))) + +(defun enable-tty-local-modes (tty mask) + (let* ((old (nth-value 3 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :local-modes (logior old mask))))) + +(defun disable-tty-local-modes (tty mask) + (let* ((old (nth-value 3 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :local-modes (logand old (lognot mask)))))) + +(defun set-tty-raw (tty) + (rlet ((attr :termios)) + (#_cfmakeraw attr) + (eql 0 (#_tcsetattr tty #$TCSAFLUSH attr)))) Index: /branches/qres/ccl/library/sequence-utils.lisp =================================================================== --- /branches/qres/ccl/library/sequence-utils.lisp (revision 13564) +++ /branches/qres/ccl/library/sequence-utils.lisp (revision 13564) @@ -0,0 +1,92 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*- +;;;; *********************************************************************** +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sequence-utils.lisp +;;;; Version: 0.2 +;;;; Project: utilities +;;;; Purpose: utilities for working with sequences +;;;; +;;;; *********************************************************************** + +(in-package "CCL") + +;;; ----------------------------------------------------------------- +;;; splitting sequences +;;; ----------------------------------------------------------------- + +;;; Split a sequence SEQ at each point where TEST is true +;;; DIR should be one of :BEFORE, :AFTER or :ELIDE + +(defun split-if (test seq &optional (dir :before)) + (remove-if + #'(lambda (x) (equal x (subseq seq 0 0))) + (loop for start fixnum = 0 + then (if (eq dir :before) stop (the fixnum (1+ (the fixnum stop)))) + while (< start (length seq)) + for stop = (position-if + test seq + :start (if (eq dir :elide) start (the fixnum (1+ start)))) + collect (subseq + seq start + (if (and stop (eq dir :after)) + (the fixnum (1+ (the fixnum stop))) + stop)) + while stop))) + +(defun split-if-char (char seq &optional dir) + (split-if #'(lambda (ch) (eq ch char)) seq dir)) + +(defmethod split-lines ((text string)) + (delete-if (lambda (x) (string= x "")) + (mapcar (lambda (s) + (string-trim '(#\return #\newline) s)) + (split-if (lambda (c) (member c '(#\return #\newline) :test #'char=)) + text)))) + +;;; ----------------------------------------------------------------- +;;; matching subsequences +;;; ----------------------------------------------------------------- + +(defun match-subsequence (subseq seq &key (test #'eql) (start 0)) + (let ((max-index (1- (length seq)))) + (block matching + ;; search for mismatches + (dotimes (i (length subseq)) + (let ((pos (+ start i))) + (when (or (> pos max-index) + (not (funcall test (elt seq pos) + (elt subseq i)))) + (return-from matching nil)))) + ;; no mismatches found; return true + (return-from matching t)))) + +(defun %find-matching-subsequence-backward (subseq seq &key (test #'eql) (start 0) end) + (let ((end (or end (length seq))) + (pos end) + (min-index (or start 0))) + (block finding + (dotimes (i (- (length seq) start)) + (setf pos (- end i)) + (if (<= pos min-index) + (return-from finding nil) + (when (match-subsequence subseq seq :test test :start pos) + (return-from finding pos)))) + nil))) + +(defun %find-matching-subsequence-forward (subseq seq &key (test #'eql) (start 0) end) + (let ((pos start) + (max-index (or end (length seq)))) + (block finding + (dotimes (i (- (length seq) start)) + (setf pos (+ start i)) + (if (>= pos max-index) + (return-from finding nil) + (when (match-subsequence subseq seq :test test :start pos) + (return-from finding pos)))) + nil))) + +(defun find-matching-subsequence (subseq seq &key (test #'eql) (start 0) end from-end) + (if from-end + (%find-matching-subsequence-backward subseq seq :test test :start start :end end) + (%find-matching-subsequence-forward subseq seq :test test :start start :end end))) Index: /branches/qres/ccl/library/sharp-comma.lisp =================================================================== --- /branches/qres/ccl/library/sharp-comma.lisp (revision 13564) +++ /branches/qres/ccl/library/sharp-comma.lisp (revision 13564) @@ -0,0 +1,32 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; #, was removed from CL in 1998 or so, but there may be some legacy +;;; code that still uses it. + +(set-dispatch-macro-character + #\# + #\, + #'(lambda (stream subchar numarg) + (let* ((sharp-comma-token *reading-for-cfasl*)) + (if (or *read-suppress* (not *compiling-file*) (not sharp-comma-token)) + (read-eval stream subchar numarg) + (progn + (require-no-numarg subchar numarg) + (list sharp-comma-token (read stream t nil t))))))) Index: /branches/qres/ccl/library/splay-tree.lisp =================================================================== --- /branches/qres/ccl/library/splay-tree.lisp (revision 13564) +++ /branches/qres/ccl/library/splay-tree.lisp (revision 13564) @@ -0,0 +1,208 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2003-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +;;; A (partial) implementation of SPLAY-TREEs, which are binary trees +;;; that reorganize themselves so that the most recently accessed keys +;;; cluster near the tree's root. + +(defstruct (tree-node + (:constructor make-tree-node (key value))) + key + value + left ; the child < this key, or NIL + right ; the child > this key, or NIL + parent ; we're the root if NIL. + ) + +(defmethod print-object ((node tree-node) stream) + (print-unreadable-object (node stream :type t :identity t) + (let* ((*print-circle* t)) + (format stream "~s -> ~s" (tree-node-key node) (tree-node-value node))))) + + +(defun tree-node-is-leaf (n) + (and (null (tree-node-left n)) + (null (tree-node-right n)))) + +(defun tree-node-is-root (n) + (null (tree-node-parent n))) + +;;; Is node the left child of its parent ? +(defun tree-node-is-left (n) + (let* ((parent (tree-node-parent n))) + (and parent (eq n (tree-node-left parent))))) + +(defun tree-node-is-right (n) + (let* ((parent (tree-node-parent n))) + (and parent (eq n (tree-node-right parent))))) + +(defun tree-node-set-right (node newright) + (when (setf (tree-node-right node) newright) + (setf (tree-node-parent newright) node))) + +(defun tree-node-set-left (node newleft) + (when (setf (tree-node-left node) newleft) + (setf (tree-node-parent newleft) node))) + +(defun tree-node-replace-child (node old new) + (if (eq old (tree-node-left node)) + (tree-node-set-left node new) + (tree-node-set-right node new))) + +(defstruct (splay-tree (:constructor %make-splay-tree)) + (root nil #|:type (or null splay-tree-node)|#) + equal ; true if x = y + less ; true if x < y + (count 0) + ) + +(defmethod print-object ((tree splay-tree) stream) + (print-unreadable-object (tree stream :type t :identity t) + (format stream "count = ~d, root = ~s" + (splay-tree-count tree) + (splay-tree-root tree)))) + + + +;;; Returns tree-node or NIL +(defun binary-tree-get (tree key) + (do* ((equal (splay-tree-equal tree)) + (less (splay-tree-less tree)) + (node (splay-tree-root tree))) + ((null node)) + (let* ((node-key (tree-node-key node))) + (if (funcall equal key node-key) + (return node) + (if (funcall less key node-key) + (setq node (tree-node-left node)) + (setq node (tree-node-right node))))))) + +;;; No node with matching key exists in the tree +(defun binary-tree-insert (tree node) + (let* ((root (splay-tree-root tree))) + (if (null root) + (setf (splay-tree-root tree) node) + (do* ((less (splay-tree-less tree)) + (key (tree-node-key node)) + (current root) + (parent nil)) + ((null current) + (if (funcall less key (tree-node-key parent)) + (tree-node-set-left parent node) + (tree-node-set-right parent node))) + (setq parent current) + (if (funcall less key (tree-node-key current)) + (setq current (tree-node-left current)) + (setq current (tree-node-right current)))))) + (incf (splay-tree-count tree))) + + +;;; Replace the node's parent with the node itself, updating the +;;; affected children so that the binary tree remains properly +;;; ordered. +(defun binary-tree-rotate (tree node) + (when (and node (not (tree-node-is-root node))) + (let* ((parent (tree-node-parent node)) + (grandparent (if parent (tree-node-parent parent))) + (was-left (tree-node-is-left node))) + (if grandparent + (tree-node-replace-child grandparent parent node) + (setf (splay-tree-root tree) node + (tree-node-parent node) nil)) + (if was-left + (progn + (tree-node-set-left parent (tree-node-right node)) + (tree-node-set-right node parent)) + (progn + (tree-node-set-right parent (tree-node-left node)) + (tree-node-set-left node parent)))))) + +;;; Keep rotating the node (and maybe its parent) until the node's the +;;; root of tree. +(defun splay-tree-splay (tree node) + (when node + (do* () + ((tree-node-is-root node)) + (let* ((parent (tree-node-parent node)) + (grandparent (tree-node-parent parent))) + (cond ((null grandparent) + (binary-tree-rotate tree node)) ; node is now root + ((eq (tree-node-is-left node) + (tree-node-is-left parent)) + (binary-tree-rotate tree parent) + (binary-tree-rotate tree node)) + (t + (binary-tree-rotate tree node) + (binary-tree-rotate tree node))))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The more-or-less public API follows. +;;; +;;; I suppose that we should support DELETE as well, and perhaps +;;; UPDATE (find the node and modify its key in place.) For now, +;;; SPLAY-TREE-PUT assumes that no node with a matching key exists. +;;; Access to the tree has to be serialized by the caller. + +(defun splay-tree-get (tree key &optional default) + (let* ((node (binary-tree-get tree key))) + (if node + (progn + (splay-tree-splay tree node) + (tree-node-value node)) + default))) + +(defun splay-tree-put (tree key value) + (let* ((node (make-tree-node key value))) + (binary-tree-insert tree node) + (splay-tree-splay tree node) + value)) + +;;; Note that the tree wants two comparison functions. This may +;;; increase the chance that builtin CL functions can be used; a tree +;;; whose keys are real numbers could use #'= and #'<, for instance. +;;; Using two comparison functions is (at best) only slightly better +;;; than insisting that a single comparison function return (values +;;; equal less), or (member -1 0 1), or some other convention. + +(defun make-splay-tree (equal less) + (check-type equal function) + (check-type less function) + (%make-splay-tree :equal equal :less less)) + +;;; Do an inorder traversal of the splay tree, applying function F +;;; to the value of each node. + +(defun map-splay-tree (tree f) + (labels ((map-tree-node (node) + (when node + (map-tree-node (tree-node-left node)) + (funcall f (tree-node-value node)) + (map-tree-node (tree-node-right node))))) + (map-tree-node (splay-tree-root tree)))) + +(defun map-splay-tree-keys-and-values (tree f) + (labels ((map-tree-node (node) + (when node + (map-tree-node (tree-node-left node)) + (funcall f (tree-node-key node) (tree-node-value node)) + (map-tree-node (tree-node-right node))))) + (map-tree-node (splay-tree-root tree)))) Index: /branches/qres/ccl/library/syscall.lisp =================================================================== --- /branches/qres/ccl/library/syscall.lisp (revision 13564) +++ /branches/qres/ccl/library/syscall.lisp (revision 13564) @@ -0,0 +1,68 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; "Generic" syscall sypport. + +(in-package "CCL") + +(defpackage "SYSCALLS" (:use)) + +(defstruct syscall + (idx 0 :type fixnum) + (arg-specs () :type list) + (result-spec nil :type symbol) + (min-args 0 :type fixnum)) + +(defvar *os-syscall-definitions* ()) + +(defun platform-syscall-definitions (platform-os) + (or (getf *os-syscall-definitions* platform-os) + (setf (getf *os-syscall-definitions* platform-os) + (make-hash-table :test 'eq)))) + +(defun backend-syscall-definitions (backend) + (platform-syscall-definitions (backend-platform-syscall-mask backend))) + + + +(defmacro define-syscall (platform name idx (&rest arg-specs) result-spec + &key (min-args (length arg-specs))) + `(progn + (setf (gethash ',name (platform-syscall-definitions ,platform)) + (make-syscall :idx ,idx + :arg-specs ',arg-specs + :result-spec ',result-spec + :min-args ,min-args)) + ',name)) + +(defmacro syscall (name &rest args) + (let* ((info (or (gethash name (backend-syscall-definitions *target-backend*)) + (error "Unknown system call: ~s" name))) + (idx (syscall-idx info)) + (arg-specs (syscall-arg-specs info)) + (n-argspecs (length arg-specs)) + (n-args (length args)) + (min-args (syscall-min-args info)) + (result (syscall-result-spec info))) + (unless (and (>= n-args min-args) (<= n-args n-argspecs)) + (error "wrong number of args in ~s" args)) + (do* ((call ()) + (specs arg-specs (cdr specs)) + (args args (cdr args))) + ((null args) + `(%syscall ,idx ,@(nreverse (cons result call)))) + (push (car specs) call) + (push (car args) call)))) Index: /branches/qres/ccl/library/x86-win64-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/x86-win64-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/x86-win64-syscalls.lisp (revision 13564) @@ -0,0 +1,281 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::open 0 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::close 1 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::read 2 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::write 3 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchmod 4 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::lseek 5 (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::stat 6 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fstat 7 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 8 (:unsigned-fullword :unsigned-doubleword) + :signed-fullword) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::opendir 9 (:address) :address) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readdir 10 (:address) :address) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::closedir 11 (:address) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pipe 12 (:address) :signed-fullword ) + +#+notdefinedyet +(progn + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::lstat 190 (:address :address) :signed-fullword) + + + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::exit 1 (:signed-fullword) :void) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fork 2 () :signed-fullword) + + + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::link 9 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::unlink 10 (:address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chdir 12 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :unsigned-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::lchown 254 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpid 20 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mount 21 (:address :address :address :unsigned-fullword :address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getuid 24 () :unsigned-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ptrace 26 (:unsigned-fullword + :unsigned-fullword + :address + :address) + :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned-fullword) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::access 33 (:address :unsigned-fullword) :signed-fullword) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sync 36 () :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rename 128 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rmdir 17 (:address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getgid 47 () :unsigned-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getegid 43 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::acct 51 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setpgid 82 (:signed-fullword :signed-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::umask 60 (:unsigned-fullword) :unsigned-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chroot 61 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 81 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setsid 147 () :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigaction 416 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 116 (:address :address) :void) + + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::socket 97 (:signed-fullword :signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::connect 98 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::accept 30 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::bind 104 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::listen 106 (:signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpeername 31 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getsockname 32 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::socketpair 135 (:signed-fullword :signed-fullword :signed-fullword :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::uname 164 (:address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getcwd 326 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::poll 209 ((:* (:struct :pollfd)) :int :int) :int) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setreuid 70 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setregid 71 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigpending 73 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sethostname 74 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getgroups 80 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setgroups 81 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::symlink 83 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::uselib 86 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::swapon 87 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::reboot 88 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readdir 89 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::truncate 92 () ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchown 95 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpriority 96 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setpriority 97 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::statfs 99 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ioperm 101 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::syslog 103 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setitimer 38 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getitimer 36 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::olduname 109 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::iopl 110 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::vhangup 111 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::idle 112 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::vm86 113 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::wait4 7 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::swapoff 115 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ipc 117 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::clone 120 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mprotect 10 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::create_module 127 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::init_module 128 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::delete_module 129 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::quotactl 131 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpgid 132 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::bdflush 134 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sysfs 135 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::personality 136 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getdents 141 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::_newselect 142 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::flock 143 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::msync 26 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readv 19 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::writev 20 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getsid 147 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mlock 150 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::munlock 151 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mlockall 152 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::munlockall 153 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_yield 24 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 35 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mremap 25 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setresuid 164 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getresuid 165 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::query_module 166 () ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setresgid 169 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getresgid 170 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::prctl 171 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigreturn 15 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigaction 13 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigprocmask 14 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pread 17 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pwrite 18 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::capget 183 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::capset 184 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sendfile 40 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::vfork 189 () ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mmap 9 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::munmap 73 () ) + +) Index: /branches/qres/ccl/library/x8664-freebsd-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/x8664-freebsd-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/x8664-freebsd-syscalls.lisp (revision 13564) @@ -0,0 +1,272 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + + + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::read 3 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::write 4 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::stat 188 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fstat 189 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::lstat 190 (:address :address) :signed-fullword) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::lseek 199 (:unsigned-fullword :unsigned-doubleword :signed-doubleword :unsigned-fullword) :signed-doubleword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::exit 1 (:signed-fullword) :void) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fork 2 () :signed-fullword) + + + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::link 9 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::unlink 10 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chdir 12 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :unsigned-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::lchown 254 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpid 20 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mount 21 (:address :address :address :unsigned-fullword :address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getuid 24 () :unsigned-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ptrace 26 (:unsigned-fullword + :unsigned-fullword + :address + :address) + :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned-fullword) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::access 33 (:address :unsigned-fullword) :signed-fullword) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sync 36 () :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rename 128 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rmdir 137 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pipe 42 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getgid 47 () :unsigned-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getegid 43 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::acct 51 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setpgid 82 (:signed-fullword :signed-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::umask 60 (:unsigned-fullword) :unsigned-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chroot 61 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 81 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setsid 147 () :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigaction 416 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 116 (:address :address) :void) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchmod 91 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::socket 97 (:signed-fullword :signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::connect 98 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::accept 30 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::bind 104 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::listen 106 (:signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpeername 31 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getsockname 32 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::socketpair 135 (:signed-fullword :signed-fullword :signed-fullword :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::uname 164 (:address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getcwd 326 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::poll 209 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setreuid 70 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setregid 71 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigpending 73 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sethostname 74 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getgroups 80 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setgroups 81 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::symlink 83 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::uselib 86 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::swapon 87 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::reboot 88 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::readdir 89 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::truncate 92 () ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchown 95 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpriority 96 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setpriority 97 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::statfs 99 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ioperm 101 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::syslog 103 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setitimer 38 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getitimer 36 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::olduname 109 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::iopl 110 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::vhangup 111 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::idle 112 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::vm86 113 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::wait4 7 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::swapoff 115 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ipc 117 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::clone 120 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mprotect 10 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::create_module 127 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::init_module 128 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::delete_module 129 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::quotactl 131 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpgid 132 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::bdflush 134 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sysfs 135 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::personality 136 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getdents 141 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::_newselect 142 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::flock 143 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::msync 26 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::readv 19 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::writev 20 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getsid 147 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mlock 150 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::munlock 151 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mlockall 152 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::munlockall 153 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_yield 24 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 35 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mremap 25 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setresuid 164 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getresuid 165 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::query_module 166 () ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setresgid 169 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getresgid 170 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::prctl 171 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigreturn 15 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigaction 13 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigprocmask 14 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pread 17 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pwrite 18 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::capget 183 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::capset 184 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sendfile 40 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::vfork 189 () ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mmap 9 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::munmap 73 () ) + +) Index: /branches/qres/ccl/library/x8664-linux-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/x8664-linux-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/x8664-linux-syscalls.lisp (revision 13564) @@ -0,0 +1,261 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + + + + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::read 0 (:int :address :size_t) + :ssize_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::write 1 (:int :address :size_t) + :ssize_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::open 2 (:address :int :mode_t) :int :min-args 2) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::close 3 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::stat 4 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fstat 5 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lstat 6 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::poll 7 ((:* (:struct :pollfd)) :int :int) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lseek 8 (:int :off_t :int) :off_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::exit 60 (:int) :void) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fork 57 () :pid_t) + + + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :mode_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::link 86 (:address :address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::unlink 87 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chdir 80 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :time_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mknod 133 (:address :mode_t :dev_t) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chmod 90 (:address :mode_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lchown 94 (:address :uid_t :gid_t) + :int) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpid 39 () :pid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mount 165 (:address + :address + :address + :unsigned-long + :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address :int) :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setuid 105 (:uid_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getuid 102 () :uid_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ptrace 101 (:unsigned-fullword + :pid_t + :address + :address) + :long) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned) :unsigned ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :unt) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::access 21 (:address :int) :int) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sync 162 () :void ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::kill 62 (:pid_t :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rename 82 (:address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mkdir 83 (:address :mode_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rmdir 84 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup 32 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pipe 22 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :clock_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setgid 106 (:gid_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getgid 104 () :gid_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::geteuid 107 () :uid_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getegid 108 () :gid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::acct 163 (:address) :INT ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ioctl 16 (:int :int :address) :int :min-args 2 ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fcntl 72 (:int :int :long) :int :min-args 2 ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setpgid 109 (:pid_t :gid_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umask 95 (:mode_t) :mode_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chroot 161 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:dev_t :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup2 33 (:int :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getppid 110 () :pid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 111 () :gid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsid 112 () :pid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt-sigaction 13 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getrusage 98 (:int :address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 96 (:address :address) :void) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 77 (:int :off_t) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchmod 91 (:int :mode_t) + :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socket 41 (:int :int :int) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::connect 42 (:int :address :socklen_t) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::accept 43 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendto 44 (:int :address :size_t :int :address :socklen_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 45 (:int :address :size_t :int :address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 46 (:int :address :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 47 (:int :address :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::shutdown 48 (:int :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::bind 49 (:int :address :socklen_t) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::listen 50 (:int :int) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockname 51 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpeername 52 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socketpair 53 (:int :int :int :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 54 (:int :int :int :address :socklen_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 55 (:int :int :int :address :address) :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fsync 118 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::uname 63 (:address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchdir 133 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::_llseek 140 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::select 23 (:int :address :address + :address :address) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getcwd 79 (:address :unsigned-long) :long ) + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::futex 202 (:address :int :int :address :address :int) :int ) + +#+notdefinedyet +(progn +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setreuid 70 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setregid 71 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigpending 73 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sethostname 74 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getgroups 80 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setgroups 81 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::symlink 83 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::readlink 85 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::uselib 86 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::swapon 87 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::reboot 88 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::readdir 89 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::truncate 92 () ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchown 95 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpriority 96 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setpriority 97 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::statfs 99 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ioperm 101 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::syslog 103 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setitimer 38 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getitimer 36 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::olduname 109 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::iopl 110 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::vhangup 111 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::idle 112 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::vm86 113 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::wait4 114 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::swapoff 115 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ipc 117 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::clone 120 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mprotect 10 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::create_module 127 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::init_module 128 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::delete_module 129 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::quotactl 131 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpgid 132 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::bdflush 134 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sysfs 135 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::personality 136 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getdents 141 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::_newselect 142 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::flock 143 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::msync 26 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::readv 19 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::writev 20 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsid 147 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mlock 150 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::munlock 151 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mlockall 152 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::munlockall 153 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_yield 24 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 35 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mremap 25 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setresuid 164 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getresuid 165 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::query_module 166 () ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setresgid 169 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getresgid 170 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::prctl 171 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigreturn 15 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigaction 13 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigprocmask 14 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pread 17 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pwrite 18 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::capget 183 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::capset 184 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendfile 40 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::vfork 189 () ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mmap 9 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::munmap 11 () ) + +) Index: /branches/qres/ccl/library/x8664-solaris-syscalls.lisp =================================================================== --- /branches/qres/ccl/library/x8664-solaris-syscalls.lisp (revision 13564) +++ /branches/qres/ccl/library/x8664-solaris-syscalls.lisp (revision 13564) @@ -0,0 +1,493 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::syscall 0 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::exit 1 (:int) :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::forkall 2 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::read 3 (:int :address :size_t) :ssize_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::write 4 (:int :address :size_t) :ssize_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::open 5 (:address :int :mode_t) :int :min-args 2) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::close 6 (:int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::wait 7 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::creat 8 (:address :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::link 9 (:address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::unlink 10 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::exec 11 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chdir 12 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::time 13 (:address) :time_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mknod 14 (:address :mode_t :dev_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chmod 15 (:address :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chown 16 (:address :uid_t :gid_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::brk 17 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stat 18 (:address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lseek 19 (:int :off_t :int) :off_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpid 20 () :pid_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mount 21 (:address :address :int :address :address :int :adress :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::umount 22 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setuid 23 (:uid_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getuid 24 () :uid_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stime 25 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pcsample 26 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::alarm 27 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstat 28 (:int :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pause 29 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::utime 30 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stty 31 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::gtty 32 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::access 33 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::nice 34 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::statfs 35 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sync 36 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::kill 37 (:pid_t :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 38 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pgrpsys 39 () :void) + #|| + * subcodes: + * getpgrp() :: syscall(39,0) + * setpgrp() :: syscall(39,1) + * getsid(pid) :: syscall(39,2,pid) + * setsid() :: syscall(39,3) + * getpgid(pid) :: syscall(39,4,pid) + * setpgid(pid,pgid) :: syscall(39,5,pid,pgid) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uucopystr 40 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::dup 41 (:int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pipe 42 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::times 43 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::profil 44 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::plock 45 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setgid 46 (:gid_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getgid 47 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::signal 48 () :void) + #|| + * subcodes: + * signal(sig, f) :: signal(sig, f) ((sig&SIGNO_MASK) == sig) + * sigset(sig, f) :: signal(sig|SIGDEFER, f) + * sighold(sig) :: signal(sig|SIGHOLD) + * sigrelse(sig) :: signal(sig|SIGRELSE) + * sigignore(sig) :: signal(sig|SIGIGNORE) + * sigpause(sig) :: signal(sig|SIGPAUSE) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::msgsys 49 () :void) + #|| + * subcodes: + * msgget(...) :: msgsys(0, ...) + * msgctl(...) :: msgsys(1, ...) + * msgrcv(...) :: msgsys(2, ...) + * msgsnd(...) :: msgsys(3, ...) + * msgids(...) :: msgsys(4, ...) + * msgsnap(...) :: msgsys(5, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sysi86 50 () :void) + #|| + * subcodes: + * sysi86(code, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::acct 51 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::shmsys 52 () :void) + #|| + * subcodes: + * shmat (...) :: shmsys(0, ...) + * shmctl(...) :: shmsys(1, ...) + * shmdt (...) :: shmsys(2, ...) + * shmget(...) :: shmsys(3, ...) + * shmids(...) :: shmsys(4, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::semsys 53 () :void) + #|| + * subcodes: + * semctl(...) :: semsys(0, ...) + * semget(...) :: semsys(1, ...) + * semop (...) :: semsys(2, ...) + * semids(...) :: semsys(3, ...) + * semtimedop(...) :: semsys(4, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ioctl 54 (:int :int :address) :int :min-args 2) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uadmin 55 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::utssys 57 () :void) + #|| + * subcodes (third argument): + * uname(obuf) (obsolete) :: syscall(57, obuf, ign, 0) + * subcode 1 unused + * ustat(dev, obuf) :: syscall(57, obuf, dev, 2) + * fusers(path, flags, obuf) :: syscall(57, path, flags, 3, obuf) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fdsync 58 (:int :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::execve 59 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::umask 60 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chroot 61 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fcntl 62 (:int :int :address) :int :min-args 2) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ulimit 63 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_64 64 #|| 64 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_65 65 #|| 65 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_66 66 #|| 66 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_67 67 #|| 67 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_68 68 #|| 68 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_69 69 #|| 69 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::tasksys 70 () :void) + #|| + * subcodes: + * settaskid(...) :: tasksys(0, ...) + * gettaskid(...) :: tasksys(1, ...) + * getprojid(...) :: tasksys(2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::acctctl 71 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::exacctsys 72 () :void) + #|| + * subcodes: + * getacct(...) :: exacct(0, ...) + * putacct(...) :: exacct(1, ...) + * wracct(...) :: exacct(2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpagesizes 73 () :void) + #|| + * subcodes: + * getpagesizes2(...) :: getpagesizes(0, ...) + * getpagesizes(...) :: getpagesizes(1, ...) legacy + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rctlsys 74 () :void) + #|| + * subcodes: + * getrctl(...) :: rctlsys(0, ...) + * setrctl(...) :: rctlsys(1, ...) + * rctllist(...) :: rctlsys(2, ...) + * rctlctl(...) :: rctlsys(3, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sidsys 75 () :void) + #|| + * subcodes: + * allocids(...) :: sidsys(0, ...) + * idmap_reg(...) :: sidsys(1, ...) + * idmap_unreg(...) :: sidsys(2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fsat 76 () :void) + #|| + * subcodes: + * openat(...) :: fsat(0, ...) + * openat64(...) :: fsat(1, ...) + * fstatat64(...) :: fsat(2, ...) + * fstatat(...) :: fsat(3, ...) + * renameat(...) :: fsat(4, ...) + * fchownat(...) :: fsat(5, ...) + * unlinkat(...) :: fsat(6, ...) + * futimesat(...) :: fsat(7, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_park 77 () :void) + #|| + * subcodes: + * _lwp_park(timespec_t *, lwpid_t) :: syslwp_park(0, ...) + * _lwp_unpark(lwpid_t, int) :: syslwp_park(1, ...) + * _lwp_unpark_all(lwpid_t *, int) :: syslwp_park(2, ...) + * _lwp_unpark_cancel(lwpid_t *, int) :: syslwp_park(3, ...) + * _lwp_set_park(lwpid_t *, int) :: syslwp_park(4, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sendfilev 78 () :void) + #|| + * subcodes : + * sendfilev() :: sendfilev(0, ...) + * sendfilev64() :: sendfilev(1, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rmdir 79 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mkdir 80 (:address :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getdents 81 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::privsys 82 () :void) + #|| + * subcodes: + * setppriv(...) :: privsys(0, ...) + * getppriv(...) :: privsys(1, ...) + * getimplinfo(...) :: privsys(2, ...) + * setpflags(...) :: privsys(3, ...) + * getpflags(...) :: privsys(4, ...) + * issetugid(); :: privsys(5) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ucredsys 83 () :void) + #|| + * subcodes: + * ucred_get(...) :: ucredsys(0, ...) + * getpeerucred(...) :: ucredsys(1, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sysfs 84 () :void) + #|| + * subcodes: + * sysfs(code, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getmsg 85 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::putmsg 86 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::poll 87 (:address :nfds_t :int) :int) + +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lstat 88 (:address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::symlink 89 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::readlink 90 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setgroups 91 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getgroups 92 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchmod 93 (:int :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchown 94 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 95 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 96 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 97 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigaction 98 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigpending 99 () :void) + #|| + * subcodes: + * subcode 0 unused + * sigpending(...) :: syscall(99, 1, ...) + * sigfillset(...) :: syscall(99, 2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::context 100 () :void) + #|| + * subcodes: + * getcontext(...) :: syscall(100, 0, ...) + * setcontext(...) :: syscall(100, 1, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::evsys 101 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::evtrapret 102 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::statvfs 103 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstatvfs 104 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getloadavg 105 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::nfssys 106 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::waitid 107 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigsendsys 108 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::hrtsys 109 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigresend 111 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::priocntlsys 112 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pathconf 113 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mincore 114 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mmap 115 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mprotect 116 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::munmap 117 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fpathconf 118 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::vfork 119 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchdir 120 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::readv 121 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::writev 122 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::xstat 123 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lxstat 124 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fxstat 125 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::xmknod 126 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 128 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 129 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lchown 130 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::memcntl 131 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 132 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 133 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rename 134 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uname 135 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setegid 136 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sysconfig 137 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::adjtime 138 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::systeminfo 139 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sharefs 140 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::seteuid 141 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::forksys 142 () :void) + #|| + * subcodes: + * forkx(flags) :: forksys(0, flags) + * forkallx(flags) :: forksys(1, flags) + * vforkx(flags) :: forksys(2, flags) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fork1 143 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigtimedwait 144 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_info 145 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::yield 146 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_wait 147 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_post 148 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_trywait 149 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_detach 150 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::corectl 151 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::modctl 152 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchroot 153 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::utimes 154 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::vhangup 155 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 156 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getitimer 157 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setitimer 158 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_create 159 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_exit 160 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_suspend 161 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_continue 162 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_kill 163 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_self 164 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sigmask 165 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_private 166 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_wait 167 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_wakeup 168 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_lock 169 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_cond_wait 170 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_cond_signal 171 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_cond_broadcast 172 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pread 173 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pwrite 174 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::llseek 175 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::inst_sync 176 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::brand 177 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::kaio 178 () :void) + #|| + * subcodes: + * aioread(...) :: kaio(AIOREAD, ...) + * aiowrite(...) :: kaio(AIOWRITE, ...) + * aiowait(...) :: kaio(AIOWAIT, ...) + * aiocancel(...) :: kaio(AIOCANCEL, ...) + * aionotify() :: kaio(AIONOTIFY) + * aioinit() :: kaio(AIOINIT) + * aiostart() :: kaio(AIOSTART) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::cpc 179 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lgrpsys 180 () :void) + #|| + * subcodes: + * meminfo(...) :: meminfosys(MIsyscalls::MEMINFO, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rusagesys 181 (:int :int :address) :int) + #|| + * subcodes: + * getrusage(...) :: rusagesys(RUSAGEsyscalls::GETRUSAGE, ...) + * getvmusage(...) :: rusagesys(RUSAGEsyscalls::GETVMUSAGE, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::port 182 () :void) + #|| + * subcodes: + * port_create(...) :: portfs(PORT_CREATE, ...) + * port_associate(...) :: portfs(PORT_ASSOCIATE, ...) + * port_dissociate(...) :: portfs(PORT_DISSOCIATE, ...) + * port_send(...) :: portfs(PORT_SEND, ...) + * port_sendn(...) :: portfs(PORT_SENDN, ...) + * port_get(...) :: portfs(PORT_GET, ...) + * port_getn(...) :: portfs(PORT_GETN, ...) + * port_alert(...) :: portfs(PORT_ALERT, ...) + * port_dispatch(...) :: portfs(PORT_DISPATCH, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pollsys 183 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::labelsys 184 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::acl 185 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::auditsys 186 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::processor_bind 187 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::processor_info 188 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::p_online 189 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigqueue 190 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::clock_gettime 191 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::clock_settime 192 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::clock_getres 193 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_create 194 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_delete 195 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_settime 196 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_gettime 197 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_getoverrun 198 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 199 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::facl 200 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::door 201 () :void) + #|| + * Door Subcodes: + * 0 door_create + * 1 door_revoke + * 2 door_info + * 3 door_call + * 4 door_return + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setreuid 202 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setregid 203 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::install_utrap 204 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::signotify 205 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::schedctl 206 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pset 207 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sparc_utrap_install 208 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::resolvepath 209 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_timedlock 210 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_timedwait 211 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_rwlock_sys 212 () :void) + #|| + * subcodes: + * lwp_rwlock_rdlock(...) :: syscall(212, 0, ...) + * lwp_rwlock_wrlock(...) :: syscall(212, 1, ...) + * lwp_rwlock_tryrdlock(...) :: syscall(212, 2, ...) + * lwp_rwlock_trywrlock(...) :: syscall(212, 3, ...) + * lwp_rwlock_unlock(...) :: syscall(212, 4, ...) + ||# +#|| system calls for large file ( > 2 gigabyte) support ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getdents64 213 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mmap64 214 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stat64 215 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lstat64 216 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstat64 217 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::statvfs64 218 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstatvfs64 219 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setrlimit64 220 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getrlimit64 221 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pread64 222 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pwrite64 223 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::creat64 224 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::open64 225 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rpcsys 226 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::zone 227 () :void) + #|| + * subcodes: + * zone_create(...) :: zone(ZONE_CREATE, ...) + * zone_destroy(...) :: zone(ZONE_DESTROY, ...) + * zone_getattr(...) :: zone(ZONE_GETATTR, ...) + * zone_enter(...) :: zone(ZONE_ENTER, ...) + * zone_list(...) :: zone(ZONE_LIST, ...) + * zone_shutdown(...) :: zone(ZONE_SHUTDOWN, ...) + * zone_lookup(...) :: zone(ZONE_LOOKUP, ...) + * zone_boot(...) :: zone(ZONE_BOOT, ...) + * zone_version(...) :: zone(ZONE_VERSION, ...) + * zone_setattr(...) :: zone(ZONE_SETATTR, ...) + * zone_add_datalink(...) :: zone(ZONE_ADD_DATALINK, ...) + * zone_remove_datalink(...) :: zone(ZONE_DEL_DATALINK, ...) + * zone_check_datalink(...) :: zone(ZONE_CHECK_DATALINK, ...) + * zone_list_datalink(...) :: zone(ZONE_LIST_DATALINK, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::autofssys 228 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getcwd 229 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::so_socket 230 (:int :int :int :address :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::so_socketpair 231 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::bind 232 (:int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::listen 233 (:int :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::accept 234 (:int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::connect 235 (:int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::shutdown 236 (:int :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::recv 237 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 238 (:int :address :size_t :int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 239 (:int :address :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::send 240 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 241 (:int :address :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sendto 242 (:int :address :size_t :int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpeername 243 (:int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getsockname 244 (:int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 245 (:int :int :int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 246 (:int :int :int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sockconfig 247 () :void) + #|| + * NTP codes + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ntp_gettime 248 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ntp_adjtime 249 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_unlock 250 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_trylock 251 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_register 252 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::cladm 253 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uucopy 254 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::umount2 255 () :void) Index: /branches/qres/ccl/lisp-kernel/.cvsignore =================================================================== --- /branches/qres/ccl/lisp-kernel/.cvsignore (revision 13564) +++ /branches/qres/ccl/lisp-kernel/.cvsignore (revision 13564) @@ -0,0 +1,1 @@ +*~.* Index: /branches/qres/ccl/lisp-kernel/Threads.h =================================================================== --- /branches/qres/ccl/lisp-kernel/Threads.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/Threads.h (revision 13564) @@ -0,0 +1,275 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include +#ifndef WINDOWS +#include +#include +#endif +#undef __argv +#include +#ifndef WINDOWS +#include +#endif +#ifdef WINDOWS +#include +#endif +#include +#include + +#ifdef SOLARIS +#include +#include +#endif + +#ifdef LINUX +#include +#endif + +#undef USE_MACH_SEMAPHORES +#define USE_POSIX_SEMAPHORES +#undef USE_WINDOWS_SEMAPHORES + +#ifdef DARWIN +#define USE_MACH_SEMAPHORES 1 +#undef USE_POSIX_SEMAPHORES +#endif +#ifdef WINDOWS +#define USE_WINDOWS_SEMAPHORES 1 +#undef USE_POSIX_SEMAPHORES +#ifdef WIN_32 +struct timespec { + int tv_sec; + int tv_nsec; +}; +#endif +#endif + +#ifdef USE_POSIX_SEMAPHORES +#include +#endif + + +#ifdef USE_MACH_SEMAPHORES +/* We have to use Mach semaphores, even if we're otherwise + using POSIX signals, etc. */ +#include +#include +#endif + +#include + +#ifdef FREEBSD +#include +#endif + +#ifndef WINDOWS +#include +#endif + +#include "lisp.h" +#include "lisp_globals.h" +#include "gc.h" + +#ifdef USE_FUTEX +#ifndef FUTEX_WAIT +#define FUTEX_WAIT (0) +#endif +#ifndef FUTEX_WAKE +#define FUTEX_WAKE (1) +#endif +#include +#endif + +#ifndef WINDOWS +#include +#endif + +Boolean extern threads_initialized; +Boolean extern log_tcr_info; + +#define LOCK_SPINLOCK(x,tcr) get_spin_lock(&(x),tcr) +#define RELEASE_SPINLOCK(x) (x)=0 + +#define TCR_TO_TSD(tcr) ((void *)((natural)(tcr)+TCR_BIAS)) +#define TCR_FROM_TSD(tsd) ((TCR *)((natural)(tsd)-TCR_BIAS)) + +#ifdef USE_WINDOWS_SEMAPHORES + +typedef void * SEMAPHORE; +#define SEM_WAIT(s) WaitForSingleObject(s,INFINITE) +#define SEM_RAISE(s) ReleaseSemaphore(s, 1L, NULL) +#define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0) +#define SEM_TIMEDWAIT(s,t) WaitOnSingleObject(s,t) + +#endif +#ifdef USE_POSIX_SEMAPHORES +typedef sem_t * SEMAPHORE; +#define SEM_WAIT(s) sem_wait((SEMAPHORE)s) +#define SEM_RAISE(s) sem_post((SEMAPHORE)s) +#define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0) +#define SEM_TIMEDWAIT(s,t) sem_timedwait((SEMAPHORE)s,(struct timespec *)t) +#endif + +#ifdef USE_MACH_SEMAPHORES +typedef semaphore_t SEMAPHORE; +#define SEM_WAIT(s) semaphore_wait((SEMAPHORE)(natural)s) +#define SEM_RAISE(s) semaphore_signal((SEMAPHORE)(natural)s) +#define SEM_BROADCAST(s,count)semaphore_signal_all((SEMAPHORE)(natural)s) +#define SEM_TIMEDWAIT(s,t) semaphore_timedwait((SEMAPHORE)(natural)s,t) +#endif + +void sem_wait_forever(SEMAPHORE s); + +#ifdef USE_POSIX_SEMAPHORES +#define SEM_WAIT_FOREVER(s) sem_wait_forever((SEMAPHORE)s) +#endif + +#ifdef USE_MACH_SEMAPHORES +#define SEM_WAIT_FOREVER(s) sem_wait_forever((SEMAPHORE)(natural)s) +#endif + +#ifdef USE_WINDOWS_SEMAPHORES +#define SEM_WAIT_FOREVER(s) sem_wait_forever((SEMAPHORE)s) +#endif + +typedef struct +{ + signed_natural avail; + TCR* owner; + signed_natural count; + void* signal; + signed_natural waiting; + void *malloced_ptr; + signed_natural spinlock; +} _recursive_lock, *RECURSIVE_LOCK; + + +int lock_recursive_lock(RECURSIVE_LOCK, TCR *); +int unlock_recursive_lock(RECURSIVE_LOCK, TCR *); +RECURSIVE_LOCK new_recursive_lock(void); +void destroy_recursive_lock(RECURSIVE_LOCK); +int recursive_lock_trylock(RECURSIVE_LOCK, TCR *, int *); + +#define LOCK(m, t) lock_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(m), (TCR *)t) +#define UNLOCK(m, t) unlock_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(m), (TCR *)t) + +/* Hmm. This doesn't look like the MacOS Thread Manager ... */ +LispObj current_thread_osid(void); +void *current_native_thread_id(void); +void *new_semaphore(int); +void destroy_semaphore(void**); +void tsd_set(LispObj, void *); +void *tsd_get(LispObj); +TCR *new_tcr(natural, natural); +TCR *initial_thread_tcr; + +#define DEFAULT_THREAD_STACK_SIZE ((size_t) -1) +#define MINIMAL_THREAD_STACK_SIZE ((size_t) 0) + + +Boolean create_system_thread(size_t stack_size, + void* stackaddr, +#ifdef WINDOWS + unsigned CALLBACK (*start_routine)(void *) +#else + void* (*start_routine)(void *) +#endif + , + void* param); + +TCR *get_tcr(Boolean); +TCR *get_interrupt_tcr(Boolean); +Boolean suspend_tcr(TCR *); +Boolean resume_tcr(TCR *); + +typedef struct +{ + signed_natural spin; /* need spin lock to change fields */ + signed_natural state; /* 0 = free, positive if writer, negative if readers; */ + natural blocked_writers; + natural blocked_readers; + TCR *writer; +#ifdef USE_FUTEX + natural reader_signal; + natural writer_signal; +#else + void * reader_signal; + void * writer_signal; +#endif + void *malloced_ptr; +} rwlock; + + +rwlock * rwlock_new(void); +void rwlock_destroy(rwlock *); +int rwlock_rlock(rwlock *, TCR *, struct timespec *); +int rwlock_wlock(rwlock *, TCR *, struct timespec *); +int rwlock_try_wlock(rwlock *, TCR *); +int rwlock_try_rlock(rwlock *, TCR *); +int rwlock_unlock(rwlock *, TCR *); + + +natural +atomic_and(natural*, natural); + +natural +atomic_ior(natural*, natural); + +#define SET_TCR_FLAG(t,bit) atomic_ior(&(t->flags),(1L<flags),~(1L<succ sense) those that don't (stacks). + The list header's "area" pointer is an "AREA_VOID" area; the header + (once allocated during kernel initialization) never + moves or changes. Lisp code can get its hands on + the list header via a nilreg global, and carefully, + atomically, traverse it to do ROOM, etc. +*/ + + +area *new_area(BytePtr, BytePtr, area_code); +void add_area(area *, TCR *); +void add_area_holding_area_lock(area *); +void condemn_area(area *, TCR *); +void condemn_area_holding_area_lock(area *); +area *area_containing(BytePtr); +area *stack_area_containing(BytePtr); +area *heap_area_containing(BytePtr); +void tenure_to_area(area *); +void untenure_from_area(area *); + +/* serialize add_area/remove_area, and also the tcr queue */ +void *tcr_area_lock; + +#define reserved_area ((area *)(all_areas)) +#define active_dynamic_area ((area *)(reserved_area->succ)) + +typedef struct area_list { + area *the_area; + struct area_list *next; +} area_list; + +/* The useable size of a tsp or vsp stack segment. + */ +/* #define STACK_SEGMENT_SIZE (64<<10) */ +#define MIN_CSTACK_SIZE (1<<17) +#define CSTACK_HARDPROT (100<<10) +#define CSTACK_SOFTPROT (100<<10) +#define MIN_VSTACK_SIZE (1<<16) +#define VSTACK_HARDPROT (1<<12) +#define VSTACK_SOFTPROT (1<<16) +#define MIN_TSTACK_SIZE (1<<18) +#define TSTACK_HARDPROT 0 +#define TSTACK_SOFTPROT (1<<16) +#ifdef PPC +#define CS_OVERFLOW_FORCE_LIMIT ((natural)(-(sizeof(lisp_frame)))) +#endif + +#ifdef X86 +#define CS_OVERFLOW_FORCE_LIMIT ((natural)(-16)) +#endif + + +#ifdef PPC +#ifdef LINUX +#ifdef PPC64 +#define IMAGE_BASE_ADDRESS 0x100000000L +#else +#define IMAGE_BASE_ADDRESS 0x31000000 +#endif +#endif +#ifdef DARWIN +#ifdef PPC64 +#define IMAGE_BASE_ADDRESS 0x100000000L +#else +#define IMAGE_BASE_ADDRESS 0x04000000 +#endif +#endif +#endif + +#ifdef X86 +#ifdef LINUX +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#else +#define IMAGE_BASE_ADDRESS 0x10000000 +#endif +#endif +#ifdef FREEBSD +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L /* 0x100000000L */ +#else +#define IMAGE_BASE_ADDRESS 0x30000000 +#endif +#endif +#ifdef SOLARIS +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#else +#define IMAGE_BASE_ADDRESS 0x10000000 +#endif +#endif +#ifdef DARWIN +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#else +#define IMAGE_BASE_ADDRESS 0x04000000 +#endif +#endif +#endif +#ifdef WINDOWS +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x100000000LL +#else +#define IMAGE_BASE_ADDRESS 0x04000000 +#endif +#endif + +#ifdef X8664 +#define PURESPACE_RESERVE 0x40000000 /* 1GB */ +#else +#define PURESPACE_RESERVE 0x04000000 /* 64MB */ +#endif + +#define STATIC_RESERVE heap_segment_size + +#ifndef X86 +#define STATIC_BASE_ADDRESS (0x00002000+(LOWMEM_BIAS)) +#else +#define STATIC_BASE_ADDRESS (0x00012000+(LOWMEM_BIAS)) +#endif + +#define SPJUMP_TARGET_ADDRESS (STATIC_BASE_ADDRESS+0x3000) + +extern LispObj image_base; +extern BytePtr pure_space_start, pure_space_active, pure_space_limit; +extern BytePtr static_space_start, static_space_active, static_space_limit; +extern area *find_readonly_area(void); + +#endif /* __AREA_H__ */ Index: /branches/qres/ccl/lisp-kernel/bits.c =================================================================== --- /branches/qres/ccl/lisp-kernel/bits.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/bits.c (revision 13564) @@ -0,0 +1,70 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + +#include "lisp.h" +#include "bits.h" +#include "lisp-exceptions.h" + + +/* This should be a lot faster than calling set_bit N times */ + +void +set_n_bits(bitvector bits, natural first, natural n) +{ + if (n) { + natural + lastbit = (first+n)-1, + leftbit = first & bitmap_shift_count_mask, + leftmask = ALL_ONES >> leftbit, + rightmask = ALL_ONES << ((nbits_in_word-1) - (lastbit & bitmap_shift_count_mask)), + *wstart = ((natural *) bits) + (first>>bitmap_shift), + *wend = ((natural *) bits) + (lastbit>>bitmap_shift); + + if (wstart == wend) { + *wstart |= (leftmask & rightmask); + } else { + *wstart++ |= leftmask; + n -= (nbits_in_word - leftbit); + + while (n >= nbits_in_word) { + *wstart++ = ALL_ONES; + n-= nbits_in_word; + } + + if (n) { + *wstart |= rightmask; + } + } + } +} + +/* Note that this zeros longwords */ +void +zero_bits(bitvector bits, natural nbits) +{ + memset(bits, 0, ((sizeof(natural)*(((nbits+(nbits_in_word-1)))>>bitmap_shift)))); +} + +void +ior_bits(bitvector dest, bitvector src, natural nbits) +{ + while (nbits > 0) { + *dest++ |= *src++; + nbits -= nbits_in_word; + } +} Index: /branches/qres/ccl/lisp-kernel/bits.h =================================================================== --- /branches/qres/ccl/lisp-kernel/bits.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/bits.h (revision 13564) @@ -0,0 +1,183 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + + +#ifndef __bits_h__ +#define __bits_h__ 1 + +#include + +typedef natural *bitvector; + +#if WORD_SIZE == 64 +#define bitmap_shift 6 +#define BIT0_MASK 0x8000000000000000ULL +#define ALL_ONES 0xffffffffffffffffULL +#define NATURAL1 1ULL +#else +#define bitmap_shift 5 +#define BIT0_MASK 0x80000000U +#define ALL_ONES 0xFFFFFFFFU +#define NATURAL1 1U +#endif + +#define bitmap_shift_count_mask ((1<>bitmap_shift, + old = bits[windex], + new = old | (BIT0_MASK >> (bitnum & bitmap_shift_count_mask)); + if (new == old) { + return 1; /* Was set */ + } else { + bits[windex] = new; + return 0; /* Was clear */ + } +} + +static inline int +atomic_set_bit(bitvector bits ,natural bitnum) +{ + extern natural atomic_ior(bitvector, natural); + natural + windex = bitnum>>bitmap_shift, + mask = (BIT0_MASK >> (bitnum & bitmap_shift_count_mask)); + + return atomic_ior(bits + windex, mask); +} + +void set_n_bits(bitvector,natural,natural); + +static inline int +clr_bit(bitvector bits, natural bitnum) +{ + natural + windex = bitnum>>bitmap_shift, + old = bits[windex], + new = old & ~(BIT0_MASK >> (bitnum & bitmap_shift_count_mask)); + if (new == old) { + return 0; /* Was clear */ + } else { + bits[windex] = new; + return 1; /* Was set */ + } +} + + +static inline unsigned +ref_bit(bitvector bits,natural bitnum) __attribute__((always_inline)); + +static inline unsigned +ref_bit(bitvector bits,natural bitnum) +{ + return ((bits[bitnum>>bitmap_shift] & (BIT0_MASK >> (bitnum & bitmap_shift_count_mask))) != 0); +} + +void zero_bits(bitvector, natural); +void ior_bits(bitvector,bitvector,natural); + +#define bits_word_index(bitnum) (((natural)(bitnum)) >> bitmap_shift) +#define bits_bit_index(bitnum) (((natural)(bitnum)) & bitmap_shift_count_mask) +#define bits_word_ptr(bits,bitnum) \ + ((natural*) (((natural*) bits) + ((natural) (bits_word_index(bitnum))))) +#define bits_word_mask(bitnum) ((BIT0_MASK) >> bits_bit_index(bitnum)) +#define bits_indexed_word(bitv,indexw) ((((natural*)(bitv))[indexw])) +#define bits_word(bitv,bitnum) bits_indexed_word(bits,bits_word_index(bitnum)) + +/* Evaluates some arguments twice */ + +#define set_bits_vars(BITVvar,BITNUMvar,BITPvar,BITWvar,MASKvar) \ +{ BITPvar = bits_word_ptr(BITVvar,BITNUMvar); BITWvar = *BITPvar; MASKvar = bits_word_mask(BITNUMvar); } + +#define set_bitidx_vars(BITVvar,BITNUMvar,BITPvar,BITWvar,BITIDXvar) \ +{ BITPvar = bits_word_ptr(BITVvar,BITNUMvar); BITIDXvar = bits_bit_index(BITNUMvar); \ + BITWvar = (*BITPvar << BITIDXvar) >> BITIDXvar; } + +#ifdef __GNUC__ +static __inline__ natural +current_stack_pointer(void) __attribute__((always_inline)); + +static __inline__ natural +current_stack_pointer(void) +{ +#ifdef PPC + register natural _sp __asm__("r1"); +#endif +#ifdef X8664 + register natural _sp __asm__("%rsp"); +#endif +#ifdef X8632 + register natural _sp __asm__("%esp"); +#endif + return _sp; +} +#else +natural +current_stack_pointer(void); +#endif + +#ifdef __GNUC__ +static __inline__ unsigned +count_leading_zeros(natural w) __attribute__((always_inline)); + + +/* Beware: on some platforms, __builtin_clz[ll](0) returns an undefined + result */ + +static __inline__ unsigned +count_leading_zeros(natural w) +{ +#if __GNUC__ >= 4 +#if WORD_SIZE == 64 + return __builtin_clzll(w); +#else + return __builtin_clz(w); +#endif +#else /* __GNUC__ < 4 */ + natural lz; +#ifdef PPC +#ifdef PPC64 + __asm__ __volatile__("cntlzd %0,%1" : "=r" (lz) : "r" (w)); +#else + __asm__ __volatile__("cntlzw %0,%1" : "=r" (lz) : "r" (w)); +#endif +#endif /* PPC */ +#ifdef X86 +#ifdef X8664 + __asm__ __volatile__("bsr %1,%0" : "=r" (lz) : "r" (w)); + __asm__ __volatile__("xor $63,%0" : "=r" (lz)); +#else + __asm__ __volatile__("bsr %1,%0" : "=r" (lz) : "r" (w)); + __asm__ __volatile__("xor $31,%0" : "=r" (lz)); +#endif +#endif + return lz; +#endif +} +#else /* not __GNUC__ */ +unsigned +count_leading_zeros(natural); +#endif + +#endif /* __bits_h__ */ Index: /branches/qres/ccl/lisp-kernel/errors.s =================================================================== --- /branches/qres/ccl/lisp-kernel/errors.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/errors.s (revision 13564) @@ -0,0 +1,236 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + +error_reg_errnum = 0 /* "real" (typically negative) error number is in RB */ +error_udf = 1 +error_udf_call = 2 +error_throw_tag_missing = 3 +error_alloc_failed = 4 +error_stack_overflow = 5 +error_excised_function_call = 6 +error_too_many_values = 7 +error_propagate_suspend = 10 +error_interrupt = 11 +error_suspend = 12 +error_suspend_all = 13 +error_resume = 14 +error_resume_all = 15 +error_cant_call = 17 + +error_type_error = 128 + +define(`__type_error_counter__',128) +define(`def_type_error',` +error_object_not_$1 = __type_error_counter__ + define(`__type_error_counter__',eval(__type_error_counter__+1))') + + def_type_error(array) + def_type_error(bignum) + def_type_error(fixnum) + def_type_error(character) + def_type_error(integer) + def_type_error(list) + def_type_error(number) + def_type_error(sequence) + def_type_error(simple_string) + def_type_error(simple_vector) + def_type_error(string) + def_type_error(symbol) + def_type_error(macptr) + def_type_error(real) + def_type_error(cons) + def_type_error(unsigned_byte) + def_type_error(radix) + def_type_error(float) + def_type_error(rational) + def_type_error(ratio) + def_type_error(short_float) + def_type_error(double_float) + def_type_error(complex) + def_type_error(vector) + def_type_error(simple_base_string) + def_type_error(function) + def_type_error(unsigned_byte_16) + def_type_error(unsigned_byte_8) + def_type_error(unsigned_byte_32) + def_type_error(signed_byte_32) + def_type_error(signed_byte_16) + def_type_error(signed_byte_8) + def_type_error(base_character) + def_type_error(bit) + def_type_error(unsigned_byte_24) + def_type_error(u64) + def_type_error(s64) + def_type_error(unsigned_byte_56) + def_type_error(simple_array_double_float_2d) + def_type_error(simple_array_single_float_2d) + def_type_error(mod_char_code_limit) + def_type_error(array_2d) + def_type_error(array_3d) + def_type_error(array_t) + def_type_error(array_bit) + def_type_error(array_s8) + def_type_error(array_u8) + def_type_error(array_s16) + def_type_error(array_u16) + def_type_error(array_s32) + def_type_error(array_u32) + def_type_error(array_s64) + def_type_error(array_u64) + def_type_error(array_fixnum) + def_type_error(array_single_float) + def_type_error(array_double_float) + def_type_error(array_char) + def_type_error(array_t_2d) + def_type_error(array_bit_2d) + def_type_error(array_s8_2d) + def_type_error(array_u8_2d) + def_type_error(array_s16_2d) + def_type_error(array_u16_2d) + def_type_error(array_s32_2d) + def_type_error(array_u32_2d) + def_type_error(array_s64_2d) + def_type_error(array_u64_2d) + def_type_error(array_fixnum_2d) + def_type_error(array_single_float_2d) + def_type_error(array_double_float_2d) + def_type_error(array_char_2d) + def_type_error(simple_array_t_2d) + def_type_error(simple_array_bit_2d) + def_type_error(simple_array_s8_2d) + def_type_error(simple_array_u8_2d) + def_type_error(simple_array_s16_2d) + def_type_error(simple_array_u16_2d) + def_type_error(simple_array_s32_2d) + def_type_error(simple_array_u32_2d) + def_type_error(simple_array_s64_2d) + def_type_error(simple_array_u64_2d) + def_type_error(simple_array_fixnum_2d) + def_type_error(simple_array_char_2d) + def_type_error(array_t_3d) + def_type_error(array_bit_3d) + def_type_error(array_s8_3d) + def_type_error(array_u8_3d) + def_type_error(array_s16_3d) + def_type_error(array_u16_3d) + def_type_error(array_s32_3d) + def_type_error(array_u32_3d) + def_type_error(array_s64_3d) + def_type_error(array_u64_3d) + def_type_error(array_fixnum_3d) + def_type_error(array_single_float_3d) + def_type_error(array_double_float_3d) + def_type_error(array_char_3d) + def_type_error(simple_array_t_3d) + def_type_error(simple_array_bit_3d) + def_type_error(simple_array_s8_3d) + def_type_error(simple_array_u8_3d) + def_type_error(simple_array_s16_3d) + def_type_error(simple_array_u16_3d) + def_type_error(simple_array_s32_3d) + def_type_error(simple_array_u32_3d) + def_type_error(simple_array_s64_3d) + def_type_error(simple_array_u64_3d) + def_type_error(simple_array_fixnum_3d) + def_type_error(simple_array_single_float_3d) + def_type_error(simple_array_double_float_3d) + def_type_error(simple_array_char_3d) + def_type_error(vector_t) + def_type_error(bit_vector) + def_type_error(vector_s8) + def_type_error(vector_u8) + def_type_error(vector_s16) + def_type_error(vector_u16) + def_type_error(vector_s32) + def_type_error(vector_u32) + def_type_error(vector_s64) + def_type_error(vector_u64) + def_type_error(vector_fixnum) + def_type_error(vector_single_float) + def_type_error(vector_double_float) + + + +/* These are the "old" error constants that %ERR-DISP understands */ + +define(`deferr',` +$1 = $2< +#include +#include + +#ifndef WINDOWS +#include +#endif + +#ifndef timeradd +# define timeradd(a, b, result) \ + do { \ + (result)->tv_sec = (a)->tv_sec + (b)->tv_sec; \ + (result)->tv_usec = (a)->tv_usec + (b)->tv_usec; \ + if ((result)->tv_usec >= 1000000) \ + { \ + ++(result)->tv_sec; \ + (result)->tv_usec -= 1000000; \ + } \ + } while (0) +#endif +#ifndef timersub +# define timersub(a, b, result) \ + do { \ + (result)->tv_sec = (a)->tv_sec - (b)->tv_sec; \ + (result)->tv_usec = (a)->tv_usec - (b)->tv_usec; \ + if ((result)->tv_usec < 0) { \ + --(result)->tv_sec; \ + (result)->tv_usec += 1000000; \ + } \ + } while (0) +#endif + +void +comma_output_decimal(char *buf, int len, natural n) +{ + int nout = 0; + + buf[--len] = 0; + do { + buf[--len] = n%10+'0'; + n = n/10; + if (n == 0) { + while (len) { + buf[--len] = ' '; + } + return; + } + if (len == 0) return; + nout ++; + if (nout == 3) { + buf[--len] = ','; + nout = 0; + } + } while (len >= 0); +} + + +natural +static_dnodes_for_area(area *a) +{ + if (a->low == tenured_area->low) { + return tenured_area->static_dnodes; + } + return 0; +} + +Boolean GCDebug = false, GCverbose = false; +bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL; +LispObj GCarealow = 0, GCareadynamiclow = 0; +natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0; +LispObj GCweakvll = (LispObj)NULL; +LispObj GCdwsweakvll = (LispObj)NULL; +LispObj GCephemeral_low = 0; +natural GCn_ephemeral_dnodes = 0; +natural GCstack_limit = 0; + + +void +reapweakv(LispObj weakv) +{ + /* + element 2 of the weak vector should be tagged as a cons: if it + isn't, just mark it as a root. if it is, cdr through it until a + "marked" cons is encountered. If the car of any unmarked cons is + marked, mark the cons which contains it; otherwise, splice the + cons out of the list. N.B. : elements 0 and 1 are already marked + (or are immediate, etc.) + */ + LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev; + LispObj termination_list = lisp_nil; + natural weak_type = (natural) deref(weakv,2); + Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist), + terminatablep = ((weak_type >> population_termination_bit) != 0); + Boolean done = false; + cons *rawcons; + natural dnode, car_dnode; + bitvector markbits = GCmarkbits; + + if (terminatablep) { + termination_list = deref(weakv,1+3); + } + + if (fulltag_of(cell) != fulltag_cons) { + mark_root(cell); + } else if (alistp) { + /* weak alist */ + while (! done) { + dnode = gc_area_dnode(cell); + if ((dnode >= GCndnodes_in_area) || + (ref_bit(markbits, dnode))) { + done = true; + } else { + /* Cons cell is unmarked. */ + LispObj alist_cell, thecar; + unsigned cell_tag; + + rawcons = (cons *) ptr_from_lispobj(untag(cell)); + alist_cell = rawcons->car; + cell_tag = fulltag_of(alist_cell); + + if ((cell_tag == fulltag_cons) && + ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode)) && + (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) && + ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode))) { + *prev = rawcons->cdr; + if (terminatablep) { + rawcons->cdr = termination_list; + termination_list = cell; + } + } else { + set_bit(markbits, dnode); + prev = (LispObj *)(&(rawcons->cdr)); + mark_root(alist_cell); + } + cell = *prev; + } + } + } else { + /* weak list */ + while (! done) { + dnode = gc_area_dnode(cell); + if ((dnode >= GCndnodes_in_area) || + (ref_bit(markbits, dnode))) { + done = true; + } else { + /* Cons cell is unmarked. */ + LispObj thecar; + unsigned cartag; + + rawcons = (cons *) ptr_from_lispobj(untag(cell)); + thecar = rawcons->car; + cartag = fulltag_of(thecar); + + if (is_node_fulltag(cartag) && + ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode))) { + *prev = rawcons->cdr; + if (terminatablep) { + rawcons->cdr = termination_list; + termination_list = cell; + } + } else { + set_bit(markbits, dnode); + prev = (LispObj *)(&(rawcons->cdr)); + } + cell = *prev; + } + } + } + + if (terminatablep) { + deref(weakv,1+3) = termination_list; + } + if (termination_list != lisp_nil) { + deref(weakv,1) = GCweakvll; + GCweakvll = untag(weakv); + } else { + deref(weakv,1) = lisp_global(WEAKVLL); + lisp_global(WEAKVLL) = untag(weakv); + } +} + +/* + Screw: doesn't deal with finalization. + */ + +void +reaphashv(LispObj hashv) +{ + hash_table_vector_header + *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv)); + natural + dnode; + signed_natural + npairs = (header_element_count(hashp->header) - + (hash_table_vector_header_count -1)) >> 1; + LispObj *pairp = (LispObj*) (hashp+1), weakelement; + int weak_index = (((hashp->flags & nhash_weak_value_mask) == 0) ? 0 : 1); + Boolean + keys_frozen = ((hashp->flags & nhash_keys_frozen_mask) != 0); + bitvector markbits = GCmarkbits; + int tag; + + natural *tenured_low = (LispObj *)tenured_area->low; + natural tenured_dnodes = area_dnode(GCarealow, tenured_low); + natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+weak_index), tenured_low); + Boolean + hashv_tenured = (memo_dnode < tenured_dnodes); + natural bits, bitidx, *bitsp; + + if (hashv_tenured) { + set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx); + } + + while (true) { + if (hashv_tenured) { + while (bits == 0) { + int skip = nbits_in_word - bitidx; + npairs -= skip; + if (npairs <= 0) break; + pairp += (skip+skip); + bitidx = 0; + bits = *++bitsp; + } + if (bits != 0) { + int skip = (count_leading_zeros(bits) - bitidx); + if (skip != 0) { + npairs -= skip; + pairp += (skip+skip); + bitidx += skip; + } + } + } + + if (npairs <= 0) break; + + weakelement = pairp[weak_index]; + tag = fulltag_of(weakelement); + if (is_node_fulltag(tag)) { + dnode = gc_area_dnode(weakelement); + if ((dnode < GCndnodes_in_area) && + ! ref_bit(markbits, dnode)) { + pairp[0] = slot_unbound; + if (keys_frozen) { + if (pairp[1] != slot_unbound) { + pairp[1] = unbound; + } + } + else { + pairp[1] = lisp_nil; + } + hashp->weak_deletions_count += (1<header) - + (hash_table_vector_header_count - 1)) >> 1; + LispObj *pairp = (LispObj*) (hashp+1); + Boolean + weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); + + + for (i = 2; i <= skip; i++) { + rmark(deref(htabv,i)); + } + + if (!weak_on_value) { + pairp++; + } + /* unconditionally mark the non-weak element of each pair */ + while (npairs--) { + rmark(*pairp); + pairp += 2; + } + deref(htabv,1) = GCweakvll; + GCweakvll = (LispObj)untag(htabv); +} + + +Boolean +mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements) +{ + natural flags = hashp->flags, weak_dnode, nonweak_dnode; + Boolean + marked_new = false, + weak_marked; + int non_weak_index = (((flags & nhash_weak_value_mask) != 0) ? 0 : 1); + int + skip = hash_table_vector_header_count-1, + weak_tag, + nonweak_tag, + i; + signed_natural + npairs = (elements - skip) >> 1; + LispObj + *pairp = (LispObj*) (hashp+1), + weak, + nonweak; + + natural *tenured_low = (LispObj *)tenured_area->low; + natural tenured_dnodes = area_dnode(GCarealow, tenured_low); + natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+non_weak_index), tenured_low); + Boolean hashv_tenured = (memo_dnode < tenured_dnodes); + natural bits, bitidx, *bitsp; + + if (hashv_tenured) { + set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx); + } + + /* Mark everything in the header */ + + for (i = 2; i<= skip; i++) { + mark_root(deref(ptr_to_lispobj(hashp),i)); + } + + while (true) { + if (hashv_tenured) { + while (bits == 0) { + int skip = nbits_in_word - bitidx; + npairs -= skip; + if (npairs <= 0) break; + pairp += (skip+skip); + bitidx = 0; + bits = *++bitsp; + } + if (bits != 0) { + int skip = count_leading_zeros(bits) - bitidx; + if (skip != 0) { + npairs -= skip; + pairp += (skip+skip); + bitidx += skip; + } + } + } + if (npairs <= 0) break; + + nonweak = pairp[non_weak_index]; + weak = pairp[1-non_weak_index]; + + nonweak_tag = fulltag_of(nonweak); + if (is_node_fulltag(nonweak_tag)) { + nonweak_dnode = gc_area_dnode(nonweak); + if ((nonweak_dnode < GCndnodes_in_area) && + ! ref_bit(GCmarkbits,nonweak_dnode)) { + weak_marked = true; + weak_tag = fulltag_of(weak); + if (is_node_fulltag(weak_tag)) { + weak_dnode = gc_area_dnode(weak); + if ((weak_dnode < GCndnodes_in_area) && + ! ref_bit(GCmarkbits, weak_dnode)) { + weak_marked = false; + } + } + if (weak_marked) { + mark_root(nonweak); + marked_new = true; + } + } + } + + pairp+=2; + --npairs; + } + return marked_new; +} + + +Boolean +mark_weak_alist(LispObj weak_alist, int weak_type) +{ + natural + elements = header_element_count(header_of(weak_alist)), + dnode; + int pair_tag; + Boolean marked_new = false; + LispObj alist, pair, key, value; + bitvector markbits = GCmarkbits; + + if (weak_type >> population_termination_bit) { + elements -= 1; + } + for(alist = deref(weak_alist, elements); + (fulltag_of(alist) == fulltag_cons) && + ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode)); + alist = cdr(alist)) { + pair = car(alist); + pair_tag = fulltag_of(pair); + if ((is_node_fulltag(pair_tag)) && + ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode))) { + if (pair_tag == fulltag_cons) { + key = car(pair); + if ((! is_node_fulltag(fulltag_of(key))) || + ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) || + ref_bit(markbits,dnode)) { + /* key is marked, mark value if necessary */ + value = cdr(pair); + if (is_node_fulltag(fulltag_of(value)) && + ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode))) { + mark_root(value); + marked_new = true; + } + } + } else { + mark_root(pair); + marked_new = true; + } + } + } + return marked_new; +} + +void +mark_termination_lists() +{ + /* + Mark the termination lists in all terminatable weak vectors, which + are now linked together on GCweakvll, and add them to WEAKVLL, + which already contains all other weak vectors. + */ + LispObj pending = GCweakvll, + *base = (LispObj *)NULL; + + while (pending) { + base = ptr_from_lispobj(pending); + pending = base[1]; + + mark_root(base[1+3]); + } + if (base) { + base[1] = lisp_global(WEAKVLL); + lisp_global(WEAKVLL) = GCweakvll; + } + +} + + +void +traditional_markhtabvs() +{ + LispObj *base, this, header, pending; + int subtag; + hash_table_vector_header *hashp; + Boolean marked_new; + + do { + pending = (LispObj) NULL; + marked_new = false; + + while (GCweakvll) { + base = ptr_from_lispobj(GCweakvll); + GCweakvll = base[1]; + + header = base[0]; + subtag = header_subtag(header); + + if (subtag == subtag_weak) { + natural weak_type = base[2]; + this = ptr_to_lispobj(base) + fulltag_misc; + base[1] = pending; + pending = ptr_to_lispobj(base); + if ((weak_type & population_type_mask) == population_weak_alist) { + if (mark_weak_alist(this, weak_type)) { + marked_new = true; + } + } + } else if (subtag == subtag_hash_vector) { + natural elements = header_element_count(header); + + hashp = (hash_table_vector_header *) base; + if (hashp->flags & nhash_weak_mask) { + base[1] = pending; + pending = ptr_to_lispobj(base); + if (mark_weak_hash_vector(hashp, elements)) { + marked_new = true; + } + } + } else { + Bug(NULL, "Strange object on weak vector linked list: " LISP "\n", base); + } + } + + if (marked_new) { + GCweakvll = pending; + } + } while (marked_new); + + /* Now, everything's marked that's going to be, and "pending" is a list + of populations and weak hash tables. CDR down that list and free + anything that isn't marked. + */ + + while (pending) { + base = ptr_from_lispobj(pending); + pending = base[1]; + base[1] = (LispObj)NULL; + + this = ptr_to_lispobj(base) + fulltag_misc; + + subtag = header_subtag(base[0]); + if (subtag == subtag_weak) { + reapweakv(this); + } else { + reaphashv(this); + } + } + mark_termination_lists(); +} + +void +ncircle_markhtabvs() +{ + LispObj *base, this, header, pending = 0; + int subtag; + + /* First, process any weak hash tables that may have + been encountered by the link-inverting marker; we + should have more stack space now. */ + + while (GCdwsweakvll) { + this = GCdwsweakvll; + GCdwsweakvll = deref(this,1); + ncircle_mark_weak_htabv(this); + } + + while (GCweakvll) { + base = ptr_from_lispobj(GCweakvll); + GCweakvll = base[1]; + base[1] = (LispObj)NULL; + + this = ptr_to_lispobj(base) + fulltag_misc; + + header = base[0]; + subtag = header_subtag(header); + + if (subtag == subtag_weak) { + natural weak_type = base[2]; + base[1] = pending; + pending = ptr_to_lispobj(base); + if ((weak_type & population_type_mask) == population_weak_alist) { + mark_weak_alist(this, weak_type); + } + } else if (subtag == subtag_hash_vector) { + reaphashv(this); + } + } + + /* Now, everything's marked that's going to be, and "pending" is a list + of populations. CDR down that list and free + anything that isn't marked. + */ + + while (pending) { + base = ptr_from_lispobj(pending); + pending = base[1]; + base[1] = (LispObj)NULL; + + this = ptr_to_lispobj(base) + fulltag_misc; + + subtag = header_subtag(base[0]); + if (subtag == subtag_weak) { + reapweakv(this); + } else { + Bug(NULL, "Bad object on pending list: %s\n", this); + } + } + + mark_termination_lists(); +} + +void +mark_tcr_tlb(TCR *tcr) +{ + natural n = tcr->tlb_limit; + LispObj + *start = tcr->tlb_pointer, + *end = (LispObj *) ((BytePtr)start+n), + node; + + while (start < end) { + node = *start; + if (node != no_thread_local_binding_marker) { + mark_root(node); + } + start++; + } +} + +/* + Mark things that're only reachable through some (suspended) TCR. + (This basically means the tcr's gc_context and the exception + frames on its xframe_list.) +*/ + +void +mark_tcr_xframes(TCR *tcr) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifndef X8632 + mark_xp(xp); +#else + mark_xp(xp, tcr->node_regs_mask); +#endif + } +#ifdef X8632 + mark_root(tcr->save0); + mark_root(tcr->save1); + mark_root(tcr->save2); + mark_root(tcr->save3); + mark_root(tcr->next_method_context); +#endif + + for (xframes = (xframe_list *) tcr->xframe; + xframes; + xframes = xframes->prev) { +#ifndef X8632 + mark_xp(xframes->curr); +#else + mark_xp(xframes->curr, xframes->node_regs_mask); +#endif + } +} + + +void *postGCptrs = NULL; +struct xmacptr *user_postGC_macptrs = NULL; + + +void +postGCfree(void *p) +{ + *(void **)p = postGCptrs; + postGCptrs = p; +} + +void +postGCfreexmacptr(struct xmacptr *p) +{ + p->class = (LispObj) user_postGC_macptrs; + user_postGC_macptrs = p; +} + + +xmacptr_dispose_fn xmacptr_dispose_functions[xmacptr_flag_user_last-xmacptr_flag_user_first]; + + + +void +freeGCptrs() +{ + void *p, *next, *addr; + struct xmacptr *x, *xnext; + int i, flags; + xmacptr_dispose_fn dfn; + + for (p = postGCptrs; p; p = next) { + next = *((void **)p); + free(p); + } + postGCptrs = NULL; + + for (x = user_postGC_macptrs; x; x = xnext) { + xnext = (xmacptr *) (x->class);; + flags = x->flags - xmacptr_flag_user_first; + dfn = xmacptr_dispose_functions[flags]; + addr = (void *) x->address; + x->address = 0; + x->flags = 0; + x->link = 0; + x->class = 0; + if (dfn && addr) { + dfn(addr); + } + } + + user_postGC_macptrs = NULL; +} + +int +register_xmacptr_dispose_function(void *dfn) +{ + int i, k; + + for( i = 0, k = xmacptr_flag_user_first; k < xmacptr_flag_user_last; i++, k++) { + if (xmacptr_dispose_functions[i]==NULL) { + xmacptr_dispose_functions[i] = dfn; + return k; + } + if (xmacptr_dispose_functions[i] == dfn) { + return k; + } + } + return 0; +} + +void +reap_gcable_ptrs() +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr; + xmacptr_flag flag; + natural dnode; + xmacptr *x; + + while((next = *prev) != (LispObj)NULL) { + dnode = gc_area_dnode(next); + x = (xmacptr *) ptr_from_lispobj(untag(next)); + + if ((dnode >= GCndnodes_in_area) || + (ref_bit(GCmarkbits,dnode))) { + prev = &(x->link); + } else { + *prev = x->link; + flag = (xmacptr_flag)(x->flags); + ptr = x->address; + + if (ptr) { + switch (flag) { + case xmacptr_flag_recursive_lock: + destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_ptr: + postGCfree((void *)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_rwlock: + rwlock_destroy((rwlock *)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_semaphore: + destroy_semaphore((void**)&(x->address)); + break; + + default: + if ((flag >= xmacptr_flag_user_first) && + (flag < xmacptr_flag_user_last)) { + set_n_bits(GCmarkbits,dnode,3); + postGCfreexmacptr(x); + break; + } + /* (warn "unknown xmacptr_flag: ~s" flag) */ + /* Unknowd, and perhaps unknowdable. */ + /* Fall in: */ + case xmacptr_flag_none: + break; + } + } + } + } +} + + + +#if WORD_SIZE == 64 +unsigned short *_one_bits = NULL; + +unsigned short +logcount16(unsigned short n) +{ + unsigned short c=0; + + while(n) { + n = n & (n-1); + c++; + } + return c; +} + +void +gc_init() +{ + int i; + + _one_bits = malloc(sizeof(unsigned short) * (1<<16)); + + for (i = 0; i < (1<<16); i++) { + _one_bits[i] = dnode_size*logcount16(i); + } +} + + +#else +const unsigned char _one_bits[256] = { + 0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8 +}; + + +void +gc_init() +{ +} + +#endif + + +weak_mark_fun dws_mark_weak_htabv = traditional_dws_mark_htabv; +weak_mark_fun mark_weak_htabv = traditional_mark_weak_htabv; +weak_process_fun markhtabvs = traditional_markhtabvs; + +void +install_weak_mark_functions(natural set) { + switch(set) { + case 0: + default: + dws_mark_weak_htabv = traditional_dws_mark_htabv; + mark_weak_htabv = traditional_mark_weak_htabv; + markhtabvs = traditional_markhtabvs; + break; + case 1: + dws_mark_weak_htabv = ncircle_dws_mark_htabv; + mark_weak_htabv = ncircle_mark_weak_htabv; + markhtabvs = ncircle_markhtabvs; + break; + } +} + +void +init_weakvll () +{ + LispObj this = lisp_global(WEAKVLL); /* all weak vectors as of last gc */ + + GCweakvll = (LispObj)NULL; + lisp_global(WEAKVLL) = (LispObj)NULL; + + if (GCn_ephemeral_dnodes) { + /* For egc case, initialize GCweakvll with weak vectors not in the + GC area. Weak vectors in the GC area will be added during marking. + */ + + LispObj *tenured_low = (LispObj *)tenured_area->low; + natural tenured_dnodes = area_dnode(GCarealow, tenured_low); + bitvector refbits = tenured_area->refbits; + + while (this) { + LispObj *base = ptr_from_lispobj(this); + LispObj next = base[1]; + natural dnode = gc_dynamic_area_dnode(this); + if (dnode < GCndynamic_dnodes_in_area) { + base[1] = (LispObj)NULL; /* drop it, might be garbage */ + } else { + base[1] = GCweakvll; + GCweakvll = ptr_to_lispobj(base); + if (header_subtag(base[0]) == subtag_weak) { + dnode = area_dnode(&base[3], tenured_low); + if (dnode < tenured_dnodes) { + clr_bit(refbits, dnode); /* Don't treat population.data as root */ + } + } else { + if (header_subtag(base[0]) != subtag_hash_vector) + Bug(NULL, "Unexpected entry " LISP " -> " LISP " on WEAKVLL", base, base[0]); + dnode = area_dnode(base, tenured_low); + if ((dnode < tenured_dnodes) && !ref_bit(refbits, dnode)) { + Boolean drop = true; + /* hash vectors get marked headers if they have any ephemeral keys */ + /* but not if they have ephemeral values. */ + if (((hash_table_vector_header *)base)->flags & nhash_weak_value_mask) { + signed_natural count = (header_element_count(base[0]) + 2) >> 1; + natural bits, bitidx, *bitsp; + set_bitidx_vars(refbits, dnode, bitsp, bits, bitidx); + while ((0 < count) && (bits == 0)) { + int skip = nbits_in_word - bitidx; + count -= skip; + bits = *++bitsp; + bitidx = 0; + } + count -= (count_leading_zeros(bits) - bitidx); + + if (0 < count) { + set_bit(refbits, dnode); /* has ephemeral values, mark header */ + drop = false; + } + } + if (drop) { /* if nothing ephemeral, drop it from GCweakvll. */ + GCweakvll = base[1]; + base[1] = lisp_global(WEAKVLL); + lisp_global(WEAKVLL) = ptr_to_lispobj(base); + } + } + } + } + this = next; + } + } +} + + +void +preforward_weakvll () +{ + /* reset population refbits for forwarding */ + if (GCn_ephemeral_dnodes) { + LispObj this = lisp_global(WEAKVLL); + LispObj *tenured_low = (LispObj *)tenured_area->low; + natural tenured_dnodes = area_dnode(GCarealow, tenured_low); + bitvector refbits = tenured_area->refbits; + + while (this) { + LispObj *base = ptr_from_lispobj(this); + if (header_subtag(base[0]) == subtag_weak) { + natural dnode = area_dnode(&base[3], tenured_low); + if (base[3] >= GCarealow) { + if (dnode < tenured_dnodes) { + set_bit(refbits, dnode); + } + } + /* might have set termination list to a new pointer */ + if ((base[2] >> population_termination_bit) && (base[4] >= GCarealow)) { + if ((dnode + 1) < tenured_dnodes) { + set_bit(refbits, dnode+1); + } + } + } + this = base[1]; + } + } +} + + +void +forward_weakvll_links() +{ + LispObj *ptr = &(lisp_global(WEAKVLL)), this, new, old; + + while (this = *ptr) { + old = this + fulltag_misc; + new = node_forwarding_address(old); + if (old != new) { + *ptr = untag(new); + } + ptr = &(deref(new,1)); + } +} + + + + + +LispObj +node_forwarding_address(LispObj node) +{ + int tag_n; + natural dnode = gc_dynamic_area_dnode(node); + + if ((dnode >= GCndynamic_dnodes_in_area) || + (node < GCfirstunmarked)) { + return node; + } + + tag_n = fulltag_of(node); + if (!is_node_fulltag(tag_n)) { + return node; + } + + return dnode_forwarding_address(dnode, tag_n); +} + +Boolean +update_noderef(LispObj *noderef) +{ + LispObj + node = *noderef, + new = node_forwarding_address(node); + + if (new != node) { + *noderef = new; + return true; + } + return false; +} + +void +update_locref(LispObj *locref) +{ + LispObj + obj = *locref, + new = locative_forwarding_address(obj); + + if (new != obj) { + *locref = new; + } +} + +void +forward_gcable_ptrs() +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new; + struct xmacptr **xprev, *xnext, *xnew; + + while ((next = *prev) != (LispObj)NULL) { + new = node_forwarding_address(next); + if (new != next) { + *prev = new; + } + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } + xprev = &user_postGC_macptrs; + while (xnext = *xprev) { + xnew = (struct xmacptr *)locative_forwarding_address((LispObj)xnext); + if (xnew != xnext) { + *xprev = xnew; + } + xprev = (struct xmacptr **)(&(xnext->class)); + } +} + +void +forward_memoized_area(area *a, natural num_memo_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2, new; + natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0; + int tag_x1; + hash_table_vector_header *hashp = NULL; + Boolean header_p; + + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + /* This is pretty straightforward, but we have to note + when we move a key in a hash table vector that wants + us to tell it about that. */ + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + bits = *++bitsp; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = p[0]; + x2 = p[1]; + tag_x1 = fulltag_of(x1); + bits &= ~(BIT0_MASK >> bitidx); + header_p = (nodeheader_tag_p(tag_x1)); + + if (header_p && + (header_subtag(x1) == subtag_hash_vector)) { + hashp = (hash_table_vector_header *) p; + if (hashp->flags & nhash_track_keys_mask) { + hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1); + } else { + hashp = NULL; + } + } + + + if (! header_p) { + new = node_forwarding_address(x1); + if (new != x1) { + *p = new; + } + } + p++; + + new = node_forwarding_address(x2); + if (new != x2) { + *p = new; + if (memo_dnode < hash_dnode_limit) { + /* If this code is reached, 'hashp' is non-NULL and pointing + at the header of a hash_table_vector, and 'memo_dnode' identifies + a pair of words inside the hash_table_vector. It may be + hard for program analysis tools to recognize that, but I + believe that warnings about 'hashp' being NULL here can + be safely ignored. */ + hashp->flags |= nhash_key_moved_mask; + hash_dnode_limit = 0; + hashp = NULL; + } + } + p++; + memo_dnode++; + bitidx++; + + } + } +} + +void +forward_tcr_tlb(TCR *tcr) +{ + natural n = tcr->tlb_limit; + LispObj + *start = tcr->tlb_pointer, + *end = (LispObj *) ((BytePtr)start+n), + node; + + while (start < end) { + node = *start; + if (node != no_thread_local_binding_marker) { + update_noderef(start); + } + start++; + } +} + +void +reclaim_static_dnodes() +{ + natural nstatic = tenured_area->static_dnodes, i, bits, bitnum; + cons *c = (cons *)tenured_area->low, *d; + bitvector bitsp = GCmarkbits; + LispObj head = lisp_global(STATIC_CONSES); + + if (nstatic) { + if (head) { + for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) { + bits = *bitsp++; + if (bits != ALL_ONES) { + for (bitnum = 0; bitnum < nbits_in_word; bitnum++) { + if (! (bits & (BIT0_MASK>>bitnum))) { + d = c + bitnum; + d->car = 0; + d->cdr = head; + head = ((LispObj)d)+fulltag_cons; + } + } + } + } + lisp_global(STATIC_CONSES) = head; + } else { + for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) { + bits = *bitsp++; + if (bits != ALL_ONES) { + for (bitnum = 0; bitnum < nbits_in_word; bitnum++) { + if (! (bits & (BIT0_MASK>>bitnum))) { + d = c + bitnum; + d->car = 0; + d->cdr = 0; + } + } + } + } + } + } +} + +Boolean +youngest_non_null_area_p (area *a) +{ + if (a->active == a->high) { + return false; + } else { + for (a = a->younger; a; a = a->younger) { + if (a->active != a->high) { + return false; + } + } + }; + return true; +} + +Boolean just_purified_p = false; + +/* + All thread's stack areas have been "normalized", as + has the dynamic heap. (The "active" pointer in these areas + matches the stack pointer/freeptr value at the time that + the exception occurred.) +*/ + +#define get_time(when) gettimeofday(&when, NULL) + + + +#ifdef FORCE_DWS_MARK +#warning recursive marker disabled for testing; remember to re-enable it +#endif + + +void +gc(TCR *tcr, signed_natural param) +{ + struct timeval start, stop; + area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL; + unsigned timeidx = 1; + paging_info paging_info_start; + LispObj + pkg = 0, + itabvec = 0; + BytePtr oldfree = a->active; + TCR *other_tcr; + natural static_dnodes; + natural weak_method = lisp_global(WEAK_GC_METHOD) >> fixnumshift; + +#ifndef FORCE_DWS_MARK + if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) { + GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; + } else { + GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size; + } +#else + GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; +#endif + + GCephemeral_low = lisp_global(OLDEST_EPHEMERAL); + if (GCephemeral_low) { + GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low); + } else { + GCn_ephemeral_dnodes = 0; + } + + if (GCn_ephemeral_dnodes) { + GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0); + } else { + GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0); + } + + if (GCephemeral_low) { + if ((oldfree-g1_area->low) < g1_area->threshold) { + to = g1_area; + note = a; + timeidx = 4; + } else if ((oldfree-g2_area->low) < g2_area->threshold) { + to = g2_area; + from = g1_area; + note = g1_area; + timeidx = 3; + } else { + to = tenured_area; + from = g2_area; + note = g2_area; + timeidx = 2; + } + } else { + note = tenured_area; + } + + install_weak_mark_functions(weak_method); + + if (GCverbose) { + char buf[16]; + + sample_paging_info(&paging_info_start); + comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift); + if (GCephemeral_low) { + fprintf(dbgout, + "\n\n;;; Starting Ephemeral GC of generation %d", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); + } else { + fprintf(dbgout,"\n\n;;; Starting full GC"); + } + fprintf(dbgout, ", %s bytes allocated.\n", buf); + } + + get_time(start); + + /* The link-inverting marker might need to write to watched areas */ + unprotect_watched_areas(); + + lisp_global(IN_GC) = (1<markbits; + GCarealow = ptr_to_lispobj(a->low); + GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift); + GCndnodes_in_area = gc_area_dnode(oldfree); + + if (GCndnodes_in_area) { + GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes; + GCdynamic_markbits = + GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift); + + zero_bits(GCmarkbits, GCndnodes_in_area); + + init_weakvll(); + + if (GCn_ephemeral_dnodes == 0) { + /* For GCTWA, mark the internal package hash table vector of + *PACKAGE*, but don't mark its contents. */ + { + LispObj + itab; + natural + dnode, ndnodes; + + pkg = nrs_PACKAGE.vcell; + if ((fulltag_of(pkg) == fulltag_misc) && + (header_subtag(header_of(pkg)) == subtag_package)) { + itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab; + itabvec = car(itab); + dnode = gc_area_dnode(itabvec); + if (dnode < GCndnodes_in_area) { + ndnodes = (header_element_count(header_of(itabvec))+1) >> 1; + set_n_bits(GCmarkbits, dnode, ndnodes); + } + } + } + } + + mark_root(lisp_global(STATIC_CONSES)); + + { + area *next_area; + area_code code; + + /* Could make a jump table instead of the typecase */ + + for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + mark_tstack_area(next_area); + break; + + case AREA_VSTACK: + mark_vstack_area(next_area); + break; + + case AREA_CSTACK: + mark_cstack_area(next_area); + break; + + case AREA_STATIC: + case AREA_WATCHED: + case AREA_DYNAMIC: /* some heap that isn't "the" heap */ + /* In both of these cases, we -could- use the area's "markbits" + bitvector as a reference map. It's safe (but slower) to + ignore that map and process the entire area. + */ + if (next_area->younger == NULL) { + mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active); + } + break; + + default: + break; + } + } + } + + if (GCephemeral_low) { + mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low)); + } + + other_tcr = tcr; + do { + mark_tcr_xframes(other_tcr); + mark_tcr_tlb(other_tcr); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + + + /* Go back through *package*'s internal symbols, marking + any that aren't worthless. + */ + + if (itabvec) { + natural + i, + n = header_element_count(header_of(itabvec)); + LispObj + sym, + *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); + + for (i = 0; i < n; i++) { + sym = *raw++; + if (is_symbol_fulltag(sym)) { + lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); + natural dnode = gc_area_dnode(sym); + + if ((dnode < GCndnodes_in_area) && + (!ref_bit(GCmarkbits,dnode))) { + /* Symbol is in GC area, not marked. + Mark it if fboundp, boundp, or if + it has a plist or another home package. + */ + + if (FBOUNDP(rawsym) || + BOUNDP(rawsym) || + (rawsym->flags != 0) || /* SPECIAL, etc. */ + (rawsym->plist != lisp_nil) || + ((rawsym->package_predicate != pkg) && + (rawsym->package_predicate != lisp_nil))) { + mark_root(sym); + } + } + } + } + } + + (void)markhtabvs(); + + if (itabvec) { + natural + i, + n = header_element_count(header_of(itabvec)); + LispObj + sym, + *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); + + for (i = 0; i < n; i++, raw++) { + sym = *raw; + if (is_symbol_fulltag(sym)) { + natural dnode = gc_area_dnode(sym); + + if ((dnode < GCndnodes_in_area) && + (!ref_bit(GCmarkbits,dnode))) { + *raw = unbound_marker; + } + } + } + } + + reap_gcable_ptrs(); + + preforward_weakvll(); + + GCrelocptr = global_reloctab; + GCfirstunmarked = calculate_relocation(); + + if (!GCephemeral_low) { + reclaim_static_dnodes(); + } + + forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked)); + + other_tcr = tcr; + do { + forward_tcr_xframes(other_tcr); + forward_tcr_tlb(other_tcr); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + forward_gcable_ptrs(); + + + + { + area *next_area; + area_code code; + + /* Could make a jump table instead of the typecase */ + + for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + forward_tstack_area(next_area); + break; + + case AREA_VSTACK: + forward_vstack_area(next_area); + break; + + case AREA_CSTACK: + forward_cstack_area(next_area); + break; + + case AREA_STATIC: + case AREA_WATCHED: + case AREA_DYNAMIC: /* some heap that isn't "the" heap */ + if (next_area->younger == NULL) { + forward_range((LispObj *) next_area->low, (LispObj *) next_area->active); + } + break; + + default: + break; + } + } + } + + if (GCephemeral_low) { + forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low)); + } + + a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap()); + + forward_weakvll_links(); + + if (to) { + tenure_to_area(to); + } + + zero_memory_range(a->active, oldfree); + + resize_dynamic_heap(a->active, + (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0); + + /* + If the EGC is enabled: If there's no room for the youngest + generation, untenure everything. If this was a full GC and + there's now room for the youngest generation, tenure everything. + */ + if (a->older != NULL) { + natural nfree = (a->high - a->active); + + + if (nfree < a->threshold) { + untenure_from_area(tenured_area); + } else { + if (GCephemeral_low == 0) { + tenure_to_area(tenured_area); + } + } + } + } + lisp_global(GC_NUM) += (1<gccount += (1<vcell; + if ((fulltag_of(val) == fulltag_misc) && + (header_subtag(header_of(val)) == subtag_macptr)) { + timersub(&stop, &start, &elapsed); + timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address); + timeradd(timeinfo, &elapsed, timeinfo); + timeradd(timeinfo+timeidx, &elapsed, timeinfo+timeidx); + } + + val = total_bytes_freed->vcell; + if ((fulltag_of(val) == fulltag_misc) && + (header_subtag(header_of(val)) == subtag_macptr)) { + long long justfreed = oldfree - a->active; + *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed; + if (GCverbose) { + char buf[16]; + paging_info paging_info_stop; + + sample_paging_info(&paging_info_stop); + if (justfreed <= heap_segment_size) { + justfreed = 0; + } + comma_output_decimal(buf,16,justfreed); + if (note == tenured_area) { + fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec); + } else { + fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0, + buf, + elapsed.tv_sec, elapsed.tv_usec); + } + report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop); + } + } + } +} Index: /branches/qres/ccl/lisp-kernel/gc.h =================================================================== --- /branches/qres/ccl/lisp-kernel/gc.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/gc.h (revision 13564) @@ -0,0 +1,243 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __GC_H__ +#define __GC_H__ 1 + +#include "lisp.h" +#include "bits.h" +#include "lisp-exceptions.h" +#include "memprotect.h" + + + +#ifdef PPC +#define is_node_fulltag(f) ((1<<(f))&((1<>dnode_shift)) +#define gc_area_dnode(w) area_dnode(w,GCarealow) +#define gc_dynamic_area_dnode(w) area_dnode(w,GCareadynamiclow) + +#if defined(PPC64) || defined(X8632) +#define forward_marker subtag_forward_marker +#else +#define forward_marker fulltag_nil +#endif + +#ifdef PPC64 +#define VOID_ALLOCPTR ((LispObj)(0x8000000000000000-dnode_size)) +#else +#define VOID_ALLOCPTR ((LispObj)(-dnode_size)) +#endif + +#ifdef DARWIN +#include +typedef struct task_events_info paging_info; +#else +#ifndef WINDOWS +#include +typedef struct rusage paging_info; +#else +typedef natural paging_info; +#endif +#endif + +#undef __argv +#include + +void sample_paging_info(paging_info *); +void report_paging_info_delta(FILE*, paging_info *, paging_info *); + + +#define GC_TRAP_FUNCTION_IMMEDIATE_GC (-1) +#define GC_TRAP_FUNCTION_GC 0 +#define GC_TRAP_FUNCTION_PURIFY 1 +#define GC_TRAP_FUNCTION_IMPURIFY 2 +#define GC_TRAP_FUNCTION_FLASH_FREEZE 4 +#define GC_TRAP_FUNCTION_SAVE_APPLICATION 8 + +#define GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD 16 +#define GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD 17 +#define GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD 18 +#define GC_TRAP_FUNCTION_EGC_CONTROL 32 +#define GC_TRAP_FUNCTION_CONFIGURE_EGC 64 +#define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128 /* deprecated */ +#define GC_TRAP_FUNCTION_FREEZE 129 +#define GC_TRAP_FUNCTION_THAW 130 + +Boolean GCDebug, GCverbose, just_purified_p; +bitvector GCmarkbits, GCdynamic_markbits; +LispObj GCarealow, GCareadynamiclow; +natural GCndnodes_in_area, GCndynamic_dnodes_in_area; +LispObj GCweakvll,GCdwsweakvll; +LispObj GCephemeral_low; +natural GCn_ephemeral_dnodes; +natural GCstack_limit; + +#if WORD_SIZE == 64 +unsigned short *_one_bits; +#else +const unsigned char _one_bits[256]; +#endif + +#define one_bits(x) _one_bits[x] + +natural static_dnodes_for_area(area *a); +void reapweakv(LispObj weakv); +void reaphashv(LispObj hashv); +Boolean mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements); +Boolean mark_weak_alist(LispObj weak_alist, int weak_type); +void mark_tcr_tlb(TCR *); +void mark_tcr_xframes(TCR *); +void freeGCptrs(void); +void reap_gcable_ptrs(void); +unsigned short logcount16(unsigned short); +void gc_init(void); +LispObj node_forwarding_address(LispObj); +Boolean update_noderef(LispObj *); +void update_locref(LispObj *); +void forward_gcable_ptrs(void); +void forward_memoized_area(area *, natural); +void forward_tcr_tlb(TCR *); +void reclaim_static_dnodes(void); +Boolean youngest_non_null_area_p(area *); +void gc(TCR *, signed_natural); + +/* backend-interface */ + +typedef void (*weak_mark_fun) (LispObj); +weak_mark_fun mark_weak_htabv, dws_mark_weak_htabv; + +typedef void (*weak_process_fun)(void); + +weak_process_fun markhtabvs; + + +#define hash_table_vector_header_count (sizeof(hash_table_vector_header)/sizeof(LispObj)) + +void mark_root(LispObj); +void rmark(LispObj); +#ifdef X8632 +void mark_xp(ExceptionInformation *, natural); +#else +void mark_xp(ExceptionInformation *); +#endif +LispObj dnode_forwarding_address(natural, int); +LispObj locative_forwarding_address(LispObj); +void check_refmap_consistency(LispObj *, LispObj *, bitvector); +void check_all_areas(TCR *); +void mark_tstack_area(area *); +void mark_vstack_area(area *); +void mark_cstack_area(area *); +void mark_simple_area_range(LispObj *, LispObj *); +void mark_memoized_area(area *, natural); +LispObj calculate_relocation(void); +void forward_range(LispObj *, LispObj *); +void forward_tstack_area(area *); +void forward_vstack_area(area *); +void forward_cstack_area(area *); +LispObj compact_dynamic_heap(void); +signed_natural purify(TCR *, signed_natural); +signed_natural impurify(TCR *, signed_natural); +signed_natural gc_like_from_xp(ExceptionInformation *, signed_natural(*fun)(TCR *, signed_natural), signed_natural); + + +typedef enum { + xmacptr_flag_none = 0, /* Maybe already disposed by Lisp */ + xmacptr_flag_recursive_lock, /* recursive-lock */ + xmacptr_flag_ptr, /* malloc/free */ + xmacptr_flag_rwlock, /* read/write lock */ + xmacptr_flag_semaphore, /* semaphore */ + xmacptr_flag_user_first = 8, /* first user-defined dispose fn */ + xmacptr_flag_user_last = 16 /* exclusive upper bound */ +} xmacptr_flag; + + +typedef void (*xmacptr_dispose_fn)(void *); + +extern xmacptr_dispose_fn xmacptr_dispose_functions[]; + +#endif /* __GC_H__ */ Index: /branches/qres/ccl/lisp-kernel/image.c =================================================================== --- /branches/qres/ccl/lisp-kernel/image.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/image.c (revision 13564) @@ -0,0 +1,548 @@ +/* + Copyright (C) 2002-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "area.h" +#include "image.h" +#include "gc.h" +#include +#include +#ifndef WINDOWS +#include +#endif +#include +#include + + + +#if defined(PPC64) || defined(X8632) +#define RELOCATABLE_FULLTAG_MASK \ + ((1<low), + *end = (LispObj *)(a->active), + low = (LispObj)image_base - bias, + high = ptr_to_lispobj(active_dynamic_area->active) - bias, + w0; + int fulltag; + + while (start < end) { + w0 = *start; + fulltag = fulltag_of(w0); + if (immheader_tag_p(fulltag)) { + start = (LispObj *)skip_over_ivector((natural)start, w0); + } else { +#ifdef X86 + if (header_subtag(w0) == subtag_function) { +#ifdef X8664 + int skip = ((int) start[1])+1; +#else + extern void update_self_references(LispObj *); + extern natural imm_word_count(LispObj); + + natural skip = (natural)imm_word_count(((LispObj)start)+fulltag_misc)+1; + update_self_references(start); +#endif + + start += skip; + if (((LispObj) start) & node_size) { + --start; + } + w0 = *start; + fulltag = fulltag_of(w0); + } +#endif + if (header_subtag(w0) == subtag_weak) { + LispObj link = start[1]; + if ((link >= low) && (link < high)) { + start[1] = (link+bias); + } + } + if ((w0 >= low) && (w0 < high) && + ((1<= low) && (w0 < high) && + ((1< end) { + Bug(NULL, "Overran area bounds in relocate_area_contents"); + } +} + + + + +off_t +seek_to_next_page(int fd) +{ + off_t pos = LSEEK(fd, 0, SEEK_CUR); + pos = align_to_power_of_2(pos, log2_page_size); + return LSEEK(fd, pos, SEEK_SET); +} + +/* + fd is positioned to EOF; header has been allocated by caller. + If we find a trailer (and that leads us to the header), read + the header & return true else return false. +*/ +Boolean +find_openmcl_image_file_header(int fd, openmcl_image_file_header *header) +{ + openmcl_image_file_trailer trailer; + int disp; + off_t pos; + unsigned version, flags; + + pos = LSEEK(fd, 0, SEEK_END); + if (pos < 0) { + return false; + } + pos -= sizeof(trailer); + + if (LSEEK(fd, pos, SEEK_SET) < 0) { + return false; + } + if (read(fd, &trailer, sizeof(trailer)) != sizeof(trailer)) { + return false; + } + if ((trailer.sig0 != IMAGE_SIG0) || + (trailer.sig1 != IMAGE_SIG1) || + (trailer.sig2 != IMAGE_SIG2)) { + return false; + } + disp = trailer.delta; + + if (disp >= 0) { + return false; + } + if (LSEEK(fd, disp, SEEK_CUR) < 0) { + return false; + } + if (read(fd, header, sizeof(openmcl_image_file_header)) != + sizeof(openmcl_image_file_header)) { + return false; + } + if ((header->sig0 != IMAGE_SIG0) || + (header->sig1 != IMAGE_SIG1) || + (header->sig2 != IMAGE_SIG2) || + (header->sig3 != IMAGE_SIG3)) { + return false; + } + version = (header->abi_version) & 0xffff; + if (version < ABI_VERSION_MIN) { + fprintf(dbgout, "Heap image is too old for this kernel.\n"); + return false; + } + if (version > ABI_VERSION_MAX) { + fprintf(dbgout, "Heap image is too new for this kernel.\n"); + return false; + } + flags = header->flags; + if (flags != PLATFORM) { + fprintf(dbgout, "Heap image was saved for another platform.\n"); + return false; + } + return true; +} + +void +load_image_section(int fd, openmcl_image_section_header *sect) +{ + extern area* allocate_dynamic_area(unsigned); + off_t + pos = seek_to_next_page(fd), advance; + natural + mem_size = sect->memory_size; + void *addr; + area *a; + + advance = mem_size; + switch(sect->code) { + case AREA_READONLY: + if (!MapFile(pure_space_active, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RX, + fd)) { + return; + } + a = new_area(pure_space_active, pure_space_limit, AREA_READONLY); + pure_space_active += mem_size; + a->active = pure_space_active; + sect->area = a; + break; + + case AREA_STATIC: + if (!MapFile(static_space_active, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RWX, + fd)) { + return; + } + a = new_area(static_space_active, static_space_limit, AREA_STATIC); + static_space_active += mem_size; + a->active = static_space_active; + sect->area = a; + break; + + case AREA_DYNAMIC: + a = allocate_dynamic_area(mem_size); + if (!MapFile(a->low, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RWX, + fd)) { + return; + } + + a->static_dnodes = sect->static_dnodes; + sect->area = a; + break; + + case AREA_MANAGED_STATIC: + a = new_area(pure_space_limit, pure_space_limit, AREA_MANAGED_STATIC); + sect->area = a; + break; + + default: + return; + + } + LSEEK(fd, pos+advance, SEEK_SET); +} + +LispObj +load_openmcl_image(int fd, openmcl_image_file_header *h) +{ + LispObj image_nil = 0; + area *a; + if (find_openmcl_image_file_header(fd, h)) { + int i, nsections = h->nsections; + openmcl_image_section_header sections[nsections], *sect=sections; + LispObj bias = image_base - ACTUAL_IMAGE_BASE(h); +#if (WORD_SIZE== 64) + signed_natural section_data_delta = + ((signed_natural)(h->section_data_offset_high) << 32L) | h->section_data_offset_low; +#endif + + if (read (fd, sections, nsections*sizeof(openmcl_image_section_header)) != + nsections * sizeof(openmcl_image_section_header)) { + return 0; + } +#if WORD_SIZE == 64 + LSEEK(fd, section_data_delta, SEEK_CUR); +#endif + for (i = 0; i < nsections; i++, sect++) { + load_image_section(fd, sect); + a = sect->area; + if (a == NULL) { + return 0; + } + } + + for (i = 0, sect = sections; i < nsections; i++, sect++) { + a = sect->area; + switch(sect->code) { + case AREA_STATIC: + nilreg_area = a; +#ifdef PPC +#ifdef PPC64 + image_nil = ptr_to_lispobj(a->low + (1024*4) + sizeof(lispsymbol) + fulltag_misc); +#else + image_nil = (LispObj)(a->low + 8 + 8 + (1024*4) + fulltag_nil); +#endif +#endif +#ifdef X86 +#ifdef X8664 + image_nil = (LispObj)(a->low) + (1024*4) + fulltag_nil; +#else + image_nil = (LispObj)(a->low) + (1024*4) + fulltag_cons; +#endif +#endif + set_nil(image_nil); + if (bias) { + relocate_area_contents(a, bias); + } + make_dynamic_heap_executable(a->low, a->active); + add_area_holding_area_lock(a); + break; + + case AREA_READONLY: + readonly_area = a; + add_area_holding_area_lock(a); + break; + } + } + for (i = 0, sect = sections; i < nsections; i++, sect++) { + a = sect->area; + switch(sect->code) { + case AREA_MANAGED_STATIC: + if (bias) { + relocate_area_contents(a, bias); + } + managed_static_area = a; + add_area_holding_area_lock(a); + break; + case AREA_DYNAMIC: + if (bias) { + relocate_area_contents(a, bias); + } + resize_dynamic_heap(a->active, lisp_heap_gc_threshold); + xMakeDataExecutable(a->low, a->active - a->low); + break; + } + } + } + return image_nil; +} + +void +prepare_to_write_dynamic_space() +{ + area *a = active_dynamic_area; + LispObj + *start = (LispObj *)(a->low), + *end = (LispObj *) (a->active), + x1; + int tag, subtag, element_count; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + subtag = header_subtag(x1); + if (subtag == subtag_macptr) { + if ((start[1] >= (natural)0x10000) && (start[1] < (natural)-0x10000)) { + /* Leave small pointers alone */ + *start = make_header(subtag_dead_macptr,header_element_count(x1)); + } + } + start = (LispObj *)skip_over_ivector((natural)start, x1); + } else if (nodeheader_tag_p(tag)) { + element_count = header_element_count(x1) | 1; + start += (element_count+1); + } else { + start += 2; + } + } +} + + + +int +write_file_and_section_headers(int fd, + openmcl_image_file_header *file_header, + openmcl_image_section_header* section_headers, + int nsections, + off_t *header_pos) +{ + *header_pos = seek_to_next_page(fd); + + if (LSEEK (fd, *header_pos, SEEK_SET) < 0) { + return errno; + } + if (write(fd, file_header, sizeof(*file_header)) != sizeof(*file_header)) { + return errno; + } + if (write(fd, section_headers, sizeof(section_headers[0])*nsections) + != (sizeof(section_headers[0])*nsections)) { + return errno; + } + return 0; +} + +natural +writebuf(int fd, char *bytes, natural n) +{ + natural remain = n, this_size; + signed_natural result; + + while (remain) { + this_size = remain; + if (this_size > INT_MAX) { + this_size = INT_MAX; + } + result = write(fd, bytes, this_size); + if (result < 0) { + return errno; + } + bytes += result; + + remain -= result; + } + return 0; +} + +OSErr +save_application(unsigned fd, Boolean egc_was_enabled) +{ + openmcl_image_file_header fh; + openmcl_image_section_header sections[NUM_IMAGE_SECTIONS]; + openmcl_image_file_trailer trailer; + area *areas[NUM_IMAGE_SECTIONS], *a; + int i, err; + off_t header_pos, eof_pos; +#if WORD_SIZE == 64 + off_t image_data_pos; + signed_natural section_data_delta; +#endif + + areas[0] = nilreg_area; + areas[1] = active_dynamic_area; + areas[2] = readonly_area; + areas[3] = managed_static_area; + for (i = 0; i < NUM_IMAGE_SECTIONS; i++) { + a = areas[i]; + sections[i].code = a->code; + sections[i].area = NULL; + sections[i].memory_size = a->active - a->low; + if (a == active_dynamic_area) { + sections[i].static_dnodes = tenured_area->static_dnodes; + } else { + sections[i].static_dnodes = 0; + } + } + fh.sig0 = IMAGE_SIG0; + fh.sig1 = IMAGE_SIG1; + fh.sig2 = IMAGE_SIG2; + fh.sig3 = IMAGE_SIG3; + fh.timestamp = time(NULL); + CANONICAL_IMAGE_BASE(&fh) = IMAGE_BASE_ADDRESS; + ACTUAL_IMAGE_BASE(&fh) = image_base; + fh.nsections = NUM_IMAGE_SECTIONS; + fh.abi_version=ABI_VERSION_CURRENT; +#if WORD_SIZE == 64 + fh.section_data_offset_high = 0; + fh.section_data_offset_low = 0; +#else + fh.pad0[0] = fh.pad0[1] = 0; + fh.pad1[0] = fh.pad1[1] = fh.pad1[2] = fh.pad1[3] = 0; +#endif + fh.flags = PLATFORM; + +#if WORD_SIZE == 64 + image_data_pos = seek_to_next_page(fd); +#else + err = write_file_and_section_headers(fd, &fh, sections, NUM_IMAGE_SECTIONS, &header_pos); + if (err) { + return err; + } +#endif + + /* + Coerce macptrs to dead_macptrs. + */ + + prepare_to_write_dynamic_space(active_dynamic_area); + + { + area *g0_area = g1_area->younger; + + /* Save GC config */ + lisp_global(LISP_HEAP_THRESHOLD) = lisp_heap_gc_threshold; + lisp_global(G0_THRESHOLD) = g0_area->threshold; + lisp_global(G1_THRESHOLD) = g1_area->threshold; + lisp_global(G2_THRESHOLD) = g2_area->threshold; + lisp_global(EGC_ENABLED) = (LispObj)egc_was_enabled; + } + /* + lisp_global(GC_NUM) and lisp_global(FWDNUM) are persistent, + as is DELETED_STATIC_PAIRS. + Nothing else is even meaningful at this point. + */ + for (i = MIN_KERNEL_GLOBAL; i < 0; i++) { + switch (i) { + case FWDNUM: + case GC_NUM: + case STATIC_CONSES: + case WEAK_GC_METHOD: + case LISP_HEAP_THRESHOLD: + case EGC_ENABLED: + case G0_THRESHOLD: + case G1_THRESHOLD: + case G2_THRESHOLD: + break; + case WEAKVLL: + break; + default: + lisp_global(i) = 0; + } + } + + for (i = 0; i < NUM_IMAGE_SECTIONS; i++) { + natural n; + a = areas[i]; + seek_to_next_page(fd); + n = sections[i].memory_size; + if (writebuf(fd, a->low, n)) { + return errno; + } + } + +#if WORD_SIZE == 64 + seek_to_next_page(fd); + section_data_delta = -((LSEEK(fd,0,SEEK_CUR)+sizeof(fh)+sizeof(sections)) - + image_data_pos); + fh.section_data_offset_high = (int)(section_data_delta>>32L); + fh.section_data_offset_low = (unsigned)section_data_delta; + err = write_file_and_section_headers(fd, &fh, sections, NUM_IMAGE_SECTIONS, &header_pos); + if (err) { + return err; + } +#endif + + trailer.sig0 = IMAGE_SIG0; + trailer.sig1 = IMAGE_SIG1; + trailer.sig2 = IMAGE_SIG2; + eof_pos = LSEEK(fd, 0, SEEK_CUR) + sizeof(trailer); + trailer.delta = (int) (header_pos-eof_pos); + if (write(fd, &trailer, sizeof(trailer)) == sizeof(trailer)) { +#ifndef WINDOWS + fsync(fd); +#endif + close(fd); + return 0; + } + i = errno; + close(fd); + return i; +} + + + + Index: /branches/qres/ccl/lisp-kernel/image.h =================================================================== --- /branches/qres/ccl/lisp-kernel/image.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/image.h (revision 13564) @@ -0,0 +1,96 @@ +/* + Copyright (C) 2002-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + +#define IMAGE_SIG0 (('O'<<24) | ('p'<<16) | ('e'<<8) | 'n') +#define IMAGE_SIG1 (('M'<<24) | ('C'<<16) | ('L'<<8) | 'I') +#define IMAGE_SIG2 (('m'<<24) | ('a'<<16) | ('g'<<8) | 'e') +#define IMAGE_SIG3 (('F'<<24) | ('i'<<16) | ('l'<<8) | 'e') + +/* + An image file contains a header (which describes the type, size, + and nominal memory address of one or more sections) and data for + each section; each section's data is page-aligned within the image + file, so its disk address is implicit. The header must reside + entirely within a page; the first section's data starts on the page + after the image header, and subsequent sections start on the pages + after the page which contains the last byte of their predecessor's + data. + + The image header's position relative to the start of the file is + arbitrary. The image header's position relative to the end of the + file is indicated by the last word in the file (which is preceded + by the first three signature words above.) The last word contains + the distance from the end-of-file to the start of the header. + + As long as these alignment constraints are met, the image file can + have arbitrary data (or executable programs, or shell scripts) + prepended to it. This is supposed to simplify distribution. +*/ + +typedef struct { + natural code; + area *area; + natural memory_size; + natural static_dnodes; +} openmcl_image_section_header; + +typedef struct { + unsigned sig0, sig1, sig2, sig3; + unsigned timestamp; + unsigned canonical_image_base_32; /* IMAGE_BASE_ADDRESS */ + unsigned actual_image_base_32; /* Hopefully the same */ + unsigned nsections; + unsigned abi_version; +#if WORD_SIZE == 64 + int section_data_offset_high; /* signed offset from end of + section headers to first + section's data. May be zero. */ + unsigned section_data_offset_low; + unsigned flags; + natural canonical_image_base_64; + natural actual_image_base_64; +#else + unsigned pad0[2]; + unsigned flags; + unsigned pad1[4]; +#endif +} openmcl_image_file_header; + +#if WORD_SIZE == 64 +#define ACTUAL_IMAGE_BASE(header) ((header)->actual_image_base_64) +#define CANONICAL_IMAGE_BASE(header) ((header)->canonical_image_base_64) +#else +#define ACTUAL_IMAGE_BASE(header) ((header)->actual_image_base_32) +#define CANONICAL_IMAGE_BASE(header) ((header)->canonical_image_base_32) +#endif + +typedef struct { + unsigned sig0, sig1, sig2; + int delta; +} openmcl_image_file_trailer; + +LispObj +load_openmcl_image(int, openmcl_image_file_header*); + + + + +#define ABI_VERSION_MIN 1033 +#define ABI_VERSION_CURRENT 1033 +#define ABI_VERSION_MAX 1033 + +#define NUM_IMAGE_SECTIONS 4 /* used to be 3 */ Index: /branches/qres/ccl/lisp-kernel/imports.s =================================================================== --- /branches/qres/ccl/lisp-kernel/imports.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/imports.s (revision 13564) @@ -0,0 +1,120 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + include(m4macros.m4) +define(`PTR',` + __ifdef(`PPC64') + .quad $1 + __else + __ifdef(`X8664') + .quad $1 + __else + .long $1 + __endif + __endif +') + _beginfile + + + .globl C(import_ptrs_base) +define(`defimport',` + .globl C($1) + PTR(C($1)) + +# __line__ +') + .data +import_ptrs_start: + + defimport(fd_setsize_bytes) + defimport(do_fd_set) + defimport(do_fd_clr) + defimport(do_fd_is_set) + defimport(do_fd_zero) + defimport(xMakeDataExecutable) + defimport(xGetSharedLibrary) + defimport(xFindSymbol) + defimport(allocate) + defimport(deallocate) + defimport(jvm_init) + defimport(tcr_frame_ptr) + defimport(register_xmacptr_dispose_function) + defimport(open_debug_output) + defimport(get_r_debug) + defimport(restore_soft_stack_limit) + defimport(lisp_egc_control) + defimport(lisp_bug) + defimport(xNewThread) + defimport(cooperative_thread_startup) + defimport(xDisposeThread) + defimport(xThreadCurrentStackSpace) + defimport(usage_exit) + defimport(save_fp_context) + defimport(restore_fp_context) + defimport(put_vector_registers) + defimport(get_vector_registers) + defimport(new_semaphore) + defimport(wait_on_semaphore) + defimport(signal_semaphore) + defimport(destroy_semaphore) + defimport(new_recursive_lock) + defimport(lock_recursive_lock) + defimport(unlock_recursive_lock) + defimport(destroy_recursive_lock) + defimport(lisp_suspend_other_threads) + defimport(lisp_resume_other_threads) + defimport(lisp_suspend_tcr) + defimport(lisp_resume_tcr) + defimport(rwlock_new) + defimport(rwlock_destroy) + defimport(rwlock_rlock) + defimport(rwlock_wlock) + defimport(rwlock_unlock) + defimport(recursive_lock_trylock) + defimport(foreign_name_and_offset) + defimport(lisp_read) + defimport(lisp_write) + defimport(lisp_open) + defimport(lisp_fchmod) + defimport(lisp_lseek) + defimport(lisp_close) + defimport(lisp_ftruncate) + defimport(lisp_stat) + defimport(lisp_fstat) + defimport(lisp_futex) + defimport(lisp_opendir) + defimport(lisp_readdir) + defimport(lisp_closedir) + defimport(lisp_pipe) + defimport(lisp_gettimeofday) + defimport(lisp_sigexit) + + .globl C(import_ptrs_base) +C(import_ptrs_base): + PTR(import_ptrs_start) + + __ifdef(`PPC') + __ifdef(`LINUX') + __ifndef(`PPC64') + .globl __trampoline_setup + .long __trampoline_setup + __endif + __endif + __endif + + + + + _endfile Index: /branches/qres/ccl/lisp-kernel/kernel-globals.h =================================================================== --- /branches/qres/ccl/lisp-kernel/kernel-globals.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/kernel-globals.h (revision 13564) @@ -0,0 +1,33 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __kernel_globals__ +#define __kernel_globals__ +#include "area.h" + + +extern area *nilreg_area, *tenured_area, *g2_area, *g1_area, *managed_static_area, *readonly_area; +extern area *all_areas; +extern int cache_block_size; + + + + + + + +#endif /* __kernel_globals__ */ Index: /branches/qres/ccl/lisp-kernel/linuxx8664/.gdbinit =================================================================== --- /branches/qres/ccl/lisp-kernel/linuxx8664/.gdbinit (revision 13564) +++ /branches/qres/ccl/lisp-kernel/linuxx8664/.gdbinit (revision 13564) @@ -0,0 +1,83 @@ +define x86_lisp_string +x/s $arg0-5 +end + +define gtra +br *$r10 +cont +end + +define x86pname +set $temp=*((long *)((long)($arg0-6))) +x86_lisp_string $temp +end + + +define pname + x86pname $arg0 +end + +define l + call print_lisp_object($arg0) +end + +define lw + l $r13 +end + +define clobber_breakpoint + set *(short *)($pc-2)=0x9090 +end + +define arg_z + l $rsi +end + +define arg_y + l $rdi +end + +define arg_x + l $r8 +end + +define bx + l $rbx +end + +define showlist + set $l=$arg0 + while $l != 0x200b + set $car = *((LispObj *)($l+5)) + set $l = *((LispObj *)($l-3)) + l $car + end +end + +define lbt + call plbt_sp($rbp) +end + +define ada + p/x *(all_areas->succ) +end + +define lregs + call debug_lisp_registers($arg0,0,0) +end + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIG40 pass nostop noprint +handle SIG41 pass nostop noprint +handle SIG42 pass nostop noprint +handle SIGPWR pass nostop noprint +handle SIGQUIT pass nostop noprint + Index: /branches/qres/ccl/lisp-kernel/linuxx8664/Makefile =================================================================== --- /branches/qres/ccl/lisp-kernel/linuxx8664/Makefile (revision 13564) +++ /branches/qres/ccl/lisp-kernel/linuxx8664/Makefile (revision 13564) @@ -0,0 +1,88 @@ +# +# Copyright (C) 2005 Clozure Associates +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +AS = as +M4 = m4 +ASFLAGS = --64 +M4FLAGS = -DLINUX -DX86 -DX8664 -DHAVE_TLS +CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS -DUSE_FUTEX #-DDISABLE_EGC +CDEBUG = -g +COPT = -O2 +# Once in a while, -Wformat says something useful. The odds are against that, +# however. +WFORMAT = -Wno-format + +# If the linker supports a "--hash-style=" option, use traditional +# SysV hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(WFORMAT) -m64 -o $@ + +SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils64.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants64.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../lx86cl64 + + +OSLIBS = -ldl -lm -lpthread +LINK_MAP = ./elf_x86_64.x +USE_LINK_MAP = # -T ./elf_x86_64.x + +../../lx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile $(LINK_MAP) + $(CC) -m64 $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ $(USE_LINK_MAP) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../lx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../lx86cl64 + strip -g ../../lx86cl64 Index: /branches/qres/ccl/lisp-kernel/linuxx8664/elf_x86_64.x =================================================================== --- /branches/qres/ccl/lisp-kernel/linuxx8664/elf_x86_64.x (revision 13564) +++ /branches/qres/ccl/lisp-kernel/linuxx8664/elf_x86_64.x (revision 13564) @@ -0,0 +1,196 @@ +/* Script for -z combreloc: combine and sort reloc sections */ +OUTPUT_FORMAT("elf64-x86-64", "elf64-x86-64", + "elf64-x86-64") +OUTPUT_ARCH(i386:x86-64) +ENTRY(_start) +SEARCH_DIR("/usr/x86_64-linux-gnu/lib64"); SEARCH_DIR("/usr/local/lib64"); SEARCH_DIR("/lib64"); SEARCH_DIR("/usr/lib64"); SEARCH_DIR("/usr/x86_64-linux-gnu/lib"); SEARCH_DIR("/usr/local/lib"); SEARCH_DIR("/lib"); SEARCH_DIR("/usr/lib"); +/* Do we need any of these for elf? + __DYNAMIC = 0; */ +SECTIONS +{ + /* Read-only sections, merged into text segment: */ + PROVIDE (__executable_start = 0x400000); . = 0x400000 + SIZEOF_HEADERS; + .interp : { *(.interp) } + .hash : { *(.hash) } + .dynsym : { *(.dynsym) } + .dynstr : { *(.dynstr) } + .gnu.version : { *(.gnu.version) } + .gnu.version_d : { *(.gnu.version_d) } + .gnu.version_r : { *(.gnu.version_r) } + .rel.dyn : + { + *(.rel.init) + *(.rel.text .rel.text.* .rel.gnu.linkonce.t.*) + *(.rel.fini) + *(.rel.rodata .rel.rodata.* .rel.gnu.linkonce.r.*) + *(.rel.data.rel.ro*) + *(.rel.data .rel.data.* .rel.gnu.linkonce.d.*) + *(.rel.tdata .rel.tdata.* .rel.gnu.linkonce.td.*) + *(.rel.tbss .rel.tbss.* .rel.gnu.linkonce.tb.*) + *(.rel.ctors) + *(.rel.dtors) + *(.rel.got) + *(.rel.bss .rel.bss.* .rel.gnu.linkonce.b.*) + } + .rela.dyn : + { + *(.rela.init) + *(.rela.text .rela.text.* .rela.gnu.linkonce.t.*) + *(.rela.fini) + *(.rela.rodata .rela.rodata.* .rela.gnu.linkonce.r.*) + *(.rela.data .rela.data.* .rela.gnu.linkonce.d.*) + *(.rela.tdata .rela.tdata.* .rela.gnu.linkonce.td.*) + *(.rela.tbss .rela.tbss.* .rela.gnu.linkonce.tb.*) + *(.rela.ctors) + *(.rela.dtors) + *(.rela.got) + *(.rela.bss .rela.bss.* .rela.gnu.linkonce.b.*) + } + .rel.plt : { *(.rel.plt) } + .rela.plt : { *(.rela.plt) } + .init : + { + KEEP (*(.init)) + } =0x90909090 + .plt : { *(.plt) } + .subprims 0x410000: + { + x86-spjump64.o(.text) + x86-spentry64.o(.text) + x86-subprims64.o(.text) + } + .text : + { + *(.text .stub .text.* .gnu.linkonce.t.*) + KEEP (*(.text.*personality*)) + /* .gnu.warning sections are handled specially by elf32.em. */ + *(.gnu.warning) + } =0x90909090 + .fini : + { + KEEP (*(.fini)) + } =0x90909090 + PROVIDE (__etext = .); + PROVIDE (_etext = .); + PROVIDE (etext = .); + .rodata : { *(.rodata .rodata.* .gnu.linkonce.r.*) } + .rodata1 : { *(.rodata1) } + .eh_frame_hdr : { *(.eh_frame_hdr) } + .eh_frame : ONLY_IF_RO { KEEP (*(.eh_frame)) } + .gcc_except_table : ONLY_IF_RO { KEEP (*(.gcc_except_table)) *(.gcc_except_table.*) } + /* Adjust the address for the data segment. We want to adjust up to + the same address within the page on the next page up. */ + . = ALIGN (0x100000) - ((0x100000 - .) & (0x100000 - 1)); . = DATA_SEGMENT_ALIGN (0x100000, 0x1000); + /* Exception handling */ + .eh_frame : ONLY_IF_RW { KEEP (*(.eh_frame)) } + .gcc_except_table : ONLY_IF_RW { KEEP (*(.gcc_except_table)) *(.gcc_except_table.*) } + /* Thread Local Storage sections */ + .tdata : { *(.tdata .tdata.* .gnu.linkonce.td.*) } + .tbss : { *(.tbss .tbss.* .gnu.linkonce.tb.*) *(.tcommon) } + /* Ensure the __preinit_array_start label is properly aligned. We + could instead move the label definition inside the section, but + the linker would then create the section even if it turns out to + be empty, which isn't pretty. */ + . = ALIGN(64 / 8); + PROVIDE (__preinit_array_start = .); + .preinit_array : { KEEP (*(.preinit_array)) } + PROVIDE (__preinit_array_end = .); + PROVIDE (__init_array_start = .); + .init_array : { KEEP (*(.init_array)) } + PROVIDE (__init_array_end = .); + PROVIDE (__fini_array_start = .); + .fini_array : { KEEP (*(.fini_array)) } + PROVIDE (__fini_array_end = .); + .ctors : + { + /* gcc uses crtbegin.o to find the start of + the constructors, so we make sure it is + first. Because this is a wildcard, it + doesn't matter if the user does not + actually link against crtbegin.o; the + linker won't look for a file to match a + wildcard. The wildcard also means that it + doesn't matter which directory crtbegin.o + is in. */ + KEEP (*crtbegin*.o(.ctors)) + /* We don't want to include the .ctor section from + from the crtend.o file until after the sorted ctors. + The .ctor section from the crtend file contains the + end of ctors marker and it must be last */ + KEEP (*(EXCLUDE_FILE (*crtend*.o ) .ctors)) + KEEP (*(SORT(.ctors.*))) + KEEP (*(.ctors)) + } + .dtors : + { + KEEP (*crtbegin*.o(.dtors)) + KEEP (*(EXCLUDE_FILE (*crtend*.o ) .dtors)) + KEEP (*(SORT(.dtors.*))) + KEEP (*(.dtors)) + } + .jcr : { KEEP (*(.jcr)) } + .data.rel.ro : { *(.data.rel.ro.local) *(.data.rel.ro*) } + .dynamic : { *(.dynamic) } + .got : { *(.got) } + . = DATA_SEGMENT_RELRO_END (24, .); + .got.plt : { *(.got.plt) } + .data : + { + *(.data .data.* .gnu.linkonce.d.*) + KEEP (*(.gnu.linkonce.d.*personality*)) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + _edata = .; + PROVIDE (edata = .); + __bss_start = .; + .bss : + { + *(.dynbss) + *(.bss .bss.* .gnu.linkonce.b.*) + *(COMMON) + /* Align here to ensure that the .bss section occupies space up to + _end. Align after .bss to ensure correct alignment even if the + .bss section disappears because there are no input sections. */ + . = ALIGN(64 / 8); + } + . = ALIGN(64 / 8); + _end = .; + PROVIDE (end = .); + . = DATA_SEGMENT_END (.); + /* Stabs debugging sections. */ + .stab 0 : { *(.stab) } + .stabstr 0 : { *(.stabstr) } + .stab.excl 0 : { *(.stab.excl) } + .stab.exclstr 0 : { *(.stab.exclstr) } + .stab.index 0 : { *(.stab.index) } + .stab.indexstr 0 : { *(.stab.indexstr) } + .comment 0 : { *(.comment) } + /* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section so we begin them at 0. */ + /* DWARF 1 */ + .debug 0 : { *(.debug) } + .line 0 : { *(.line) } + /* GNU DWARF 1 extensions */ + .debug_srcinfo 0 : { *(.debug_srcinfo) } + .debug_sfnames 0 : { *(.debug_sfnames) } + /* DWARF 1.1 and DWARF 2 */ + .debug_aranges 0 : { *(.debug_aranges) } + .debug_pubnames 0 : { *(.debug_pubnames) } + /* DWARF 2 */ + .debug_info 0 : { *(.debug_info .gnu.linkonce.wi.*) } + .debug_abbrev 0 : { *(.debug_abbrev) } + .debug_line 0 : { *(.debug_line) } + .debug_frame 0 : { *(.debug_frame) } + .debug_str 0 : { *(.debug_str) } + .debug_loc 0 : { *(.debug_loc) } + .debug_macinfo 0 : { *(.debug_macinfo) } + /* SGI/MIPS DWARF 2 extensions */ + .debug_weaknames 0 : { *(.debug_weaknames) } + .debug_funcnames 0 : { *(.debug_funcnames) } + .debug_typenames 0 : { *(.debug_typenames) } + .debug_varnames 0 : { *(.debug_varnames) } + /DISCARD/ : { *(.note.GNU-stack) } +} + Index: /branches/qres/ccl/lisp-kernel/lisp-debug.c =================================================================== --- /branches/qres/ccl/lisp-kernel/lisp-debug.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lisp-debug.c (revision 13564) @@ -0,0 +1,1256 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include +#include +#include +#include +#include + +#ifdef WINDOWS +#include +#else +#include +#include +#endif +#include + +FILE *dbgout = NULL; + +typedef enum { + debug_continue, /* stay in the repl */ + debug_exit_success, /* return 0 from lisp_Debugger */ + debug_exit_fail, /* return non-zero from lisp_Debugger */ + debug_kill +} debug_command_return; + + +Boolean +open_debug_output(int fd) +{ + FILE *f = fdopen(fd, "w"); + + if (f) { + if (setvbuf(f, NULL, _IONBF, 0) == 0) { +#ifdef WINDOWS + if (fileno(stdin) < 0) { + stdin->_file = 0; + } +#endif + dbgout = f; + return true; + } + fclose(f); + } + return false; +} + + +typedef debug_command_return (*debug_command) (ExceptionInformation *, + siginfo_t *, + int); + +#define DEBUG_COMMAND_FLAG_REQUIRE_XP 1 /* function */ +#define DEBUG_COMMAND_FLAG_AUX_REGNO (2 | DEBUG_COMMAND_FLAG_REQUIRE_XP) +#define DEBUG_COMMAND_FLAG_AUX_SPR (4 | DEBUG_COMMAND_FLAG_REQUIRE_XP) +#define DEBUG_COMMAND_REG_FLAGS 7 +#define DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY 8 +#define DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG 16 + +typedef struct { + debug_command f; + char *help_text; + unsigned flags; + char *aux_prompt; + int c; +} debug_command_entry; + + +extern +debug_command_entry debug_command_entries[]; + +Boolean lisp_debugger_in_foreign_code = false; + +#ifndef WINDOWS +Boolean +stdin_is_dev_null() +{ + struct stat fd0stat, devnullstat; + + if (fstat(fileno(stdin),&fd0stat)) { + return true; + } + if (stat("/dev/null",&devnullstat)) { + return true; + } + return ((fd0stat.st_ino == devnullstat.st_ino) && + (fd0stat.st_dev == devnullstat.st_dev)); +} +#endif + +#ifdef WINDOWS +Boolean +stdin_is_dev_null() +{ + HANDLE stdIn; + stdIn = GetStdHandle(STD_INPUT_HANDLE); + return (stdIn == NULL); +} +#endif + + + + +char * +foreign_name_and_offset(natural addr, int *delta) +{ +#ifndef WINDOWS + Dl_info info; +#endif + char *ret = NULL; + + if (delta) { + *delta = 0; + } +#ifndef WINDOWS + if (dladdr((void *)addr, &info)) { + ret = (char *)info.dli_sname; + if (delta) { + *delta = ((natural)addr - (natural)info.dli_saddr); + } + } +#endif + return ret; +} + + +#if defined(LINUX) || defined(SOLARIS) +#define fpurge __fpurge +#endif + +#ifdef WINDOWS +void +fpurge (FILE* file) +{ +} +#endif + +int +readc() +{ + unsigned tries = 1000; + int c; + + while (tries) { + c = getchar(); + switch(c) { + case '\n': + continue; + case '\r': + continue; + case EOF: + if (ferror(stdin)) { + if ((errno == EINTR) || (errno == EIO)) { + clearerr(stdin); + tries--; + continue; + } + } + /* fall through */ + default: + return c; + } + } + return EOF; +} + +#ifdef X8664 +#ifdef LINUX +char* Iregnames[] = {"r8 ","r9 ","r10","r11","r12","r13","r14","r15", + "rdi","rsi","rbp", "rbx", "rdx", "rax", "rcx","rsp"}; +#endif +#ifdef SOLARIS +char* Iregnames[] = {"r15 ","r14 ","r13","r12","r11","r10","r9 ","r8 ", + "rdi","rsi","rbp", "rbx", "rdx", "rcx", "rcx","rsp"}; +#endif +#ifdef FREEBSD +char* Iregnames[] = {"???", "rdi", "rsi", "rdx", "rcx", "r8 ", "r9 ", "rax", + "rbx", "rbp", "r10", "r11", "r12", "r13", "r14", "r15", + "???", "???", "???", "???", "???", "???", "???", "rsp"}; +#endif +#ifdef DARWIN +char* Iregnames[] = {"rax", "rbx", "rcx", "rdx", "rdi", "rsi", + "rbp", "rsp", "r8 ", "r9 ", "r10", "r11", "r12", "r13", + "r14", "r15", "rip", "rfl"}; +#endif +#ifdef WINDOWS +char* Iregnames[] = {"rax ","rcx ","rdx","rbx","rsp","rrbp","rsi","rdi", + "r8","r9","r10", "r11", "r12", "r13", "r14","r15"}; +#endif +#endif + +#ifdef X8632 +#ifdef DARWIN +char *Iregnames[] = {"eax", "ebx", "ecx", "edx", "edi", "esi", + "ebp", "???", "efl", "eip"}; +#endif +#ifdef LINUX +char *Iregnames[] = {"???", "???", "???", "???", + "edi", "esi", "ebp", "esp", + "ebx", "edx", "ecx", "eax", + "???", "???", "eip", "???", "efl"}; +#endif +#ifdef WINDOWS +char *Iregnames[] = {"edi", "esi", "ebx", "edx", "ecx", "eax", + "ebp", "eip", "???", "efl", "esp"}; +#endif +#ifdef FREEBSD +char *Iregnames[] = {"???", "???", "???", "???", "???" + "edi", "esi", "ebp", "ebx", "edx", + "ecx", "eax", "???", "???", "eip", + "???", "efl", "esp"}; +#endif +#ifdef SOLARIS +char *Iregnames[] = {"???", "???", "???", "???", "???", + "edi", "esi", "ebp", "???", "ebx", + "edx", "ecx", "eax", "???", "???", + "eip", "???", "efl", "esp"}; +#endif +#endif + +#ifdef X8632 +int bit_for_regnum(int r) +{ + switch (r) { + case REG_EAX: return 1<<0; + case REG_ECX: return 1<<1; + case REG_EDX: return 1<<2; + case REG_EBX: return 1<<3; + case REG_ESP: return 1<<4; + case REG_EBP: return 1<<5; + case REG_ESI: return 1<<6; + case REG_EDI: return 1<<7; + } +} +#endif + +void +show_lisp_register(ExceptionInformation *xp, char *label, int r) +{ + + extern char* print_lisp_object(LispObj); + + LispObj val = xpGPR(xp, r); + +#ifdef PPC + fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val)); +#endif +#ifdef X8664 + fprintf(dbgout, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val)); +#endif +#ifdef X8632 + { + TCR *tcr = get_tcr(false); + char *s; + + if (r == REG_EDX && (xpGPR(xp, REG_EFL) & EFL_DF)) + s = "marked as unboxed (DF set)"; + else if (tcr && (tcr->node_regs_mask & bit_for_regnum(r)) == 0) + s = "marked as unboxed (node_regs_mask)"; + else + s = print_lisp_object(val); + + fprintf(dbgout, "%%%s (%s) = %s\n", Iregnames[r], label, s); + } +#endif + +} + + +void +describe_memfault(ExceptionInformation *xp, siginfo_t *info) +{ +#ifdef PPC + void *addr = (void *)xpDAR(xp); + natural dsisr = xpDSISR(xp); + + fprintf(dbgout, "%s operation to %s address 0x%lx\n", + dsisr & (1<<25) ? "Write" : "Read", + dsisr & (1<<27) ? "protected" : "unmapped", + addr); +#endif +} + +#ifdef PPC +void +describe_ppc_illegal(ExceptionInformation *xp) +{ + pc where = xpPC(xp); + opcode the_uuo = *where; + Boolean described = false; + + if (IS_UUO(the_uuo)) { + unsigned + minor = UUO_MINOR(the_uuo), + errnum = 0x3ff & (the_uuo >> 16); + + switch(minor) { + case UUO_INTERR: + switch (errnum) { + case error_udf_call: + fprintf(dbgout, "ERROR: undefined function call: %s\n", + print_lisp_object(xpGPR(xp,fname))); + described = true; + break; + + default: + fprintf(dbgout, "ERROR: lisp error %d\n", errnum); + described = true; + break; + } + break; + + default: + break; + } + } + if (!described) { + fprintf(dbgout, "Illegal instruction (0x%08x) at 0x%lx\n", + the_uuo, where); + } +} +#endif + +#ifdef PPC +void +describe_ppc_trap(ExceptionInformation *xp) +{ + pc where = xpPC(xp); + opcode the_trap = *where, instr; + int err_arg2, ra, rs; + Boolean identified = false; + + if ((the_trap & OP_MASK) == OP(major_opcode_TRI)) { + /* TWI/TDI. If the RA field is "nargs", that means that the + instruction is either a number-of-args check or an + event-poll. Otherwise, the trap is some sort of + typecheck. */ + + if (RA_field(the_trap) == nargs) { + switch (TO_field(the_trap)) { + case TO_NE: + if (xpGPR(xp, nargs) < D_field(the_trap)) { + fprintf(dbgout, "Too few arguments (no opt/rest)\n"); + } else { + fprintf(dbgout, "Too many arguments (no opt/rest)\n"); + } + identified = true; + break; + + case TO_GT: + fprintf(dbgout, "Event poll !\n"); + identified = true; + break; + + case TO_HI: + fprintf(dbgout, "Too many arguments (with opt)\n"); + identified = true; + break; + + case TO_LT: + fprintf(dbgout, "Too few arguments (with opt/rest/key)\n"); + identified = true; + break; + + default: /* some weird trap, not ours. */ + identified = false; + break; + } + } else { + /* A type or boundp trap of some sort. */ + switch (TO_field(the_trap)) { + case TO_EQ: + /* Boundp traps are of the form: + treqi rX,unbound + where some preceding instruction is of the form: + lwz/ld rX,symbol.value(rY). + The error message should try to say that rY is unbound. */ + + if (D_field(the_trap) == unbound) { +#ifdef PPC64 + instr = scan_for_instr(LD_instruction(RA_field(the_trap), + unmasked_register, + offsetof(lispsymbol,vcell)-fulltag_misc), + D_RT_IMM_MASK, + where); +#else + instr = scan_for_instr(LWZ_instruction(RA_field(the_trap), + unmasked_register, + offsetof(lispsymbol,vcell)-fulltag_misc), + D_RT_IMM_MASK, + where); +#endif + if (instr) { + ra = RA_field(instr); + if (lisp_reg_p(ra)) { + fprintf(dbgout, "Unbound variable: %s\n", + print_lisp_object(xpGPR(xp,ra))); + identified = true; + } + } + } + break; + + case TO_NE: + /* A type check. If the type (the immediate field of the trap + instruction) is a header type, an "lbz + rX,misc_header_offset(rY)" should precede it, in which case + we say that "rY is not of header type ." If the type + is not a header type, then rX should have been set by a + preceding "clrlwi rX,rY,29/30". In that case, scan + backwards for an RLWINM instruction that set rX and report + that rY isn't of the indicated type. */ + err_arg2 = D_field(the_trap); + if (nodeheader_tag_p(err_arg2) || + immheader_tag_p(err_arg2)) { + instr = scan_for_instr(LBZ_instruction(RA_field(the_trap), + unmasked_register, + misc_subtag_offset), + D_RT_IMM_MASK, + where); + if (instr) { + ra = RA_field(instr); + if (lisp_reg_p(ra)) { + fprintf(dbgout, "value 0x%lX is not of the expected header type 0x%02X\n", xpGPR(xp, ra), err_arg2); + identified = true; + } + } + } else { + /* Not a header type, look for rlwinm whose RA field matches the_trap's */ + instr = scan_for_instr((OP(major_opcode_RLWINM) | (the_trap & RA_MASK)), + (OP_MASK | RA_MASK), + where); + if (instr) { + rs = RS_field(instr); + if (lisp_reg_p(rs)) { + fprintf(dbgout, "value 0x%lX is not of the expected type 0x%02X\n", + xpGPR(xp, rs), err_arg2); + identified = true; + } + } + } + break; + } + } + } else { + /* a "TW ,ra,rb" instruction." + twltu sp,rN is stack-overflow on SP. + twgeu rX,rY is subscript out-of-bounds, which was preceded + by an "lwz rM,misc_header_offset(rN)" instruction. + rM may or may not be the same as rY, but no other header + would have been loaded before the trap. */ + switch (TO_field(the_trap)) { + case TO_LO: + if (RA_field(the_trap) == sp) { + fprintf(dbgout, "Stack overflow! Run away! Run away!\n"); + identified = true; + } + break; + + case (TO_HI|TO_EQ): + instr = scan_for_instr(OP(major_opcode_LWZ) | (D_MASK & misc_header_offset), + (OP_MASK | D_MASK), + where); + if (instr) { + ra = RA_field(instr); + if (lisp_reg_p(ra)) { + fprintf(dbgout, "Bad index %d for vector %lX length %d\n", + unbox_fixnum(xpGPR(xp, RA_field(the_trap))), + xpGPR(xp, ra), + unbox_fixnum(xpGPR(xp, RB_field(the_trap)))); + identified = true; + } + } + break; + } + } + + if (!identified) { + fprintf(dbgout, "Unknown trap: 0x%08x\n", the_trap); + } + + +} +#endif + +debug_command_return +debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + if (lisp_debugger_in_foreign_code == false) { +#ifdef PPC + TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext)); + + fprintf(dbgout, "rcontext = 0x%lX ", xpcontext); + if (!active_tcr_p(xpcontext)) { + fprintf(dbgout, "(INVALID)\n"); + } else { + fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift); + show_lisp_register(xp, "fn", fn); + show_lisp_register(xp, "arg_z", arg_z); + show_lisp_register(xp, "arg_y", arg_y); + show_lisp_register(xp, "arg_x", arg_x); + show_lisp_register(xp, "temp0", temp0); + show_lisp_register(xp, "temp1/next_method_context", temp1); + show_lisp_register(xp, "temp2/nfn", temp2); + show_lisp_register(xp, "temp3/fname", temp3); + /* show_lisp_register(xp, "new_fn", new_fn); */ + show_lisp_register(xp, "save0", save0); + show_lisp_register(xp, "save1", save1); + show_lisp_register(xp, "save2", save2); + show_lisp_register(xp, "save3", save3); + show_lisp_register(xp, "save4", save4); + show_lisp_register(xp, "save5", save5); + show_lisp_register(xp, "save6", save6); + show_lisp_register(xp, "save7", save7); + } +#endif +#ifdef X8664 + + show_lisp_register(xp, "arg_z", Iarg_z); + show_lisp_register(xp, "arg_y", Iarg_y); + show_lisp_register(xp, "arg_x", Iarg_x); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "fn", Ifn); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "save0", Isave0); + show_lisp_register(xp, "save1", Isave1); + show_lisp_register(xp, "save2", Isave2); + show_lisp_register(xp, "save3", Isave3); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "temp0", Itemp0); + show_lisp_register(xp, "temp1", Itemp1); + show_lisp_register(xp, "temp2", Itemp2); + fprintf(dbgout,"------\n"); + if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) { + fprintf(dbgout,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff)); + } +#endif + +#ifdef X8632 + show_lisp_register(xp, "arg_z", Iarg_z); + show_lisp_register(xp, "arg_y", Iarg_y); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "fn", Ifn); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "temp0", Itemp0); + show_lisp_register(xp, "temp1", Itemp1); + fprintf(dbgout,"------\n"); + if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) { + fprintf(dbgout,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs))); + } +#endif + } + + return debug_continue; +} + +#ifdef PPC +debug_command_return +debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + adjust_exception_pc(xp,4); + return debug_continue; +} +#endif + +debug_command_return +debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg) +{ +#ifdef PPC + pc program_counter = xpPC(xp); + opcode instruction = 0; + + switch (arg) { + case SIGILL: + case SIGTRAP: + instruction = *program_counter; + if (major_opcode_p(instruction, major_opcode_TRI) || + X_opcode_p(instruction,major_opcode_X31,minor_opcode_TR)) { + describe_ppc_trap(xp); + } else { + describe_ppc_illegal(xp); + } + break; + case SIGSEGV: + case SIGBUS: + describe_memfault(xp, info); + break; + default: + break; + } +#endif + return debug_continue; +} + +char * +debug_get_string_value(char *prompt) +{ + static char buf[128]; + char *p, *res; + + do { + fpurge(stdin); + fprintf(dbgout, "\n %s :",prompt); + buf[0] = 0; + res = fgets(buf, sizeof(buf), stdin); + } while (0); + p = strchr(res, '\n'); + if (p) { + *p = 0; + return buf; + } + return NULL; +} + +natural +debug_get_natural_value(char *prompt) +{ + char s[32], *res; + int n; + natural val; + + do { + fpurge(stdin); + fprintf(dbgout, "\n %s :", prompt); + s[0]=0; + res = fgets(s, 24, stdin); + n = sscanf(s, "%lu", &val); + } while (n != 1); + return val; +} + +unsigned +debug_get_u5_value(char *prompt) +{ + char s[32], *res; + int n; + unsigned val; + + do { + fpurge(stdin); + fprintf(dbgout, "\n %s :", prompt); + res = fgets(s, 24, stdin); + n = sscanf(res, "%i", &val); + } while ((n != 1) || (val > 31)); + return val; +} + +debug_command_return +debug_show_symbol(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + char *pname = debug_get_string_value("symbol name"); + extern void *plsym(ExceptionInformation *,char*); + + if (pname != NULL) { + plsym(xp, pname); + } + return debug_continue; +} + +debug_command_return +debug_thread_info(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + TCR * tcr = get_tcr(false); + + if (tcr) { + area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area; + + fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr); + fprintf(dbgout, "Control (C) stack area: low = 0x" LISP ", high = 0x" LISP "\n", + (cs_area->low), (cs_area->high)); + fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n", + (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high); + fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n", +#ifdef PPC + (u64_t) (natural)(xpGPR(xp,1)) +#endif +#ifdef X86 + (u64_t) (natural)(xpGPR(xp,Isp)) +#endif + ); + } + return debug_continue; +} + + +debug_command_return +debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + char buf[32]; + natural val; + + sprintf(buf, "value for GPR %d", arg); + val = debug_get_natural_value(buf); + xpGPR(xp,arg) = val; + return debug_continue; +} + +debug_command_return +debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + + +#ifdef PPC +#ifdef PPC64 + int a, b; + for (a = 0, b = 16; a < 16; a++, b++) { + fprintf(dbgout,"r%02d = 0x%016lX r%02d = 0x%016lX\n", + a, xpGPR(xp, a), + b, xpGPR(xp, b)); + } + + fprintf(dbgout, "\n PC = 0x%016lX LR = 0x%016lX\n", + xpPC(xp), xpLR(xp)); + fprintf(dbgout, "CTR = 0x%016lX CCR = 0x%08X\n", + xpCTR(xp), xpCCR(xp)); + fprintf(dbgout, "XER = 0x%08X MSR = 0x%016lX\n", + xpXER(xp), xpMSR(xp)); + fprintf(dbgout,"DAR = 0x%016lX DSISR = 0x%08X\n", + xpDAR(xp), xpDSISR(xp)); +#else + int a, b, c, d;; + for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) { + fprintf(dbgout,"r%02d = 0x%08X r%02d = 0x%08X r%02d = 0x%08X r%02d = 0x%08X\n", + a, xpGPR(xp, a), + b, xpGPR(xp, b), + c, xpGPR(xp, c), + d, xpGPR(xp, d)); + } + fprintf(dbgout, "\n PC = 0x%08X LR = 0x%08X CTR = 0x%08X CCR = 0x%08X\n", + xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp)); + fprintf(dbgout, "XER = 0x%08X MSR = 0x%08X DAR = 0x%08X DSISR = 0x%08X\n", + xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp)); +#endif +#endif + +#ifdef X8664 + fprintf(dbgout,"%%rax = 0x" ZLISP " %%r8 = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8)); + fprintf(dbgout,"%%rcx = 0x" ZLISP " %%r9 = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9)); + fprintf(dbgout,"%%rdx = 0x" ZLISP " %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10)); + fprintf(dbgout,"%%rbx = 0x" ZLISP " %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11)); + fprintf(dbgout,"%%rsp = 0x" ZLISP " %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12)); + fprintf(dbgout,"%%rbp = 0x" ZLISP " %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13)); + fprintf(dbgout,"%%rsi = 0x" ZLISP " %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14)); + fprintf(dbgout,"%%rdi = 0x" ZLISP " %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15)); + fprintf(dbgout,"%%rip = 0x" ZLISP " %%rflags = 0x%08lx\n", + xpGPR(xp, Iip), eflags_register(xp)); +#endif + +#ifdef X8632 + unsigned short rcs,rds,res,rfs,rgs,rss; +#ifdef DARWIN + rcs = xp->uc_mcontext->__ss.__cs; + rds = xp->uc_mcontext->__ss.__ds; + res = xp->uc_mcontext->__ss.__es; + rfs = xp->uc_mcontext->__ss.__fs; + rgs = xp->uc_mcontext->__ss.__gs; + rss = xp->uc_mcontext->__ss.__ss; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef LINUX + rcs = xp->uc_mcontext.gregs[REG_CS]; + rds = xp->uc_mcontext.gregs[REG_DS]; + res = xp->uc_mcontext.gregs[REG_ES]; + rfs = xp->uc_mcontext.gregs[REG_FS]; + rgs = xp->uc_mcontext.gregs[REG_GS]; + rss = xp->uc_mcontext.gregs[REG_SS]; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef FREEBSD + rcs = xp->uc_mcontext.mc_cs; + rds = xp->uc_mcontext.mc_ds; + res = xp->uc_mcontext.mc_es; + rfs = xp->uc_mcontext.mc_fs; + rgs = xp->uc_mcontext.mc_gs; + rss = xp->uc_mcontext.mc_ss; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef SOLARIS + rcs = xp->uc_mcontext.gregs[CS]; + rds = xp->uc_mcontext.gregs[DS]; + res = xp->uc_mcontext.gregs[ES]; + rfs = xp->uc_mcontext.gregs[FS]; + rgs = xp->uc_mcontext.gregs[GS]; + rss = xp->uc_mcontext.gregs[SS]; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef WINDOWS + rcs = xp->SegCs; + rds = xp->SegDs; + res = xp->SegEs; + rfs = xp->SegFs; + rgs = xp->SegGs; + rss = xp->SegSs; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif + + + + fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX)); + fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX)); + fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX)); + fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX)); + fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP)); + fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP)); + fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI)); + fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI)); + fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP)); + fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL)); +#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS + fprintf(dbgout,"\n"); + fprintf(dbgout, "%%cs = 0x%04x\n", rcs); + fprintf(dbgout, "%%ds = 0x%04x\n", rds); + fprintf(dbgout, "%%ss = 0x%04x\n", rss); + fprintf(dbgout, "%%es = 0x%04x\n", res); + fprintf(dbgout, "%%fs = 0x%04x\n", rfs); + fprintf(dbgout, "%%gs = 0x%04x\n", rgs); + +#endif + +#endif + + return debug_continue; +} + +debug_command_return +debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + double *dp; + int *np, i; +#ifdef PPC + dp = xpFPRvector(xp); + np = (int *) dp; + + for (i = 0; i < 32; i++, np+=2) { + fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i, np[0], np[1], *dp++); + } + fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp)); +#endif +#ifdef X8664 +#ifdef LINUX + struct _libc_xmmreg * xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]); +#endif +#ifdef DARWIN + struct xmm { + char fpdata[16]; + }; + struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp)); +#endif +#ifdef WINDOWS + struct xmm { + char fpdata[16]; + }; + struct xmm *xmmp; /* XXX: actually get them */ +#endif +#ifdef FREEBSD + struct xmmacc *xmmp = xpXMMregs(xp); +#endif +#ifdef SOLARIS + upad128_t *xmmp = xpXMMregs(xp); +#endif + float *sp; + + + for (i = 0; i < 16; i++, xmmp++) { + sp = (float *) xmmp; + dp = (double *) xmmp; + np = (int *) xmmp; + fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp); + } + fprintf(dbgout, "mxcsr = 0x%08x\n", +#ifdef LINUX + xp->uc_mcontext.fpregs->mxcsr +#endif +#ifdef DARWIN + UC_MCONTEXT(xp)->__fs.__fpu_mxcsr +#endif +#ifdef FREEBSD + (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr) +#endif +#ifdef SOLARIS + xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus +#endif +#ifdef WINDOWS + *(xpMXCSRptr(xp)) +#endif + ); +#endif +#ifdef X8632 +#ifdef DARWIN + struct xmm { + char fpdata[8]; + }; + struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp)); + + for (i = 0; i < 8; i++, xmmp++) { + float *sp = (float *)xmmp; + dp = (double *)xmmp; + np = (int *)xmmp; + fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, + (double)(*sp), np[1], np[0], *dp); + } + fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr); +#endif +#endif + + return debug_continue; +} + +debug_command_return +debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) { + return debug_kill; +} + +debug_command_return +debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) { + return debug_exit_success; +} + +debug_command_return +debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) { + return debug_exit_fail; +} + +debug_command_return +debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) { + debug_command_entry *entry; + + for (entry = debug_command_entries; entry->f; entry++) { + /* If we have an XP or don't need one, call the function */ + if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) { + fprintf(dbgout, "(%c) %s\n", entry->c, entry->help_text); + } + } + return debug_continue; +} + + + + +debug_command_return +debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + extern LispObj current_stack_pointer(); + extern void plbt_sp(LispObj); + extern void plbt(ExceptionInformation *); + + if (xp) { + plbt(xp); + } else { + plbt_sp(current_stack_pointer()); + } + return debug_continue; +} + +debug_command_return +debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + reset_lisp_process(xp); + return debug_exit_success; +} + + +debug_command_entry debug_command_entries[] = +{ + {debug_set_gpr, + "Set specified GPR to new value", + DEBUG_COMMAND_FLAG_AUX_REGNO, + "GPR to set (0-31) ?", + 'G'}, +#ifdef PPC + {debug_advance_pc, + "Advance the program counter by one instruction (use with caution!)", + DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY, + NULL, + 'A'}, + {debug_identify_exception, + "Describe the current exception in greater detail", + DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY | + DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG, + NULL, + 'D'}, +#endif + {debug_show_registers, + "Show raw GPR/SPR register values", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'R'}, + {debug_lisp_registers, + "Show Lisp values of tagged registers", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'L'}, + {debug_show_fpu, + "Show FPU registers", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'F'}, + {debug_show_symbol, + "Find and describe symbol matching specified name", + 0, + NULL, + 'S'}, + {debug_backtrace, + "Show backtrace", + 0, + NULL, + 'B'}, + {debug_thread_info, + "Show info about current thread", + 0, + NULL, + 'T'}, + {debug_win, + "Exit from this debugger, asserting that any exception was handled", + 0, + NULL, + 'X'}, +#ifdef DARWIN + {debug_lose, + "Propagate the exception to another handler (debugger or OS)", + DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY, + NULL, + 'P'}, +#endif +#if 0 + {debug_thread_reset, + "Reset current thread (as if in response to stack overflow)", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'T'}, +#endif + {debug_kill_process, + "Kill Clozure CL process", + 0, + NULL, + 'K'}, + {debug_help, + "Show this help", + 0, + NULL, + '?'}, + /* end-of-table */ + {NULL, + NULL, + 0, + NULL, + 0} +}; + +debug_command_return +apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) +{ + if (c == EOF) { + return debug_kill; + } else { + debug_command_entry *entry; + debug_command f; + c = toupper(c); + + for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) { + if (toupper(entry->c) == c) { + /* If we have an XP or don't need one, call the function */ + if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) && + ((why > debug_entry_exception) || + !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) { + int arg = 0; + if ((entry->flags & DEBUG_COMMAND_REG_FLAGS) + == DEBUG_COMMAND_FLAG_AUX_REGNO) { + arg = debug_get_u5_value("register number"); + } + if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) { + arg = why; + } + return (f)(xp, info, arg); + } + break; + } + } + return debug_continue; + } +} + +debug_identify_function(ExceptionInformation *xp, siginfo_t *info) +{ +#ifdef PPC + if (xp) { + if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) { + LispObj f = xpGPR(xp, fn), codev; + pc where = xpPC(xp); + + if (!(codev = register_codevector_contains_pc(f, where))) { + f = xpGPR(xp, nfn); + codev = register_codevector_contains_pc(f, where); + } + if (codev) { + fprintf(dbgout, " While executing: %s\n", print_lisp_object(f)); + } + } else { + int disp; + char *foreign_name; + natural where = (natural)xpPC(xp); + + fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where); + foreign_name = foreign_name_and_offset(where, &disp); + if (foreign_name) { + fprintf(dbgout, " [%s + %d]\n", foreign_name, disp); + } + } + } +#endif +} + +#ifndef WINDOWS +extern pid_t main_thread_pid; +#endif + + +OSStatus +lisp_Debugger(ExceptionInformation *xp, + siginfo_t *info, + int why, + Boolean in_foreign_code, + char *message, + ...) +{ + va_list args; + debug_command_return state = debug_continue; + + + if (stdin_is_dev_null()) { + return -1; + } + + va_start(args,message); + vfprintf(dbgout, message, args); + fprintf(dbgout, "\n"); + va_end(args); + + if (threads_initialized) { + suspend_other_threads(false); + } + + lisp_debugger_in_foreign_code = in_foreign_code; + if (in_foreign_code) { + char *foreign_name; + int disp; + fprintf(dbgout, "Exception occurred while executing foreign code\n"); + foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp); + if (foreign_name) { + fprintf(dbgout, " at %s + %d\n", foreign_name, disp); + } + } + + if (xp) { + if (why > debug_entry_exception) { + debug_identify_exception(xp, info, why); + } + debug_identify_function(xp, info); + } + if (lisp_global(BATCH_FLAG)) { +#ifdef WINDOWS + fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId()); +#else + fprintf(dbgout, "Main thread pid %d\n", main_thread_pid); +#endif + debug_thread_info(xp, info, 0); + if (xp) { + debug_show_registers(xp, info, 0); + debug_lisp_registers(xp, info, 0); + debug_show_fpu(xp, info, 0); + } + debug_backtrace(xp, info, 0); + abort(); + } + + fprintf(dbgout, "? for help\n"); + while (state == debug_continue) { +#ifdef WINDOWS + fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId()); +#else + fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid); +#endif + fflush(dbgout); /* dbgout should be unbuffered, so this shouldn't be necessary. But it can't hurt ... */ + state = apply_debug_command(xp, readc(), info, why); + } + switch (state) { + case debug_exit_success: + if (threads_initialized) { + resume_other_threads(false); + } + return 0; + case debug_exit_fail: + if (threads_initialized) { + resume_other_threads(false); + } + return -1; + case debug_kill: + terminate_lisp(); + default: + return 0; + } +} + +void +Bug(ExceptionInformation *xp, const char *format, ...) +{ + va_list args; + char s[512]; + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + lisp_Debugger(xp, NULL, debug_entry_bug, false, s); + +} + +void +FBug(ExceptionInformation *xp, const char *format, ...) +{ + va_list args; + char s[512]; + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + lisp_Debugger(xp, NULL, debug_entry_bug, true, s); + +} + +void +lisp_bug(char *string) +{ + Bug(NULL, "Bug in Clozure CL system code:\n%s", string); +} + Index: /branches/qres/ccl/lisp-kernel/lisp-errors.h =================================================================== --- /branches/qres/ccl/lisp-kernel/lisp-errors.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lisp-errors.h (revision 13564) @@ -0,0 +1,163 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __ERRORS_X +#define __ERRORS_X 1 + + +#define error_reg_regnum 0 +#define error_udf 1 +#define error_udf_call 2 +#define error_throw_tag_missing 3 +#define error_alloc_failed 4 +#define error_stack_overflow 5 +#define error_excised_function_call 6 +#define error_too_many_values 7 +#define error_propagate_suspend 10 +#define error_interrupt 11 +#define error_suspend 12 +#define error_suspend_all 13 +#define error_resume 14 +#define error_resume_all 15 +#define error_kill 16 +#define error_cant_call 17 +#define error_allocate_list 18 + +#define error_type_error 128 + +typedef enum { + error_object_not_array = error_type_error, + error_object_not_bignum, + error_object_not_fixnum, + error_object_not_character, + error_object_not_integer, + error_object_not_list, + error_object_not_number, + error_object_not_sequence, + error_object_not_simple_string, + error_object_not_simple_vector, + error_object_not_string, + error_object_not_symbol, + error_object_not_macptr, + error_object_not_real, + error_object_not_cons, + error_object_not_unsigned_byte, + error_object_not_radix, + error_object_not_float, + error_object_not_rational, + error_object_not_ratio, + error_object_not_short_float, + error_object_not_double_float, + error_object_not_complex, + error_object_not_vector, + error_object_not_simple_base_string, + error_object_not_function, + error_object_not_unsigned_byte_16, + error_object_not_unsigned_byte_8, + error_object_not_unsigned_byte_32, + error_object_not_signed_byte_32, + error_object_not_signed_byte_16, + error_object_not_signed_byte_8, + error_object_not_base_character, + error_object_not_bit, + error_object_not_unsigned_byte_24, + error_object_not_u64, + error_object_not_s64, + error_object_not_unsigned_byte_56, + error_object_not_simple_array_double_float_2d, + error_object_not_simple_array_single_float_2d, + error_object_not_mod_char_code_limit, + error_object_not_array_2d, + error_object_not_array_3d, + error_object_not_array_t, + error_object_not_array_bit, + error_object_not_array_s8, + error_object_not_array_u8, + error_object_not_array_s16, + error_object_not_array_u16, + error_object_not_array_s32, + error_object_not_array_u32, + error_object_not_array_s64, + error_object_not_array_u64, + error_object_not_array_fixnum, + error_object_not_array_single_float, + error_object_not_array_double_float, + error_object_not_array_char, + error_object_not_array_t_2d, + error_object_not_array_bit_2d, + error_object_not_array_s8_2d, + error_object_not_array_u8_2d, + error_object_not_array_s16_2d, + error_object_not_array_u16_2d, + error_object_not_array_s32_2d, + error_object_not_array_u32_2d, + error_object_not_array_s64_2d, + error_object_not_array_u64_2d, + error_object_not_array_fixnum_2d, + error_object_not_array_single_float_2d, + error_object_not_array_double_float_2d, + error_object_not_array_char_2d, + error_object_not_simple_array_t_2d, + error_object_not_simple_array_bit_2d, + error_object_not_simple_array_s8_2d, + error_object_not_simple_array_u8_2d, + error_object_not_simple_array_s16_2d, + error_object_not_simple_array_u16_2d, + error_object_not_simple_array_s32_2d, + error_object_not_simple_array_u32_2d, + error_object_not_simple_array_s64_2d, + error_object_not_simple_array_u64_2d, + error_object_not_simple_array_fixnum_2d, + error_object_not_simple_array_char_2d, + error_object_not_array_t_3d, + error_object_not_array_bit_3d, + error_object_not_array_s8_3d, + error_object_not_array_u8_3d, + error_object_not_array_s16_3d, + error_object_not_array_u16_3d, + error_object_not_array_s32_3d, + error_object_not_array_u32_3d, + error_object_not_array_s64_3d, + error_object_not_array_u64_3d, + error_object_not_array_fixnum_3d, + error_object_not_array_single_float_3d, + error_object_not_array_double_float_3d, + error_object_not_array_char_3d, + error_object_not_simple_array_t_3d, + error_object_not_simple_array_bit_3d, + error_object_not_simple_array_s8_3d, + error_object_not_simple_array_u8_3d, + error_object_not_simple_array_s16_3d, + error_object_not_simple_array_u16_3d, + error_object_not_simple_array_s32_3d, + error_object_not_simple_array_u32_3d, + error_object_not_simple_array_s64_3d, + error_object_not_simple_array_u64_3d, + error_object_not_simple_array_fixnum_3d, + error_object_not_simple_array_single_float_3d, + error_object_not_simple_array_double_float_3d, + error_object_not_simple_array_char_3d +} type_error; + +#define error_FPU_exception_double 1024 +#define error_FPU_exception_short 1025 + +#define error_memory_full 2048 + + + +#endif /* __ERRORS_X */ Index: /branches/qres/ccl/lisp-kernel/lisp-exceptions.h =================================================================== --- /branches/qres/ccl/lisp-kernel/lisp-exceptions.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lisp-exceptions.h (revision 13564) @@ -0,0 +1,158 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisp_exceptions_h__ +#define __lisp_exceptions_h__ 1 + + +#include +#include "memprotect.h" +#include "gc.h" + +#ifdef WINDOWS +#include +#endif + +typedef enum { + kDebugger, + kContinue, + kExit +} ErrAction; + + +#ifdef WINDOWS +typedef EXCEPTION_RECORD siginfo_t; /* Not even close to being the right thing to do */ +#endif + + +void +zero_page(BytePtr); + +void +zero_heap_segment(BytePtr); + +extern protected_area_ptr AllProtectedAreas; + +protected_area_ptr find_protected_area(BytePtr); + +OSStatus +lisp_Debugger(ExceptionInformation *, siginfo_t *, int, Boolean, char *, ...); + +OSStatus +handle_protection_violation(ExceptionInformation *, siginfo_t *, TCR *, int); + +protected_area_ptr +new_protected_area(BytePtr, BytePtr, lisp_protection_kind, natural, Boolean); + +void +unprotect_area_prefix(protected_area_ptr, size_t); + +void +protect_area_prefix(protected_area_ptr, size_t); + +void +protect_area(protected_area_ptr); + + +Boolean +resize_dynamic_heap(BytePtr, natural); + +OSStatus +PMCL_exception_handler(int, ExceptionInformation *, TCR *, siginfo_t *, int); + +TCR* +get_tcr(Boolean); + +ErrAction +error_action( void ); + +void +install_pmcl_exception_handlers(void); + +void +unprotect_all_areas(void); + +void +exception_cleanup(void); + +void +exception_init(); + + +#define debug_entry_exception 0 +#define debug_entry_bug -1 +#define debug_entry_dbg -2 + +#ifdef WINDOWS +#define ALLOW_EXCEPTIONS(context) // blank stare for now +#else +#define ALLOW_EXCEPTIONS(context) \ + pthread_sigmask(SIG_SETMASK, &context->uc_sigmask, NULL); +#endif + +void +Fatal(StringPtr, StringPtr); + + +Ptr +allocate(natural); + +Ptr +zalloc(natural); + +void +deallocate(Ptr); + + + +void +non_fatal_error( char * ); + +void Bug(ExceptionInformation *, const char *format_string, ...); +void FBug(ExceptionInformation *, const char *format_string, ...); +signed_natural gc_from_xp(ExceptionInformation *, signed_natural); +signed_natural purify_from_xp(ExceptionInformation *, signed_natural); +signed_natural impurify_from_xp(ExceptionInformation *, signed_natural); + + + +void +adjust_exception_pc(ExceptionInformation *, int); + +size_t +symbol_name( unsigned, char *, size_t ); + + +size_t +exception_fn_name( ExceptionInformation *, int, char *, size_t ); + + + +#ifdef PPC +#include "ppc-exceptions.h" +#endif + +#ifdef X86 +#include "x86-exceptions.h" +#endif + +void suspend_other_threads(Boolean); +void resume_other_threads(Boolean); + + +#endif /* __lisp_exceptions_h__ */ + Index: /branches/qres/ccl/lisp-kernel/lisp.h =================================================================== --- /branches/qres/ccl/lisp-kernel/lisp.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lisp.h (revision 13564) @@ -0,0 +1,133 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisp__ +#define __lisp__ + + + +#include "lisptypes.h" +#ifndef LOWMEM_BIAS +#define LOWMEM_BIAS 0 +#endif + +#ifdef PPC +#include "ppc-constants.h" +#endif +#ifdef X86 +#include "x86-constants.h" +#endif +#include "macros.h" + +extern Boolean use_mach_exception_handling; + +extern int page_size, log2_page_size; + +static inline natural +_align_to_power_of_2(natural n, unsigned power) +{ + natural align = (1< + +extern FILE *dbgout; Index: /branches/qres/ccl/lisp-kernel/lisp.s =================================================================== --- /branches/qres/ccl/lisp-kernel/lisp.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lisp.s (revision 13564) @@ -0,0 +1,68 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + include(m4macros.m4) + ifdef(`LOWMEM_BIAS',` +`LOWMEM_BIAS' = LOWMEM_BIAS +',` +`LOWMEM_BIAS' = 0 +') + undefine(`LOWMEM_BIAS') + /* DWARF2 exception fsm */ + DW_CFA_advance_loc = 0x40 + DW_CFA_offset = 0x80 + DW_CFA_restore = 0xc0 + DW_CFA_nop = 0x00 + DW_CFA_set_loc = 0x01 + DW_CFA_advance_loc1 = 0x02 + DW_CFA_advance_loc2 = 0x03 + DW_CFA_advance_loc4 = 0x04 + DW_CFA_offset_extended = 0x05 + DW_CFA_restore_extended = 0x06 + DW_CFA_undefined = 0x07 + DW_CFA_same_value = 0x08 + DW_CFA_register = 0x09 + DW_CFA_remember_state = 0x0a + DW_CFA_restore_state = 0x0b + DW_CFA_def_cfa = 0x0c + DW_CFA_def_cfa_register = 0x0d + DW_CFA_def_cfa_offset = 0x0e + /* DWARF 3. */ + DW_CFA_def_cfa_expression = 0x0f + DW_CFA_expression = 0x10 + DW_CFA_offset_extended_sf = 0x11 + DW_CFA_def_cfa_sf = 0x12 + DW_CFA_def_cfa_offset_sf = 0x13 + DW_CFA_val_offset = 0x14 + DW_CFA_val_offset_sf = 0x15 + DW_CFA_val_expression = 0x16 + /* SGI/MIPS specific. */ + DW_CFA_MIPS_advance_loc8 = 0x1d + /* GNU extensions. */ + DW_CFA_GNU_window_save = 0x2d + DW_CFA_GNU_args_size = 0x2e + DW_CFA_GNU_negative_offset_extended = 0x2f + + ifdef(`PPC',` + include(ppc-constants.s) + include(ppc-macros.s) + include(ppc-uuo.s) + ') + ifdef(`X86',` + include(x86-constants.s) + include(x86-macros.s) + include(x86-uuo.s) + ') + Index: /branches/qres/ccl/lisp-kernel/lisp_globals.h =================================================================== --- /branches/qres/ccl/lisp-kernel/lisp_globals.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lisp_globals.h (revision 13564) @@ -0,0 +1,147 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisp_globals__ +#define __lisp_globals__ + + +extern LispObj lisp_nil; + +#define GET_TCR (-1) /* address of get_tcr() for callbacks */ +#define TCR_COUNT (-2) /* next tcr's tcr_id */ +#define INTERRUPT_SIGNAL (-3) /* signal to use for PROCESS-INTERRUPT */ +#define KERNEL_IMPORTS (-4) /* some things we need to have imported for us. */ +#define OBJC_2_PERSONALITY (-5) /* A good listener. Doesn't say much */ +#define SAVETOC (-6) /* Saved TOC register, for some platforms */ +#define SAVER13 (-7) /* Saved (global) r13, on some platforms */ +#define SUBPRIMS_BASE (-8) /* where the dynamic subprims wound up */ +#define RET1VALN (-9) /* magic multiple-values return address */ +#define TCR_KEY (-10) /* tsd key for per-thread tcr */ +#define TCR_AREA_LOCK (-11) /* all_areas/tcr queue lock */ +#define EXCEPTION_LOCK (-12) /* serialize exception handling */ +#define STATIC_CONSES (-13) +#define DEFAULT_ALLOCATION_QUANTUM (-14) +#define INTFLAG (-15) +#define GC_INHIBIT_COUNT (-16) +#define REFBITS (-17) +#define OLDSPACE_DNODE_COUNT (-18) /* count of dynamic dnodes older than generation 0 */ +#define ALTIVEC_PRESENT (-19) /* non-zero if AltiVec present. */ +#define FWDNUM (-20) /* fixnum: GC "forwarder" call count. */ +#define GC_NUM (-21) /* fixnum: GC call count. */ +#define GCABLE_POINTERS (-22) /* linked-list of weak macptrs. */ +#define HEAP_START (-23) /* start of lisp heap */ +#define HEAP_END (-24) /* end of lisp heap */ +#define STATICALLY_LINKED (-25) /* non-zero if -static */ +#define STACK_SIZE (-26) /* from the command line */ +#define OBJC_2_BEGIN_CATCH (-27) /* address of ObjC 2.0 objc_begin_catch() */ +#define KERNEL_PATH (-28) /* real executable name */ +#define ALL_AREAS (-29) /* doubly-linked list of stack & heap areas */ +#define LEXPR_RETURN (-30) /* magic &lexpr cleanup code */ +#define LEXPR_RETURN1V (-31) /* single-value &lexpr cleanup code */ +#define IN_GC (-32) /* non-zero when lisp addresses may be invalid */ +#define METERING_INFO (-33) /* address of lisp_metering global */ +#define OBJC_2_END_CACTCH (-34) /* address of ObjC 2.0 objc_end_catch() */ +#define SHORT_FLOAT_ZERO (-35) /* low half of 1.0d0 */ +#define DOUBLE_FLOAT_ONE (-36) /* high half of 1.0d0 */ +#define LISP_RETURN_HOOK (-37) /* install lisp exception handling */ +#define LISP_EXIT_HOOK (-38) /* install foreign exception handling */ +#define OLDEST_EPHEMERAL (-39) /* doubleword address of oldest ephemeral object or 0 */ +#define TENURED_AREA (-40) /* the tenured area */ +#define ERRNO (-41) /* address of errno */ +#define ARGV (-42) /* pointer to &argv[0] */ +#define HOST_PLATFORM (-43) /* for platform-specific initialization */ +#define BATCH_FLAG (-44) /* -b arg */ +#define UNWIND_RESUME (-45) /* address of _Unwind_Resume from libobjc */ +#define WEAK_GC_METHOD (-46) /* weak GC algorithm */ +#define IMAGE_NAME (-47) /* --image-name arg */ +#define INITIAL_TCR (-48) /* initial thread tcr */ +#define WEAKVLL (-49) /* all populations as of last GC */ + +#define MIN_KERNEL_GLOBAL WEAKVLL + +/* These are only non-zero when an image is being saved or loaded */ + +#if (WORD_SIZE==64) +#define LISP_HEAP_THRESHOLD (-511) +#define EGC_ENABLED (-510) +#define G0_THRESHOLD (-509) +#define G1_THRESHOLD (-508) +#define G2_THRESHOLD (-507) +#else +#define LISP_HEAP_THRESHOLD (-1023) +#define EGC_ENABLED (-1022) +#define G0_THRESHOLD (-1021) +#define G1_THRESHOLD (-1020) +#define G2_THRESHOLD (-1019) +#endif + +#ifdef PPC +#ifdef PPC64 +#define lisp_global(g) (((LispObj *) (0x3000+(LOWMEM_BIAS)))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (0x3000+(LOWMEM_BIAS)))[(s)]) +#else +#define lisp_global(g) (((LispObj *) (nil_value-fulltag_nil))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (nil_value+(8-fulltag_nil)+8))[(s)]) +#endif +#endif + +#ifdef X8664 +#define lisp_global(g) (((LispObj *) (0x13000+(LOWMEM_BIAS)))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (0x13020+(LOWMEM_BIAS)))[(s)]) +#endif + +#ifdef X8632 +#define lisp_global(g) (((LispObj *) (0x13000+(LOWMEM_BIAS)))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (0x13008+(LOWMEM_BIAS)))[(s)]) +#endif + +#define nrs_T (nrs_symbol(0)) /* t */ +#define nrs_NILSYM (nrs_symbol(1)) /* nil */ +#define nrs_ERRDISP (nrs_symbol(2)) /* %err-disp */ +#define nrs_CMAIN (nrs_symbol(3)) /* cmain */ +#define nrs_EVAL (nrs_symbol(4)) /* eval */ +#define nrs_APPEVALFN (nrs_symbol(5)) /* apply-evaluated-function */ +#define nrs_ERROR (nrs_symbol(6)) /* error */ +#define nrs_DEFUN (nrs_symbol(7)) /* %defun */ +#define nrs_DEFVAR (nrs_symbol(8)) /* %defvar */ +#define nrs_DEFCONSTANT (nrs_symbol(9)) /* %defconstant */ +#define nrs_MACRO (nrs_symbol(10)) /* %macro */ +#define nrs_KERNELRESTART (nrs_symbol(11)) /* %kernel-restart */ +#define nrs_PACKAGE (nrs_symbol(12)) /* *package* */ +#define nrs_TOTAL_BYTES_FREED (nrs_symbol(13)) /* *total-bytes-freed* */ +#define nrs_KALLOWOTHERKEYS (nrs_symbol(14)) /* :allow-other-keys */ +#define nrs_TOPLCATCH (nrs_symbol(15)) /* %toplevel-catch% */ +#define nrs_TOPLFUNC (nrs_symbol(16)) /* %toplevel-function% */ +#define nrs_CALLBACKS (nrs_symbol(17)) /* %pascal-functions% */ +#define nrs_ALLMETEREDFUNS (nrs_symbol(18)) /* *all-metered-functions* */ +#define nrs_TOTAL_GC_MICROSECONDS (nrs_symbol(19)) /* *total-gc-microseconds* */ +#define nrs_BUILTIN_FUNCTIONS (nrs_symbol(20)) /* %builtin-functions% */ +#define nrs_UDF (nrs_symbol(21)) /* %unbound-function% */ +#define nrs_INIT_MISC (nrs_symbol(22)) /* %init-misc% */ +#define nrs_MACRO_CODE (nrs_symbol(23)) /* %macro-code% */ +#define nrs_CLOSURE_CODE (nrs_symbol(24)) /* %closure-code% */ +#define nrs_NEW_GCABLE_PTR (nrs_symbol(25)) /* %new-gcable-ptr */ +#define nrs_GC_EVENT_STATUS_BITS (nrs_symbol(26)) /* *gc-event-status-bits* */ +#define nrs_POST_GC_HOOK (nrs_symbol(27)) /* *post-gc-hook* */ +#define nrs_HANDLERS (nrs_symbol(28)) /* %handlers% */ +#define nrs_ALL_PACKAGES (nrs_symbol(29)) /* %all-packages% */ +#define nrs_KEYWORD_PACKAGE (nrs_symbol(30)) /* *keyword-package* */ +#define nrs_FINALIZATION_ALIST (nrs_symbol(31)) /* %finalization-alist% */ +#define nrs_FOREIGN_THREAD_CONTROL (nrs_symbol(32)) /* %foreign-thread-control */ +#define num_nilreg_symbols 33 +#define nilreg_symbols_end ((BytePtr) &(nrs_symbol(num_nilreg_symbols))) +#endif Index: /branches/qres/ccl/lisp-kernel/lispdcmd.c =================================================================== --- /branches/qres/ccl/lisp-kernel/lispdcmd.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lispdcmd.c (revision 13564) @@ -0,0 +1,47 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +/* + MCL-PPC dcmd utilities. +*/ + +#include "lispdcmd.h" + + + + +void +display_buffer(char *buf) +{ + fprintf(dbgout, "%s\n", buf); +} + +int +Dprintf(const char *format, ...) +{ + char buf[512]; + va_list args; + int res; + + va_start(args, format); + res = vsnprintf(buf, sizeof(buf), format, args); + if (res >= 0) { + display_buffer(buf); + } + return res; +} + Index: /branches/qres/ccl/lisp-kernel/lispdcmd.h =================================================================== --- /branches/qres/ccl/lisp-kernel/lispdcmd.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lispdcmd.h (revision 13564) @@ -0,0 +1,31 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include +#include + +#include "lisp.h" +#include "area.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" + +/* More-or-less like c printf(); */ +int Dprintf(const char *format, ...); + + +char * +print_lisp_object(LispObj); Index: /branches/qres/ccl/lisp-kernel/lisptypes.h =================================================================== --- /branches/qres/ccl/lisp-kernel/lisptypes.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/lisptypes.h (revision 13564) @@ -0,0 +1,238 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisptypes__ +#define __lisptypes__ + +#include +#define WORD_SIZE 32 +#ifdef PPC64 +#undef WORD_SIZE +#define WORD_SIZE 64 +#endif +#ifdef X8664 +#undef WORD_SIZE +#define WORD_SIZE 64 +#endif + + +#ifdef WINDOWS +#include +typedef long long s64_t; +typedef unsigned long long u64_t; +typedef signed long s32_t; +typedef unsigned long u32_t; +typedef signed short s16_t; +typedef unsigned short u16_t; +typedef signed char s8_t; +typedef unsigned char u8_t; +#else + +#include + +#ifdef SOLARIS +/* Solaris doesn't laugh and play like the other children */ +typedef int64_t s64_t; +typedef uint64_t u64_t; +typedef int32_t s32_t; +typedef uint32_t u32_t; +typedef int16_t s16_t; +typedef uint16_t u16_t; +typedef int8_t s8_t; +typedef uint8_t u8_t; +#else +typedef int64_t s64_t; +typedef u_int64_t u64_t; +typedef int32_t s32_t; +typedef u_int32_t u32_t; +typedef int16_t s16_t; +typedef u_int16_t u16_t; +typedef int8_t s8_t; +typedef u_int8_t u8_t; +#endif +#endif + +#if WORD_SIZE == 64 +typedef u64_t LispObj; +typedef u64_t natural; +typedef s64_t signed_natural; +typedef u64_t unsigned_of_pointer_size; +#else +typedef u32_t LispObj; +typedef u32_t natural; +typedef s32_t signed_natural; +typedef u32_t unsigned_of_pointer_size; +#endif + + +#ifdef DARWIN +#include +#include +#include + +#ifdef PPC +#if MAC_OS_X_VERSION_MIN_REQUIRED <= MAC_OS_X_VERSION_10_4 +#define __ss ss +#define __es es +#define __fs fs + +#define __srr0 srr0 +#define __srr1 srr1 +#define __r0 r0 +#define __r1 r1 +#define __r3 r3 +#define __r4 r4 +#define __r5 r5 +#define __r6 r6 +#define __r13 r13 +#define __cr cr +#define __xer xer +#define __lr lr +#define __ctr ctr + +#define __dar dar +#define __dsisr dsisr +#define __exception exception + +#define __fpregs fpregs +#define __fpscr fpscr +#endif + +#if WORD_SIZE == 64 +#ifdef _STRUCT_UCONTEXT64 +typedef _STRUCT_UCONTEXT64 ExceptionInformation; +typedef _STRUCT_MCONTEXT64 *MCONTEXT_T; +#else /* _STRUCT_UCONTEXT64 */ +typedef struct ucontext64 ExceptionInformation; +typedef struct mcontext64 *MCONTEXT_T; +#endif /* _STRUCT_UCONTEXT64 */ +#define UC_MCONTEXT(UC) UC->uc_mcontext64 +#else /* WORD_SIZE */ +#ifdef _STRUCT_UCONTEXT +typedef _STRUCT_UCONTEXT ExceptionInformation; +typedef _STRUCT_MCONTEXT *MCONTEXT_T; +#else +typedef struct ucontext ExceptionInformation; +typedef struct mcontext *MCONTEXT_T; +#endif +#define UC_MCONTEXT(UC) UC->uc_mcontext +#endif /* WORD_SIZE */ + + + +#endif /* PPC */ + +#ifdef X8664 +#if MAC_OS_X_VERSION_MIN_REQUIRED <= MAC_OS_X_VERSION_10_4 +/* Broken in Mac OS 10.4u SDK */ +struct mcontext64 { + x86_exception_state64_t __es; + x86_thread_state64_t __ss; + x86_float_state64_t __fs; +}; + +typedef struct mcontext64 *MCONTEXT_T; +typedef ucontext64_t ExceptionInformation; +#define UC_MCONTEXT(UC) UC->uc_mcontext64 +#define __rax rax +#define __fpu_mxcsr fpu_mxcsr +#define __fpu_xmm0 fpu_xmm0 +#define __rsp rsp +#define __trapno trapno +#define __faultvaddr faultvaddr +#define __err err +#define __rip rip +#define __rsi rsi +#define __rdi rdi +#define __rdx rdx +#define __rcx rcx +#define __r8 r8 +#define __rflags rflags +#else /* post-10.4 */ +typedef mcontext_t MCONTEXT_T; +typedef ucontext_t ExceptionInformation; +#define UC_MCONTEXT(UC) UC->uc_mcontext +#endif +#endif + +#ifdef X8632 +/* Assume rational */ +/* Sadly, we can't make that assumption, since Apple renamed things + for Leopard. Yow! Are we standards-compliant yet ? */ +/* In the long term, we probably want to use the leopard-compliant + names (with leading __ prefixes). In the shorter term, we want + kernels compiled on Leopard to run on Tiger (and not reference + foo$UNIX2003 and similar nonsense, and that means getting the old + names (without leading __ prefixes.) Confused yet ? */ + +#if MAC_OS_X_VERSION_MIN_REQUIRED <= MAC_OS_X_VERSION_10_4 +#define __ss ss +#define __ds ds +#define __es es +#define __cs cs +#define __fs fs +#define __gs gs +#define __eax eax +#define __esp esp +#define __eip eip +#define __eflags eflags +#define __fpu_xmm0 fpu_xmm0 +#define __fpu_mxcsr fpu_mxcsr +#define __fpu_stmm0 fpu_stmm0 +#define __trapno trapno +#define __err err +#define __faultvaddr faultvaddr +#endif + +#define UC_MCONTEXT(UC) UC->uc_mcontext +typedef mcontext_t MCONTEXT_T; +typedef ucontext_t ExceptionInformation; +#endif + +#endif /* #ifdef DARWIN */ + +#ifdef LINUX +typedef struct ucontext ExceptionInformation; +#endif + +#ifdef FREEBSD +typedef struct __ucontext ExceptionInformation; +#endif + +#ifdef SOLARIS +typedef struct ucontext ExceptionInformation; +#endif + +#ifdef WINDOWS +typedef CONTEXT ExceptionInformation; +#endif + +typedef u32_t lisp_char_code; + +typedef int OSStatus, OSErr; +#define noErr ((OSErr) 0) +typedef int Boolean; +typedef void *LogicalAddress; +typedef char *Ptr, *BytePtr, *StringPtr; +typedef unsigned int UInt32; + + + +#define true 1 +#define false 0 + +#endif /*__lisptypes__ */ Index: /branches/qres/ccl/lisp-kernel/m4macros.m4 =================================================================== --- /branches/qres/ccl/lisp-kernel/m4macros.m4 (revision 13564) +++ /branches/qres/ccl/lisp-kernel/m4macros.m4 (revision 13564) @@ -0,0 +1,353 @@ +changecom(`/*',`*/') + + + +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + +/* BSD debugging information (line numbers, etc) is a little different */ +/* from ELF/SVr4 debugging information. There are probably lots more */ +/* differences, but this helps us to distinguish between what LinuxPPC */ +/* (ELF/SVr4) wants and what Darwin(BSD) wants. */ + + +define(`BSDstabs',`1') +define(`ELFstabs',`2') +define(`COFFstabs',`3') +undefine(`EABI') +undefine(`POWEROPENABI') +undefine(`rTOC') + + +ifdef(`DARWIN',`define(`SYSstabs',`BSDstabs') + define(`DarwinAssembler',`') + define(`CNamesNeedUnderscores',`') + define(`LocalLabelPrefix',`L') + define(`StartTextLabel',`Ltext0') + define(`EndTextLabel',`Letext') + ifdef(`PPC',` + define(`POWEROPENABI',`')') + ifdef(`X86',` + define(`SYSCALL_SETS_CARRY_ON_ERROR',`') + define(`SSE2_MATH_LIB',`')') +') + +ifdef(`LINUX',`define(`SYSstabs',`ELFstabs') + define(`HaveWeakSymbols',`') + define(`LocalLabelPrefix',`.L') + define(`StartTextLabel',`.Ltext0') + define(`EndTextLabel',`.Letext') + ifdef(`PPC64',` + define(`POWEROPENABI',`') + define(`rTOC',`r2')', ` + define(`EABI',`')')') + +ifdef(`FREEBSD',`define(`SYSstabs',`ELFstabs') + define(`HaveWeakSymbols',`') + define(`LocalLabelPrefix',`.L') + define(`StartTextLabel',`.Ltext0') + define(`EndTextLabel',`.Letext')' + ifdef(`X86',` + define(`SYSCALL_SETS_CARRY_ON_ERROR',`')') +) + +ifdef(`SOLARIS',`define(`SYSstabs',`ELFstabs') + define(`HaveWeakSymbols',`') + define(`LocalLabelPrefix',`.L') + define(`StartTextLabel',`.Ltext0') + define(`EndTextLabel',`.Letext')') + +ifdef(`WINDOWS',`define(`SYSstabs',`COFFstabs') + define(`CNamesNeedUnderscores',`') + define(`LocalLabelPrefix',`L') + define(`StartTextLabel',`Ltext0') + define(`EndTextLabel',`Letext')') + + +/* Names exported to (or imported from) C may need leading underscores. */ +/* Still. After all these years. Why ? */ + +define(`C',`ifdef(`CNamesNeedUnderscores',``_'$1',`$1')') + +define(`_linecounter_',0) + +define(`_emit_BSD_source_line_stab',` +ifdef(`X86',` +# __line__ "__file__" 1',` + .stabd 68,0,$1 +')') + + +/* We don't really do "weak importing" of symbols from a separate */ +/* subprims library anymore; if we ever do and the OS supports it, */ +/* here's how to say that we want it ... */ + +define(`WEAK',`ifdef(`HaveWeakSymbols',` + .weak $1 +',` + .globl $1 +')') + +define(`_emit_ELF_source_line_stab',` + define(`_linecounter_',incr(_linecounter_)) + .stabn 68,0,$1,`.LM'_linecounter_`-'__func_name +`.LM'_linecounter_: +') + +define(`_emit_COFF_source_line_stab',` + _emit_ELF_source_line_stab($1) +') + + +define(`emit_source_line_stab',` + ifelse(eval(SYSstabs), + eval(BSDstabs), + `_emit_BSD_source_line_stab($1)', + eval(SYSstabs), + eval(ELFstabs), + `_emit_ELF_source_line_stab($1)', + `_emit_COFF_source_line_stab($1)')') + + + + + + +/* Assemble a reference to the high half of a 32-bit constant, */ +/* possibly adjusted for sign-extension of thw low half. */ + + +define(`HA',`ifdef(`DARWIN',`ha16($1)',`$1@ha')') + + +/* Likewise for the low half, and for the high half without */ +/* concern for sign-extension of the low half. */ + +define(`LO',`ifdef(`DARWIN',`lo16($1)',`$1@l')') +define(`HI',`ifdef(`DARWIN',`hi16($1)',`$1@hi')') + +/* Note that m4 macros that could be expanded in the .text segment */ +/* need to advertise the current line number after they have finished */ +/* expanding. That shouldn't be too onerous, if only because there */ +/* should not be too many of them. */ + + +define(`N_FUN',36) +define(`N_SO',100) + +/* I wish that there was a less-dumb way of doing this. */ + +define(`pwd0',esyscmd(`/bin/pwd')) +define(`__pwd__',substr(pwd0,0,decr(len(pwd0)))`/') + +/* _beginfile() -- gets line/file in synch, generates N_SO for file, */ +/* starts .text section */ + + +define(`_beginfile',` + .stabs "__pwd__",N_SO,0,0,StartTextLabel() + .stabs "__file__",N_SO,0,0,StartTextLabel() +ifdef(`PPC64',` +ifdef(`DARWIN',` + .machine ppc64 +')') + .text +StartTextLabel(): +# __line__ "__file__" +') + +define(`_endfile',` + .stabs "",N_SO,0,0,EndTextLabel() +EndTextLabel(): +# __line__ +') + +define(`_startfn',`define(`__func_name',$1) +# __line__ + ifelse(eval(SYSstabs),eval(ELFstabs),` + .type $1,@function +') + +$1: +ifdef(`WINDOWS',` + .def $1; .scl 2; .type 32; .endef +',` + .stabd 68,0,__line__ +') + .stabs "$1:F1",36,0,__line__,$1 + .set func_start,$1 +# __line__ "__file__" 1 ') + + + +define(`_exportfn',` + .globl $1 + _startfn($1) +ifdef(`PPC64',` +ifdef(`LINUX',` + .global `.'$1 +`.'$1: +')') +# __line__ +') + + +define(`_endfn',` +LocalLabelPrefix`'__func_name`999': +ifdef(`WINDOWS',` +',` + .stabs "",36,0,0,LocalLabelPrefix`'__func_name`999'-__func_name + .line __line__ + ifelse(eval(SYSstabs),eval(ELFstabs),` + .size __func_name,LocalLabelPrefix`'__func_name`999'-__func_name +') +') + undefine(`__func_name') +') + + +/* _struct(name,start_offset) */ +/* This just generates a bunch of assembler equates; m4 */ +/* doesn't remember much of it .. */ + +define(`_struct', `define(`__struct_name',$1) + define(`_struct_org_name', _$1_org) + define(`_struct_base_name', _$1_base) + .set _struct_org_name,$2 + .set _struct_base_name,_struct_org_name + ifelse($3,`',` + undefine(`_struct_fixed_size_name') + ',` + define(`_struct_fixed_size_name', _$1_fixed_size) + .set _struct_fixed_size_name,$3 + ') +') + +define(`_struct_pad',` + .set _struct_org_name,_struct_org_name + $1 +') + +define(`_struct_label',` + .set __struct_name`.'$1, _struct_org_name +') + +/* _field(name,size) */ +define(`_field',`_struct_label($1) _struct_pad($2)') + +define(`_halfword', `_field($1, 2)') +define(`_word', `_field($1, 4)') +define(`_dword',`_field($1, 8)') +define(`_node', `_field($1, node_size)') + +define(`_ends',`ifdef(`_struct_fixed_size_name',` + .set __struct_name`.size',_struct_fixed_size_name + ',` + .set __struct_name`.size', _struct_org_name-_struct_base_name + ') +') + + +/* Lisp fixed-size objects always have a 1-word header */ +/* and are always accessed from a "fulltag_misc"-tagged pointer. */ +/* We also want to define STRUCT_NAME.element_count for each */ +/* such object. */ + + +define(`_structf',` + _struct($1,ifelse($2,`',-misc_bias,$2)) + _node(header) +') + +define(`_endstructf',` + .set __struct_name.`element_count',((_struct_org_name-node_size)-_struct_base_name)/node_size + _ends +') + + +define(`__',`emit_source_line_stab(__line__) + $@ + ') + +define(`__local_label_counter__',0) +define(`__macro_label_counter__',0) + +define(`new_local_labels', + `define(`__local_label_counter__',incr(__local_label_counter__))') + +define(`new_macro_labels', + `define(`__macro_label_counter__',incr(__macro_label_counter__))') + +define(`_local_label',`LocalLabelPrefix()`'$1') + +define(`local_label',`_local_label($1`'__local_label_counter__)') + +define(`macro_label',`_local_label($1`'__macro_label_counter__)') + + +/* The Darwin assembler doesn't seem to support .ifdef/.ifndef, but */ +/* does understand .if. */ +/* Note that using M4's own ifdef is certainly possible, but it's */ +/* hard to generate source line information when doing so. */ + + +define(`__ifdef',`ifdef(`$1',`.if 1',`.if 0')') +define(`__ifndef',`ifdef(`$1',`.if 0',`.if 1')') +define(`__else',`.else') +define(`__endif',`.endif') +define(`__if',`.if $1') + +define(`equate_if_defined',`ifdef($1,` +`$1' = 1 +',` +`$1' = 0 +')') + +equate_if_defined(`DARWIN') +equate_if_defined(`LINUX') +equate_if_defined(`FREEBSD') +equate_if_defined(`SOLARIS') +equate_if_defined(`WIN_64') +equate_if_defined(`PPC64') +equate_if_defined(`X8664') +equate_if_defined(`WIN_32') +equate_if_defined(`WINDOWS') + +equate_if_defined(`HAVE_TLS') +/* DARWIN_GS_HACK is hopefully short-lived */ +equate_if_defined(`DARWIN_GS_HACK') + +equate_if_defined(`TCR_IN_GPR') + +/* Well, so much for that. Maybe this will go away soon ? */ +equate_if_defined(`WIN32_ES_HACK') +equate_if_defined(`SYSCALL_SETS_CARRY_ON_ERROR') + + + +/* We use (more-or-less) a PowerOpen C frame, except on LinuxPPC32 */ + +define(`USE_POWEROPEN_C_FRAME',`') +undefine(`USE_EABI_C_FRAME') + +ifdef(`LINUX',` +ifdef(`PPC64',`',` +define(`USE_EABI_C_FRAME',`') +undefine(`USE_POWEROPEN_C_FRAME') +')') + + + + Index: /branches/qres/ccl/lisp-kernel/macros.h =================================================================== --- /branches/qres/ccl/lisp-kernel/macros.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/macros.h (revision 13564) @@ -0,0 +1,116 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +/* Totally different content than 'macros.s' */ + + + +#ifndef __macros__ +#define __macros__ + +#define ptr_to_lispobj(p) ((LispObj)(p)) +#define ptr_from_lispobj(o) ((LispObj*)(o)) +#define lisp_reg_p(reg) ((reg) >= fn) + +#define fulltag_of(o) ((o) & fulltagmask) +#define tag_of(o) ((o) & tagmask) +#define untag(o) ((o) & ~fulltagmask) +#define node_aligned(o) ((o) & ~tagmask) +#define indirect_node(o) (*(LispObj *)(node_aligned(o))) + +#define deref(o,n) ((((LispObj*) (untag((LispObj)o))))[(n)]) +#define header_of(o) deref(o,0) + +#define header_subtag(h) ((h) & subtagmask) +#define header_element_count(h) ((h) >> num_subtag_bits) +#define make_header(subtag,element_count) ((subtag)|((element_count)<>fixnum_shift)) +#define box_fixnum(x) ((LispObj)((signed_natural)(x)<car) +#define cdr(x) (((cons *)ptr_from_lispobj(untag(x)))->cdr) + +/* "sym" is an untagged pointer to a symbol */ +#define BOUNDP(sym) ((((lispsymbol *)(sym))->vcell) != undefined) + +/* Likewise. */ +#define FBOUNDP(sym) ((((lispsymbol *)(sym))->fcell) != nrs_UDF.vcell) + +#ifdef PPC +#ifdef PPC64 +#define nodeheader_tag_p(tag) (((tag) & lowtag_mask) == lowtag_nodeheader) +#define immheader_tag_p(tag) (((tag) & lowtag_mask) == lowtag_immheader) +#else +#define nodeheader_tag_p(tag) (tag == fulltag_nodeheader) +#define immheader_tag_p(tag) (tag == fulltag_immheader) +#endif +#endif + +#ifdef X86 +#ifdef X8664 +#define NODEHEADER_MASK ((1<<(fulltag_nodeheader_0)) | \ + (1<<(fulltag_nodeheader_1))) +#define nodeheader_tag_p(tag) ((1<<(tag)) & NODEHEADER_MASK) + +#define IMMHEADER_MASK ((1<tlb_pointer))[INTERRUPT_LEVEL_BINDING_INDEX]) +#endif + +#ifdef WINDOWS +#define LSEEK(fd,offset,how) _lseeki64(fd,offset,how) +#else +#define LSEEK(fd,offset,how) lseek(fd,offset,how) +#endif + +/* We can't easily and unconditionally use format strings like "0x%lx" + to print lisp objects: the "l" might not match the word size, and + neither would (necessarily) something like "0x%llx". We can at + least exploit the fact that on all current platforms, "ll" ("long long") + is the size of a 64-bit lisp object and "l" ("long") is the size of + a 32-bit lisp object. */ + +#if (WORD_SIZE == 64) +#define LISP "%llx" +#define ZLISP "%016llx" +#define DECIMAL "%lld" +#else +#define LISP "%lx" +#define ZLISP "%08x" +#define DECIMAL "%ld" +#endif Index: /branches/qres/ccl/lisp-kernel/memory.c =================================================================== --- /branches/qres/ccl/lisp-kernel/memory.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/memory.c (revision 13564) @@ -0,0 +1,989 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" +#include "Threads.h" +#include +#include +#include +#include +#include +#include +#include +#include +#include +#ifdef LINUX +#include +#include +#include +#endif + +#ifndef WINDOWS +#include +#endif + +#define DEBUG_MEMORY 0 + +void +allocation_failure(Boolean pointerp, natural size) +{ + char buf[64]; + sprintf(buf, "Can't allocate %s of size " DECIMAL " bytes.", pointerp ? "pointer" : "handle", size); + Fatal(": Kernel memory allocation failure. ", buf); +} + +void +fatal_oserr(StringPtr param, OSErr err) +{ + char buf[64]; + sprintf(buf," - operating system error %d.", err); + Fatal(param, buf); +} + + +Ptr +allocate(natural size) +{ + return (Ptr) malloc(size); +} + +void +deallocate(Ptr p) +{ + free((void *)p); +} + +Ptr +zalloc(natural size) +{ + Ptr p = allocate(size); + if (p != NULL) { + memset(p, 0, size); + } + return p; +} + +#ifdef DARWIN +#if WORD_SIZE == 64 +#define vm_region vm_region_64 +#endif + +/* + Check to see if the specified address is unmapped by trying to get + information about the mapped address at or beyond the target. If + the difference between the target address and the next mapped address + is >= len, we can safely mmap len bytes at addr. +*/ +Boolean +address_unmapped_p(char *addr, natural len) +{ + vm_address_t vm_addr = (vm_address_t)addr; + vm_size_t vm_size; +#if WORD_SIZE == 64 + vm_region_basic_info_data_64_t vm_info; +#else + vm_region_basic_info_data_t vm_info; +#endif +#if WORD_SIZE == 64 + mach_msg_type_number_t vm_info_size = VM_REGION_BASIC_INFO_COUNT_64; +#else + mach_msg_type_number_t vm_info_size = VM_REGION_BASIC_INFO_COUNT; +#endif + mach_port_t vm_object_name = (mach_port_t) 0; + kern_return_t kret; + + kret = vm_region(mach_task_self(), + &vm_addr, + &vm_size, +#if WORD_SIZE == 64 + VM_REGION_BASIC_INFO_64, +#else + VM_REGION_BASIC_INFO, +#endif + (vm_region_info_t)&vm_info, + &vm_info_size, + &vm_object_name); + if (kret != KERN_SUCCESS) { + return false; + } + + return vm_addr >= (vm_address_t)(addr+len); +} +#endif + + + /* + Through trial and error, we've found that IMAGE_BASE_ADDRESS is + likely to reside near the beginning of an unmapped block of memory + that's at least 1GB in size. We'd like to load the heap image's + sections relative to IMAGE_BASE_ADDRESS; if we're able to do so, + that'd allow us to file-map those sections (and would enable us to + avoid having to relocate references in the data sections.) + + In short, we'd like to reserve 1GB starting at IMAGE_BASE_ADDRESS + by creating an anonymous mapping with mmap(). + + If we try to insist that mmap() map a 1GB block at + IMAGE_BASE_ADDRESS exactly (by specifying the MAP_FIXED flag), + mmap() will gleefully clobber any mapped memory that's already + there. (That region's empty at this writing, but some future + version of the OS might decide to put something there.) + + If we don't specify MAP_FIXED, mmap() is free to treat the address + we give it as a hint; Linux seems to accept the hint if doing so + wouldn't cause a problem. Naturally, that behavior's too useful + for Darwin (or perhaps too inconvenient for it): it'll often + return another address, even if the hint would have worked fine. + + We call address_unmapped_p() to ask Mach whether using MAP_FIXED + would conflict with anything. Until we discover a need to do + otherwise, we'll assume that if Linux's mmap() fails to take the + hint, it's because of a legitimate conflict. + + If Linux starts ignoring hints, we can parse /proc//maps + to implement an address_unmapped_p() for Linux. + */ + +LogicalAddress +ReserveMemoryForHeap(LogicalAddress want, natural totalsize) +{ + LogicalAddress start; + Boolean fixed_map_ok = false; +#ifdef DARWIN + fixed_map_ok = address_unmapped_p(want,totalsize); +#endif +#ifdef SOLARIS + fixed_map_ok = true; +#endif + raise_limit(); +#ifdef WINDOWS + start = VirtualAlloc((void *)want, + totalsize + heap_segment_size, + MEM_RESERVE, + PAGE_NOACCESS); + if (!start) { +#if DEBUG_MEMORY + fprintf(dbgout, "Can't get desired heap address at 0x" LISP "\n", want); +#endif + start = VirtualAlloc(0, + totalsize + heap_segment_size, + MEM_RESERVE, + PAGE_NOACCESS); + if (!start) { + return NULL; + } + } +#else + start = mmap((void *)want, + totalsize + heap_segment_size, + PROT_NONE, + MAP_PRIVATE | MAP_ANON | (fixed_map_ok ? MAP_FIXED : 0) | MAP_NORESERVE, + -1, + 0); + if (start == MAP_FAILED) { + return NULL; + } + + if (start != want) { + munmap(start, totalsize+heap_segment_size); + start = (void *)((((natural)start)+heap_segment_size-1) & ~(heap_segment_size-1)); + if(mmap(start, totalsize, PROT_NONE, MAP_PRIVATE | MAP_ANON | MAP_FIXED | MAP_NORESERVE, -1, 0) != start) { + return NULL; + } + } + mprotect(start, totalsize, PROT_NONE); +#endif +#if DEBUG_MEMORY + fprintf(dbgout, "Reserving heap at 0x" LISP ", size 0x" LISP "\n", start, totalsize); +#endif + return start; +} + +int +CommitMemory (LogicalAddress start, natural len) +{ + LogicalAddress rc; +#if DEBUG_MEMORY + fprintf(dbgout, "Committing memory at 0x" LISP ", size 0x" LISP "\n", start, len); +#endif +#ifdef WINDOWS + if ((start < ((LogicalAddress)nil_value)) && + (((LogicalAddress)nil_value) < (start+len))) { + /* nil area is in the executable on Windows; ensure range is + read-write */ + DWORD as_if_i_care; + if (!VirtualProtect(start,len,PAGE_EXECUTE_READWRITE,&as_if_i_care)) { + return false; + } + return true; + } + rc = VirtualAlloc(start, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE); + if (!rc) { + wperror("CommitMemory VirtualAlloc"); + return false; + } + return true; +#else + int i, err; + void *addr; + + for (i = 0; i < 3; i++) { + addr = mmap(start, len, MEMPROTECT_RWX, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0); + if (addr == start) { + return true; + } else { + mmap(addr, len, MEMPROTECT_NONE, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0); + } + } + return false; +#endif +} + +void +UnCommitMemory (LogicalAddress start, natural len) { +#if DEBUG_MEMORY + fprintf(dbgout, "Uncommitting memory at 0x" LISP ", size 0x" LISP "\n", start, len); +#endif +#ifdef WINDOWS + int rc = VirtualFree(start, len, MEM_DECOMMIT); + if (!rc) { + wperror("UnCommitMemory VirtualFree"); + Fatal("mmap error", ""); + return; + } +#else + if (len) { + madvise(start, len, MADV_DONTNEED); + if (mmap(start, len, MEMPROTECT_NONE, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0) + != start) { + int err = errno; + Fatal("mmap error", ""); + fprintf(dbgout, "errno = %d", err); + } + } +#endif +} + + +LogicalAddress +MapMemory(LogicalAddress addr, natural nbytes, int protection) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Mapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + return VirtualAlloc(addr, nbytes, MEM_RESERVE|MEM_COMMIT, MEMPROTECT_RWX); +#else + { + int flags = MAP_PRIVATE|MAP_ANON; + + if (addr > 0) flags |= MAP_FIXED; + return mmap(addr, nbytes, protection, flags, -1, 0); + } +#endif +} + +LogicalAddress +MapMemoryForStack(natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Mapping stack of size 0x" LISP "\n", nbytes); +#endif +#ifdef WINDOWS + return VirtualAlloc(0, nbytes, MEM_RESERVE|MEM_COMMIT, MEMPROTECT_RWX); +#else + return mmap(NULL, nbytes, MEMPROTECT_RWX, MAP_PRIVATE|MAP_ANON|MAP_GROWSDOWN, -1, 0); +#endif +} + +int +UnMapMemory(LogicalAddress addr, natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Unmapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + /* Can't MEM_RELEASE here because we only want to free a chunk */ + return VirtualFree(addr, nbytes, MEM_DECOMMIT); +#else + return munmap(addr, nbytes); +#endif +} + +int +ProtectMemory(LogicalAddress addr, natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Protecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + DWORD oldProtect; + BOOL status = VirtualProtect(addr, nbytes, MEMPROTECT_RX, &oldProtect); + + if(!status) { + wperror("ProtectMemory VirtualProtect"); + Bug(NULL, "couldn't protect " DECIMAL " bytes at 0x" LISP ", errno = %d", nbytes, addr, status); + } + return status; +#else + int status = mprotect(addr, nbytes, PROT_READ | PROT_EXEC); + + if (status) { + status = errno; + Bug(NULL, "couldn't protect " DECIMAL " bytes at " LISP ", errno = %d", nbytes, addr, status); + } + return status; +#endif +} + +int +UnProtectMemory(LogicalAddress addr, natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Unprotecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + DWORD oldProtect; + return VirtualProtect(addr, nbytes, MEMPROTECT_RWX, &oldProtect); +#else + return mprotect(addr, nbytes, PROT_READ|PROT_WRITE|PROT_EXEC); +#endif +} + +int +MapFile(LogicalAddress addr, natural pos, natural nbytes, int permissions, int fd) +{ +#ifdef WINDOWS +#if 0 + /* Lots of hair in here: mostly alignment issues, but also address space reservation */ + HANDLE hFile, hFileMapping; + LPVOID rc; + DWORD desiredAccess; + + if (permissions == MEMPROTECT_RWX) { + permissions |= PAGE_WRITECOPY; + desiredAccess = FILE_MAP_READ|FILE_MAP_WRITE|FILE_MAP_COPY|FILE_MAP_EXECUTE; + } else { + desiredAccess = FILE_MAP_READ|FILE_MAP_COPY|FILE_MAP_EXECUTE; + } + + hFile = _get_osfhandle(fd); + hFileMapping = CreateFileMapping(hFile, NULL, permissions, + (nbytes >> 32), (nbytes & 0xffffffff), NULL); + + if (!hFileMapping) { + wperror("CreateFileMapping"); + return false; + } + + rc = MapViewOfFileEx(hFileMapping, + desiredAccess, + (pos >> 32), + (pos & 0xffffffff), + nbytes, + addr); +#else + size_t count, total = 0; + size_t opos; + + opos = LSEEK(fd, 0, SEEK_CUR); + CommitMemory(addr, nbytes); + LSEEK(fd, pos, SEEK_SET); + + while (total < nbytes) { + count = read(fd, addr + total, nbytes - total); + total += count; + // fprintf(dbgout, "read " DECIMAL " bytes, for a total of " DECIMAL " out of " DECIMAL " so far\n", count, total, nbytes); + if (!(count > 0)) + return false; + } + + LSEEK(fd, opos, SEEK_SET); + + return true; +#endif +#else + return mmap(addr, nbytes, permissions, MAP_PRIVATE|MAP_FIXED, fd, pos) != MAP_FAILED; +#endif +} + +void +unprotect_area(protected_area_ptr p) +{ + BytePtr start = p->start; + natural nprot = p->nprot; + + if (nprot) { + UnProtectMemory(start, nprot); + p->nprot = 0; + } +} + +protected_area_ptr +new_protected_area(BytePtr start, BytePtr end, lisp_protection_kind reason, natural protsize, Boolean now) +{ + protected_area_ptr p = (protected_area_ptr) allocate(sizeof(protected_area)); + + if (p == NULL) return NULL; + p->protsize = protsize; + p->nprot = 0; + p->start = start; + p->end = end; + p->why = reason; + p->next = AllProtectedAreas; + + AllProtectedAreas = p; + if (now) { + protect_area(p); + } + + return p; +} + +/* + Un-protect the first nbytes bytes in specified area. + Note that this may cause the area to be empty. +*/ +void +unprotect_area_prefix(protected_area_ptr area, size_t delta) +{ + unprotect_area(area); + area->start += delta; + if ((area->start + area->protsize) <= area->end) { + protect_area(area); + } +} + + +/* + Extend the protected area, causing the preceding nbytes bytes + to be included and protected. +*/ +void +protect_area_prefix(protected_area_ptr area, size_t delta) +{ + unprotect_area(area); + area->start -= delta; + protect_area(area); +} + +protected_area_ptr +AllProtectedAreas = NULL; + + +/* + This does a linear search. Areas aren't created all that often; + if there get to be very many of them, some sort of tree search + might be justified. +*/ + +protected_area_ptr +find_protected_area(BytePtr addr) +{ + protected_area* p; + + for(p = AllProtectedAreas; p; p=p->next) { + if ((p->start <= addr) && (p->end > addr)) { + return p; + } + } + return NULL; +} + + +void +zero_memory_range(BytePtr start, BytePtr end) +{ +#ifdef WINDOWS + ZeroMemory(start,end-start); +#else + bzero(start,(size_t)(end-start)); +#endif +} + + + + +/* + Grow or shrink the dynamic area. Or maybe not. + Whether or not the end of (mapped space in) the heap changes, + ensure that everything between the freeptr and the heap end + is mapped and read/write. (It'll incidentally be zeroed.) +*/ +Boolean +resize_dynamic_heap(BytePtr newfree, + natural free_space_size) +{ + extern int page_size; + area *a = active_dynamic_area; + BytePtr newlimit, protptr, zptr; + int psize = page_size; + if (free_space_size) { + BytePtr lowptr = a->active; + newlimit = lowptr + align_to_power_of_2(newfree-lowptr+free_space_size, + log2_heap_segment_size); + if (newlimit > a->high) { + return grow_dynamic_area(newlimit-a->high); + } else if ((lowptr + free_space_size) < a->high) { + shrink_dynamic_area(a->high-newlimit); + return true; + } + } +} + +void +protect_area(protected_area_ptr p) +{ + BytePtr start = p->start; + natural n = p->protsize; + + if (n && ! p->nprot) { + ProtectMemory(start, n); + p->nprot = n; + } +} + + +void +zero_page(BytePtr start) +{ + extern int page_size; +#ifdef PPC + extern void zero_cache_lines(BytePtr, size_t, size_t); + zero_cache_lines(start, (page_size/cache_block_size), cache_block_size); +#else + memset(start, 0, page_size); +#endif +} + +/* area management */ + + +area * +new_area(BytePtr lowaddr, BytePtr highaddr, area_code code) +{ + area *a = (area *) (zalloc(sizeof(area))); + if (a) { + natural ndnodes = area_dnode(highaddr, lowaddr); + a->low = lowaddr; + a->high = highaddr; + a->active = (code == AREA_DYNAMIC) ? lowaddr : highaddr; + a->code = code; + a->ndnodes = ndnodes; + /* Caller must allocate markbits when allocating heap ! */ + + } + return a; +} + +static area * +add_area_before(area *new_area, area *before) +{ + area *before_before = before->pred; + + new_area->pred = before_before; + new_area->succ = before; + before_before->succ = new_area; + before->pred = new_area; + return new_area; +} + +/* + The active dynamic area comes first. + Static areas follow dynamic areas. + Stack areas follow static areas. + Readonly areas come last. +*/ + +/* + If we already own the area_lock (or during iniitalization), it's safe + to add an area. +*/ + + +void +add_area_holding_area_lock(area *new_area) +{ + area *that = all_areas; + int + thiscode = (int)(new_area->code), + thatcode; + + /* Cdr down the linked list */ + do { + that = that->succ; + thatcode = (int)(that->code); + } while (thiscode < thatcode); + add_area_before(new_area, that); +} + +/* + In general, we need to own the area lock before adding an area. +*/ +void +add_area(area *new_area, TCR *tcr) +{ + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + add_area_holding_area_lock(new_area); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); +} + +/* + Search areas "forward" from the header's successor, until + an area containing ADDR is found or an area with code < MINCODE + is encountered. + This walks the area list visiting heaps (dynamic, then static) + first, then stacks. + +*/ +static area * +find_area_forward(BytePtr addr, area_code mincode) +{ + area *p, *header = all_areas; + + for (p = header->succ; p != header; p = p->succ) { + area_code pcode = p->code; + if (pcode < mincode) { + return NULL; + } + if (pcode >= AREA_READONLY) { + if ((addr >= p->low) && + (addr < p->active)) { + return p; + } + } else { + if ((addr >= p->active) && + (addr < p->high)) { + return p; + } + } + } + return NULL; +} + +static area * +find_area_backward(BytePtr addr, area_code maxcode) +{ + area *p, *header = all_areas; + + for (p = header->pred; p != header; p = p->pred) { + area_code pcode = p->code; + + if (pcode > maxcode) { + return NULL; + } + if (pcode >= AREA_READONLY) { + if ((addr >= p->low) && + (addr < p->active)) { + return p; + } + } else { + if ((addr >= p->active) && + (addr < p->high)) { + return p; + } + } + } + return NULL; +} + +area * +area_containing(BytePtr addr) +{ + return find_area_forward(addr, AREA_VOID); +} + +area * +heap_area_containing(BytePtr addr) +{ + return find_area_forward(addr, AREA_READONLY); +} + +area * +stack_area_containing(BytePtr addr) +{ + return find_area_backward(addr, AREA_TSTACK); +} + +/* + Make everything "younger" than the start of the target area + belong to that area; all younger areas will become empty, and + the dynamic area will have to lose some of its markbits (they + get zeroed and become part of the tenured area's refbits.) + + The active dynamic area must have been "normalized" (e.g., its + active pointer must match the free pointer) before this is called. + + If the target area is 'tenured_area' (the oldest ephemeral generation), + zero its refbits and update YOUNGEST_EPHEMERAL. + +*/ + +void +tenure_to_area(area *target) +{ + area *a = active_dynamic_area, *child; + BytePtr + curfree = a->active, + target_low = target->low, + tenured_low = tenured_area->low; + natural + dynamic_dnodes = area_dnode(curfree, a->low), + new_tenured_dnodes = area_dnode(curfree, tenured_area->low); + bitvector + refbits = tenured_area->refbits, + markbits = a->markbits, + new_markbits; + + target->high = target->active = curfree; + target->ndnodes = area_dnode(curfree, target_low); + + for (child = target->younger; child != a; child = child->younger) { + child->high = child->low = child->active = curfree; + child->ndnodes = 0; + } + + a->low = curfree; + a->ndnodes = area_dnode(a->high, curfree); + + new_markbits = refbits + ((new_tenured_dnodes + (nbits_in_word-1)) >> bitmap_shift); + + if (target == tenured_area) { + zero_bits(refbits, new_tenured_dnodes); + lisp_global(OLDEST_EPHEMERAL) = ptr_to_lispobj(curfree); + } else { + /* Need more (zeroed) refbits & fewer markbits */ + zero_bits(markbits, ((new_markbits-markbits)<markbits = new_markbits; + lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(curfree, lisp_global(HEAP_START)); +} + + + +/* + Make everything younger than the oldest byte in 'from' belong to + the youngest generation. If 'from' is 'tenured_area', this means + that nothing's ephemeral any more (and OLDEST_EPHEMERAL can be set + to 0 to indicate this.) + + Some tenured_area refbits become dynamic area markbits in the process; + it's not necessary to zero them, since the GC will do that. +*/ + +void +untenure_from_area(area *from) +{ + if (lisp_global(OLDEST_EPHEMERAL) != 0) { + area *a = active_dynamic_area, *child; + BytePtr curlow = from->low; + natural new_tenured_dnodes = area_dnode(curlow, tenured_area->low); + + for (child = from; child != a; child = child->younger) { + child->low = child->active = child->high = curlow; + child->ndnodes = 0; + } + + a->low = curlow; + a->ndnodes = area_dnode(a->high, curlow); + + a->markbits = (tenured_area->refbits) + ((new_tenured_dnodes+(nbits_in_word-1))>>bitmap_shift); + if (from == tenured_area) { + /* Everything's in the dynamic area */ + lisp_global(OLDEST_EPHEMERAL) = 0; + lisp_global(OLDSPACE_DNODE_COUNT) = 0; + + } + } +} + + +Boolean +egc_control(Boolean activate, BytePtr curfree) +{ + area *a = active_dynamic_area; + Boolean egc_is_active = (a->older != NULL); + + if (activate != egc_is_active) { + if (curfree != NULL) { + a->active = curfree; + } + if (activate) { + a->older = g1_area; + tenure_to_area(tenured_area); + egc_is_active = true; + } else { + untenure_from_area(tenured_area); + a->older = NULL; + egc_is_active = false; + } + } + return egc_is_active; +} + +/* + Lisp ff-calls this; it needs to set the active area's active pointer + correctly. +*/ + +Boolean +lisp_egc_control(Boolean activate) +{ + area *a = active_dynamic_area; + return egc_control(activate, (BytePtr) a->active); +} + + + + + +/* Splice the protected_area_ptr out of the list and dispose of it. */ +void +delete_protected_area(protected_area_ptr p) +{ + BytePtr start = p->start; + int nbytes = p->nprot; + protected_area_ptr *prev = &AllProtectedAreas, q; + + if (nbytes) { + UnProtectMemory((LogicalAddress)start, nbytes); + } + + while ((q = *prev) != NULL) { + if (p == q) { + *prev = p->next; + break; + } else { + prev = &(q->next); + } + } + + deallocate((Ptr)p); +} + + + + +/* + Unlink the area from all_areas. + Unprotect and dispose of any hard/soft protected_areas. + If the area has a handle, dispose of that as well. + */ + +void +condemn_area_holding_area_lock(area *a) +{ + void free_stack(void *); + area *prev = a->pred, *next = a->succ; + Ptr h = a->h; + protected_area_ptr p; + + prev->succ = next; + next->pred = prev; + + p = a->softprot; + if (p) delete_protected_area(p); + + p = a->hardprot; + + if (p) delete_protected_area(p); + + if (h) free_stack(h); + deallocate((Ptr)a); +} + + + +void +condemn_area(area *a, TCR *tcr) +{ + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + condemn_area_holding_area_lock(a); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); +} + + + + +/* + condemn an area and all the other areas that can be reached + via the area.older & area.younger links. + This is the function in the ppc::kernel-import-condemn-area slot, + called by free-stack-area + */ +void +condemn_area_chain(area *a, TCR *tcr) +{ + area *older; + + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + + for (; a->younger; a = a->younger) ; + for (;a;) { + older = a->older; + condemn_area_holding_area_lock(a); + a = older; + } + UNLOCK(lisp_global(TCR_AREA_LOCK),tcr); +} + +void +release_readonly_area() +{ + area *a = readonly_area; + UnMapMemory(a->low,align_to_power_of_2(a->active-a->low, log2_page_size)); + a->active = a->low; + a->ndnodes = 0; + pure_space_active = pure_space_start; +} + +void +protect_watched_areas() +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + if (code == AREA_WATCHED) { + natural size = a->high - a->low; + + ProtectMemory(a->low, size); + } + a = a->succ; + code = a->code; + } +} + +void +unprotect_watched_areas() +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + if (code == AREA_WATCHED) { + natural size = a->high - a->low; + + UnProtectMemory(a->low, size); + } + a = a->succ; + code = a->code; + } +} Index: /branches/qres/ccl/lisp-kernel/memprotect.h =================================================================== --- /branches/qres/ccl/lisp-kernel/memprotect.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/memprotect.h (revision 13564) @@ -0,0 +1,132 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __memprotect_h__ +#define __memprotect_h__ + + + +#include "lisptypes.h" +#ifdef PPC +#include "ppc-constants.h" +#endif +#include +#ifndef WINDOWS +#ifdef DARWIN +#include +#else +#include +#endif +#endif + +#ifdef WINDOWS +#define MAP_FAILED ((void *)(-1)) + +#define MEMPROTECT_NONE PAGE_NOACCESS +#define MEMPROTECT_RO PAGE_READONLY +#define MEMPROTECT_RW PAGE_READWRITE +#define MEMPROTECT_RX PAGE_EXECUTE_READ +#define MEMPROTECT_RWX PAGE_EXECUTE_READWRITE + +#else + +#define MEMPROTECT_NONE PROT_NONE +#define MEMPROTECT_RO PROT_READ +#define MEMPROTECT_RW (PROT_READ|PROT_WRITE) +#define MEMPROTECT_RX (PROT_READ|PROT_EXEC) +#define MEMPROTECT_RWX (PROT_READ|PROT_WRITE|PROT_EXEC) +#ifndef MAP_GROWSDOWN +#define MAP_GROWSDOWN (0) +#endif + + +#endif + +LogicalAddress +ReserveMemoryForHeap(LogicalAddress want, natural totalsize); + +int +CommitMemory (LogicalAddress start, natural len); + +void +UnCommitMemory (LogicalAddress start, natural len); + +LogicalAddress +MapMemory(LogicalAddress addr, natural nbytes, int protection); + +LogicalAddress +MapMemoryForStack(natural nbytes); + +int +UnMapMemory(LogicalAddress addr, natural nbytes); + +int +ProtectMemory(LogicalAddress, natural); + +int +UnProtectMemory(LogicalAddress, natural); + +int +MapFile(LogicalAddress addr, natural pos, natural nbytes, int permissions, int fd); + +typedef enum { + kNotProtected, /* At least not at the moment. */ + kVSPsoftguard, + kSPsoftguard, + kTSPsoftguard, + kSPhardguard, /* Touch one and die. */ + kVSPhardguard, + kTSPhardguard, + kHEAPsoft, /* Uninitialized page in the heap */ + kHEAPhard, /* The end-of-the-line in the heap */ + /* Phony last entry. */ + kNumProtectionKinds + } lisp_protection_kind; + +typedef +struct protected_area { + struct protected_area *next; + BytePtr start; /* first byte (page-aligned) that might be protected */ + BytePtr end; /* last byte (page-aligned) that could be protected */ + unsigned nprot; /* Might be 0 */ + unsigned protsize; /* number of bytes to protect */ + lisp_protection_kind why; +} protected_area, *protected_area_ptr; + + +/* Various functions that try to respond to a protection violation */ +typedef + OSStatus (protection_handler)(ExceptionInformation *, protected_area_ptr, BytePtr); + +protection_handler + do_spurious_wp_fault, + do_soft_stack_overflow, + do_hard_stack_overflow, + do_tenured_space_write, + do_heap_soft_probe, + do_heap_hard_probe; + +extern protection_handler + *protection_handlers[]; + + +void +exception_cleanup(void); + + + +#endif /* __memprotect_h__ */ Index: /branches/qres/ccl/lisp-kernel/pad.s =================================================================== --- /branches/qres/ccl/lisp-kernel/pad.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/pad.s (revision 13564) @@ -0,0 +1,6 @@ + .globl openmcl_low_address +openmcl_low_address: + nop + + + Index: /branches/qres/ccl/lisp-kernel/plbt.c =================================================================== --- /branches/qres/ccl/lisp-kernel/plbt.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/plbt.c (revision 13564) @@ -0,0 +1,318 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lispdcmd.h" +#ifdef LINUX +#define __USE_GNU 1 +#include +#endif + +#ifdef DARWIN +#if 0 +#undef undefined +#include +#include +#include + +typedef struct dl_info { + const char *dli_fname; /* Pathname of shared object */ + void *dli_fbase; /* Base address of shared object */ + const char *dli_sname; /* Name of nearest symbol */ + void *dli_saddr; /* Address of nearest symbol */ +} Dl_info; + +int +darwin_dladdr(void *p, Dl_info *info) +{ + unsigned long i; + unsigned long j; + uint32_t count = _dyld_image_count(); + struct mach_header *mh = 0; + struct load_command *lc = 0; + unsigned long addr = 0; + unsigned long table_off = (unsigned long)0; + int found = 0; + + if (!info) + return 0; + info->dli_fname = 0; + info->dli_fbase = 0; + info->dli_sname = 0; + info->dli_saddr = 0; + /* Some of this was swiped from code posted by Douglas Davidson + * to darwin-development AT lists DOT + * apple DOT com and slightly modified + */ + for (i = 0; i < count; i++) { + addr = (unsigned long)p - _dyld_get_image_vmaddr_slide(i); + mh = (struct mach_header *)_dyld_get_image_header(i); + if (mh) { + lc = (struct load_command *)((char *)mh + sizeof(struct mach_header)); + for (j = 0; j < mh->ncmds; j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) { + if (LC_SEGMENT == lc->cmd && + addr >= ((struct segment_command *)lc)->vmaddr && + addr < + ((struct segment_command *)lc)->vmaddr + ((struct segment_command *)lc)->vmsize) { + info->dli_fname = _dyld_get_image_name(i); + info->dli_fbase = (void *)mh; + found = 1; + break; + } + } + if (found) { + break; + } + } + } + if (!found) { + return 0; + } + lc = (struct load_command *)((char *)mh + sizeof(struct mach_header)); + for (j = 0; + j < mh->ncmds; + j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) { + if (LC_SEGMENT == lc->cmd) { + if (!strcmp(((struct segment_command *)lc)->segname, "__LINKEDIT")) + break; + } + } + table_off = + ((unsigned long)((struct segment_command *)lc)->vmaddr) - + ((unsigned long)((struct segment_command *)lc)->fileoff) + _dyld_get_image_vmaddr_slide(i); + + lc = (struct load_command *)((char *)mh + sizeof(struct mach_header)); + for (j = 0; + j < mh->ncmds; + j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) { + if (LC_SYMTAB == lc->cmd) { + struct nlist *symtable = (struct nlist *)(((struct symtab_command *)lc)->symoff + table_off); + unsigned long numsyms = ((struct symtab_command *)lc)->nsyms; + struct nlist *nearest = NULL; + unsigned long diff = 0xffffffff; + unsigned long strtable = (unsigned long)(((struct symtab_command *)lc)->stroff + table_off); + for (i = 0; i < numsyms; i++) { + /* fprintf(dbgout,"%s : 0x%08x, 0x%x\n",(char *)(strtable + symtable->n_un.n_strx) ,symtable->n_value, symtable->n_type); */ + /* Ignore the following kinds of Symbols */ + if ((!symtable->n_value) /* Undefined */ + || (symtable->n_type & N_STAB) /* Debug symbol */ + || ((symtable->n_type & N_TYPE) != N_SECT) /* Absolute, indirect, ... */ + ) { + symtable++; + continue; + } + if ((addr >= symtable->n_value) && + (diff >= addr - (symtable->n_value ))) { + diff = addr- (unsigned long)symtable->n_value; + nearest = symtable; + } + symtable++; + } + if (nearest) { + info->dli_saddr = nearest->n_value + ((void *)p - addr); + info->dli_sname = (char *)(strtable + nearest->n_un.n_strx); + } + } + } + return 1; +} + +#define dladdr darwin_dladdr +#else +#include +#endif +#endif + + + +extern Boolean lisp_frame_p(lisp_frame *); + +void +print_lisp_frame(lisp_frame *frame) +{ + LispObj fun = frame->savefn, pc = frame->savelr; + int delta = 0; + Dl_info info; + char *spname; + + if ((fun == 0) || (fun == fulltag_misc)) { + spname = "unknown ?"; +#ifndef STATIC + if (dladdr((void *)ptr_from_lispobj(pc), &info)) { + spname = (char *)(info.dli_sname); +#ifdef DARWIN + if (spname[-1] != '_') { + --spname; + } +#endif + } +#endif +#ifdef PPC64 + Dprintf("(#x%016lX) #x%016lX : (subprimitive %s)", frame, pc, spname); +#else + Dprintf("(#x%08X) #x%08X : (subprimitive %s)", frame, pc, spname); +#endif + } else { + if ((fulltag_of(fun) != fulltag_misc) || + (header_subtag(header_of(fun)) != subtag_function)) { +#ifdef PPC64 + Dprintf("(#x%016lX) #x%016lX : (not a function!)", frame, pc); +#else + Dprintf("(#x%08X) #x%08X : (not a function!)", frame, pc); +#endif + } else { + LispObj code_vector = deref(fun, 1); + + if ((pc >= (code_vector+misc_data_offset)) && + (pc < ((code_vector+misc_data_offset)+(header_element_count(header_of(code_vector))<<2)))) { + delta = (pc - (code_vector+misc_data_offset)); + } +#ifdef PPC64 + Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta); +#else + Dprintf("(#x%08X) #x%08X : %s + %d", frame, pc, print_lisp_object(fun), delta); +#endif + } + } +} + + +void +print_foreign_frame(void *frame) +{ +#ifdef LINUX + natural pc = (natural) (((eabi_c_frame *)frame)->savelr); +#endif +#ifdef DARWIN + natural pc = (natural) (((c_frame *)frame)->savelr); +#endif + Dl_info foreign_info; + +#ifndef STATIC + if (dladdr((void *)pc, &foreign_info)) { + Dprintf( +#ifdef PPC64 +"(#x%016lx) #x%016lX : %s + %d" +#else +"(#x%08x) #x%08X : %s + %d" +#endif +, frame, pc, foreign_info.dli_sname, + pc-((long)foreign_info.dli_saddr)); + } else { +#endif + Dprintf( +#ifdef PPC64 +"(#x%016X) #x%016X : foreign code (%s)" +#else +"(#x%08X) #x%08X : foreign code (%s)" +#endif +, frame, pc, "unknown"); +#ifndef STATIC + } +#endif +} + + +/* Walk frames from "start" to "end". + Say whatever can be said about foreign frames and lisp frames. +*/ + +void +walk_stack_frames(lisp_frame *start, lisp_frame *end) +{ + lisp_frame *next; + Dprintf("\n"); + while (start < end) { + + if (lisp_frame_p(start)) { + print_lisp_frame(start); + } else { +#ifdef DARWIN + print_foreign_frame((c_frame *)start); +#else + print_foreign_frame((eabi_c_frame *)start); +#endif + } + + next = start->backlink; + if (next == 0) { + next = end; + } + if (next < start) { + fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start); + break; + } + start = next; + } +} + +char * +interrupt_level_description(TCR *tcr) +{ + signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr); + if (level < 0) { + if (tcr->interrupt_pending) { + return "disabled(pending)"; + } else { + return "disabled"; + } + } else { + return "enabled"; + } +} + +void +walk_other_areas() +{ + TCR *start = (TCR *)get_tcr(true), *tcr = start->next; + area *a; + char *ilevel = interrupt_level_description(tcr); + + while (tcr != start) { + a = tcr->cs_area; + Dprintf("\n\n TCR = 0x%lx, cstack area #x%lx, native thread ID = 0x%lx, interrupts %s", tcr, a, tcr->native_thread_id, ilevel); + walk_stack_frames((lisp_frame *) (a->active), (lisp_frame *) (a->high)); + tcr = tcr->next; + } +} + +void +plbt_sp(LispObj currentSP) +{ + area *cs_area; + +{ + TCR *tcr = (TCR *)get_tcr(true); + char *ilevel = interrupt_level_description(tcr); + cs_area = tcr->cs_area; + if ((((LispObj) ptr_to_lispobj(cs_area->low)) > currentSP) || + (((LispObj) ptr_to_lispobj(cs_area->high)) < currentSP)) { + Dprintf("\nStack pointer [#x%lX] in unknown area.", currentSP); + } else { + fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel); + walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentSP), (lisp_frame *) (cs_area->high)); + walk_other_areas(); + } + } +} + + +void +plbt(ExceptionInformation *xp) +{ + plbt_sp(xpGPR(xp, sp)); +} + Index: /branches/qres/ccl/lisp-kernel/plprint.c =================================================================== --- /branches/qres/ccl/lisp-kernel/plprint.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/plprint.c (revision 13564) @@ -0,0 +1,30 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lispdcmd.h" + + +void +plprint(ExceptionInformation *xp, LispObj obj) +{ + if (lisp_nil == (LispObj) NULL) { + fprintf(dbgout,"can't find lisp NIL; lisp process not active process ?\n"); + } else { + Dprintf("\n%s", print_lisp_object(obj)); + } +} + Index: /branches/qres/ccl/lisp-kernel/plsym.c =================================================================== --- /branches/qres/ccl/lisp-kernel/plsym.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/plsym.c (revision 13564) @@ -0,0 +1,128 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lispdcmd.h" + +void +describe_symbol(LispObj sym) +{ + lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); + LispObj function = rawsym->fcell; +#ifdef fulltag_symbol + sym += (fulltag_symbol-fulltag_misc); +#endif + Dprintf("Symbol %s at #x%llX", print_lisp_object(sym), (u64_t) sym); + Dprintf(" value : %s", print_lisp_object(rawsym->vcell)); + if (function != nrs_UDF.vcell) { + Dprintf(" function : %s", print_lisp_object(function)); + } +} + +int +compare_lisp_string_to_c_string(lisp_char_code *lisp_string, + char *c_string, + natural n) +{ + natural i; + for (i = 0; i < n; i++) { + if (lisp_string[i] != (lisp_char_code)(c_string[i])) { + return 1; + } + } + return 0; +} + +/* + Walk the heap until we find a symbol + whose pname matches "name". Return the + tagged symbol or NULL. +*/ + +LispObj +find_symbol_in_range(LispObj *start, LispObj *end, char *name) +{ + LispObj header, tag; + int n = strlen(name); + char *s = name; + lisp_char_code *p; + while (start < end) { + header = *start; + tag = fulltag_of(header); + if (header_subtag(header) == subtag_symbol) { + LispObj + pname = deref(ptr_to_lispobj(start), 1), + pname_header = header_of(pname); + if ((header_subtag(pname_header) == subtag_simple_base_string) && + (header_element_count(pname_header) == n)) { + p = (lisp_char_code *) ptr_from_lispobj(pname + misc_data_offset); + if (compare_lisp_string_to_c_string(p, s, n) == 0) { + return (ptr_to_lispobj(start))+fulltag_misc; + } + } + } + if (nodeheader_tag_p(tag)) { + start += (~1 & (2 + header_element_count(header))); + } else if (immheader_tag_p(tag)) { + start = (LispObj *) skip_over_ivector((natural)start, header); + } else { + start += 2; + } + } + return (LispObj)NULL; +} + +LispObj +find_symbol(char *name) +{ + area *a = ((area *) (ptr_from_lispobj(lisp_global(ALL_AREAS))))->succ; + area_code code; + LispObj sym = 0; + + while ((code = a->code) != AREA_VOID) { + if ((code == AREA_STATIC) || + (code == AREA_DYNAMIC)) { + sym = find_symbol_in_range((LispObj *)(a->low), (LispObj *)(a->active), name); + if (sym) { + break; + } + } + a = a->succ; + } + return sym; +} + + +void +plsym(ExceptionInformation *xp, char *pname) +{ + natural address = 0; + + address = find_symbol(pname); + if (address == 0) { + Dprintf("Can't find symbol."); + return; + } + + if ((fulltag_of(address) == fulltag_misc) && + (header_subtag(header_of(address)) == subtag_symbol)){ + describe_symbol(address); + } else { + fprintf(dbgout, "Not a symbol.\n"); + } + return; +} + Index: /branches/qres/ccl/lisp-kernel/pmcl-kernel.c =================================================================== --- /branches/qres/ccl/lisp-kernel/pmcl-kernel.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/pmcl-kernel.c (revision 13564) @@ -0,0 +1,2259 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifdef DARWIN +/* dyld.h included here because something in "lisp.h" causes + a conflict (actually I think the problem is in "constants.h") +*/ +#include + +#endif +#include "lisp.h" +#include "lisp_globals.h" +#include "gc.h" +#include "area.h" +#include +#include +#include "lisp-exceptions.h" +#include +#include +#ifndef WINDOWS +#include +#endif +#include +#include +#include +#ifndef WINDOWS +#include +#include +#endif + +#ifdef LINUX +#include +#include +#include +#include +#include +#include +#include + +/* + The version of provided by some distributions will + claim that doesn't exist. It may be present + in the Linux kernel source tree even if it's not copied to + /usr/include/asm-ppc64. Hopefully, this will be straightened out + soon (and/or the PPC_FEATURE_HAS_ALTIVEC constant will be defined + in a less volatile place.) Until that's straightened out, it may + be necessary to install a copy of the kernel header in the right + place and/or persuade to lighten up a bit. +*/ + +#ifdef PPC +#ifndef PPC64 +#include +#endif +#ifndef PPC_FEATURE_HAS_ALTIVEC +#define PPC_FEATURE_HAS_ALTIVEC 0x10000000 +#endif +#endif +#endif + +Boolean use_mach_exception_handling = +#ifdef DARWIN + true +#else + false +#endif +; + +#ifdef DARWIN +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#if defined(FREEBSD) || defined(SOLARIS) +#include +#include +#include +#include +#include +#endif + +#include +#ifndef WINDOWS +#include +#endif +#include "Threads.h" + +#include +#include + +#ifndef MAP_NORESERVE +#define MAP_NORESERVE (0) +#endif + +#ifdef WINDOWS +#include +#include +void +wperror(char* message) +{ + char* buffer; + DWORD last_error = GetLastError(); + + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER| + FORMAT_MESSAGE_FROM_SYSTEM| + FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + last_error, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR)&buffer, + 0, NULL); + fprintf(dbgout, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer); + LocalFree(buffer); +} +#endif + +LispObj lisp_nil = (LispObj) 0; +bitvector global_mark_ref_bits = NULL; + + +/* These are all "persistent" : they're initialized when + subprims are first loaded and should never change. */ +extern LispObj ret1valn; +extern LispObj nvalret; +extern LispObj popj; + +LispObj text_start = 0; + +/* A pointer to some of the kernel's own data; also persistent. */ + +extern LispObj import_ptrs_base; + + + +void +xMakeDataExecutable(void *, unsigned long); + +void +make_dynamic_heap_executable(LispObj *p, LispObj *q) +{ + void * cache_start = (void *) p; + natural ncacheflush = (natural) q - (natural) p; + + xMakeDataExecutable(cache_start, ncacheflush); +} + +size_t +ensure_stack_limit(size_t stack_size) +{ +#ifdef WINDOWS + extern void os_get_current_thread_stack_bounds(void **, natural*); + natural totalsize; + void *ignored; + + os_get_current_thread_stack_bounds(&ignored, &totalsize); + + return (size_t)totalsize-(size_t)(CSTACK_HARDPROT+CSTACK_SOFTPROT); + +#else + struct rlimit limits; + rlim_t cur_stack_limit, max_stack_limit; + + stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT); + getrlimit(RLIMIT_STACK, &limits); + cur_stack_limit = limits.rlim_cur; + max_stack_limit = limits.rlim_max; + if (stack_size > max_stack_limit) { + stack_size = max_stack_limit; + } + if (cur_stack_limit < stack_size) { + limits.rlim_cur = stack_size; + errno = 0; + if (setrlimit(RLIMIT_STACK, &limits)) { + int e = errno; + fprintf(dbgout, "errno = %d\n", e); + Fatal(": Stack resource limit too small", ""); + } + } +#endif + return stack_size; +} + + +/* This should write-protect the bottom of the stack. + Doing so reliably involves ensuring that everything's unprotected on exit. +*/ + +BytePtr +allocate_lisp_stack(natural useable, + unsigned softsize, + unsigned hardsize, + lisp_protection_kind softkind, + lisp_protection_kind hardkind, + Ptr *h_p, + BytePtr *base_p, + protected_area_ptr *softp, + protected_area_ptr *hardp) +{ + void *allocate_stack(natural); + void free_stack(void *); + natural size = useable+softsize+hardsize; + natural overhead; + BytePtr base, softlimit, hardlimit; + Ptr h = allocate_stack(size+4095); + protected_area_ptr hprotp = NULL, sprotp; + + if (h == NULL) { + return NULL; + } + if (h_p) *h_p = h; + base = (BytePtr) align_to_power_of_2( h, log2_page_size); + hardlimit = (BytePtr) (base+hardsize); + softlimit = hardlimit+softsize; + + overhead = (base - (BytePtr) h); + if (hardsize) { + hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true); + if (hprotp == NULL) { + if (base_p) *base_p = NULL; + if (h_p) *h_p = NULL; + deallocate(h); + return NULL; + } + if (hardp) *hardp = hprotp; + } + if (softsize) { + sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true); + if (sprotp == NULL) { + if (base_p) *base_p = NULL; + if (h_p) *h_p = NULL; + if (hardp) *hardp = NULL; + if (hprotp) delete_protected_area(hprotp); + free_stack(h); + return NULL; + } + if (softp) *softp = sprotp; + } + if (base_p) *base_p = base; + return (BytePtr) ((natural)(base+size)); +} + +/* + This should only called by something that owns the area_lock, or + by the initial thread before other threads exist. +*/ +area * +allocate_lisp_stack_area(area_code stack_type, + natural usable, + unsigned softsize, + unsigned hardsize, + lisp_protection_kind softkind, + lisp_protection_kind hardkind) + +{ + BytePtr base, bottom; + Ptr h; + area *a = NULL; + protected_area_ptr soft_area=NULL, hard_area=NULL; + + bottom = allocate_lisp_stack(usable, + softsize, + hardsize, + softkind, + hardkind, + &h, + &base, + &soft_area, + &hard_area); + + if (bottom) { + a = new_area(base, bottom, stack_type); + a->hardlimit = base+hardsize; + a->softlimit = base+hardsize+softsize; + a->h = h; + a->softprot = soft_area; + a->hardprot = hard_area; + add_area_holding_area_lock(a); + } + return a; +} + +/* + Also assumes ownership of the area_lock +*/ +area* +register_cstack_holding_area_lock(BytePtr bottom, natural size) +{ + BytePtr lowlimit = (BytePtr) (((((natural)bottom)-size)+4095)&~4095); + area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK); + a->hardlimit = lowlimit+CSTACK_HARDPROT; + a->softlimit = a->hardlimit+CSTACK_SOFTPROT; +#ifdef USE_SIGALTSTACK + setup_sigaltstack(a); +#endif + add_area_holding_area_lock(a); + return a; +} + + +area* +allocate_vstack_holding_area_lock(natural usable) +{ + return allocate_lisp_stack_area(AREA_VSTACK, + usable > MIN_VSTACK_SIZE ? + usable : MIN_VSTACK_SIZE, + VSTACK_SOFTPROT, + VSTACK_HARDPROT, + kVSPsoftguard, + kVSPhardguard); +} + +area * +allocate_tstack_holding_area_lock(natural usable) +{ + return allocate_lisp_stack_area(AREA_TSTACK, + usable > MIN_TSTACK_SIZE ? + usable : MIN_TSTACK_SIZE, + TSTACK_SOFTPROT, + TSTACK_HARDPROT, + kTSPsoftguard, + kTSPhardguard); +} + + +/* It's hard to believe that max & min don't exist already */ +unsigned unsigned_min(unsigned x, unsigned y) +{ + if (x <= y) { + return x; + } else { + return y; + } +} + +unsigned unsigned_max(unsigned x, unsigned y) +{ + if (x >= y) { + return x; + } else { + return y; + } +} + +#if WORD_SIZE == 64 +#ifdef DARWIN +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef FREEBSD +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef SOLARIS +#define MAXIMUM_MAPPABLE_MEMORY (128L<<30L) +#endif +#ifdef LINUX +#ifdef X8664 +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef PPC +#define MAXIMUM_MAPPABLE_MEMORY (128L<<30L) +#endif +#endif +#ifdef WINDOWS +/* Supposedly, the high-end version of Vista allow 128GB of pageable memory */ +#define MAXIMUM_MAPPABLE_MEMORY (120LL<<30LL) +#endif +#else +#ifdef DARWIN +#define MAXIMUM_MAPPABLE_MEMORY ((1U<<31)-2*heap_segment_size) +#endif +#ifdef LINUX +#ifdef X86 +#define MAXIMUM_MAPPABLE_MEMORY (9U<<28) +#else +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#endif +#ifdef WINDOWS +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#ifdef FREEBSD +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#ifdef SOLARIS +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#endif + +natural +reserved_area_size = MAXIMUM_MAPPABLE_MEMORY; + +area + *nilreg_area=NULL, + *tenured_area=NULL, + *g2_area=NULL, + *g1_area=NULL, + *managed_static_area=NULL, + *readonly_area=NULL; + +area *all_areas=NULL; +int cache_block_size=32; + + +#if WORD_SIZE == 64 +#define DEFAULT_LISP_HEAP_GC_THRESHOLD (32<<20) +#define G2_AREA_THRESHOLD (8<<20) +#define G1_AREA_THRESHOLD (4<<20) +#define G0_AREA_THRESHOLD (2<<20) +#else +#define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20) +#define G2_AREA_THRESHOLD (4<<20) +#define G1_AREA_THRESHOLD (2<<20) +#define G0_AREA_THRESHOLD (1<<20) +#endif + +#define MIN_DYNAMIC_SIZE (DEFAULT_LISP_HEAP_GC_THRESHOLD *2) + +#if (WORD_SIZE == 32) +#define DEFAULT_INITIAL_STACK_SIZE (1<<20) +#else +#define DEFAULT_INITIAL_STACK_SIZE (2<<20) +#endif + +natural +lisp_heap_gc_threshold = DEFAULT_LISP_HEAP_GC_THRESHOLD; + +natural +initial_stack_size = DEFAULT_INITIAL_STACK_SIZE; + +natural +thread_stack_size = 0; + + +/* + 'start' should be on a segment boundary; 'len' should be + an integral number of segments. remap the entire range. +*/ + +void +uncommit_pages(void *start, size_t len) +{ + UnCommitMemory(start, len); +} + +#define TOUCH_PAGES_ON_COMMIT 0 + +Boolean +touch_all_pages(void *start, size_t len) +{ +#if TOUCH_PAGES_ON_COMMIT + extern Boolean touch_page(void *); + char *p = (char *)start; + + while (len) { + if (!touch_page(p)) { + return false; + } + len -= page_size; + p += page_size; + } +#endif + return true; +} + +Boolean +commit_pages(void *start, size_t len) +{ + if (len != 0) { + if (CommitMemory(start, len)) { + if (touch_all_pages(start, len)) { + return true; + } + } + } + return true; +} + +area * +find_readonly_area() +{ + area *a; + + for (a = active_dynamic_area->succ; a != all_areas; a = a->succ) { + if (a->code == AREA_READONLY) { + return a; + } + } + return NULL; +} + +area * +extend_readonly_area(unsigned more) +{ + area *a; + unsigned mask; + BytePtr new_start, new_end; + + if ((a = find_readonly_area()) != NULL) { + if ((a->active + more) > a->high) { + return NULL; + } + mask = ((natural)a->active) & (page_size-1); + if (mask) { + UnProtectMemory(a->active-mask, page_size); + } + new_start = (BytePtr)(align_to_power_of_2(a->active,log2_page_size)); + new_end = (BytePtr)(align_to_power_of_2(a->active+more,log2_page_size)); + if (!CommitMemory(new_start, new_end-new_start)) { + return NULL; + } + return a; + } + return NULL; +} + +LispObj image_base=0; +BytePtr pure_space_start, pure_space_active, pure_space_limit; +BytePtr static_space_start, static_space_active, static_space_limit; + +void +raise_limit() +{ +#ifdef RLIMIT_AS + struct rlimit r; + if (getrlimit(RLIMIT_AS, &r) == 0) { + r.rlim_cur = r.rlim_max; + setrlimit(RLIMIT_AS, &r); + /* Could limit heaplimit to rlim_max here if smaller? */ + } +#endif +} + + +area * +create_reserved_area(natural totalsize) +{ + Ptr h; + natural base; + BytePtr + end, + lastbyte, + start, + want = (BytePtr)IMAGE_BASE_ADDRESS; + area *reserved; + Boolean fatal = false; + + totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size); + + if (totalsize < (PURESPACE_RESERVE + MIN_DYNAMIC_SIZE)) { + totalsize = PURESPACE_RESERVE + MIN_DYNAMIC_SIZE; + fatal = true; + } + + start = ReserveMemoryForHeap(want, totalsize); + + if (start == NULL) { + if (fatal) { + perror("minimal initial mmap"); + exit(1); + } + return NULL; + } + + h = (Ptr) start; + base = (natural) start; + image_base = base; + lastbyte = (BytePtr) (start+totalsize); + static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS; + static_space_limit = static_space_start + STATIC_RESERVE; + pure_space_start = pure_space_active = start; + pure_space_limit = start + PURESPACE_RESERVE; + start = pure_space_limit; + + /* + Allocate mark bits here. They need to be 1/64 the size of the + maximum useable area of the heap (+ 3 words for the EGC.) + */ + end = lastbyte; + end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63)>>6)) & ~4095)); + + global_mark_ref_bits = (bitvector)end; + end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63) >> 6)) & ~4095)); + global_reloctab = (LispObj *) end; + reserved = new_area(start, end, AREA_VOID); + /* The root of all evil is initially linked to itself. */ + reserved->pred = reserved->succ = reserved; + all_areas = reserved; + reserved->markbits = global_mark_ref_bits; + return reserved; +} + +void * +allocate_from_reserved_area(natural size) +{ + area *reserved = reserved_area; + BytePtr low = reserved->low, high = reserved->high; + natural avail = high-low; + + size = align_to_power_of_2(size, log2_heap_segment_size); + + if (size > avail) { + return NULL; + } + reserved->low += size; + reserved->active = reserved->low; + reserved->ndnodes -= (size>>dnode_shift); + return low; +} + + + +BytePtr reloctab_limit = NULL, markbits_limit = NULL; + +void +ensure_gc_structures_writable() +{ + natural + ndnodes = area_dnode(lisp_global(HEAP_END),lisp_global(HEAP_START)), + markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3), + reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<>bitmap_shift)+1)), + n; + BytePtr + new_reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size), + new_markbits_limit = (BytePtr)align_to_power_of_2(((natural)global_mark_ref_bits)+markbits_size,log2_page_size); + + if (new_reloctab_limit > reloctab_limit) { + n = new_reloctab_limit - reloctab_limit; + CommitMemory(reloctab_limit, n); + UnProtectMemory(reloctab_limit, n); + reloctab_limit = new_reloctab_limit; + } + + if (new_markbits_limit > markbits_limit) { + n = new_markbits_limit-markbits_limit; + CommitMemory(markbits_limit, n); + UnProtectMemory(markbits_limit, n); + markbits_limit = new_markbits_limit; + } +} + + +area * +allocate_dynamic_area(natural initsize) +{ + natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size); + BytePtr start, end; + area *a; + + start = allocate_from_reserved_area(totalsize); + if (start == NULL) { + fprintf(dbgout, "reserved area too small to load heap image\n"); + exit(1); + } + end = start + totalsize; + a = new_area(start, end, AREA_DYNAMIC); + a->active = start+initsize; + add_area_holding_area_lock(a); + a->markbits = reserved_area->markbits; + reserved_area->markbits = NULL; + CommitMemory(start, end-start); + a->h = start; + a->softprot = NULL; + a->hardprot = NULL; + lisp_global(HEAP_START) = ptr_to_lispobj(a->low); + lisp_global(HEAP_END) = ptr_to_lispobj(a->high); + markbits_limit = (BytePtr)global_mark_ref_bits; + reloctab_limit = (BytePtr)global_reloctab; + ensure_gc_structures_writable(); + return a; + } + + +Boolean +grow_dynamic_area(natural delta) +{ + area *a = active_dynamic_area, *reserved = reserved_area; + natural avail = reserved->high - reserved->low; + + delta = align_to_power_of_2(delta, log2_heap_segment_size); + if (delta > avail) { + return false; + } + + if (!commit_pages(a->high,delta)) { + return false; + } + + + if (!allocate_from_reserved_area(delta)) { + return false; + } + + + a->high += delta; + a->ndnodes = area_dnode(a->high, a->low); + lisp_global(HEAP_END) += delta; + ensure_gc_structures_writable(); + return true; +} + +/* + As above. Pages that're returned to the reserved_area are + "condemned" (e.g, we try to convince the OS that they never + existed ...) +*/ +Boolean +shrink_dynamic_area(natural delta) +{ + area *a = active_dynamic_area, *reserved = reserved_area; + + delta = align_to_power_of_2(delta, log2_heap_segment_size); + + a->high -= delta; + a->ndnodes = area_dnode(a->high, a->low); + a->hardlimit = a->high; + uncommit_pages(a->high, delta); + reserved->low -= delta; + reserved->ndnodes += (delta>>dnode_shift); + lisp_global(HEAP_END) -= delta; + return true; +} + + + +#ifndef WINDOWS +void +user_signal_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ + if (signum == SIGINT) { + lisp_global(INTFLAG) = (((signum<<8) + 1) << fixnumshift); + } + else if (signum == SIGTERM) { + lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift); + } + else if (signum == SIGQUIT) { + lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift); + } +#ifdef DARWIN + DarwinSigReturn(context); +#endif +} + +#endif + +void +register_user_signal_handler() +{ +#ifdef WINDOWS + extern BOOL CALLBACK ControlEventHandler(DWORD); + + signal(SIGINT, SIG_IGN); + + SetConsoleCtrlHandler(ControlEventHandler,TRUE); +#else + install_signal_handler(SIGINT, (void *)user_signal_handler); + install_signal_handler(SIGTERM, (void *)user_signal_handler); +#endif +} + + + +BytePtr +initial_stack_bottom() +{ +#ifndef WINDOWS + extern char **environ; + char *p = *environ; + while (*p) { + p += (1+strlen(p)); + } + return (BytePtr)((((natural) p) +4095) & ~4095); +#endif +#ifdef WINDOWS + return (BytePtr)((current_stack_pointer() + 4095) & ~ 4095); +#endif +} + + + + +Ptr fatal_spare_ptr = NULL; + + +void +Fatal(StringPtr param0, StringPtr param1) +{ + + if (fatal_spare_ptr) { + deallocate(fatal_spare_ptr); + fatal_spare_ptr = NULL; + } + fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1); + _exit(-1); +} + +OSErr application_load_err = noErr; + +area * +set_nil(LispObj); + + +/* Check for the existence of a file named by 'path'; return true + if it seems to exist, without checking size, permissions, or + anything else. */ +Boolean +probe_file(char *path) +{ + struct stat st; + + return (stat(path,&st) == 0); +} + + +#ifdef WINDOWS +/* Chop the trailing ".exe" from the kernel image name */ +wchar_t * +chop_exe_suffix(wchar_t *path) +{ + int len = wcslen(path); + wchar_t *copy = malloc((len+1)*sizeof(wchar_t)), *tail; + + wcscpy(copy,path); + tail = wcsrchr(copy, '.'); + if (tail) { + *tail = 0; + } + return copy; +} +#endif + +#ifdef WINDOWS +wchar_t * +path_by_appending_image(wchar_t *path) +{ + int len = wcslen(path) + wcslen(L".image") + 1; + wchar_t *copy = (wchar_t *) malloc(len*sizeof(wchar_t)); + + if (copy) { + wcscpy(copy, path); + wcscat(copy, L".image"); + } + return copy; +} +#else +char * +path_by_appending_image(char *path) +{ + int len = strlen(path) + strlen(".image") + 1; + char *copy = (char *) malloc(len); + + if (copy) { + strcpy(copy, path); + strcat(copy, ".image"); + } + return copy; +} +#endif + +char * +case_inverted_path(char *path) +{ + char *copy = strdup(path), *base = copy, *work = copy, c; + if (copy == NULL) { + return NULL; + } + while(*work) { + if (*work++ == '/') { + base = work; + } + } + work = base; + while ((c = *work) != '\0') { + if (islower(c)) { + *work++ = toupper(c); + } else { + *work++ = tolower(c); + } + } + return copy; +} +/* + The underlying file system may be case-insensitive (e.g., HFS), + so we can't just case-invert the kernel's name. + Tack ".image" onto the end of the kernel's name. Much better ... +*/ +#ifdef WINDOWS +wchar_t * +default_image_name(wchar_t *orig) +{ + wchar_t *path = chop_exe_suffix(orig); + wchar_t *image_name = path_by_appending_image(path); + return image_name; +} +#else +char * +default_image_name(char *orig) +{ +#ifdef WINDOWS + char *path = chop_exe_suffix(orig); +#else + char *path = orig; +#endif + char *image_name = path_by_appending_image(path); +#if !defined(WINDOWS) && !defined(DARWIN) + if (!probe_file(image_name)) { + char *legacy = case_inverted_path(path); + if (probe_file(legacy)) { + image_name = legacy; + } + } +#endif + return image_name; +} +#endif + + + +char *program_name = NULL; +#ifdef WINDOWS +wchar_t *real_executable_name = NULL; +#else +char *real_executable_name = NULL; +#endif + +#ifndef WINDOWS + +char * +ensure_real_path(char *path) +{ + char buf[PATH_MAX*2], *p, *q; + int n; + + p = realpath(path, buf); + + if (p == NULL) { + return path; + } + n = strlen(p); + q = malloc(n+1); + strcpy(q,p); + return q; +} + +char * +determine_executable_name(char *argv0) +{ +#ifdef DARWIN + uint32_t len = 1024; + char exepath[1024], *p = NULL; + + if (_NSGetExecutablePath(exepath, (void *)&len) == 0) { + p = malloc(len+1); + memmove(p, exepath, len); + p[len]=0; + return ensure_real_path(p); + } + return ensure_real_path(argv0); +#endif +#ifdef LINUX + char exepath[PATH_MAX], *p; + int n; + + if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) { + p = malloc(n+1); + memmove(p,exepath,n); + p[n]=0; + return p; + } + return argv0; +#endif +#ifdef FREEBSD + return ensure_real_path(argv0); +#endif +#ifdef SOLARIS + char exepath[PATH_MAX], proc_path[PATH_MAX], *p; + int n; + + snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid()); + + if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) { + p = malloc(n+1); + memmove(p,exepath,n); + p[n]=0; + return p; + } + return ensure_real_path(argv0); +#endif + return ensure_real_path(argv0); +} +#endif + +#ifdef WINDOWS +wchar_t * +determine_executable_name() +{ + DWORD nsize = 512, result; + wchar_t *buf = malloc(nsize*sizeof(wchar_t)); + + do { + result = GetModuleFileNameW(NULL, buf, nsize); + if (result == nsize) { + nsize *= 2; + buf = realloc(buf,nsize*sizeof(wchar_t)); + } else { + return buf; + } + } while (1); +} + + +wchar_t * +ensure_real_path(wchar_t *path) +{ + int bufsize = 256, n; + + do { + wchar_t buf[bufsize]; + + n = GetFullPathNameW(path,bufsize,buf,NULL); + if (n == 0) { + return path; + } + + if (n < bufsize) { + int i; + wchar_t *q = calloc(n+1,sizeof(wchar_t)); + + for (i = 0; i < n; i++) { + q[i] = buf[i]; + } + return q; + } + bufsize = n+1; + } while (1); +} +#endif + +void +usage_exit(char *herald, int exit_status, char* other_args) +{ + if (herald && *herald) { + fprintf(dbgout, "%s\n", herald); + } + fprintf(dbgout, "usage: %s \n", program_name); + fprintf(dbgout, "\t or %s \n", program_name); + fprintf(dbgout, "\t where are one or more of:\n"); + if (other_args && *other_args) { + fputs(other_args, dbgout); + } + fprintf(dbgout, "\t-R, --heap-reserve : reserve (default: %lld)\n", + (u64_t) reserved_area_size); + fprintf(dbgout, "\t\t bytes for heap expansion\n"); + fprintf(dbgout, "\t-S, --stack-size : set size of initial thread's control stack to \n"); + fprintf(dbgout, "\t-Z, --thread-stack-size : set default size of first (listener) thread's stacks based on \n"); + fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n"); + fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n"); + fprintf(dbgout, "\t-I, --image-name \n"); +#ifndef WINDOWS + fprintf(dbgout, "\t and defaults to %s\n", + default_image_name(program_name)); +#endif + fprintf(dbgout, "\n"); + _exit(exit_status); +} + +int no_sigtrap = 0; +#ifdef WINDOWS +wchar_t *image_name = NULL; +#else +char *image_name = NULL; +#endif +int batch_flag = 0; + + +natural +parse_numeric_option(char *arg, char *argname, natural default_val) +{ + char *tail; + natural val = 0; + + val = strtoul(arg, &tail, 0); + switch(*tail) { + case '\0': + break; + + case 'M': + case 'm': + val = val << 20; + break; + + case 'K': + case 'k': + val = val << 10; + break; + + case 'G': + case 'g': + val = val << 30; + break; + + default: + fprintf(dbgout, "couldn't parse %s argument %s", argname, arg); + val = default_val; + break; + } + return val; +} + + + +/* + The set of arguments recognized by the kernel is + likely to remain pretty small and pretty simple. + This removes everything it recognizes from argv; + remaining args will be processed by lisp code. +*/ + +void +process_options(int argc, char *argv[], wchar_t *shadow[]) +{ + int i, j, k, num_elide, flag, arg_error; + char *arg, *val; + wchar_t *warg, *wval; +#ifdef DARWIN + extern int NXArgc; +#endif + + for (i = 1; i < argc;) { + arg = argv[i]; + if (shadow) { + warg = shadow[i]; + } + arg_error = 0; + if (*arg != '-') { + i++; + } else { + num_elide = 0; + val = NULL; + if ((flag = (strncmp(arg, "-I", 2) == 0)) || + (strcmp (arg, "--image-name") == 0)) { + if (flag && arg[2]) { + val = arg+2; + if (shadow) { + wval = warg+2; + } + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + if (shadow) { + wval = shadow[i+1]; + } + num_elide = 2; + } else { + arg_error = 1; + } + } + if (val) { +#ifdef WINDOWS + image_name = wval; +#else + image_name = val; +#endif + } + } else if ((flag = (strncmp(arg, "-R", 2) == 0)) || + (strcmp(arg, "--heap-reserve") == 0)) { + natural reserved_size = reserved_area_size; + + if (flag && arg[2]) { + val = arg+2; + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + num_elide = 2; + } else { + arg_error = 1; + } + } + + if (val) { + reserved_size = parse_numeric_option(val, + "-R/--heap-reserve", + reserved_area_size); + } + + if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) { + reserved_area_size = reserved_size; + } + + } else if ((flag = (strncmp(arg, "-S", 2) == 0)) || + (strcmp(arg, "--stack-size") == 0)) { + natural stack_size; + + if (flag && arg[2]) { + val = arg+2; + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + num_elide = 2; + } else { + arg_error = 1; + } + } + + if (val) { + stack_size = parse_numeric_option(val, + "-S/--stack-size", + initial_stack_size); + + + if (stack_size >= MIN_CSTACK_SIZE) { + initial_stack_size = stack_size; + } + } + + } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) || + (strcmp(arg, "--thread-stack-size") == 0)) { + natural stack_size; + + if (flag && arg[2]) { + val = arg+2; + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + num_elide = 2; + } else { + arg_error = 1; + } + } + + if (val) { + stack_size = parse_numeric_option(val, + "-Z/--thread-stack-size", + thread_stack_size); + + + if (stack_size >= MIN_CSTACK_SIZE) { + thread_stack_size = stack_size; + } + if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) { + thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1; + } + + } + + } else if (strcmp(arg, "--no-sigtrap") == 0) { + no_sigtrap = 1; + num_elide = 1; + } else if ((strcmp(arg, "-b") == 0) || + (strcmp(arg, "--batch") == 0)) { + batch_flag = 1; + num_elide = 1; + } else if (strcmp(arg,"--") == 0) { + break; + } else { + i++; + } + if (arg_error) { + usage_exit("error in program arguments", 1, ""); + } + if (num_elide) { + for (j = i+num_elide, k=i; j < argc; j++, k++) { + argv[k] = argv[j]; + if (shadow) { + shadow[k] = shadow[j]; + } + } + argc -= num_elide; +#ifdef DARWIN + NXArgc -= num_elide; +#endif + argv[argc] = NULL; + if (shadow) { + shadow[argc] = NULL; + } + } + } + } +} + +#ifdef WINDOWS +void +terminate_lisp() +{ + _exit(EXIT_FAILURE); +} +#else +pid_t main_thread_pid = (pid_t)0; + +void +terminate_lisp() +{ + kill(main_thread_pid, SIGKILL); + _exit(-1); +} +#endif + +#ifdef DARWIN +#define min_os_version "8.0" /* aka Tiger */ +#endif +#ifdef LINUX +#ifdef PPC +#define min_os_version "2.2" +#endif +#ifdef X86 +#define min_os_version "2.6" +#endif +#endif +#ifdef FREEBSD +#define min_os_version "6.0" +#endif +#ifdef SOLARIS +#define min_os_version "5.10" +#endif + +#ifdef PPC +#if defined(PPC64) || !defined(DARWIN) +/* ld64 on Darwin doesn't offer anything close to reliable control + over the layout of a program in memory. About all that we can + be assured of is that the canonical subprims jump table address + (currently 0x5000) is unmapped. Map that page, and copy the + actual spjump table there. */ + + +void +remap_spjump() +{ + extern opcode spjump_start, spjump_end; + pc new, + old = &spjump_start, + limit = &spjump_end, + work; + opcode instr; + void *target; + int disp; + + if (old != (pc)SPJUMP_TARGET_ADDRESS) { + new = mmap((pc) SPJUMP_TARGET_ADDRESS, + 0x1000, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_ANON | MAP_FIXED, + -1, + 0); + if (new != (pc) SPJUMP_TARGET_ADDRESS) { + perror("remap spjump"); + _exit(1); + } + + for (work = new; old < limit; work++, old++) { + instr = *old; + disp = instr & ((1<<26)-1); + target = (void*)old+disp; + disp = target-(void *)work; + *work = ((instr >> 26) << 26) | disp; + } + xMakeDataExecutable(new, (void*)work-(void*)new); + ProtectMemory(new, 0x1000); + } +} +#endif +#endif + +#ifdef X86 +#ifdef WINDOWS + +/* By using linker tricks, we ensure there's memory between 0x11000 + and 0x21000, so we just need to fix permissions and copy the spjump + table. */ + +void +remap_spjump() +{ + extern opcode spjump_start; + DWORD old_protect; + + if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) { + if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS, + 0x1000, + PAGE_EXECUTE_READWRITE, + &old_protect)) { + wperror("VirtualProtect spjump"); + _exit(1); + } + memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000); + } +} +#else +void +remap_spjump() +{ + extern opcode spjump_start; + pc new = mmap((pc) SPJUMP_TARGET_ADDRESS, + 0x1000, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_ANON | MAP_FIXED, + -1, + 0), + old = &spjump_start; + if (new == (pc)-1) { + perror("remap spjump"); + _exit(1); + } + memmove(new, old, 0x1000); +} +#endif +#endif + + +void +check_os_version(char *progname) +{ +#ifdef WINDOWS + /* We should be able to run with any version of Windows that actually gets here executing the binary, so don't do anything for now. */ +#else + struct utsname uts; + long got, want; + char *got_end,*want_end; +#ifdef X8632 + extern Boolean rcontext_readonly; +#endif + + want = strtoul(min_os_version,&want_end,10); + + uname(&uts); + got = strtoul(uts.release,&got_end,10); +#ifdef X8632 +#ifdef FREEBSD + if (!strcmp(uts.machine,"amd64")) { + rcontext_readonly = true; + } +#endif +#endif + while (got == want) { + if (*want_end == '.') { + want = strtoul(want_end+1,&want_end,10); + got = 0; + if (*got_end == '.') { + got = strtoul(got_end+1,&got_end,10); + } else { + break; + } + } else { + break; + } + } + + if (got < want) { + fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release); + exit(1); + } +#endif +} + +#ifdef X86 +/* + This should determine the cache block size. It should also + probably complain if we don't have (at least) SSE2. +*/ +extern int cpuid(natural, natural*, natural*, natural*); + +#define X86_FEATURE_CMOV (1<<15) +#define X86_FEATURE_CLFLUSH (1<<19) +#define X86_FEATURE_MMX (1<<23) +#define X86_FEATURE_SSE (1<<25) +#define X86_FEATURE_SSE2 (1<<26) + +#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2) + +Boolean +check_x86_cpu() +{ + natural eax, ebx, ecx, edx; + + eax = cpuid(0, &ebx, &ecx, &edx); + + if (eax >= 1) { + eax = cpuid(1, &ebx, &ecx, &edx); + cache_block_size = (ebx & 0xff00) >> 5; + if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) { + return true; + } + /* It's very unlikely that SSE2 would be present and other things + that we want wouldn't. If they don't have MMX or CMOV either, + might as well tell them. */ + if ((edx & X86_FEATURE_SSE2) == 0) { + fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n"); + } + if ((edx & X86_FEATURE_MMX) == 0) { + fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n"); + } + if ((edx & X86_FEATURE_CMOV) == 0) { + fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n"); + } + + } + return false; +} +#endif + +void +lazarus() +{ + TCR *tcr = get_tcr(false); + if (tcr) { + /* Some threads may be dying; no threads should be created. */ + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + tcr->vs_area->active = tcr->vs_area->high - node_size; + tcr->save_vsp = (LispObj *)(tcr->vs_area->active); + tcr->ts_area->active = tcr->ts_area->high; + tcr->save_tsp = (LispObj *)(tcr->ts_area->active); + tcr->catch_top = 0; + tcr->db_link = 0; + tcr->xframe = 0; + start_lisp(tcr, 0); + } +} + +#ifdef LINUX +#ifdef X8664 +#include +#include + +void +ensure_gs_available(char *progname) +{ + LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self(); + char *gnu_get_libc_version(void); + + arch_prctl(ARCH_GET_GS, &gs_addr); + arch_prctl(ARCH_GET_FS, &fs_addr); + if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) { + fprintf(dbgout, "The installed C library - version %s - seems to be using the %%gs register for thread storage.\n\"%s\" cannot run, since it expects to be\nable to use that register for its own purposes.\n", gnu_get_libc_version(),progname); + _exit(1); + } +} +#endif +#endif + +Boolean +bogus_fp_exceptions = false; + +typedef +float (*float_arg_returns_float)(float); + +float +fcallf(float_arg_returns_float fun, float arg) +{ + return fun(arg); +} + +void +check_bogus_fp_exceptions() +{ +#ifdef X8664 + float asinf(float),result; + + + natural save_mxcsr = get_mxcsr(), post_mxcsr; + set_mxcsr(0x1f80); + + result = fcallf(asinf, 1.0); + post_mxcsr = get_mxcsr(); + set_mxcsr(save_mxcsr); + if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) { + bogus_fp_exceptions = true; + } +#endif +} + +#ifdef WINDOWS +char * +utf_16_to_utf_8(wchar_t *utf_16) +{ + int utf8len = WideCharToMultiByte(CP_UTF8, + 0, + utf_16, + -1, + NULL, + 0, + NULL, + NULL); + + char *utf_8 = malloc(utf8len); + + WideCharToMultiByte(CP_UTF8, + 0, + utf_16, + -1, + utf_8, + utf8len, + NULL, + NULL); + + return utf_8; +} + +char ** +wide_argv_to_utf_8(wchar_t *wide_argv[], int argc) +{ + char** argv = calloc(argc+1,sizeof(char *)); + int i; + + for (i = 0; i < argc; i++) { + if (wide_argv[i]) { + argv[i] = utf_16_to_utf_8(wide_argv[i]); + } else { + argv[i] = NULL; + } + } + return argv; +} +#endif + + + + + +int +main(int argc, char *argv[] +#ifndef WINDOWS +, char *envp[], void *aux +#endif +) +{ + extern int page_size; + natural default_g0_threshold = G0_AREA_THRESHOLD, + default_g1_threshold = G1_AREA_THRESHOLD, + default_g2_threshold = G2_AREA_THRESHOLD, + lisp_heap_threshold_from_image = 0; + Boolean egc_enabled = +#ifdef DISABLE_EGC + false +#else + true +#endif + ; + Boolean lisp_heap_threshold_set_from_command_line = false; + wchar_t **utf_16_argv = NULL; + +#ifdef PPC + extern int altivec_present; +#endif +#ifdef WINDOWS + extern LispObj load_image(wchar_t *); +#else + extern LispObj load_image(char *); +#endif + area *a; + BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer(); + TCR *tcr; + + dbgout = stderr; + +#ifdef WINDOWS + { + int wide_argc; + extern void init_winsock(void); + extern void init_windows_io(void); + + _fmode = O_BINARY; + _setmode(1, O_BINARY); + _setmode(2, O_BINARY); + setvbuf(dbgout, NULL, _IONBF, 0); + init_winsock(); + init_windows_io(); + utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc); + } +#endif + + check_os_version(argv[0]); +#ifdef WINDOWS + real_executable_name = determine_executable_name(); +#else + real_executable_name = determine_executable_name(argv[0]); +#endif + page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */ + + check_bogus_fp_exceptions(); +#ifdef LINUX +#ifdef X8664 + ensure_gs_available(real_executable_name); +#endif +#endif +#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN)) + remap_spjump(); +#endif + +#ifdef PPC +#ifdef LINUX + { + ElfW(auxv_t) *av = aux; + int hwcap, done = false; + + if (av) { + do { + switch (av->a_type) { + case AT_DCACHEBSIZE: + cache_block_size = av->a_un.a_val; + break; + + case AT_HWCAP: + hwcap = av->a_un.a_val; + altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0); + break; + + case AT_NULL: + done = true; + break; + } + av++; + } while (!done); + } + } +#endif +#ifdef DARWIN + { + unsigned value = 0; + size_t len = sizeof(value); + int mib[2]; + + mib[0] = CTL_HW; + mib[1] = HW_CACHELINE; + if (sysctl(mib,2,&value,&len, NULL, 0) != -1) { + if (len == sizeof(value)) { + cache_block_size = value; + } + } + mib[1] = HW_VECTORUNIT; + value = 0; + len = sizeof(value); + if (sysctl(mib,2,&value,&len, NULL, 0) != -1) { + if (len == sizeof(value)) { + altivec_present = value; + } + } + } +#endif +#endif + +#ifdef X86 + if (!check_x86_cpu()) { + fprintf(dbgout, "CPU doesn't support required features\n"); + exit(1); + } +#endif + +#ifdef SOLARIS +#ifdef X8632 + { + extern void solaris_ldt_init(void); + solaris_ldt_init(); + } +#endif +#endif + +#ifndef WINDOWS + main_thread_pid = getpid(); +#endif + tcr_area_lock = (void *)new_recursive_lock(); + + program_name = argv[0]; + if ((argc == 2) && (*argv[1] != '-')) { +#ifdef WINDOWS + image_name = utf_16_argv[1]; +#else + image_name = argv[1]; +#endif + argv[1] = NULL; +#ifdef WINDOWS + utf_16_argv[1] = NULL; +#endif + } else { + process_options(argc,argv,utf_16_argv); + } + if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) { + lisp_heap_threshold_set_from_command_line = true; + } + + initial_stack_size = ensure_stack_limit(initial_stack_size); + if (image_name == NULL) { + if (check_for_embedded_image(real_executable_name)) { + image_name = real_executable_name; + } else { + image_name = default_image_name(real_executable_name); + } + } + + while (1) { + if (create_reserved_area(reserved_area_size)) { + break; + } + reserved_area_size = reserved_area_size *.9; + } + + gc_init(); + + set_nil(load_image(image_name)); + lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD); + if (lisp_heap_threshold_from_image) { + if ((!lisp_heap_threshold_set_from_command_line) && + (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) { + lisp_heap_gc_threshold = lisp_heap_threshold_from_image; + resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold); + } + /* If lisp_heap_threshold_from_image was set, other image params are + valid. */ + default_g0_threshold = lisp_global(G0_THRESHOLD); + default_g1_threshold = lisp_global(G1_THRESHOLD); + default_g2_threshold = lisp_global(G2_THRESHOLD); + egc_enabled = lisp_global(EGC_ENABLED); + } + + lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock); + +#ifdef X86 + lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10)); +#else + lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10); +#endif + lisp_global(RET1VALN) = (LispObj)&ret1valn; + lisp_global(LEXPR_RETURN) = (LispObj)&nvalret; + lisp_global(LEXPR_RETURN1V) = (LispObj)&popj; + lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas); + lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift; + lisp_global(STACK_SIZE) = thread_stack_size<low; + + /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */ + g1_area = new_area(lowptr, lowptr, AREA_STATIC); + g2_area = new_area(lowptr, lowptr, AREA_STATIC); + tenured_area = new_area(lowptr, lowptr, AREA_STATIC); + add_area_holding_area_lock(tenured_area); + add_area_holding_area_lock(g2_area); + add_area_holding_area_lock(g1_area); + + g1_area->code = AREA_DYNAMIC; + g2_area->code = AREA_DYNAMIC; + tenured_area->code = AREA_DYNAMIC; + +/* a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */ + g1_area->younger = a; + g1_area->older = g2_area; + g2_area->younger = g1_area; + g2_area->older = tenured_area; + tenured_area->younger = g2_area; + tenured_area->refbits = a->markbits; + tenured_area->static_dnodes = a->static_dnodes; + a->static_dnodes = 0; + tenured_area->static_used = a->static_used; + a->static_used = 0; + lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area); + lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits); + g2_area->threshold = default_g2_threshold; + g1_area->threshold = default_g1_threshold; + a->threshold = default_g0_threshold; + } + + tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE); + stack_base = initial_stack_bottom()-xStackSpace(); + init_threads((void *)(stack_base), tcr); + thread_init_tcr(tcr, current_sp, current_sp-stack_base); + + lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock()); + enable_fp_exceptions(); + register_user_signal_handler(); + +#ifdef PPC + lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift; +#endif +#if STATIC + lisp_global(STATICALLY_LINKED) = 1 << fixnumshift; +#endif + tcr->prev = tcr->next = tcr; +#ifndef WINDOWS + lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT); +#endif + tcr->vs_area->active -= node_size; + *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell; + nrs_TOPLFUNC.vcell = lisp_nil; +#ifdef GC_INTEGRITY_CHECKING + (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit); +#endif + if (egc_enabled) { + egc_control(true, NULL); + } + atexit(lazarus); + start_lisp(TCR_TO_TSD(tcr), 0); + _exit(0); +} + +area * +set_nil(LispObj r) +{ + + if (lisp_nil == (LispObj)NULL) { + + lisp_nil = r; + } + return NULL; +} + + +void +xMakeDataExecutable(void *start, unsigned long nbytes) +{ +#ifndef X86 + extern void flush_cache_lines(); + natural ustart = (natural) start, base, end; + + base = (ustart) & ~(cache_block_size-1); + end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1); + flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size); +#endif +} + +natural +xStackSpace() +{ + return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT; +} + +#ifndef DARWIN +#ifdef WINDOWS +extern void *windows_open_shared_library(char *); + +void * +xGetSharedLibrary(char *path, int mode) +{ + return windows_open_shared_library(path); +} +#else +void * +xGetSharedLibrary(char *path, int mode) +{ + return dlopen(path, mode); +} +#endif +#else +void * +xGetSharedLibrary(char *path, int *resultType) +{ + const char *error; + void *result; + + result = dlopen(path, RTLD_NOW | RTLD_GLOBAL); + + if (result == NULL) { + error = dlerror(); + *resultType = 0; + return (void *)error; + } + *resultType = 1; + return result; +} +#endif + + + +int +fd_setsize_bytes() +{ + return FD_SETSIZE/8; +} + +void +do_fd_set(int fd, fd_set *fdsetp) +{ + FD_SET(fd, fdsetp); +} + +void +do_fd_clr(int fd, fd_set *fdsetp) +{ + FD_CLR(fd, fdsetp); +} + +int +do_fd_is_set(int fd, fd_set *fdsetp) +{ + return FD_ISSET(fd,fdsetp); +} + + +void +do_fd_zero(fd_set *fdsetp) +{ + FD_ZERO(fdsetp); +} + +#include "image.h" + + + +Boolean +check_for_embedded_image ( +#ifdef WINDOWS + wchar_t *path +#else + char *path +#endif + ) +{ +#ifdef WINDOWS + int fd = wopen(path, O_RDONLY); +#else + int fd = open(path, O_RDONLY); +#endif + + Boolean image_is_embedded = false; + + if (fd >= 0) { + openmcl_image_file_header h; + + if (find_openmcl_image_file_header (fd, &h)) { + image_is_embedded = true; + } + close (fd); + } + return image_is_embedded; +} + +LispObj +load_image( +#ifdef WINDOWS + wchar_t * path +#else + char *path +#endif +) +{ +#ifdef WINDOWS + int fd = wopen(path, O_RDONLY, 0666), err; +#else + int fd = open(path, O_RDONLY, 0666), err; +#endif + LispObj image_nil = 0; + + if (fd > 0) { + openmcl_image_file_header ih; + + errno = 0; + image_nil = load_openmcl_image(fd, &ih); + /* We -were- using a duplicate fd to map the file; that + seems to confuse Darwin (doesn't everything ?), so + we'll instead keep the original file open. + */ + err = errno; + if (!image_nil) { + close(fd); + } +#ifdef WINDOWS + /* We currently don't actually map the image, and leaving the file + open seems to make it difficult to write to reliably. */ + if (image_nil) { + close(fd); + } +#endif + } else { + err = errno; + } + if (image_nil == 0) { +#ifdef WINDOWS + char *fmt = "Couldn't load lisp heap image from %ls"; +#else + char *fmt = "Couldn't load lisp heap image from %s"; +#endif + + fprintf(dbgout, fmt, path); + if (err == 0) { + fprintf(dbgout, "\n"); + } else { + fprintf(dbgout, ": %s\n", strerror(err)); + } + exit(-1); + } + return image_nil; +} + +int +set_errno(int val) +{ + errno = val; + return -1; +} + +/* A horrible hack to allow us to initialize a JVM instance from lisp. + On Darwin, creating a JVM instance clobbers the thread's existing + Mach exception infrastructure, so we save and restore it here. +*/ + +typedef int (*jvm_initfunc)(void*,void*,void*); + +int +jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2) +{ + int result = -1; + TCR *tcr = get_tcr(1); +#ifdef DARWIN + extern kern_return_t tcr_establish_lisp_exception_port(TCR *); +#endif + + result = f(arg0,arg1,arg2); +#ifdef DARWIN + tcr_establish_lisp_exception_port(tcr); +#endif + return result; +} + + + + +void * +xFindSymbol(void* handle, char *name) +{ +#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS) + return dlsym(handle, name); +#endif +#ifdef DARWIN + void *result; + + if ((handle == NULL) || (handle == ((void *) -1))) { + handle = RTLD_DEFAULT; + } + result = dlsym(handle, name); + if ((result == NULL) && (*name == '_')) { + result = dlsym(handle, name+1); + } + return result; +#endif +#ifdef WINDOWS + extern void *windows_find_symbol(void *, char *); + return windows_find_symbol(handle, name); +#endif +} + +void * +get_r_debug() +{ +#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS) +#if WORD_SIZE == 64 + extern Elf64_Dyn _DYNAMIC[]; + Elf64_Dyn *dp; +#else + extern Elf32_Dyn _DYNAMIC[]; + Elf32_Dyn *dp; +#endif + int tag; + + for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) { + if (tag == DT_DEBUG) { + return (void *)(dp->d_un.d_ptr); + } + } +#endif + return NULL; +} + + +#ifdef DARWIN +void +sample_paging_info(paging_info *stats) +{ + mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT; + + task_info(mach_task_self(), + TASK_EVENTS_INFO, + (task_info_t)stats, + &count); +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ + fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n", + stop->cow_faults-start->cow_faults, + stop->faults-start->faults, + stop->pageins-start->pageins); +} + +#else +#ifdef WINDOWS +void +sample_paging_info(paging_info *stats) +{ +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ +} +#else +void +sample_paging_info(paging_info *stats) +{ + getrusage(RUSAGE_SELF, stats); +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ + fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n", + stop->ru_minflt-start->ru_minflt, + stop->ru_majflt-start->ru_majflt, + stop->ru_nswap-start->ru_nswap); +} + +#endif +#endif Index: /branches/qres/ccl/lisp-kernel/ppc-asmutils.s =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-asmutils.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-asmutils.s (revision 13564) @@ -0,0 +1,458 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + include(lisp.s) + + _beginfile +/* Zero R4 cache lines, starting at address in R3. Each line is assumed to be */ +/* R5 bytes wide. */ +_exportfn(C(zero_cache_lines)) + __(cmpri(cr0,r4,0)) + __(mtctr r4) + __(beqlr) +1: + __(DCBZL(0,r3)) + __(add r3,r3,r5) + __(bdnz 1b) + __(blr) +_endfn + +/* Flush R4 cache lines, starting at address in R3. Each line is */ +/* assumed to be R5 bytes wide. */ +_exportfn(C(flush_cache_lines)) + __(cmpri(cr0,r4,0)) + __(mtctr r4) + __(mr r6,r3) + __(beqlr) +1: + __(dcbst 0,r3) + __(add r3,r3,r5) + __(bdnz 1b) + __(sync) /* wait until dcbst's get to memory */ + __(mr r3,r6) + __(mtctr r4) +2: + __(icbi 0,r3) + __(add r3,r3,r5) + __(bdnz 2b) + __(sync) + __(isync) + __(blr) +/* The strange reference to "exp" is supposed to force the kernel to */ +/* load libm, so lisp code can use it. Under Darwin, the functionality */ +/* of libm is contained in libsystem, along with libc & everything else. */ + + __ifndef(`DARWIN') + .data + __ifdef(`PPC64') + .quad exp + __else + .long exp + __endif + .text + __endif +_endfn + +_exportfn(C(touch_page)) + __(str(r3,0(r3))) + __(li r4,0) + __(str(r4,0(r3))) + __(li r3,1) /* can't assume that low 32 bits of r3 are non-zero */ + .globl C(touch_page_end) +C(touch_page_end): + __(blr) +_endfn + +_exportfn(C(current_stack_pointer)) + __(mr r3,sp) + __(blr) +_endfn + +_exportfn(C(count_leading_zeros)) + __ifdef(`PPC64') + __(cntlzd r3,r3) + __else + __(cntlzw r3,r3) + __endif + __(blr) +_endfn + +_exportfn(C(noop)) + __(blr) +_endfn + +_exportfn(C(set_fpscr)) + __(stru(sp,-32(sp))) + __(stw r3,12(sp)) + __(lfd f0,8(sp)) + __(mtfsf 0xff,f0) + __(la sp,32(sp)) + __(blr) +_endfn + + +_exportfn(C(get_fpscr)) + __(stru(sp,-32(sp))) + __(mffs f0) + __(stfd f0,8(sp)) + __(lwz r3,12(sp)) + __(la sp,32(sp)) + __(blr) +_endfn + + +/* The Linux kernel is constantly enabling and disabling the FPU and enabling */ +/* FPU exceptions. We can't touch the FPU without turning off the FPSCR`FEX' */ +/* bit and we can't turn off the FPSCR`FEX' bit without touching the FPU. */ +/* Force a distinguished exception, and let the handler for that exception */ +/* zero the fpscr in its exception context. */ + +_exportfn(C(zero_fpscr)) + __(uuo_zero_fpscr()) + __(blr) +_endfn + + +_exportfn(C(save_fp_context)) + __(subi r4,r3,8) + __(stfdu f0,8(r4)) + __(stfdu f1,8(r4)) + __(stfdu f2,8(r4)) + __(stfdu f3,8(r4)) + __(stfdu f4,8(r4)) + __(stfdu f5,8(r4)) + __(stfdu f6,8(r4)) + __(stfdu f7,8(r4)) + __(stfdu f8,8(r4)) + __(stfdu f9,8(r4)) + __(stfdu f10,8(r4)) + __(stfdu f11,8(r4)) + __(stfdu f12,8(r4)) + __(stfdu f13,8(r4)) + __(stfdu f14,8(r4)) + __(stfdu f15,8(r4)) + __(stfdu f16,8(r4)) + __(stfdu f17,8(r4)) + __(stfdu f18,8(r4)) + __(stfdu f19,8(r4)) + __(stfdu f20,8(r4)) + __(stfdu f21,8(r4)) + __(stfdu f22,8(r4)) + __(stfdu f23,8(r4)) + __(stfdu f24,8(r4)) + __(stfdu f25,8(r4)) + __(stfdu f26,8(r4)) + __(stfdu f27,8(r4)) + __(stfdu f28,8(r4)) + __(stfdu f29,8(r4)) + __(stfdu f30,8(r4)) + __(stfdu f31,8(r4)) + __(mffs f0) + __(stfd f0,8(r4)) + __(lfd f0,0(r3)) + __(blr) +_endfn + +_exportfn(C(restore_fp_context)) + __(mr r4,r3) + __(lfdu f1,8(r4)) + __(lfdu f2,8(r4)) + __(lfdu f3,8(r4)) + __(lfdu f4,8(r4)) + __(lfdu f5,8(r4)) + __(lfdu f6,8(r4)) + __(lfdu f7,8(r4)) + __(lfdu f8,8(r4)) + __(lfdu f9,8(r4)) + __(lfdu f10,8(r4)) + __(lfdu f11,8(r4)) + __(lfdu f12,8(r4)) + __(lfdu f13,8(r4)) + __(lfdu f14,8(r4)) + __(lfdu f15,8(r4)) + __(lfdu f16,8(r4)) + __(lfdu f17,8(r4)) + __(lfdu f18,8(r4)) + __(lfdu f19,8(r4)) + __(lfdu f20,8(r4)) + __(lfdu f21,8(r4)) + __(lfdu f22,8(r4)) + __(lfdu f23,8(r4)) + __(lfdu f24,8(r4)) + __(lfdu f25,8(r4)) + __(lfdu f26,8(r4)) + __(lfdu f27,8(r4)) + __(lfdu f28,8(r4)) + __(lfdu f29,8(r4)) + __(lfdu f30,8(r4)) + __(lfdu f31,8(r4)) + __(lfd f0,8(r4)) + __(mtfsf 0xff,f0) + __(lfd f0,0(r3)) + __(blr) +_endfn + + + +/* Atomically store new value (r5) in *r3, if old value == expected. */ +/* Return actual old value. */ + +_exportfn(C(store_conditional)) + __(mr r6,r3) +1: __(lrarx(r3,0,r6)) + __(cmpw r3,r4) + __(bne- 2f) + __(strcx(r5,0,r6)) + __(bne- 1b) + __(isync) + __(blr) +2: __(li r0,RESERVATION_DISCHARGE) + __(strcx(r0,0,r0)) + __(blr) +_endfn + +/* Atomically store new_value(r4) in *r3 ; return previous contents */ +/* of *r3. */ + +_exportfn(C(atomic_swap)) + __(sync) +1: __(lrarx(r5,0,r3)) + __(strcx(r4,0,r3)) + __(bne- 1b) + __(isync) + __(mr r3,r5) + __(blr) +_endfn + +/* Logior the value in *r3 with the value in r4 (presumably a bitmask with exactly 1 */ +/* bit set.) Return non-zero if any of the bits in that bitmask were already set. */ + +_exportfn(C(atomic_ior)) + __(sync) +1: __(lrarx(r5,0,r3)) + __(or r6,r4,r5) + __(strcx(r6,0,r3)) + __(bne- 1b) + __(isync) + __(and r3,r4,r5) + __(blr) +_endfn + + +/* Logand the value in *r3 with the value in r4 (presumably a bitmask with exactly 1 */ +/* bit set.) Return the value now in *r3 (for some value of "now" */ + +_exportfn(C(atomic_and)) + __(sync) +1: __(lrarx(r5,0,r3)) + __(and r6,r4,r5) + __(strcx(r6,0,r3)) + __(bne- 1b) + __(isync) + __(mr r3,r6) + __(blr) +_endfn + + + __ifdef(`DARWIN') +_exportfn(C(enable_fp_exceptions)) + __(.long 0) + __(blr) +_endfn + +_exportfn(C(disable_fp_exceptions)) + __(.long 0) + __(blr) +_endfn + +_exportfn(C(pseudo_sigreturn)) + __(.long 0) + __(b C(pseudo_sigreturn)) +_endfn + __endif + +/* Copy all 32 Altivec registers (+ VSCR & VRSAVE) to the buffer */ +/* in r3. If the buffer's non-NULL, it's aligned and big enough, */ +/* and Altivec is present. */ + +_exportfn(C(put_vector_registers)) + __(cmpri(r3,0)) + __(li r4,0) + __(beqlr) + __(stvx v0,r3,r4) + __(la r4,16(r4)) + __(stvx v1,r3,r4) + __(la r4,16(r4)) + __(stvx v2,r3,r4) + __(la r4,16(r4)) + __(stvx v3,r3,r4) + __(la r4,16(r4)) + __(stvx v4,r3,r4) + __(la r4,16(r4)) + __(stvx v5,r3,r4) + __(la r4,16(r4)) + __(stvx v6,r3,r4) + __(la r4,16(r4)) + __(stvx v7,r3,r4) + __(la r4,16(r4)) + __(stvx v8,r3,r4) + __(la r4,16(r4)) + __(stvx v9,r3,r4) + __(la r4,16(r4)) + __(stvx v10,r3,r4) + __(la r4,16(r4)) + __(stvx v11,r3,r4) + __(la r4,16(r4)) + __(stvx v12,r3,r4) + __(la r4,16(r4)) + __(stvx v13,r3,r4) + __(la r4,16(r4)) + __(stvx v14,r3,r4) + __(la r4,16(r4)) + __(stvx v15,r3,r4) + __(la r4,16(r4)) + __(stvx v16,r3,r4) + __(la r4,16(r4)) + __(stvx v17,r3,r4) + __(la r4,16(r4)) + __(stvx v18,r3,r4) + __(la r4,16(r4)) + __(stvx v19,r3,r4) + __(la r4,16(r4)) + __(stvx v20,r3,r4) + __(la r4,16(r4)) + __(stvx v21,r3,r4) + __(la r4,16(r4)) + __(stvx v22,r3,r4) + __(la r4,16(r4)) + __(stvx v23,r3,r4) + __(la r4,16(r4)) + __(stvx v24,r3,r4) + __(la r4,16(r4)) + __(stvx v25,r3,r4) + __(la r4,16(r4)) + __(stvx v26,r3,r4) + __(la r4,16(r4)) + __(stvx v27,r3,r4) + __(la r4,16(r4)) + __(stvx v28,r3,r4) + __(la r4,16(r4)) + __(stvx v29,r3,r4) + __(la r4,16(r4)) + __(stvx v30,r3,r4) + __(la r4,16(r4)) + __(stvx v31,r3,r4) + __(la r4,16(r4)) + __(mfvscr v0) + __(stvx v0,r3,r4) + __(mfspr r5,256) + __(stw r5,8(r4)) + __(blr) +_endfn + +_exportfn(C(get_vector_registers)) + __(cmpri(r3,0)) + __(li r4,32*16) + __(beqlr) + __(lvx v0,r3,r4) + __(mtvscr v0) + __(lwz r5,8(r4)) + __(mtspr 256,r5) + __(la r4,-16(r4)) + __(lvx v31,r3,r4) + __(la r4,-16(r4)) + __(lvx v30,r3,r4) + __(la r4,-16(r4)) + __(lvx v29,r3,r4) + __(la r4,-16(r4)) + __(lvx v28,r3,r4) + __(la r4,-16(r4)) + __(lvx v27,r3,r4) + __(la r4,-16(r4)) + __(lvx v26,r3,r4) + __(la r4,-16(r4)) + __(lvx v25,r3,r4) + __(la r4,-16(r4)) + __(lvx v24,r3,r4) + __(la r4,-16(r4)) + __(lvx v23,r3,r4) + __(la r4,-16(r4)) + __(lvx v22,r3,r4) + __(la r4,-16(r4)) + __(lvx v21,r3,r4) + __(la r4,-16(r4)) + __(lvx v20,r3,r4) + __(la r4,-16(r4)) + __(lvx v19,r3,r4) + __(la r4,-16(r4)) + __(lvx v18,r3,r4) + __(la r4,-16(r4)) + __(lvx v17,r3,r4) + __(la r4,-16(r4)) + __(lvx v16,r3,r4) + __(la r4,-16(r4)) + __(lvx v15,r3,r4) + __(la r4,-16(r4)) + __(lvx v14,r3,r4) + __(la r4,-16(r4)) + __(lvx v13,r3,r4) + __(la r4,-16(r4)) + __(lvx v12,r3,r4) + __(la r4,-16(r4)) + __(lvx v11,r3,r4) + __(la r4,-16(r4)) + __(lvx v10,r3,r4) + __(la r4,-16(r4)) + __(lvx v9,r3,r4) + __(la r4,-16(r4)) + __(lvx v8,r3,r4) + __(la r4,-16(r4)) + __(lvx v7,r3,r4) + __(la r4,-16(r4)) + __(lvx v6,r3,r4) + __(la r4,-16(r4)) + __(lvx v5,r3,r4) + __(la r4,-16(r4)) + __(lvx v4,r3,r4) + __(la r4,-16(r4)) + __(lvx v3,r3,r4) + __(la r4,-16(r4)) + __(lvx v2,r3,r4) + __(la r4,-16(r4)) + __(lvx v1,r3,r4) + __(la r4,-16(r4)) + __(lvx v0,r3,r4) + __(blr) +_endfn + +/* Some versions of Linux don't implement madvise(). That's */ +/* not catastrophic, but some versions of glibc will make a */ +/* big deal out of that at link time. This is here to try */ +/* to fool those versions of glibc. */ + + __ifdef(`LINUX') + .globl set_errno +_exportfn(C(madvise)) + __(li r0,205) /* _NR_madvise; see /usr/include/asm/unistd.h */ + __(sc) + __(bnslr) + __(b set_errno) +_endfn + __endif + + _endfile Index: /branches/qres/ccl/lisp-kernel/ppc-constants.h =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-constants.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-constants.h (revision 13564) @@ -0,0 +1,92 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __ppc_constants__ +#define __ppc_constants__ 1 + +/* Register usage: */ +#define rzero 0 +#define sp 1 +#define linux_sys_reg 2 /* volatile reg on Darwin ; thread ptr on Linux32, TOC on + Linux64. */ +#define imm0 3 +#define imm1 4 +#define imm2 5 +#define imm3 6 +#define imm4 7 +#define imm5 8 +#define allocptr 9 +#define allocbase 10 +#define nargs 11 +#define tsp 12 +#define loc_pc 14 /* code vector locative */ +#define vsp 15 +#define fn 16 +#define temp3 17 +#define temp2 18 +#define temp1 19 +#define temp0 20 +#define arg_x 21 +#define arg_y 22 +#define arg_z 23 +#define save7 24 +#define save6 25 +#define save5 26 +#define save4 27 +#define save3 28 +#define save2 29 +#define save1 30 +#define save0 31 + +#define vfp save0 /* frame pointer if needed (stack consing). */ +#define fname temp3 +#define nfn temp2 +#define next_method_context temp1 +#define closure_data temp0 + + +#define BA_MASK ((unsigned) ((-1<<26) | (1<<1))) +#define BA_VAL ((unsigned) ((18<<26) | (1<<1))) + +#define TCR_FLAG_BIT_FOREIGN fixnumshift +#define TCR_FLAG_BIT_AWAITING_PRESET (fixnumshift+1) +#define TCR_FLAG_BIT_ALT_SUSPEND (fixnumshift+2) +#define TCR_FLAG_BIT_PROPAGATE_EXCEPTION (fixnumshift+3) +#define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4) +#define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5) +#define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6) +#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7) + +#define TCR_STATE_FOREIGN (1) +#define TCR_STATE_LISP (0) +#define TCR_STATE_EXCEPTION_WAIT (2) +#define TCR_STATE_EXCEPTION_RETURN (4) + +#ifdef PPC64 +#include "ppc-constants64.h" +#else +#include "ppc-constants32.h" +#endif + +#define dnode_size (node_size*2) +#define dnode_shift (node_shift+1) + +#define INTERRUPT_LEVEL_BINDING_INDEX (1) + +#endif /* __ppc_constants__ */ + + Index: /branches/qres/ccl/lisp-kernel/ppc-constants.s =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-constants.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-constants.s (revision 13564) @@ -0,0 +1,239 @@ +/* Copyright (C) 2004-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +/* Register usage: */ + + +define(`rzero',`r0') +define(`sp',`r1') + +define(`imm0',`r3') +define(`imm1',`r4') +define(`imm2',`r5') +define(`imm3',`r6') +define(`imm4',`r7') +define(`imm5',`r8') +define(`allocptr',`r9') +define(`allocbase',`r10') +define(`nargs',`r11') +define(`tsp',`r12') /* temp-consing stack. */ + +define(`loc_pc',`r14') /* code vector locative */ +define(`vsp',`r15') +define(`fn',`r16') +define(`temp3',`r17') +define(`temp2',`r18') +define(`temp1',`r19') +define(`temp0',`r20') +define(`arg_x',`r21') +define(`arg_y',`r22') +define(`arg_z',`r23') +define(`save7',`r24') +define(`save6',`r25') +define(`save5',`r26') +define(`save4',`r27') +define(`save3',`r28') +define(`save2',`r29') +define(`save1',`r30') +define(`save0',`r31') + +define(`fname',`temp3') +define(`nfn',`temp2') +define(`next_method_context',`temp1') +define(`first_nvr',`save7') +define(`second_nvr',`save6') +define(`third_nvr',`save5') +define(`fourth_nvr',`save4') +define(`fifth_nvr',`save3') +define(`sixth_nvr',`save2') +define(`seventh_nvr',`save1') +define(`eighth_nvr',`save0') +define(`nargregs',`3') + +r0 = 0 +r1 = 1 +r2 = 2 +r3 = 3 +r4 = 4 +r5 = 5 +r6 = 6 +r7 = 7 +r8 = 8 +r9 = 9 +r10 = 10 +r11 = 11 +r12 = 12 +r13 = 13 +r14 = 14 +r15 = 15 +r16 = 16 +r17 = 17 +r18 = 18 +r19 = 19 +r20 = 20 +r21 = 21 +r22 = 22 +r23 = 23 +r24 = 24 +r25 = 25 +r26 = 26 +r27 = 27 +r28 = 28 +r29 = 29 +r30 = 30 +r31 = 31 + +/* Lisp code keeps 0.0 in fp_zero */ +define(`fp_zero',`f31') /* a non-volatile reg as far as FFI is concerned. */ +define(`fp_s32conv',`f30') /* for s32->fp conversion */ + +/* registers, as used in destrucuring-bind/macro-bind */ + +define(`whole_reg',`temp1') +define(`arg_reg',`temp3') +define(`keyvect_reg',`temp2') +define(`mask_req_start',`24') +define(`mask_req_width',`8') +define(`mask_opt_start',`16') +define(`mask_opt_width',`8') +define(`mask_key_start',`8') +define(`mask_key_width',`8') +define(`mask_initopt',`7') +define(`mask_keyp',`6') /* note that keyp can be true even when 0 keys. */ +define(`mask_aok',`5') +define(`mask_restp',`4') + +ifdef(`DARWIN',` + define(`STACK_ALIGN',16) + define(`STACK_ALIGN_MASK',15) +',` + define(`STACK_ALIGN',8) + define(`STACK_ALIGN_MASK',7) +') + +/* Indices in %builtin-functions% */ +_builtin_plus = 0 /* +-2 */ +_builtin_minus = 1 /* --2 */ +_builtin_times = 2 /* *-2 */ +_builtin_div = 3 /* /-2 */ +_builtin_eq = 4 /* =-2 */ +_builtin_ne = 5 /* /-2 */ +_builtin_gt = 6 /* >-2 */ +_builtin_ge = 7 /* >=-2 */ +_builtin_lt = 8 /* <-2 */ +_builtin_le = 9 /* <=-2 */ +_builtin_eql = 10 /* eql */ +_builtin_length = 11 /* length */ +_builtin_seqtype = 12 /* sequence-type */ +_builtin_assq = 13 /* assq */ +_builtin_memq = 14 /* memq */ +_builtin_logbitp = 15 /* logbitp */ +_builtin_logior = 16 /* logior-2 */ +_builtin_logand = 17 /* logand-2 */ +_builtin_ash = 18 /* ash */ +_builtin_negate = 19 /* %negate */ +_builtin_logxor = 20 /* logxor-2 */ +_builtin_aref1 = 21 /* %aref1 */ +_builtin_aset1 = 22 /* %aset1 */ + + /* FPSCR status bits */ +fpscr_FX = 0 +fpscr_FEX = 1 +fpscr_VX = 2 +fpscr_OX = 3 +fpscr_UX = 4 +fpscr_ZX = 5 +fpscr_XX = 6 + /* FPSCR control bits */ +fpscr_VE = 24 +fpscr_OE = 25 +fpscr_UE = 26 +fpscr_ZE = 27 +fpscr_XE = 28 + + +/* This should be (a) an (UNSIGNED-BYTE 16) and (b) one less than */ +/* TSTACK_SOFTPROT (defined in "area.h") */ + +tstack_alloc_limit = 0xffff + +define(`TCR_STATE_FOREIGN',1) +define(`TCR_STATE_LISP',0) +define(`TCR_STATE_EXCEPTION_WAIT',2) +define(`TCR_STATE_EXCEPTION_RETURN',4) + + + + +ifdef(`PPC64',` + include(ppc-constants64.s) +',` + include(ppc-constants32.s) +') + +num_lisp_globals = 49 /* MUST UPDATE THIS !!! */ + + _struct(lisp_globals,lisp_globals_limit-(num_lisp_globals*node_size)) + _node(weakvll) /* all populations as of last GC */ + _node(initial_tcr) /* initial thread tcr */ + _node(image_name) /* --image-name argument */ + _node(BADfpscr_save_high) /* high word of FP reg used to save FPSCR */ + _node(unwind_resume) /* _Unwind_Resume */ + _node(batch_flag) /* -b */ + _node(host_platform) /* for runtime platform-specific stuff */ + _node(argv) /* address of argv`0' */ + _node(errno) /* ADDRESS of errno */ + _node(tenured_area) /* the tenured_area */ + _node(oldest_ephemeral) /* dword address of oldest ephemeral object or 0 */ + _node(lisp_exit_hook) /* install foreign exception_handling */ + _node(lisp_return_hook) /* install lisp exception_handling */ + _node(double_float_one) /* high half of 1.0d0 */ + _node(short_float_zero) /* low half of 1.0d0 */ + _node(objc2_end_catch) /* objc_end_catch() */ + _node(metering_info) /* address of lisp_metering global */ + _node(in_gc) /* non-zero when GC active */ + _node(lexpr_return1v) /* simpler when &lexpr called for single value. */ + _node(lexpr_return) /* magic &lexpr return code. */ + _node(all_areas) /* doubly-linked list of all memory areas */ + _node(kernel_path) /* real executable name */ + _node(objc2_begin_catch) /* objc_begin_catch */ + _node(BAD_current_vs) /* current value-stack area */ + _node(statically_linked) /* non-zero if -static */ + _node(heap_end) /* end of lisp heap */ + _node(heap_start) /* start of lisp heap */ + _node(gcable_pointers) /* linked-list of weak macptrs. */ + _node(gc_num) /* fixnum: GC call count. */ + _node(fwdnum) /* fixnum: GC "forwarder" call count. */ + _node(altivec_present) /* non-zero when AltiVec available */ + _node(oldspace_dnode_count) /* dynamic dnodes older than g0 start */ + _node(refbits) /* EGC refbits */ + _node(gc_inhibit_count) + _node(intflag) /* sigint pending */ + _node(BAD_block_tag_counter) /* counter for (immediate) block tag */ + _node(deleted_static_pairs) + _node(exception_lock) + _node(area_lock) + _node(tcr_key) /* tsd key for per-thread tcr */ + _node(ret1val_addr) /* address of "dynamic" subprims magic values return addr */ + _node(subprims_base) /* address of dynamic subprims jump table */ + _node(saveR13) /* probably don't really need this */ + _node(saveTOC) /* where the 68K emulator stores the emulated regs */ + _node(objc_2_personality) /* exception "personality routine" address for ObjC 2.0 */ + _node(kernel_imports) /* some things we need imported for us */ + _node(interrupt_signal) /* signal used by PROCESS-INTERRUPT */ + _node(tcr_count) /* tcr_id for next tcr */ + _node(get_tcr) /* address of get_tcr() */ + _ends + Index: /branches/qres/ccl/lisp-kernel/ppc-constants32.h =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-constants32.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-constants32.h (revision 13564) @@ -0,0 +1,475 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __constants32__ +#define __constants32__ 1 + +#define rcontext 13 + +#define nbits_in_word 32 +#define log2_nbits_in_word 5 +#define nbits_in_byte 8 +#define ntagbits 3 /* But only 2 are significant to lisp */ +#define nlisptagbits 2 +#define nfixnumtagbits 2 +#define num_subtag_bits 8 +#define fixnumshift 2 +#define fixnum_shift 2 +#define fulltagmask 7 +#define tagmask 3 +#define fixnummask 3 +#define subtagmask ((1< 4 (so that code-vector entry-points can be branched to, since the low */ +/* two bits of the PC are ignored) and that both FULLTAG-MISC and FULLTAG-IMM have header fulltags */ +/* that share the same TAG. */ +/* Things that walk memory (and the stack) have to be careful to look at the FULLTAG of each */ +/* object that they see. */ + +#define fulltag_even_fixnum 0 /* I suppose EVENP/ODDP might care; nothing else does. */ +#define fulltag_cons 1 /* a real (non_null) cons. Shares TAG with fulltag_nil. */ +#define fulltag_nodeheader 2 /* Header of heap_allocated object that contains lisp_object pointers */ +#define fulltag_imm 3 /* a "real" immediate object. Shares TAG with fulltag_immheader. */ +#define fulltag_odd_fixnum 4 /* */ +#define fulltag_nil 5 /* NIL and nothing but. (Note that there's still a hidden NILSYM.) */ +#define fulltag_misc 6 /* Pointer "real" tag_misc object. Shares TAG with fulltag_nodeheader. */ +#define fulltag_immheader 7 /* Header of heap-allocated object that contains unboxed data. */ + + + +/* Order of CAR and CDR doesn't seem to matter much - there aren't */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + +typedef struct cons { + LispObj cdr; + LispObj car; +} cons; + + +#define misc_header_offset -fulltag_misc +#define misc_subtag_offset misc_header_offset+3 /* low byte of header */ +#define misc_data_offset misc_header_offset+4 /* first word of data */ +#define misc_dfloat_offset misc_header_offset+8 /* double-floats are doubleword-aligned */ + +#define max_64_bit_constant_index ((0x7fff + misc_dfloat_offset)>>3) +#define max_32_bit_constant_index ((0x7fff + misc_data_offset)>>2) +#define max_16_bit_constant_index ((0x7fff + misc_data_offset)>>1) +#define max_8_bit_constant_index (0x7fff + misc_data_offset) +#define max_1_bit_constant_index ((0x7fff + misc_data_offset)<<5) + +/* T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans */ +/* two doublewords. The arithmetic difference between T and NIL is */ +/* such that the least-significant bit and exactly one other bit is */ +/* set in the result. */ + +#define t_offset (8+(8-fulltag_nil)+fulltag_misc) +#define t_value (lisp_nil+t_offset) + +/* The order in which various header values are defined is significant in several ways: */ +/* 1) Numeric subtags precede non-numeric ones; there are further orderings among numeric subtags. */ +/* 2) All subtags which denote CL arrays are preceded by those that don't, */ +/* with a further ordering which requires that (< header-arrayH header-vectorH ,@all-other-CL-vector-types) */ +/* 3) The element-size of ivectors is determined by the ordering of ivector subtags. */ +/* 4) All subtags are >= fulltag-immheader . */ + +#define SUBTAG(tag,subtag) ((tag) | ((subtag) << ntagbits)) +#define IMM_SUBTAG(subtag) SUBTAG(fulltag_immheader,(subtag)) +#define NODE_SUBTAG(subtag) SUBTAG(fulltag_nodeheader,(subtag)) + + +/* Numeric subtags. */ + +#define subtag_bignum IMM_SUBTAG(0) +#define min_numeric_subtag subtag_bignum + +#define subtag_ratio NODE_SUBTAG(1) +#define max_rational_subtag subtag_ratio + +#define subtag_single_float IMM_SUBTAG(1) +#define subtag_double_float IMM_SUBTAG(2) +#define min_float_subtag subtag_single_float +#define max_float_subtag subtag_double_float +#define max_real_subtag subtag_double_float + +#define subtag_complex NODE_SUBTAG(3) +#define max_numeric_subtag subtag_complex + + +/* CL array types. There are more immediate types than node types; all CL array subtags must be > than */ +/* all non-CL-array subtags. So we start by defining the immediate subtags in decreasing order, starting */ +/* with that subtag whose element size isn't an integral number of bits and ending with those whose */ +/* element size - like all non-CL-array fulltag-immheader types - is 32 bits. */ + +#define subtag_bit_vector IMM_SUBTAG(31) +#define subtag_double_float_vector IMM_SUBTAG(30) +#define subtag_s16_vector IMM_SUBTAG(29) +#define subtag_u16_vector IMM_SUBTAG(28) +#define min_16_bit_ivector_subtag subtag_u16_vector +#define max_16_bit_ivector_subtag subtag_s16_vector + +#define subtag_s8_vector IMM_SUBTAG(26) +#define subtag_u8_vector IMM_SUBTAG(25) +#define min_8_bit_ivector_subtag subtag_u8_vector +#define max_8_bit_ivector_subtag IMM_SUBTAG(27) + +#define subtag_simple_base_string IMM_SUBTAG(24) +#define subtag_fixnum_vector IMM_SUBTAG(23) +#define subtag_s32_vector IMM_SUBTAG(22) +#define subtag_u32_vector IMM_SUBTAG(21) +#define subtag_single_float_vector IMM_SUBTAG(20) +#define max_32_bit_ivector_subtag IMM_SUBTAG(24) +#define min_cl_ivector_subtag subtag_single_float_vector + + +#define subtag_vectorH NODE_SUBTAG(20) +#define subtag_arrayH NODE_SUBTAG(19) +#define subtag_simple_vector NODE_SUBTAG(21) /* Only one such subtag) */ +#define min_vector_subtag subtag_vectorH +#define min_array_subtag subtag_arrayH + +/* So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag)) */ +/* for various immediate/node object types. */ + +#define subtag_macptr IMM_SUBTAG(3) +#define min_non_numeric_imm_subtag subtag_macptr + +#define subtag_dead_macptr IMM_SUBTAG(4) +#define subtag_code_vector IMM_SUBTAG(5) +#define subtag_creole IMM_SUBTAG(6) + +#define max_non_array_imm_subtag ((19<> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + + +#define population_weak_list (0< call lisp_exit_hook */ + void *native_thread_info; /* platform-dependent */ + void *native_thread_id; /* mach_thread_t, pid_t, etc. */ + void *last_allocptr; + void *save_allocptr; + void *save_allocbase; + void *reset_completion; + void *activate; + int suspend_count; + ExceptionInformation *suspend_context; + ExceptionInformation *pending_exception_context; + void *suspend; /* suspension semaphore */ + void *resume; /* resumption semaphore */ + natural flags; + ExceptionInformation *gc_context; + void *termination_semaphore; + int unwinding; + unsigned tlb_limit; + LispObj *tlb_pointer; + unsigned shutdown_count; + void *safe_ref_address; +} TCR; + +/* + These were previously global variables. There are lots of implicit + assumptions about the size of a heap segment, so they might as well + be constants. +*/ + +#define heap_segment_size 0x00010000 +#define log2_heap_segment_size 16 + + +#endif + Index: /branches/qres/ccl/lisp-kernel/ppc-constants32.s =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-constants32.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-constants32.s (revision 13564) @@ -0,0 +1,687 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +define(`rcontext',`r13') + +nbits_in_word = 32 +nbits_in_byte = 8 +ntagbits = 3 /* But only 2 are significant to lisp */ +nlisptagbits = 2 +nfixnumtagbits = 2 +num_subtag_bits = 8 +fixnumshift = 2 +fixnum_shift = 2 +fulltagmask = 7 +tagmask = 3 +fixnummask = 3 +ncharcodebits = 24 /* arguably, we're only using the low 8 */ +charcode_shift = nbits_in_word-ncharcodebits +word_shift = 2 +node_size = 4 +dnode_size = 8 +dnode_align_bits = 3 +dnode_shift = dnode_align_bits +bitmap_shift = 5 + + +fixnumone = (1< 4 (so that code-vector entry-points can be branched to, since the low */ +/* two bits of the PC are ignored) and that both FULLTAG-MISC and FULLTAG-IMM have header fulltags */ +/* that share the same TAG. */ +/* Things that walk memory (and the stack) have to be careful to look at the FULLTAG of each */ +/* object that they see. */ + + +fulltag_even_fixnum = 0 /* I suppose EVENP/ODDP might care; nothing else does. */ +fulltag_cons = 1 /* a real (non_null) cons. Shares TAG with fulltag_nil. */ +fulltag_nodeheader = 2 /* Header of heap_allocated object that contains lisp_object pointers */ +fulltag_imm = 3 /* a "real" immediate object. Shares TAG with fulltag_immheader. */ +fulltag_odd_fixnum = 4 /* */ +fulltag_nil = 5 /* NIL and nothing but. (Note that there's still a hidden NILSYM.) */ +fulltag_misc = 6 /* Pointer "real" tag_misc object. Shares TAG with fulltag_nodeheader. */ +fulltag_immheader = 7 /* Header of heap-allocated object that contains unboxed data. */ + +nil_value = 0x00003015+LOWMEM_BIAS +misc_bias = fulltag_misc +cons_bias = tag_list + +/* Functions are of (conceptually) unlimited size. */ + _struct(_function,-misc_bias) + _node(header) + _node(codevector) + _ends + + _struct(tsp_frame,0) + _node(backlink) + _node(type) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + +/* Order of CAR and CDR doesn't seem to matter much - there aren't */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + _struct(cons,-cons_bias) + _node(cdr) + _node(car) + _ends + +misc_header_offset = -fulltag_misc +misc_subtag_offset = misc_header_offset+3 /* low byte of header */ +misc_data_offset = misc_header_offset+4 /* first word of data */ +misc_dfloat_offset = misc_header_offset+8 /* double-floats are doubleword-aligned */ + +max_64_bit_constant_index = ((0x7fff + misc_dfloat_offset)>>3) +max_32_bit_constant_index = ((0x7fff + misc_data_offset)>>2) +max_16_bit_constant_index = ((0x7fff + misc_data_offset)>>1) +max_8_bit_constant_index = (0x7fff + misc_data_offset) +max_1_bit_constant_index = ((0x7fff + misc_data_offset)<<5) + +/* T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans */ +/* two doublewords. The arithmetic difference between T and NIL is */ +/* such that the least-significant bit and exactly one other bit is */ +/* set in the result. */ + +t_offset = (8+(8-fulltag_nil)+fulltag_misc) +t_value = nil_value+t_offset + +/* The order in which various header values are defined is significant in several ways: */ +/* 1) Numeric subtags precede non-numeric ones; there are further orderings among numeric subtags. */ +/* 2) All subtags which denote CL arrays are preceded by those that don't, */ +/* with a further ordering which requires that (< header-arrayH header-vectorH ,@all-other-CL-vector-types) */ +/* 3) The element-size of ivectors is determined by the ordering of ivector subtags. */ +/* 4) All subtags are >= fulltag-immheader . */ + +define(`define_subtag',` +subtag_$1 = $2|($3< than */ +/* all non-CL-array subtags. So we start by defining the immediate subtags in decreasing order, starting */ +/* with that subtag whose element size isn't an integral number of bits and ending with those whose */ +/* element size - like all non-CL-array fulltag-immheader types - is 32 bits. */ + + define_imm_subtag(bit_vector,31) + define_imm_subtag(double_float_vector,30) + define_imm_subtag(s16_vector,29) + define_imm_subtag(u16_vector,28) +min_16_bit_ivector_subtag = subtag_u16_vector +max_16_bit_ivector_subtag = subtag_s16_vector + define_imm_subtag(s8_vector,26) + define_imm_subtag(u8_vector,25) +min_8_bit_ivector_subtag = subtag_u8_vector +max_8_bit_ivector_subtag = fulltag_immheader|(27< max-numeric-subtag) & (n < min-array-subtag)) */ +/* for various immediate/node object types. */ + + define_imm_subtag(macptr,3) +min_non_numeric_imm_subtag = subtag_macptr + + define_imm_subtag(dead_macptr,4) + define_imm_subtag(code_vector,5) + define_imm_subtag(creole,6) + +max_non_array_imm_subtag = (18< -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(csp) /* pointer to lisp_frame on csp */ + _node(db_link) /* head of special-binding chain */ + _field(regs,8*node_size) /* save7-save0 */ + _node(xframe) /* exception frame chain */ + _node(tsp_segment) /* maybe someday; padding for now */ + _endstructf + + _structf(macptr) + _node(address) + _node(domain) + _node(type) + _endstructf + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + + + _struct(c_frame,0) /* PowerOpen ABI C stack frame */ + _node(backlink) + _node(crsave) + _node(savelr) + _field(unused, 8) + _node(savetoc) + _struct_label(params) + _node(param0) + _node(param1) + _node(param2) + _node(param3) + _node(param4) + _node(param5) + _node(param6) + _node(param7) + _struct_label(minsiz) + _ends + + + _struct(eabi_c_frame,0) + _word(backlink) + _word(savelr) + _word(param0) + _word(param1) + _word(param2) + _word(param3) + _word(param4) + _word(param5) + _word(param6) + _word(param7) + _struct_label(minsiz) + _ends + + /* For entry to variable-argument-list functions */ +/* (e.g., via callback) */ + _struct(varargs_eabi_c_frame,0) + _word(backlink) + _word(savelr) + _struct_label(va_list) + _word(flags) /* gpr count byte, fpr count byte, padding */ + _word(overflow_arg_area) + _word(reg_save_area) + _field(padding,4) + _struct_label(regsave) + _field(gp_save,8*node_size) + _field(fp_save,8*8) + _word(old_backlink) + _word(old_savelr) + _struct_label(incoming_stack_args) + _ends + + _struct(lisp_frame,0) + _node(backlink) + _node(savefn) + _node(savelr) + _node(savevsp) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + + + +symbol_extra = symbol.size-fulltag_misc + + _struct(nrs,nil_value-fulltag_nil) + _struct_pad(fulltag_nil) + _field(nilptr,16-fulltag_nil) + + _struct_pad(fulltag_misc) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_misc) + _struct_label(nilsym) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_misc) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_misc) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_misc) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_misc) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_misc) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_misc) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_misc) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_misc) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_misc) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_misc) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_misc) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_misc) + _struct_label(total_bytes_freed) /* *total-bytes-freed* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_misc) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_misc) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_misc) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_misc) + _struct_label(total_gc_microseconds) /* *total-gc-microseconds* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(builtin_functions) /* %builtin-functions% */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_misc) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_misc) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_misc) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_misc) + _struct_label(new_gcable_ptr) /* %new-gcable-ptr */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_misc) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_misc) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + + _struct_pad(fulltag_misc) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_misc) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_misc) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_misc) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define(`def_header',` +$1 = ($2<lisp code that needs to save/restore C NVRs in a TSP frame. */ + _struct(c_reg_save,0) + _node(tsp_link) /* backpointer */ + _node(tsp_mark) /* frame type */ + _node(save_fpscr) /* for Cs FPSCR */ + _field(save_gprs,19*4) /* r13-r31 */ + _dword(save_fp_zero) /* for fp_zero */ + _dword(save_fps32conv) + _field(save_fprs,13*8) + _ends + + +TCR_BIAS = 0 +/* TCR_BIAS = 0x7000 */ + +/* Thread context record. */ + + _struct(tcr,-TCR_BIAS) + _node(prev) /* in doubly-linked list */ + _node(next) /* in doubly-linked list */ + _node(lisp_fpscr) /* lisp thread's fpscr (in low word) */ + _node(lisp_fpscr_low) + _node(db_link) /* special binding chain head */ + _node(catch_top) /* top catch frame */ + _node(save_vsp) /* VSP when in foreign code */ + _node(save_tsp) /* TSP when in foreign code */ + _node(cs_area) /* cstack area pointer */ + _node(vs_area) /* vstack area pointer */ + _node(ts_area) /* tstack area pointer */ + _node(cs_limit) /* cstack overflow limit */ + _node(bytes_consed_high) + _node(bytes_consed_low) + _node(log2_allocation_quantum) + _node(interrupt_pending) + _node(xframe) /* per-thread exception frame list */ + _node(errno_loc) /* per-thread errno location */ + _node(ffi_exception) /* fpscr exception bits from ff-call */ + _node(osid) /* OS thread id */ + _node(valence) /* odd when in foreign code */ + _node(foreign_exception_status) + _node(native_thread_info) + _node(native_thread_id) + _node(last_allocptr) + _node(save_allocptr) + _node(save_allocbase) + _node(reset_completion) + _node(activate) + _node(suspend_count) + _node(suspend_context) + _node(pending_exception_context) + _node(suspend) /* semaphore for suspension notify */ + _node(resume) /* sempahore for resumption notify */ + _node(flags) + _node(gc_context) + _node(termination_semaphore) + _node(unwinding) + _node(tlb_limit) + _node(tlb_pointer) /* Consider using tcr+N as tlb_pointer */ + _node(shutdown_count) + _node(safe_ref_address) + _ends + +TCR_FLAG_BIT_FOREIGN = fixnum_shift +TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) +TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) +TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) +TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) +TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) +TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) +TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) + +r0 = 0 +r1 = 1 +r2 = 2 +r3 = 3 +r4 = 4 +r5 = 5 +r6 = 6 +r7 = 7 +r8 = 8 +r9 = 9 +r10 = 10 +r11 = 11 +r12 = 12 +r13 = 13 +r14 = 14 +r15 = 15 +r16 = 16 +r17 = 17 +r18 = 18 +r19 = 19 +r20 = 20 +r21 = 21 +r22 = 22 +r23 = 23 +r24 = 24 +r25 = 25 +r26 = 26 +r27 = 27 +r28 = 28 +r29 = 29 +r30 = 30 +r31 = 31 + +/* Lisp code keeps 0.0 in fp_zero */ +define(`fp_zero',`f31') /* a non-volatile reg as far as FFI is concerned. */ +define(`fp_s32conv',`f30') /* for s32->fp conversion */ + +/* registers, as used in destrucuring-bind/macro-bind */ + +define(`whole_reg',`temp1') +define(`arg_reg',`temp3') +define(`keyvect_reg',`temp2') +define(`mask_req_start',`24') +define(`mask_req_width',`8') +define(`mask_opt_start',`16') +define(`mask_opt_width',`8') +define(`mask_key_start',`8') +define(`mask_key_width',`8') +define(`mask_initopt',`7') +define(`mask_keyp',`6') /* note that keyp can be true even when 0 keys. */ +define(`mask_aok',`5') +define(`mask_restp',`4') + +ifdef(`DARWIN',` + define(`STACK_ALIGN',16) + define(`STACK_ALIGN_MASK',15) +',` + define(`STACK_ALIGN',8) + define(`STACK_ALIGN_MASK',7) +') + +define(`TCR_STATE_FOREIGN',1) +define(`TCR_STATE_LISP',0) +define(`TCR_STATE_EXCEPTION_WAIT',2) +define(`TCR_STATE_EXCEPTION_RETURN',4) + +define(`RESERVATION_DISCHARGE',0x2004) + +lisp_globals_limit = (0x3010+(LOWMEM_BIAS)) + +INTERRUPT_LEVEL_BINDING_INDEX = fixnumone Index: /branches/qres/ccl/lisp-kernel/ppc-constants64.h =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-constants64.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-constants64.h (revision 13564) @@ -0,0 +1,456 @@ +/* + Copyright (C) 2003-2009, Clozure Associates. + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __constants64__ +#define __constants64__ 1 + +#define rcontext 2 + +#define nbits_in_word 64L +#define log2_nbits_in_word 6L +#define nbits_in_byte 8L +#define ntagbits 4L +#define nlisptagbits 3L +#define nfixnumtagbits 2L +#define num_subtag_bits 8L +#define fixnumshift 3L +#define fixnum_shift 3L +#define fulltagmask 15L +#define tagmask 7L +#define fixnummask 3 +#define subtagmask ((1L<>3) +#define max_32_bit_constant_index ((0x7fff + misc_data_offset)>>2) +#define max_16_bit_constant_index ((0x7fff + misc_data_offset)>>1) +#define max_8_bit_constant_index (0x7fff + misc_data_offset) +#define max_1_bit_constant_index ((0x7fff + misc_data_offset)<<5) + + +/* The objects themselves look something like this: */ + +/* Order of CAR and CDR doesn't seem to matter much - there aren't */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + +typedef struct cons { + LispObj cdr; + LispObj car; +} cons; + + + +typedef struct lispsymbol { + LispObj header; + LispObj pname; + LispObj vcell; + LispObj fcell; + LispObj package_predicate; + LispObj flags; + LispObj plist; + LispObj binding_index; +} lispsymbol; + +typedef struct ratio { + LispObj header; + LispObj numer; + LispObj denom; +} ratio; + +typedef struct double_float { + LispObj header; + LispObj value; +} double_float; + + +typedef struct macptr { + LispObj header; + LispObj address; + LispObj class; + LispObj type; +} macptr; + +typedef struct xmacptr { + LispObj header; + LispObj address; + LispObj class; + LispObj type; + LispObj flags; + LispObj link; +} xmacptr; + + +typedef struct eabi_c_frame { + struct eabi_c_frame *backlink; + unsigned savelr; + LispObj params[8]; +} eabi_c_frame; + +/* PowerOpen ABI C frame */ + +typedef struct c_frame { + struct c_frame *backlink; + natural crsave; + natural savelr; + natural unused[2]; + natural savetoc; /* Used with CFM (and on Linux.) */ + natural params[8]; /* Space for callee to save r3-r10 */ +} c_frame; + +typedef struct lisp_frame { + struct lisp_frame *backlink; + LispObj savefn; + LispObj savelr; + LispObj savevsp; +} lisp_frame; + +typedef struct special_binding { + struct special_binding *link; + struct lispsymbol *sym; + LispObj value; +} special_binding; + +/* The GC (at least) needs to know what a + package looks like, so that it can do GCTWA. */ +typedef struct package { + LispObj header; + LispObj itab; /* itab and etab look like (vector (fixnum . fixnum) */ + LispObj etab; + LispObj used; + LispObj used_by; + LispObj names; + LispObj shadowed; +} package; + +/* + The GC also needs to know what a catch_frame looks like. +*/ + +typedef struct catch_frame { + LispObj header; + LispObj catch_tag; + LispObj link; + LispObj mvflag; + LispObj csp; + LispObj db_link; + LispObj regs[8]; + LispObj xframe; + LispObj tsp_segment; +} catch_frame; + +#define catch_frame_element_count ((sizeof(catch_frame)/sizeof(LispObj))-1) +#define catch_frame_header make_header(subtag_catch_frame,catch_frame_element_count) + + +/* + All exception frames in a thread are linked together + */ +typedef struct xframe_list { + ExceptionInformation *curr; + struct xframe_list *prev; +} xframe_list; + +#define fixnum_bitmask(n) (1LL<<((n)+fixnumshift)) + +/* + The GC (at least) needs to know about hash-table-vectors and their flag bits. +*/ + +typedef struct hash_table_vector_header { + LispObj header; + LispObj link; /* If weak */ + LispObj flags; /* a fixnum; see below */ + LispObj gc_count; /* gc-count kernel global */ + LispObj free_alist; /* preallocated conses for finalization_alist */ + LispObj finalization_alist; /* key/value alist for finalization */ + LispObj weak_deletions_count; /* incremented when GC deletes weak pair */ + LispObj hash; /* backpointer to hash-table */ + LispObj deleted_count; /* number of deleted entries [not maintained if lock-free] */ + LispObj count; /* number of valid entries [not maintained if lock-free] */ + LispObj cache_idx; /* index of last cached pair */ + LispObj cache_key; /* value of last cached key */ + LispObj cache_value; /* last cached value */ + LispObj size; /* number of entries in table */ + LispObj size_reciprocal; /* shifted reciprocal of size */ +} hash_table_vector_header; + +/* + Bits (masks) in hash_table_vector.flags: +*/ + +/* GC should track keys when addresses change */ +#define nhash_track_keys_mask fixnum_bitmask(28) + +/* GC should set when nhash_track_keys_bit & addresses change */ +#define nhash_key_moved_mask fixnum_bitmask(27) + +/* weak on key or value (need new "weak both" encoding.) */ +#define nhash_weak_mask fixnum_bitmask(12) + +/* weak on value */ +#define nhash_weak_value_mask fixnum_bitmask(11) + +/* finalizable */ +#define nhash_finalizable_mask fixnum_bitmask(10) + +/* keys frozen, i.e. don't clobber keys, only values */ +#define nhash_keys_frozen_mask fixnum_bitmask(9) + +/* Lfun bits */ + +#define lfbits_nonnullenv_mask fixnum_bitmask(0) +#define lfbits_keys_mask fixnum_bitmask(1) +#define lfbits_restv_mask fixnum_bitmask(7) +#define lfbits_optinit_mask fixnum_bitmask(14) +#define lfbits_rest_mask fixnum_bitmask(15) + +#define lfbits_aok_mask fixnum_bitmask(16) +#define lfbits_lap_mask fixnum_bitmask(23) +#define lfbits_trampoline_mask fixnum_bitmask(24) +#define lfbits_evaluated_mask fixnum_bitmask(25) +#define lfbits_cm_mask fixnum_bitmask(26) /* combined_method */ +#define lfbits_nextmeth_mask fixnum_bitmask(26) /* or call_next_method with method_mask */ +#define lfbits_gfn_mask fixnum_bitmask(27) /* generic_function */ +#define lfbits_nextmeth_with_args_mask fixnum_bitmask(27) /* or call_next_method_with_args with method_mask */ +#define lfbits_method_mask fixnum_bitmask(28) /* method function */ +/* PPC only but want it defined for xcompile */ +#define lfbits_noname_mask fixnum_bitmask(29) + + +/* Creole */ + +#define doh_quantum 400 +#define doh_block_slots ((doh_quantum >> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + + +#define population_weak_list (0< call lisp_exit_hook */ + void* native_thread_info; /* platform-dependent */ + void* native_thread_id; /* mach_thread_t, pid_t, etc. */ + void* last_allocptr; + void* save_allocptr; + void* save_allocbase; + void* reset_completion; + void* activate; + signed_natural suspend_count; + ExceptionInformation* suspend_context; + ExceptionInformation* pending_exception_context; + void* suspend; /* suspension semaphore */ + void* resume; /* resumption semaphore */ + natural flags; + ExceptionInformation* gc_context; + void* termination_semaphore; + signed_natural unwinding; + natural tlb_limit; + LispObj* tlb_pointer; + natural shutdown_count; + void *safe_ref_address; +} TCR; + +#define t_offset -(sizeof(lispsymbol)) + +/* + These were previously global variables. There are lots of implicit + assumptions about the size of a heap segment, so they might as well + be constants. +*/ + +#define heap_segment_size 0x00020000L +#define log2_heap_segment_size 17L + +#endif + Index: /branches/qres/ccl/lisp-kernel/ppc-constants64.s =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-constants64.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-constants64.s (revision 13564) @@ -0,0 +1,596 @@ +/* Copyright (C) 2003-2009, Clozure Associates. */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +define(`rcontext',`r2') + +nbits_in_word = 64 +nbits_in_byte = 8 +ntagbits = 4 +nlisptagbits = 3 +nfixnumtagbits = 3 +nlowtagbits = 2 +num_subtag_bits = 8 +fixnumshift = 3 +fixnum_shift = 3 +fulltagmask = 15 +tagmask = 7 +fixnummask = 7 +ncharcodebits = 8 +charcode_shift = 8 +word_shift = 3 +node_size = 8 +dnode_size = 16 +dnode_align_bits = 4 +dnode_shift = dnode_align_bits +bitmap_shift = 6 + +fixnumone = (1<>3) +max_32_bit_constant_index = ((0x7fff + misc_data_offset)>>2) +max_16_bit_constant_index = ((0x7fff + misc_data_offset)>>1) +max_8_bit_constant_index = (0x7fff + misc_data_offset) +max_1_bit_constant_index = ((0x7fff + misc_data_offset)<<5) + + + +/* The objects themselves look something like this: */ + +/* Order of CAR and CDR doesn't seem to matter much - there aren't */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + _struct(cons,-cons_bias) + _node(cdr) + _node(car) + _ends + + _structf(ratio) + _node(numer) + _node(denom) + _endstructf + + _structf(double_float) + _word(value) + _word(val_low) + _endstructf + + _structf(macptr) + _node(address) + _node(domain) + _node(type) + _endstructf + +/* Functions are of (conceptually) unlimited size. */ + _struct(_function,-misc_bias) + _node(header) + _node(codevector) + _ends + + _struct(tsp_frame,0) + _node(backlink) + _node(type) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + + + + _structf(symbol) + _node(pname) + _node(vcell) + _node(fcell) + _node(package_predicate) + _node(flags) + _node(plist) + _node(binding_index) + _endstructf + + _structf(catch_frame) + _node(catch_tag) /* # -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(csp) /* pointer to lisp_frame on csp */ + _node(db_link) /* head of special-binding chain */ + _field(regs,8*node_size) /* save7-save0 */ + _node(xframe) /* exception frame chain */ + _node(tsp_segment) /* maybe someday; padding for now */ + _endstructf + + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + _struct(c_frame,0) /* PowerOpen ABI C stack frame */ + _node(backlink) + _node(crsave) + _node(savelr) + _field(unused, 16) + _node(savetoc) + _struct_label(params) + _node(param0) + _node(param1) + _node(param2) + _node(param3) + _node(param4) + _node(param5) + _node(param6) + _node(param7) + _struct_label(minsiz) + _ends + + + _struct(eabi_c_frame,0) + _word(backlink) + _word(savelr) + _word(param0) + _word(param1) + _word(param2) + _word(param3) + _word(param4) + _word(param5) + _word(param6) + _word(param7) + _struct_label(minsiz) + _ends + + /* For entry to variable-argument-list functions */ + /* (e.g., via callback) */ + _struct(varargs_eabi_c_frame,0) + _word(backlink) + _word(savelr) + _struct_label(va_list) + _word(flags) /* gpr count byte, fpr count byte, padding */ + _word(overflow_arg_area) + _word(reg_save_area) + _field(padding,4) + _struct_label(regsave) + _field(gp_save,8*4) + _field(fp_save,8*8) + _word(old_backlink) + _word(old_savelr) + _struct_label(incoming_stack_args) + _ends + + _struct(lisp_frame,0) + _node(backlink) + _node(savefn) + _node(savelr) + _node(savevsp) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + + +/* Nilreg-relative globals. Talking the assembler into doing something reasonable here */ +/* is surprisingly hard. */ + +symbol_extra = symbol.size-fulltag_misc + + + _struct(nrs,(0x3000+(LOWMEM_BIAS))) + _struct_pad(fulltag_misc) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_misc) + _struct_label(nil) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_misc) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_misc) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_misc) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_misc) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_misc) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_misc) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_misc) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_misc) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_misc) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_misc) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_misc) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_misc) + _struct_label(total_bytes_freed) /* *total-bytes-freed* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_misc) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_misc) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_misc) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_misc) + _struct_label(total_gc_microseconds) /* *total-gc-microseconds* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(builtin_functions) /* %builtin-functions% */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_misc) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_misc) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_misc) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_misc) + _struct_label(new_gcable_ptr) /* %new-gcable-ptr */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_misc) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_misc) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + + _struct_pad(fulltag_misc) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_misc) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_misc) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_misc) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define(`def_header',` +$1 = ($2<lisp code that needs to save/restore C NVRs in a TSP frame. */ + _struct(c_reg_save,0) + _node(tsp_link) /* backpointer */ + _node(tsp_mark) /* frame type */ + _node(save_fpscr) /* for Cs FPSCR */ + _field(save_gprs,19*node_size) /* r13-r31 */ + _dword(save_fp_zero) /* for fp_zero */ + _dword(save_fps32conv) + _field(save_fprs,13*8) + _ends + + +TCR_BIAS = 0 + +/* Thread context record. */ + + _struct(tcr,-TCR_BIAS) + _node(prev) /* in doubly-linked list */ + _node(next) /* in doubly-linked list */ + _node(single_float_convert) /* xxxf0 */ + _word(lisp_fpscr) /* lisp thread's fpscr (in low word) */ + _word(lisp_fpscr_low) + _node(db_link) /* special binding chain head */ + _node(catch_top) /* top catch frame */ + _node(save_vsp) /* VSP when in foreign code */ + _node(save_tsp) /* TSP when in foreign code */ + _node(cs_area) /* cstack area pointer */ + _node(vs_area) /* vstack area pointer */ + _node(ts_area) /* tstack area pointer */ + _node(cs_limit) /* cstack overflow limit */ + _word(bytes_consed_high) + _word(bytes_consed_low) + _node(log2_allocation_quantum) + _node(interrupt_pending) + _node(xframe) /* per-thread exception frame list */ + _node(errno_loc) /* per-thread errno location */ + _node(ffi_exception) /* fpscr exception bits from ff-call */ + _node(osid) /* OS thread id */ + _node(valence) /* odd when in foreign code */ + _node(foreign_exception_status) + _node(native_thread_info) + _node(native_thread_id) + _node(last_allocptr) + _node(save_allocptr) + _node(save_allocbase) + _node(reset_completion) + _node(activate) + _node(suspend_count) + _node(suspend_context) + _node(pending_exception_context) + _node(suspend) /* semaphore for suspension notify */ + _node(resume) /* sempahore for resumption notify */ + _word(flags_pad) + _word(flags) + _node(gc_context) + _node(termination_semaphore) + _node(unwinding) + _node(tlb_limit) + _node(tlb_pointer) /* Consider using tcr+N as tlb_pointer */ + _node(shutdown_count) + _node(safe_ref_address) + _ends + +TCR_FLAG_BIT_FOREIGN = fixnum_shift +TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) +TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) +TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) +TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) +TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) +TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) +TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) + + +nil_value = (0x3000+symbol.size+fulltag_misc+(LOWMEM_BIAS)) + +define(`RESERVATION_DISCHARGE',(0x2008+(LOWMEM_BIAS))) + +lisp_globals_limit = (0x3000+(LOWMEM_BIAS)) + +INTERRUPT_LEVEL_BINDING_INDEX = fixnumone + + Index: /branches/qres/ccl/lisp-kernel/ppc-exceptions.c =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-exceptions.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-exceptions.c (revision 13564) @@ -0,0 +1,3231 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" +#include +#include +#include +#include +#include +#include +#include +#ifdef LINUX +#include +#include +#include +#include +#endif + +#ifdef DARWIN +#include +#define _FPU_RESERVED 0xffffff00 +#ifndef SA_NODEFER +#define SA_NODEFER 0 +#endif +#include + +/* a distinguished UUO at a distinguished address */ +extern void pseudo_sigreturn(ExceptionInformation *); +#endif + + +#include "Threads.h" + +#define MSR_FE0_MASK (((unsigned)0x80000000)>>20) +#define MSR_FE1_MASK (((unsigned)0x80000000)>>23) +#define MSR_FE0_FE1_MASK (MSR_FE0_MASK|MSR_FE1_MASK) +extern void enable_fp_exceptions(void); +extern void disable_fp_exceptions(void); + +#ifdef LINUX +/* Some relatively recent kernels support this interface. + If this prctl isn't supported, assume that we're always + running with excptions enabled and "precise". +*/ +#ifndef PR_SET_FPEXC +#define PR_SET_FPEXC 12 +#endif +#ifndef PR_FP_EXC_DISABLED +#define PR_FP_EXC_DISABLED 0 +#endif +#ifndef PR_FP_EXC_PRECISE +#define PR_FP_EXC_PRECISE 3 +#endif + +void +enable_fp_exceptions() +{ + prctl(PR_SET_FPEXC, PR_FP_EXC_PRECISE); +} + +void +disable_fp_exceptions() +{ + prctl(PR_SET_FPEXC, PR_FP_EXC_DISABLED); +} + +#endif + +/* + Handle exceptions. + +*/ + +extern LispObj lisp_nil; + +extern natural lisp_heap_gc_threshold; +extern Boolean grow_dynamic_area(natural); + + + + + + +int +page_size = 4096; + +int +log2_page_size = 12; + + + + + +/* + If the PC is pointing to an allocation trap, the previous instruction + must have decremented allocptr. Return the non-zero amount by which + allocptr was decremented. +*/ +signed_natural +allocptr_displacement(ExceptionInformation *xp) +{ + pc program_counter = xpPC(xp); + opcode instr = *program_counter, prev_instr = *(program_counter-1); + + if (instr == ALLOC_TRAP_INSTRUCTION) { + if (match_instr(prev_instr, + XO_MASK | RT_MASK | RB_MASK, + XO(major_opcode_X31,minor_opcode_SUBF, 0, 0) | + RT(allocptr) | + RB(allocptr))) { + return ((signed_natural) xpGPR(xp, RA_field(prev_instr))); + } + if (match_instr(prev_instr, + OP_MASK | RT_MASK | RA_MASK, + OP(major_opcode_ADDI) | + RT(allocptr) | + RA(allocptr))) { + return (signed_natural) -((short) prev_instr); + } + Bug(xp, "Can't determine allocation displacement"); + } + return 0; +} + + +/* + A cons cell's been successfully allocated, but the allocptr's + still tagged (as fulltag_cons, of course.) Emulate any instructions + that might follow the allocation (stores to the car or cdr, an + assignment to the "result" gpr) that take place while the allocptr's + tag is non-zero, advancing over each such instruction. When we're + done, the cons cell will be allocated and initialized, the result + register will point to it, the allocptr will be untagged, and + the PC will point past the instruction that clears the allocptr's + tag. +*/ +void +finish_allocating_cons(ExceptionInformation *xp) +{ + pc program_counter = xpPC(xp); + opcode instr; + LispObj cur_allocptr = xpGPR(xp, allocptr); + cons *c = (cons *)ptr_from_lispobj(untag(cur_allocptr)); + int target_reg; + + while (1) { + instr = *program_counter++; + + if (instr == UNTAG_ALLOCPTR_INSTRUCTION) { + xpGPR(xp, allocptr) = untag(cur_allocptr); + xpPC(xp) = program_counter; + return; + } + + switch (instr & STORE_CXR_ALLOCPTR_MASK) { + case STORE_CAR_ALLOCPTR_INSTRUCTION: + c->car = xpGPR(xp,RT_field(instr)); + break; + case STORE_CDR_ALLOCPTR_INSTRUCTION: + c->cdr = xpGPR(xp,RT_field(instr)); + break; + default: + /* Assume that this is an assignment: {rt/ra} <- allocptr. + There are several equivalent instruction forms + that might have that effect; just assign to target here. + */ + if (major_opcode_p(instr,major_opcode_X31)) { + target_reg = RA_field(instr); + } else { + target_reg = RT_field(instr); + } + xpGPR(xp,target_reg) = cur_allocptr; + break; + } + } +} + +/* + We were interrupted in the process of allocating a uvector; we + survived the allocation trap, and allocptr is tagged as fulltag_misc. + Emulate any instructions which store a header into the uvector, + assign the value of allocptr to some other register, and clear + allocptr's tag. Don't expect/allow any other instructions in + this environment. +*/ +void +finish_allocating_uvector(ExceptionInformation *xp) +{ + pc program_counter = xpPC(xp); + opcode instr; + LispObj cur_allocptr = xpGPR(xp, allocptr); + int target_reg; + + while (1) { + instr = *program_counter++; + if (instr == UNTAG_ALLOCPTR_INSTRUCTION) { + xpGPR(xp, allocptr) = untag(cur_allocptr); + xpPC(xp) = program_counter; + return; + } + if ((instr & STORE_HEADER_ALLOCPTR_MASK) == + STORE_HEADER_ALLOCPTR_INSTRUCTION) { + header_of(cur_allocptr) = xpGPR(xp, RT_field(instr)); + } else { + /* assume that this is an assignment */ + + if (major_opcode_p(instr,major_opcode_X31)) { + target_reg = RA_field(instr); + } else { + target_reg = RT_field(instr); + } + xpGPR(xp,target_reg) = cur_allocptr; + } + } +} + + +Boolean +allocate_object(ExceptionInformation *xp, + natural bytes_needed, + signed_natural disp_from_allocptr, + TCR *tcr) +{ + area *a = active_dynamic_area; + + /* Maybe do an EGC */ + if (a->older && lisp_global(OLDEST_EPHEMERAL)) { + if (((a->active)-(a->low)) >= a->threshold) { + gc_from_xp(xp, 0L); + } + } + + /* Life is pretty simple if we can simply grab a segment + without extending the heap. + */ + if (new_heap_segment(xp, bytes_needed, false, tcr)) { + xpGPR(xp, allocptr) += disp_from_allocptr; +#ifdef DEBUG + fprintf(dbgout, "New heap segment for #x%x, no GC: #x%x/#x%x, vsp = #x%x\n", + tcr,xpGPR(xp,allocbase),tcr->last_allocptr, xpGPR(xp,vsp)); +#endif + return true; + } + + /* It doesn't make sense to try a full GC if the object + we're trying to allocate is larger than everything + allocated so far. + */ + if ((lisp_global(HEAP_END)-lisp_global(HEAP_START)) > bytes_needed) { + untenure_from_area(tenured_area); /* force a full GC */ + gc_from_xp(xp, 0L); + } + + /* Try again, growing the heap if necessary */ + if (new_heap_segment(xp, bytes_needed, true, tcr)) { + xpGPR(xp, allocptr) += disp_from_allocptr; +#ifdef DEBUG + fprintf(dbgout, "New heap segment for #x%x after GC: #x%x/#x%x\n", + tcr,xpGPR(xp,allocbase),tcr->last_allocptr); +#endif + return true; + } + + return false; +} + +#ifndef XNOMEM +#define XNOMEM 10 +#endif + +void +update_bytes_allocated(TCR* tcr, void *cur_allocptr) +{ + BytePtr + last = (BytePtr) tcr->last_allocptr, + current = (BytePtr) cur_allocptr; + if (last && (cur_allocptr != ((void *)VOID_ALLOCPTR))) { + tcr->bytes_allocated += last-current; + } + tcr->last_allocptr = 0; +} + +void +lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed) +{ + /* Couldn't allocate the object. If it's smaller than some arbitrary + size (say 128K bytes), signal a "chronically out-of-memory" condition; + else signal a "allocation request failed" condition. + */ + xpGPR(xp,allocptr) = xpGPR(xp,allocbase) = VOID_ALLOCPTR; + handle_error(xp, bytes_needed < (128<<10) ? XNOMEM : error_alloc_failed, 0, 0, xpPC(xp)); +} + +/* + Allocate a large list, where "large" means "large enough to + possibly trigger the EGC several times if this was done + by individually allocating each CONS." The number of + ocnses in question is in arg_z; on successful return, + the list will be in arg_z +*/ + +Boolean +allocate_list(ExceptionInformation *xp, TCR *tcr) +{ + natural + nconses = (unbox_fixnum(xpGPR(xp,arg_z))), + bytes_needed = (nconses << dnode_shift); + LispObj + prev = lisp_nil, + current, + initial = xpGPR(xp,arg_y); + + if (nconses == 0) { + /* Silly case */ + xpGPR(xp,arg_z) = lisp_nil; + xpGPR(xp,allocptr) = lisp_nil; + return true; + } + update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr); + if (allocate_object(xp,bytes_needed,(-bytes_needed)+fulltag_cons,tcr)) { + for (current = xpGPR(xp,allocptr); + nconses; + prev = current, current+= dnode_size, nconses--) { + deref(current,0) = prev; + deref(current,1) = initial; + } + xpGPR(xp,arg_z) = prev; + xpGPR(xp,arg_y) = xpGPR(xp,allocptr); + xpGPR(xp,allocptr)-=fulltag_cons; + } else { + lisp_allocation_failure(xp,tcr,bytes_needed); + } + return true; +} + +OSStatus +handle_alloc_trap(ExceptionInformation *xp, TCR *tcr) +{ + pc program_counter; + natural cur_allocptr, bytes_needed = 0; + opcode prev_instr; + signed_natural disp = 0; + unsigned allocptr_tag; + + cur_allocptr = xpGPR(xp,allocptr); + program_counter = xpPC(xp); + prev_instr = *(program_counter-1); + allocptr_tag = fulltag_of(cur_allocptr); + + switch (allocptr_tag) { + case fulltag_cons: + bytes_needed = sizeof(cons); + disp = -sizeof(cons) + fulltag_cons; + break; + + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + break; + + case fulltag_misc: + if (match_instr(prev_instr, + XO_MASK | RT_MASK | RB_MASK, + XO(major_opcode_X31,minor_opcode_SUBF, 0, 0) | + RT(allocptr) | + RB(allocptr))) { + disp = -((signed_natural) xpGPR(xp, RA_field(prev_instr))); + } else if (match_instr(prev_instr, + OP_MASK | RT_MASK | RA_MASK, + OP(major_opcode_ADDI) | + RT(allocptr) | + RA(allocptr))) { + disp = (signed_natural) ((short) prev_instr); + } + if (disp) { + bytes_needed = (-disp) + fulltag_misc; + break; + } + /* else fall thru */ + default: + return -1; + } + + if (bytes_needed) { + update_bytes_allocated(tcr,((BytePtr)(cur_allocptr-disp))); + if (allocate_object(xp, bytes_needed, disp, tcr)) { +#if 0 + fprintf(dbgout, "alloc_trap in 0x%lx, new allocptr = 0x%lx\n", + tcr, xpGPR(xp, allocptr)); +#endif + adjust_exception_pc(xp,4); + return 0; + } + lisp_allocation_failure(xp,tcr,bytes_needed); + return -1; + } + return -1; +} + +natural gc_deferred = 0, full_gc_deferred = 0; + +signed_natural +flash_freeze(TCR *tcr, signed_natural param) +{ + return 0; +} + +OSStatus +handle_gc_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj + selector = xpGPR(xp,imm0), + arg = xpGPR(xp,imm1); + area *a = active_dynamic_area; + Boolean egc_was_enabled = (a->older != NULL); + natural gc_previously_deferred = gc_deferred; + + + switch (selector) { + case GC_TRAP_FUNCTION_EGC_CONTROL: + egc_control(arg != 0, a->active); + xpGPR(xp,arg_z) = lisp_nil + (egc_was_enabled ? t_offset : 0); + break; + + case GC_TRAP_FUNCTION_CONFIGURE_EGC: + a->threshold = unbox_fixnum(xpGPR(xp, arg_x)); + g1_area->threshold = unbox_fixnum(xpGPR(xp, arg_y)); + g2_area->threshold = unbox_fixnum(xpGPR(xp, arg_z)); + xpGPR(xp,arg_z) = lisp_nil+t_offset; + break; + + case GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD: + if (((signed_natural) arg) > 0) { + lisp_heap_gc_threshold = + align_to_power_of_2((arg-1) + + (heap_segment_size - 1), + log2_heap_segment_size); + } + /* fall through */ + case GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD: + xpGPR(xp, imm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD: + /* Try to put the current threshold in effect. This may + need to disable/reenable the EGC. */ + untenure_from_area(tenured_area); + resize_dynamic_heap(a->active,lisp_heap_gc_threshold); + if (egc_was_enabled) { + if ((a->high - a->active) >= a->threshold) { + tenure_to_area(tenured_area); + } + } + xpGPR(xp, imm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_FLASH_FREEZE: + untenure_from_area(tenured_area); + gc_like_from_xp(xp,flash_freeze,0); + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + if (egc_was_enabled) { + tenure_to_area(tenured_area); + } + xpGPR(xp, imm0) = tenured_area->static_dnodes << dnode_shift; + break; + + default: + update_bytes_allocated(tcr, (void *) ptr_from_lispobj(xpGPR(xp, allocptr))); + + if (selector == GC_TRAP_FUNCTION_IMMEDIATE_GC) { + if (!full_gc_deferred) { + gc_from_xp(xp, 0L); + break; + } + /* Tried to do a full GC when gc was disabled. That failed, + so try full GC now */ + selector = GC_TRAP_FUNCTION_GC; + } + + if (egc_was_enabled) { + egc_control(false, (BytePtr) a->active); + } + gc_from_xp(xp, 0L); + if (gc_deferred > gc_previously_deferred) { + full_gc_deferred = 1; + } else { + full_gc_deferred = 0; + } + if (selector > GC_TRAP_FUNCTION_GC) { + if (selector & GC_TRAP_FUNCTION_IMPURIFY) { + impurify_from_xp(xp, 0L); + /* nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */ + gc_from_xp(xp, 0L); + release_readonly_area(); + } + if (selector & GC_TRAP_FUNCTION_PURIFY) { + purify_from_xp(xp, 0L); + gc_from_xp(xp, 0L); + } + if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) { + OSErr err; + extern OSErr save_application(unsigned, Boolean); + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + area *vsarea = tcr->vs_area; + + nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1); + err = save_application(arg, egc_was_enabled); + if (err == noErr) { + _exit(0); + } + fatal_oserr(": save_application", err); + } + switch (selector) { + case GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE: + xpGPR(xp, imm0) = 0; + break; + + case GC_TRAP_FUNCTION_FREEZE: + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + xpGPR(xp, imm0) = tenured_area->static_dnodes << dnode_shift; + break; + default: + break; + } + } + + if (egc_was_enabled) { + egc_control(true, NULL); + } + break; + + } + + adjust_exception_pc(xp,4); + return 0; +} + + + +void +signal_stack_soft_overflow(ExceptionInformation *xp, unsigned reg) +{ + /* The cstack just overflowed. Force the current thread's + control stack to do so until all stacks are well under their overflow + limits. + */ + +#if 0 + lisp_global(CS_OVERFLOW_LIMIT) = CS_OVERFLOW_FORCE_LIMIT; /* force unsigned traps to fail */ +#endif + handle_error(xp, error_stack_overflow, reg, 0, xpPC(xp)); +} + +/* + Lower (move toward 0) the "end" of the soft protected area associated + with a by a page, if we can. +*/ + +void +adjust_soft_protection_limit(area *a) +{ + char *proposed_new_soft_limit = a->softlimit - 4096; + protected_area_ptr p = a->softprot; + + if (proposed_new_soft_limit >= (p->start+16384)) { + p->end = proposed_new_soft_limit; + p->protsize = p->end-p->start; + a->softlimit = proposed_new_soft_limit; + } + protect_area(p); +} + +void +restore_soft_stack_limit(unsigned stkreg) +{ + area *a; + TCR *tcr = get_tcr(true); + + switch (stkreg) { + case sp: + a = tcr->cs_area; + if ((a->softlimit - 4096) > (a->hardlimit + 16384)) { + a->softlimit -= 4096; + } + tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit); + break; + case vsp: + a = tcr->vs_area; + adjust_soft_protection_limit(a); + break; + case tsp: + a = tcr->ts_area; + adjust_soft_protection_limit(a); + } +} + +/* Maybe this'll work someday. We may have to do something to + make the thread look like it's not handling an exception */ +void +reset_lisp_process(ExceptionInformation *xp) +{ + TCR *tcr = TCR_FROM_TSD(xpGPR(xp,rcontext)); + catch_frame *last_catch = (catch_frame *) ptr_from_lispobj(untag(tcr->catch_top)); + + tcr->save_allocptr = (void *) ptr_from_lispobj(xpGPR(xp, allocptr)); + tcr->save_allocbase = (void *) ptr_from_lispobj(xpGPR(xp, allocbase)); + + tcr->save_vsp = (LispObj *) ptr_from_lispobj(((lisp_frame *)ptr_from_lispobj(last_catch->csp))->savevsp); + tcr->save_tsp = (LispObj *) ptr_from_lispobj((LispObj) ptr_to_lispobj(last_catch)) - (2*node_size); /* account for TSP header */ + + start_lisp(tcr, 1); +} + +/* + This doesn't GC; it returns true if it made enough room, false + otherwise. + If "extend" is true, it can try to extend the dynamic area to + satisfy the request. +*/ + +Boolean +new_heap_segment(ExceptionInformation *xp, natural need, Boolean extend, TCR *tcr) +{ + area *a; + natural newlimit, oldlimit; + natural log2_allocation_quantum = tcr->log2_allocation_quantum; + + a = active_dynamic_area; + oldlimit = (natural) a->active; + newlimit = (align_to_power_of_2(oldlimit, log2_allocation_quantum) + + align_to_power_of_2(need, log2_allocation_quantum)); + if (newlimit > (natural) (a->high)) { + if (extend) { + signed_natural inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + natural extend_by = inhibit ? 0 : lisp_heap_gc_threshold; + do { + if (resize_dynamic_heap(a->active, (newlimit-oldlimit)+extend_by)) { + break; + } + extend_by = align_to_power_of_2(extend_by>>1, log2_allocation_quantum); + if (extend_by < 4<<20) { + return false; + } + } while (1); + } else { + return false; + } + } + a->active = (BytePtr) newlimit; + tcr->last_allocptr = (void *)newlimit; + xpGPR(xp,allocptr) = (LispObj) newlimit; + xpGPR(xp,allocbase) = (LispObj) oldlimit; + + return true; +} + + +void +update_area_active (area **aptr, BytePtr value) +{ + area *a = *aptr; + for (; a; a = a->older) { + if ((a->low <= value) && (a->high >= value)) break; + }; + if (a == NULL) Bug(NULL, "Can't find active area"); + a->active = value; + *aptr = a; + + for (a = a->younger; a; a = a->younger) { + a->active = a->high; + } +} + +LispObj * +tcr_frame_ptr(TCR *tcr) +{ + ExceptionInformation *xp; + LispObj *bp = NULL; + + if (tcr->pending_exception_context) + xp = tcr->pending_exception_context; + else { + xp = tcr->suspend_context; + } + if (xp) { + bp = (LispObj *) xpGPR(xp, sp); + } + return bp; +} + +void +normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr) +{ + void *cur_allocptr = NULL; + LispObj freeptr = 0; + + if (xp) { + if (is_other_tcr) { + pc_luser_xp(xp, tcr, NULL); + freeptr = xpGPR(xp, allocptr); + if (fulltag_of(freeptr) == 0){ + cur_allocptr = (void *) ptr_from_lispobj(freeptr); + } + } + update_area_active((area **)&tcr->cs_area, (BytePtr) ptr_from_lispobj(xpGPR(xp, sp))); + update_area_active((area **)&tcr->vs_area, (BytePtr) ptr_from_lispobj(xpGPR(xp, vsp))); + update_area_active((area **)&tcr->ts_area, (BytePtr) ptr_from_lispobj(xpGPR(xp, tsp))); +#ifdef DEBUG + fprintf(dbgout, "TCR 0x%x in lisp code, vsp = 0x%lx, tsp = 0x%lx\n", + tcr, xpGPR(xp, vsp), xpGPR(xp, tsp)); + fprintf(dbgout, "TCR 0x%x, allocbase/allocptr were 0x%x/0x%x at #x%x\n", + tcr, + xpGPR(xp, allocbase), + xpGPR(xp, allocptr), + xpPC(xp)); + fprintf(dbgout, "TCR 0x%x, exception context = 0x%x\n", + tcr, + tcr->pending_exception_context); +#endif + } else { + /* In ff-call. No need to update cs_area */ + cur_allocptr = (void *) (tcr->save_allocptr); +#ifdef DEBUG + fprintf(dbgout, "TCR 0x%x in foreign code, vsp = 0x%lx, tsp = 0x%lx\n", + tcr, tcr->save_vsp, tcr->save_tsp); + fprintf(dbgout, "TCR 0x%x, save_allocbase/save_allocptr were 0x%x/0x%x at #x%x\n", + tcr, + tcr->save_allocbase, + tcr->save_allocptr, + xpPC(xp)); + +#endif + update_area_active((area **)&tcr->vs_area, (BytePtr) tcr->save_vsp); + update_area_active((area **)&tcr->ts_area, (BytePtr) tcr->save_tsp); + } + + + tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR; + if (cur_allocptr) { + update_bytes_allocated(tcr, cur_allocptr); + if (freeptr) { + xpGPR(xp, allocptr) = VOID_ALLOCPTR; + xpGPR(xp, allocbase) = VOID_ALLOCPTR; + } + } +} + +TCR *gc_tcr = NULL; + +/* Suspend and "normalize" other tcrs, then call a gc-like function + in that context. Resume the other tcrs, then return what the + function returned */ + +signed_natural +gc_like_from_xp(ExceptionInformation *xp, + signed_natural(*fun)(TCR *, signed_natural), + signed_natural param) +{ + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)), *other_tcr; + int result; + signed_natural inhibit; + + suspend_other_threads(true); + inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + if (inhibit != 0) { + if (inhibit > 0) { + lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit); + } + resume_other_threads(true); + gc_deferred++; + return 0; + } + gc_deferred = 0; + + gc_tcr = tcr; + + xpGPR(xp, allocptr) = VOID_ALLOCPTR; + xpGPR(xp, allocbase) = VOID_ALLOCPTR; + + normalize_tcr(xp, tcr, false); + + + for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) { + if (other_tcr->pending_exception_context) { + other_tcr->gc_context = other_tcr->pending_exception_context; + } else if (other_tcr->valence == TCR_STATE_LISP) { + other_tcr->gc_context = other_tcr->suspend_context; + } else { + /* no pending exception, didn't suspend in lisp state: + must have executed a synchronous ff-call. + */ + other_tcr->gc_context = NULL; + } + normalize_tcr(other_tcr->gc_context, other_tcr, true); + } + + + + result = fun(tcr, param); + + other_tcr = tcr; + do { + other_tcr->gc_context = NULL; + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + gc_tcr = NULL; + + resume_other_threads(true); + + return result; + +} + + + +/* Returns #bytes freed by invoking GC */ + +signed_natural +gc_from_tcr(TCR *tcr, signed_natural param) +{ + area *a; + BytePtr oldfree, newfree; + BytePtr oldend, newend; + +#ifdef DEBUG + fprintf(dbgout, "Start GC in 0x%lx\n", tcr); +#endif + a = active_dynamic_area; + oldend = a->high; + oldfree = a->active; + gc(tcr, param); + newfree = a->active; + newend = a->high; +#if 0 + fprintf(dbgout, "End GC in 0x%lx\n", tcr); +#endif + return ((oldfree-newfree)+(newend-oldend)); +} + +signed_natural +gc_from_xp(ExceptionInformation *xp, signed_natural param) +{ + signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param); + + freeGCptrs(); + return status; +} + +signed_natural +purify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, purify, param); +} + +signed_natural +impurify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, impurify, param); +} + + + + + + +protection_handler + * protection_handlers[] = { + do_spurious_wp_fault, + do_soft_stack_overflow, + do_soft_stack_overflow, + do_soft_stack_overflow, + do_hard_stack_overflow, + do_hard_stack_overflow, + do_hard_stack_overflow + }; + + +Boolean +is_write_fault(ExceptionInformation *xp, siginfo_t *info) +{ + /* use the siginfo if it's available. Some versions of Linux + don't propagate the DSISR and TRAP fields correctly from + 64- to 32-bit handlers. + */ + if (info) { + /* + To confuse matters still further, the value of SEGV_ACCERR + varies quite a bit among LinuxPPC variants (the value defined + in the header files varies, and the value actually set by + the kernel also varies. So far, we're only looking at the + siginfo under Linux and Linux always seems to generate + SIGSEGV, so check for SIGSEGV and check the low 16 bits + of the si_code. + */ + return ((info->si_signo == SIGSEGV) && + ((info->si_code & 0xff) == (SEGV_ACCERR & 0xff))); + } + return(((xpDSISR(xp) & (1 << 25)) != 0) && + (xpTRAP(xp) == +#ifdef LINUX +0x0300 +#endif +#ifdef DARWIN +0x0300/0x100 +#endif +) + ); +#if 0 + /* Maybe worth keeping around; not sure if it's an exhaustive + list of PPC instructions that could cause a WP fault */ + /* Some OSes lose track of the DSISR and DSR SPRs, or don't provide + valid values of those SPRs in the context they provide to + exception handlers. Look at the opcode of the offending + instruction & recognize 32-bit store operations */ + opcode instr = *(xpPC(xp)); + + if (xp->regs->trap != 0x300) { + return 0; + } + switch (instr >> 26) { + case 47: /* STMW */ + case 36: /* STW */ + case 37: /* STWU */ + return 1; + case 31: + switch ((instr >> 1) & 1023) { + case 151: /* STWX */ + case 183: /* STWUX */ + return 1; + default: + return 0; + } + default: + return 0; + } +#endif +} + +OSStatus +handle_protection_violation(ExceptionInformation *xp, siginfo_t *info, TCR *tcr, int old_valence) +{ + BytePtr addr; + protected_area_ptr area; + protection_handler *handler; + extern Boolean touch_page(void *); + extern void touch_page_end(void); + + if (info) { + addr = (BytePtr)(info->si_addr); + } else { + addr = (BytePtr) ((natural) (xpDAR(xp))); + } + + if (addr && (addr == tcr->safe_ref_address)) { + adjust_exception_pc(xp,4); + + xpGPR(xp,imm0) = 0; + return 0; + } + + if (xpPC(xp) == (pc)touch_page) { + xpGPR(xp,imm0) = 0; + xpPC(xp) = (pc)touch_page_end; + return 0; + } + + + if (is_write_fault(xp,info)) { + area = find_protected_area(addr); + if (area != NULL) { + handler = protection_handlers[area->why]; + return handler(xp, area, addr); + } else { + if ((addr >= readonly_area->low) && + (addr < readonly_area->active)) { + UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), + page_size); + return 0; + } + } + } + if (old_valence == TCR_STATE_LISP) { + callback_for_trap(nrs_CMAIN.vcell, xp, (pc)xpPC(xp), SIGBUS, (natural)addr, is_write_fault(xp,info)); + } + return -1; +} + + + + + +OSStatus +do_hard_stack_overflow(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(area,addr) +#endif + reset_lisp_process(xp); + return -1; +} + +extern area* +allocate_vstack(natural useable); /* This is in "pmcl-kernel.c" */ + +extern area* +allocate_tstack(natural useable); /* This is in "pmcl-kernel.c" */ + +#ifdef EXTEND_VSTACK +Boolean +catch_frame_p(lisp_frame *spPtr) +{ + catch_frame* catch = (catch_frame *) untag(lisp_global(CATCH_TOP)); + + for (; catch; catch = (catch_frame *) untag(catch->link)) { + if (spPtr == ((lisp_frame *) catch->csp)) { + return true; + } + } + return false; +} +#endif + +Boolean +unwind_protect_cleanup_frame_p(lisp_frame *spPtr) +{ + if ((spPtr->savevsp == (LispObj)NULL) || /* The frame to where the unwind-protect will return */ + (((spPtr->backlink)->savevsp) == (LispObj)NULL)) { /* The frame that returns to the kernel from the cleanup form */ + return true; + } else { + return false; + } +} + +Boolean +lexpr_entry_frame_p(lisp_frame *spPtr) +{ + LispObj savelr = spPtr->savelr; + LispObj lexpr_return = (LispObj) lisp_global(LEXPR_RETURN); + LispObj lexpr_return1v = (LispObj) lisp_global(LEXPR_RETURN1V); + LispObj ret1valn = (LispObj) lisp_global(RET1VALN); + + return + (savelr == lexpr_return1v) || + (savelr == lexpr_return) || + ((savelr == ret1valn) && + (((spPtr->backlink)->savelr) == lexpr_return)); +} + +Boolean +lisp_frame_p(lisp_frame *spPtr) +{ + LispObj savefn; + /* We can't just look at the size of the stack frame under the EABI + calling sequence, but that's the first thing to check. */ + if (((lisp_frame *) spPtr->backlink) != (spPtr+1)) { + return false; + } + savefn = spPtr->savefn; + return (savefn == 0) || (fulltag_of(savefn) == fulltag_misc); + +} + + +int ffcall_overflow_count = 0; + +/* Find a frame that is neither a catch frame nor one of the + lexpr_entry frames We don't check for non-lisp frames here because + we'll always stop before we get there due to a dummy lisp frame + pushed by .SPcallback that masks out the foreign frames. The one + exception is that there is a non-lisp frame without a valid VSP + while in the process of ppc-ff-call. We recognize that because its + savelr is NIL. If the saved VSP itself is 0 or the savevsp in the + next frame is 0, then we're executing an unwind-protect cleanup + form, and the top stack frame belongs to its (no longer extant) + catch frame. */ + +#ifdef EXTEND_VSTACK +lisp_frame * +find_non_catch_frame_from_xp (ExceptionInformation *xp) +{ + lisp_frame *spPtr = (lisp_frame *) xpGPR(xp, sp); + if ((((natural) spPtr) + sizeof(lisp_frame)) != ((natural) (spPtr->backlink))) { + ffcall_overflow_count++; /* This is mostly so I can breakpoint here */ + } + for (; !lisp_frame_p(spPtr) || /* In the process of ppc-ff-call */ + unwind_protect_cleanup_frame_p(spPtr) || + catch_frame_p(spPtr) || + lexpr_entry_frame_p(spPtr) ; ) { + spPtr = spPtr->backlink; + }; + return spPtr; +} +#endif + +#ifdef EXTEND_VSTACK +Boolean +db_link_chain_in_area_p (area *a) +{ + LispObj *db = (LispObj *) lisp_global(DB_LINK), + *high = (LispObj *) a->high, + *low = (LispObj *) a->low; + for (; db; db = (LispObj *) *db) { + if ((db >= low) && (db < high)) return true; + }; + return false; +} +#endif + + + + +/* Note: CURRENT_VS (CURRENT_TS) is always either the area containing + the current value of VSP (TSP) or an older area. */ + +OSStatus +do_vsp_overflow (ExceptionInformation *xp, BytePtr addr) +{ + TCR* tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + area *a = tcr->vs_area; + protected_area_ptr vsp_soft = a->softprot; + unprotect_area(vsp_soft); + signal_stack_soft_overflow(xp,vsp); + return 0; +} + + +OSStatus +do_tsp_overflow (ExceptionInformation *xp, BytePtr addr) +{ + TCR* tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + area *a = tcr->ts_area; + protected_area_ptr tsp_soft = a->softprot; + unprotect_area(tsp_soft); + signal_stack_soft_overflow(xp,tsp); + return 0; +} + +OSStatus +do_soft_stack_overflow(ExceptionInformation *xp, protected_area_ptr prot_area, BytePtr addr) +{ + /* Trying to write into a guard page on the vstack or tstack. + Allocate a new stack segment, emulate stwu and stwux for the TSP, and + signal an error_stack_overflow condition. + */ + lisp_protection_kind which = prot_area->why; + Boolean on_TSP = (which == kTSPsoftguard); + + if (on_TSP) { + return do_tsp_overflow(xp, addr); + } else { + return do_vsp_overflow(xp, addr); + } +} + +OSStatus +do_spurious_wp_fault(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(xp,area,addr) +#endif + return -1; +} + + +/* + We have a couple of choices here. We can simply unprotect the page + and let the store happen on return, or we can try to emulate writes + that we know will involve an intergenerational reference. Both are + correct as far as EGC constraints go, but the latter approach is + probably more efficient. (This only matters in the case where the + GC runs after this exception handler returns but before the write + actually happens. If we didn't emulate node stores here, the EGC + would scan the newly-writen page, find nothing interesting, and + run to completion. This thread will try the write again afer it + resumes, the page'll be re-protected, and we'll have taken this + fault twice. The whole scenario shouldn't happen very often, but + (having already taken a fault and committed to an mprotect syscall) + we might as well emulate stores involving intergenerational references, + since they're pretty easy to identify. + + Note that cases involving two or more threads writing to the same + page (before either of them can run this handler) is benign: one + invocation of the handler will just unprotect an unprotected page in + that case. + + If there are GCs (or any other suspensions of the thread between + the time that the write fault was detected and the time that the + exception lock is obtained) none of this stuff happens. +*/ + +/* + Return true (and emulate the instruction) iff: + a) the fault was caused by an "stw rs,d(ra)" or "stwx rs,ra.rb" + instruction. + b) RS is a node register (>= fn) + c) RS is tagged as a cons or vector + d) RS is in some ephemeral generation. + This is slightly conservative, since RS may be no younger than the + EA being written to. +*/ +Boolean +is_ephemeral_node_store(ExceptionInformation *xp, BytePtr ea) +{ + if (((ptr_to_lispobj(ea)) & 3) == 0) { + opcode instr = *xpPC(xp); + + if (X_opcode_p(instr,major_opcode_X31,minor_opcode_STWX) || + major_opcode_p(instr, major_opcode_STW)) { + LispObj + rs = RS_field(instr), + rsval = xpGPR(xp,rs), + tag = fulltag_of(rsval); + + if (rs >= fn) { + if ((tag == fulltag_misc) || (tag == fulltag_cons)) { + if (((BytePtr)ptr_from_lispobj(rsval) > tenured_area->high) && + ((BytePtr)ptr_from_lispobj(rsval) < active_dynamic_area->high)) { + *(LispObj *)ea = rsval; + return true; + } + } + } + } + } + return false; +} + + + + + + + +OSStatus +handle_sigfpe(ExceptionInformation *xp, TCR *tcr) +{ + (void) zero_fpscr(tcr); + enable_fp_exceptions(); + + + tcr->lisp_fpscr.words.l = xpFPSCR(xp) & ~_FPU_RESERVED; + + /* 'handle_fpux_binop' scans back from the specified PC until it finds an FPU + operation; there's an FPU operation right at the PC, so tell it to start + looking one word beyond */ + return handle_fpux_binop(xp, (pc)((natural)(xpPC(xp))+4)); +} + + +int +altivec_present = 1; + + +/* This only tries to implement the "optional" fsqrt and fsqrts + instructions, which were generally implemented on IBM hardware + but generally not available on Motorola/Freescale systems. +*/ +OSStatus +handle_unimplemented_instruction(ExceptionInformation *xp, + opcode instruction, + TCR *tcr) +{ + (void) zero_fpscr(tcr); + enable_fp_exceptions(); + /* the rc bit (bit 0 in the instruction) is supposed to cause + some FPSCR bits to be copied to CR1. Clozure CL doesn't generate + fsqrt. or fsqrts. + */ + if (((major_opcode_p(instruction,major_opcode_FPU_DOUBLE)) || + (major_opcode_p(instruction,major_opcode_FPU_SINGLE))) && + ((instruction & ((1 << 6) -2)) == (22<<1))) { + double b, d, sqrt(double); + + b = xpFPR(xp,RB_field(instruction)); + d = sqrt(b); + xpFPSCR(xp) = ((xpFPSCR(xp) & ~_FPU_RESERVED) | + (get_fpscr() & _FPU_RESERVED)); + xpFPR(xp,RT_field(instruction)) = d; + adjust_exception_pc(xp,4); + return 0; + } + + return -1; +} + +OSStatus +PMCL_exception_handler(int xnum, + ExceptionInformation *xp, + TCR *tcr, + siginfo_t *info, + int old_valence) +{ + OSStatus status = -1; + pc program_counter; + opcode instruction = 0; + + + program_counter = xpPC(xp); + + if ((xnum == SIGILL) | (xnum == SIGTRAP)) { + instruction = *program_counter; + } + + if (instruction == ALLOC_TRAP_INSTRUCTION) { + status = handle_alloc_trap(xp, tcr); + } else if ((xnum == SIGSEGV) || + (xnum == SIGBUS)) { + status = handle_protection_violation(xp, info, tcr, old_valence); + } else if (xnum == SIGFPE) { + status = handle_sigfpe(xp, tcr); + } else if ((xnum == SIGILL) || (xnum == SIGTRAP)) { + if (instruction == GC_TRAP_INSTRUCTION) { + status = handle_gc_trap(xp, tcr); + } else if (IS_UUO(instruction)) { + status = handle_uuo(xp, instruction, program_counter); + } else if (is_conditional_trap(instruction)) { + status = handle_trap(xp, instruction, program_counter, info); + } else { + status = handle_unimplemented_instruction(xp,instruction,tcr); + } + } else if (xnum == SIGNAL_FOR_PROCESS_INTERRUPT) { + tcr->interrupt_pending = 0; + callback_for_trap(nrs_CMAIN.vcell, xp, 0, TRI_instruction(TO_GT,nargs,0),0, 0); + status = 0; + } + + return status; +} + +void +adjust_exception_pc(ExceptionInformation *xp, int delta) +{ + xpPC(xp) += (delta >> 2); +} + + +/* + This wants to scan backwards until "where" points to an instruction + whose major opcode is either 63 (double-float) or 59 (single-float) +*/ + +OSStatus +handle_fpux_binop(ExceptionInformation *xp, pc where) +{ + OSStatus err; + opcode *there = (opcode *) where, instr, errnum = 0; + int i = TRAP_LOOKUP_TRIES, delta = 0; + + while (i--) { + instr = *--there; + delta -= 4; + if (codevec_hdr_p(instr)) { + return -1; + } + if (major_opcode_p(instr, major_opcode_FPU_DOUBLE)) { + errnum = error_FPU_exception_double; + break; + } + + if (major_opcode_p(instr, major_opcode_FPU_SINGLE)) { + errnum = error_FPU_exception_short; + break; + } + } + + err = handle_error(xp, errnum, rcontext, 0, there); + /* Yeah, we said "non-continuable". In case we ever change that ... */ + + adjust_exception_pc(xp, delta); + xpFPSCR(xp) &= 0x03fff; + + return err; + +} + +OSStatus +handle_uuo(ExceptionInformation *xp, opcode the_uuo, pc where) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(where) +#endif + unsigned + minor = UUO_MINOR(the_uuo), + rb = 0x1f & (the_uuo >> 11), + errnum = 0x3ff & (the_uuo >> 16); + + OSStatus status = -1; + + int bump = 4; + + switch (minor) { + + case UUO_ZERO_FPSCR: + status = 0; + xpFPSCR(xp) = 0; + break; + + + case UUO_INTERR: + { + TCR * target = (TCR *)xpGPR(xp,arg_z); + status = 0; + switch (errnum) { + case error_propagate_suspend: + break; + case error_interrupt: + xpGPR(xp,imm0) = (LispObj) raise_thread_interrupt(target); + break; + case error_suspend: + xpGPR(xp,imm0) = (LispObj) lisp_suspend_tcr(target); + break; + case error_suspend_all: + lisp_suspend_other_threads(); + break; + case error_resume: + xpGPR(xp,imm0) = (LispObj) lisp_resume_tcr(target); + break; + case error_resume_all: + lisp_resume_other_threads(); + break; + case error_kill: + xpGPR(xp,imm0) = (LispObj)kill_tcr(target); + break; + case error_allocate_list: + allocate_list(xp,get_tcr(true)); + break; + default: + status = handle_error(xp, errnum, rb, 0, where); + break; + } + } + break; + + case UUO_INTCERR: + status = handle_error(xp, errnum, rb, 1, where); + if (errnum == error_udf_call) { + /* If lisp's returned from a continuable undefined-function call, + it's put a code vector in the xp's PC. Don't advance the + PC ... */ + bump = 0; + } + break; + + case UUO_FPUX_BINOP: + status = handle_fpux_binop(xp, where); + bump = 0; + break; + + default: + status = -1; + bump = 0; + } + + if ((!status) && bump) { + adjust_exception_pc(xp, bump); + } + return status; +} + +natural +register_codevector_contains_pc (natural lisp_function, pc where) +{ + natural code_vector, size; + + if ((fulltag_of(lisp_function) == fulltag_misc) && + (header_subtag(header_of(lisp_function)) == subtag_function)) { + code_vector = deref(lisp_function, 1); + size = header_element_count(header_of(code_vector)) << 2; + if ((untag(code_vector) < (natural)where) && + ((natural)where < (code_vector + size))) + return(code_vector); + } + + return(0); +} + +/* Callback to lisp to handle a trap. Need to translate the + PC (where) into one of two forms of pairs: + + 1. If PC is in fn or nfn's code vector, use the register number + of fn or nfn and the index into that function's code vector. + 2. Otherwise use 0 and the pc itself +*/ +void +callback_for_trap (LispObj callback_macptr, ExceptionInformation *xp, pc where, + natural arg1, natural arg2, natural arg3) +{ + natural code_vector = register_codevector_contains_pc(xpGPR(xp, fn), where); + unsigned register_number = fn; + natural index = (natural)where; + + if (code_vector == 0) { + register_number = nfn; + code_vector = register_codevector_contains_pc(xpGPR(xp, nfn), where); + } + if (code_vector == 0) + register_number = 0; + else + index = ((natural)where - (code_vector + misc_data_offset)) >> 2; + callback_to_lisp(callback_macptr, xp, register_number, index, arg1, arg2, arg3); +} + +void +callback_to_lisp (LispObj callback_macptr, ExceptionInformation *xp, + natural arg1, natural arg2, natural arg3, natural arg4, natural arg5) +{ + natural callback_ptr; + area *a; + + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + + /* Put the active stack pointer where .SPcallback expects it */ + a = tcr->cs_area; + a->active = (BytePtr) ptr_from_lispobj(xpGPR(xp, sp)); + + /* Copy globals from the exception frame to tcr */ + tcr->save_allocptr = (void *)ptr_from_lispobj(xpGPR(xp, allocptr)); + tcr->save_allocbase = (void *)ptr_from_lispobj(xpGPR(xp, allocbase)); + tcr->save_vsp = (LispObj*) ptr_from_lispobj(xpGPR(xp, vsp)); + tcr->save_tsp = (LispObj*) ptr_from_lispobj(xpGPR(xp, tsp)); + + + + /* Call back. + Lisp will handle trampolining through some code that + will push lr/fn & pc/nfn stack frames for backtrace. + */ + callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address; +#ifdef DEBUG + fprintf(dbgout, "0x%x releasing exception lock for callback\n", tcr); +#endif + UNLOCK(lisp_global(EXCEPTION_LOCK), tcr); + ((void (*)())callback_ptr) (xp, arg1, arg2, arg3, arg4, arg5); + LOCK(lisp_global(EXCEPTION_LOCK), tcr); +#ifdef DEBUG + fprintf(dbgout, "0x%x acquired exception lock after callback\n", tcr); +#endif + + + + /* Copy GC registers back into exception frame */ + xpGPR(xp, allocbase) = (LispObj) ptr_to_lispobj(tcr->save_allocbase); + xpGPR(xp, allocptr) = (LispObj) ptr_to_lispobj(tcr->save_allocptr); +} + +area * +allocate_no_stack (natural size) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(size) +#endif + + return (area *) NULL; +} + + + + + + +/* callback to (symbol-value cmain) if it is a macptr, + otherwise report cause and function name to console. + Returns noErr if exception handled OK */ +OSStatus +handle_trap(ExceptionInformation *xp, opcode the_trap, pc where, siginfo_t *info) +{ + LispObj cmain = nrs_CMAIN.vcell; + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + + /* If we got here, "the_trap" is either a TRI or a TR instruction. + It's a TRI instruction iff its major opcode is major_opcode_TRI. */ + + /* If it's a "trllt" instruction where RA == sp, it's a failed + control stack overflow check. In that case: + + a) We're in "yellow zone" mode if the value of the + lisp_global(CS_OVERFLOW_LIMIT) is CS_OVERFLOW_FORCE_LIMIT. If + we're not already in yellow zone mode, attempt to create a new + thread and continue execution on its stack. If that fails, call + signal_stack_soft_overflow to enter yellow zone mode and signal + the condition to lisp. + + b) If we're already in "yellow zone" mode, then: + + 1) if the SP is past the current control-stack area's hard + overflow limit, signal a "hard" stack overflow error (e.g., throw + to toplevel as quickly as possible. If we aren't in "yellow zone" + mode, attempt to continue on another thread first. + + 2) if SP is "well" (> 4K) below its soft overflow limit, set + lisp_global(CS_OVERFLOW_LIMIT) to its "real" value. We're out of + "yellow zone mode" in this case. + + 3) Otherwise, do nothing. We'll continue to trap every time + something gets pushed on the control stack, so we should try to + detect and handle all of these cases fairly quickly. Of course, + the trap overhead is going to slow things down quite a bit. + */ + + if (X_opcode_p(the_trap,major_opcode_X31,minor_opcode_TR) && + (RA_field(the_trap) == sp) && + (TO_field(the_trap) == TO_LO)) { + area + *CS_area = tcr->cs_area, + *VS_area = tcr->vs_area; + + natural + current_SP = xpGPR(xp,sp), + current_VSP = xpGPR(xp,vsp); + + if (current_SP < (natural) (CS_area->hardlimit)) { + /* If we're not in soft overflow mode yet, assume that the + user has set the soft overflow size very small and try to + continue on another thread before throwing to toplevel */ + if ((tcr->cs_limit == CS_OVERFLOW_FORCE_LIMIT)) { + reset_lisp_process(xp); + } + } else { + if (tcr->cs_limit == CS_OVERFLOW_FORCE_LIMIT) { + /* If the control stack pointer is at least 4K away from its soft limit + and the value stack pointer is at least 4K away from its soft limit, + stop trapping. Else keep trapping. */ + if ((current_SP > (natural) ((CS_area->softlimit)+4096)) && + (current_VSP > (natural) ((VS_area->softlimit)+4096))) { + protected_area_ptr vs_soft = VS_area->softprot; + if (vs_soft->nprot == 0) { + protect_area(vs_soft); + } + tcr->cs_limit = ptr_to_lispobj(CS_area->softlimit); + } + } else { + tcr->cs_limit = ptr_to_lispobj(CS_area->hardlimit); + signal_stack_soft_overflow(xp, sp); + } + } + + adjust_exception_pc(xp, 4); + return noErr; + } else { + if (the_trap == LISP_BREAK_INSTRUCTION) { + char *message = (char *) ptr_from_lispobj(xpGPR(xp,3)); + set_xpPC(xp, xpLR(xp)); + if (message == NULL) { + message = "Lisp Breakpoint"; + } + lisp_Debugger(xp, info, debug_entry_dbg, false, message); + return noErr; + } + if (the_trap == QUIET_LISP_BREAK_INSTRUCTION) { + adjust_exception_pc(xp,4); + lisp_Debugger(xp, info, debug_entry_dbg, false, "Lisp Breakpoint"); + return noErr; + } + /* + twlle ra,rb is used to detect tlb overflow, where RA = current + limit and RB = index to use. + */ + if ((X_opcode_p(the_trap, 31, minor_opcode_TR)) && + (TO_field(the_trap) == (TO_LO|TO_EQ))) { + if (extend_tcr_tlb(tcr, xp, RA_field(the_trap), RB_field(the_trap))) { + return noErr; + } + return -1; + } + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + if (the_trap == TRI_instruction(TO_GT,nargs,0)) { + /* reset interrup_level, interrupt_pending */ + TCR_INTERRUPT_LEVEL(tcr) = 0; + tcr->interrupt_pending = 0; + } +#if 0 + fprintf(dbgout, "About to do trap callback in 0x%x\n",tcr); +#endif + callback_for_trap(cmain, xp, where, (natural) the_trap, 0, 0); + adjust_exception_pc(xp, 4); + return(noErr); + } + return -1; + } +} + + +/* Look at up to TRAP_LOOKUP_TRIES instrs before trap instr for a pattern. + Stop if subtag_code_vector is encountered. */ +unsigned +scan_for_instr( unsigned target, unsigned mask, pc where ) +{ + int i = TRAP_LOOKUP_TRIES; + + while( i-- ) { + unsigned instr = *(--where); + if ( codevec_hdr_p(instr) ) { + return 0; + } else if ( match_instr(instr, mask, target) ) { + return instr; + } + } + return 0; +} + + +void non_fatal_error( char *msg ) +{ + fprintf( dbgout, "Non-fatal error: %s.\n", msg ); + fflush( dbgout ); +} + +/* The main opcode. */ + +int +is_conditional_trap(opcode instr) +{ + unsigned to = TO_field(instr); + int is_tr = X_opcode_p(instr,major_opcode_X31,minor_opcode_TR); + +#ifndef MACOS + if ((instr == LISP_BREAK_INSTRUCTION) || + (instr == QUIET_LISP_BREAK_INSTRUCTION)) { + return 1; + } +#endif + if (is_tr || major_opcode_p(instr,major_opcode_TRI)) { + /* A "tw/td" or "twi/tdi" instruction. To be unconditional, the + EQ bit must be set in the TO mask and either the register + operands (if "tw") are the same or either both of the signed or + both of the unsigned inequality bits must be set. */ + if (! (to & TO_EQ)) { + return 1; /* Won't trap on EQ: conditional */ + } + if (is_tr && (RA_field(instr) == RB_field(instr))) { + return 0; /* Will trap on EQ, same regs: unconditional */ + } + if (((to & (TO_LO|TO_HI)) == (TO_LO|TO_HI)) || + ((to & (TO_LT|TO_GT)) == (TO_LT|TO_GT))) { + return 0; /* Will trap on EQ and either (LT|GT) or (LO|HI) : unconditional */ + } + return 1; /* must be conditional */ + } + return 0; /* Not "tw/td" or "twi/tdi". Let + debugger have it */ +} + +OSStatus +handle_error(ExceptionInformation *xp, unsigned errnum, unsigned rb, unsigned continuable, pc where) +{ + LispObj errdisp = nrs_ERRDISP.vcell; + + if ((fulltag_of(errdisp) == fulltag_misc) && + (header_subtag(header_of(errdisp)) == subtag_macptr)) { + /* errdisp is a macptr, we can call back to lisp */ + callback_for_trap(errdisp, xp, where, errnum, rb, continuable); + return(0); + } + + return(-1); +} + + +/* + Current thread has all signals masked. Before unmasking them, + make it appear that the current thread has been suspended. + (This is to handle the case where another thread is trying + to GC before this thread is able to sieze the exception lock.) +*/ +int +prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context) +{ + int old_valence = tcr->valence; + + tcr->pending_exception_context = context; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + + ALLOW_EXCEPTIONS(context); + return old_valence; +} + +void +wait_for_exception_lock_in_handler(TCR *tcr, + ExceptionInformation *context, + xframe_list *xf) +{ + + LOCK(lisp_global(EXCEPTION_LOCK), tcr); +#ifdef DEBUG + fprintf(dbgout, "0x%x has exception lock\n", tcr); +#endif + xf->curr = context; + xf->prev = tcr->xframe; + tcr->xframe = xf; + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_FOREIGN; +} + +void +unlock_exception_lock_in_handler(TCR *tcr) +{ + tcr->pending_exception_context = tcr->xframe->curr; + tcr->xframe = tcr->xframe->prev; + tcr->valence = TCR_STATE_EXCEPTION_RETURN; +#ifdef DEBUG + fprintf(dbgout, "0x%x releasing exception lock\n", tcr); +#endif + UNLOCK(lisp_global(EXCEPTION_LOCK),tcr); +} + +/* + If an interrupt is pending on exception exit, try to ensure + that the thread sees it as soon as it's able to run. +*/ +void +raise_pending_interrupt(TCR *tcr) +{ + if (TCR_INTERRUPT_LEVEL(tcr) > 0) { + pthread_kill((pthread_t)ptr_from_lispobj(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT); + } +} + +void +exit_signal_handler(TCR *tcr, int old_valence) +{ + sigset_t mask; + sigfillset(&mask); + + pthread_sigmask(SIG_SETMASK,&mask, NULL); + tcr->valence = old_valence; + tcr->pending_exception_context = NULL; +} + + +void +signal_handler(int signum, siginfo_t *info, ExceptionInformation *context, TCR *tcr, int old_valence) +{ + xframe_list xframe_link; + + if (!use_mach_exception_handling) { + + tcr = (TCR *) get_interrupt_tcr(false); + + /* The signal handler's entered with all signals (notably the + thread_suspend signal) blocked. Don't allow any other signals + (notably the thread_suspend signal) to preempt us until we've + set the TCR's xframe slot to include the current exception + context. + */ + + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + } + + if (tcr->flags & (1<regs at #x%lx", signum, xpPC(context), (natural)xpGPRvector(context)); + if (lisp_Debugger(context, info, signum, false, msg)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); + } + } + + unlock_exception_lock_in_handler(tcr); + + /* This thread now looks like a thread that was suspended while + executing lisp code. If some other thread gets the exception + lock and GCs, the context (this thread's suspend_context) will + be updated. (That's only of concern if it happens before we + can return to the kernel/to the Mach exception handler). + */ + if (!use_mach_exception_handling) { + exit_signal_handler(tcr, old_valence); + raise_pending_interrupt(tcr); + } +} + +/* + If it looks like we're in the middle of an atomic operation, make + it seem as if that operation is either complete or hasn't started + yet. + + The cases handled include: + + a) storing into a newly-allocated lisp frame on the stack. + b) marking a newly-allocated TSP frame as containing "raw" data. + c) consing: the GC has its own ideas about how this should be + handled, but other callers would be best advised to back + up or move forward, according to whether we're in the middle + of allocating a cons cell or allocating a uvector. + d) a STMW to the vsp + e) EGC write-barrier subprims. +*/ + +extern opcode + egc_write_barrier_start, + egc_write_barrier_end, + egc_store_node_conditional, + egc_store_node_conditional_test, + egc_set_hash_key, + egc_gvset, + egc_rplaca, + egc_rplacd, + egc_set_hash_key_conditional, + egc_set_hash_key_conditional_test; + + +extern opcode ffcall_return_window, ffcall_return_window_end; + +void +pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *alloc_disp) +{ + pc program_counter = xpPC(xp); + opcode instr = *program_counter; + lisp_frame *frame = (lisp_frame *)ptr_from_lispobj(xpGPR(xp,sp)); + LispObj cur_allocptr = xpGPR(xp, allocptr); + int allocptr_tag = fulltag_of(cur_allocptr); + + + + if ((program_counter < &egc_write_barrier_end) && + (program_counter >= &egc_write_barrier_start)) { + LispObj *ea = 0, val = 0, root = 0; + bitvector refbits = (bitvector)(lisp_global(REFBITS)); + Boolean need_store = true, need_check_memo = true, need_memoize_root = false; + + if (program_counter >= &egc_set_hash_key_conditional) { + if ((program_counter < &egc_set_hash_key_conditional_test) || + ((program_counter == &egc_set_hash_key_conditional_test) && + (! (xpCCR(xp) & 0x20000000)))) { + return; + } + need_store = false; + root = xpGPR(xp,arg_x); + ea = (LispObj *) (root+xpGPR(xp,arg_y)+misc_data_offset); + need_memoize_root = true; + } else if (program_counter >= &egc_store_node_conditional) { + if ((program_counter < &egc_store_node_conditional_test) || + ((program_counter == &egc_store_node_conditional_test) && + (! (xpCCR(xp) & 0x20000000)))) { + /* The conditional store either hasn't been attempted yet, or + has failed. No need to adjust the PC, or do memoization. */ + return; + } + ea = (LispObj*)(xpGPR(xp,arg_x) + xpGPR(xp,imm4)); + xpGPR(xp,arg_z) = t_value; + need_store = false; + } else if (program_counter >= &egc_set_hash_key) { + root = xpGPR(xp,arg_x); + val = xpGPR(xp,arg_z); + ea = (LispObj *) (root+xpGPR(xp,arg_y)+misc_data_offset); + need_memoize_root = true; + } else if (program_counter >= &egc_gvset) { + ea = (LispObj *) (xpGPR(xp,arg_x)+xpGPR(xp,arg_y)+misc_data_offset); + val = xpGPR(xp,arg_z); + } else if (program_counter >= &egc_rplacd) { + ea = (LispObj *) untag(xpGPR(xp,arg_y)); + val = xpGPR(xp,arg_z); + } else { /* egc_rplaca */ + ea = ((LispObj *) untag(xpGPR(xp,arg_y)))+1; + val = xpGPR(xp,arg_z); + } + if (need_store) { + *ea = val; + } + if (need_check_memo) { + natural bitnumber = area_dnode(ea, lisp_global(HEAP_START)); + if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) && + ((LispObj)ea < val)) { + atomic_set_bit(refbits, bitnumber); + if (need_memoize_root) { + bitnumber = area_dnode(root, lisp_global(HEAP_START)); + atomic_set_bit(refbits, bitnumber); + } + } + } + set_xpPC(xp, xpLR(xp)); + return; + } + + + if (instr == MARK_TSP_FRAME_INSTRUCTION) { + LispObj tsp_val = xpGPR(xp,tsp); + + ((LispObj *)ptr_from_lispobj(tsp_val))[1] = tsp_val; + adjust_exception_pc(xp, 4); + return; + } + + if (frame->backlink == (frame+1)) { + if ( +#ifdef PPC64 + (major_opcode_p(instr, major_opcode_DS_STORE64)) && + (DS_VARIANT_FIELD(instr) == DS_STORE64_VARIANT_STD) && +#else + (major_opcode_p(instr, major_opcode_STW)) && +#endif + (RA_field(instr) == sp) && + /* There are a few places in the runtime that store into + a previously-allocated frame atop the stack when + throwing values around. We only care about the case + where the frame was newly allocated, in which case + there must have been a CREATE_LISP_FRAME_INSTRUCTION + a few instructions before the current program counter. + (The whole point here is that a newly allocated frame + might contain random values that we don't want the + GC to see; a previously allocated frame should already + be completely initialized.) + */ + ((program_counter[-1] == CREATE_LISP_FRAME_INSTRUCTION) || + (program_counter[-2] == CREATE_LISP_FRAME_INSTRUCTION) || + (program_counter[-3] == CREATE_LISP_FRAME_INSTRUCTION))) { +#ifdef PPC64 + int disp = DS_field(instr); +#else + int disp = D_field(instr); +#endif + + + if (disp < (4*node_size)) { +#if 0 + fprintf(dbgout, "pc-luser: finish SP frame in 0x%x, disp = %d\n",tcr, disp); +#endif + frame->savevsp = 0; + if (disp < (3*node_size)) { + frame->savelr = 0; + if (disp == node_size) { + frame->savefn = 0; + } + } + } + return; + } + } + + if (allocptr_tag != tag_fixnum) { + signed_natural disp = allocptr_displacement(xp); + + if (disp) { + /* Being architecturally "at" the alloc trap doesn't tell + us much (in particular, it doesn't tell us whether + or not the thread has committed to taking the trap + and is waiting for the exception lock (or waiting + for the Mach exception thread to tell it how bad + things are) or is about to execute a conditional + trap. + Regardless of which case applies, we want the + other thread to take (or finish taking) the + trap, and we don't want it to consider its + current allocptr to be valid. + The difference between this case (suspend other + thread for GC) and the previous case (suspend + current thread for interrupt) is solely a + matter of what happens after we leave this + function: some non-current thread will stay + suspended until the GC finishes, then take + (or start processing) the alloc trap. The + current thread will go off and do PROCESS-INTERRUPT + or something, and may return from the interrupt + and need to finish the allocation that got interrupted. + */ + + if (alloc_disp) { + *alloc_disp = disp; + xpGPR(xp,allocptr) += disp; + /* Leave the PC at the alloc trap. When the interrupt + handler returns, it'll decrement allocptr by disp + and the trap may or may not be taken. + */ + } else { + update_bytes_allocated(tcr, (void *) ptr_from_lispobj(cur_allocptr + disp)); + xpGPR(xp, allocbase) = VOID_ALLOCPTR; + xpGPR(xp, allocptr) = VOID_ALLOCPTR - disp; + } + } else { +#ifdef DEBUG + fprintf(dbgout, "tcr 0x%x is past alloc trap, finishing alloc at 0x%x\n", tcr, xpGPR(xp,allocptr)); +#endif + /* If we're already past the alloc_trap, finish allocating + the object. */ + if (allocptr_tag == fulltag_cons) { + finish_allocating_cons(xp); +#ifdef DEBUG + fprintf(dbgout, "finish allocating cons in TCR = #x%x\n", + tcr); +#endif + } else { + if (allocptr_tag == fulltag_misc) { +#ifdef DEBUG + fprintf(dbgout, "finish allocating uvector in TCR = #x%x\n", + tcr); +#endif + finish_allocating_uvector(xp); + } else { + Bug(xp, "what's being allocated here ?"); + } + } + /* Whatever we finished allocating, reset allocptr/allocbase to + VOID_ALLOCPTR */ + xpGPR(xp,allocptr) = xpGPR(xp,allocbase) = VOID_ALLOCPTR; + } + return; + } + + if ((instr & INIT_CATCH_FRAME_MASK) == INIT_CATCH_FRAME_INSTRUCTION) { + LispObj *frame = ptr_from_lispobj(untag(xpGPR(xp, nargs))); + int idx = ((int)((short)(D_field(instr))+fulltag_misc))>>fixnumshift; +#if 0 + fprintf(dbgout, "pc-luser: CATCH frame in 0x%x, idx = %d\n",tcr, idx); +#endif + + for (;idx < sizeof(catch_frame)/sizeof(LispObj); idx++) { + deref(frame,idx) = 0; + } + ((LispObj *)(xpGPR(xp, tsp)))[1] = 0; + return; + } + +#ifndef PC64 + if ((major_opcode_p(instr, 47)) && /* 47 = stmw */ + (RA_field(instr) == vsp)) { + int r; + LispObj *vspptr = ptr_from_lispobj(xpGPR(xp,vsp)); + + for (r = RS_field(instr); r <= 31; r++) { + *vspptr++ = xpGPR(xp,r); + } + adjust_exception_pc(xp, 4); + } +#endif +} + +void +interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ + TCR *tcr = get_interrupt_tcr(false); + if (tcr) { + if (TCR_INTERRUPT_LEVEL(tcr) < 0) { + tcr->interrupt_pending = 1 << fixnumshift; + } else { + LispObj cmain = nrs_CMAIN.vcell; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + /* + This thread can (allegedly) take an interrupt now. + It's tricky to do that if we're executing + foreign code (especially Linuxthreads code, much + of which isn't reentrant.) + If we're unwinding the stack, we also want to defer + the interrupt. + */ + if ((tcr->valence != TCR_STATE_LISP) || + (tcr->unwinding != 0)) { + TCR_INTERRUPT_LEVEL(tcr) = (1 << fixnumshift); + } else { + xframe_list xframe_link; + int old_valence; + signed_natural disp=0; + + pc_luser_xp(context, tcr, &disp); + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + wait_for_exception_lock_in_handler(tcr, context, &xframe_link); +#ifdef DEBUG + fprintf(dbgout, "[0x%x acquired exception lock for interrupt]\n",tcr); +#endif + PMCL_exception_handler(signum, context, tcr, info, old_valence); + if (disp) { + xpGPR(context,allocptr) -= disp; + } + unlock_exception_lock_in_handler(tcr); +#ifdef DEBUG + fprintf(dbgout, "[0x%x released exception lock for interrupt]\n",tcr); +#endif + exit_signal_handler(tcr, old_valence); + } + } + } + } +#ifdef DARWIN + DarwinSigReturn(context); +#endif +} + + + +void +install_signal_handler(int signo, void *handler) +{ + struct sigaction sa; + + sa.sa_sigaction = (void *)handler; + sigfillset(&sa.sa_mask); + sa.sa_flags = + 0 /* SA_RESTART */ + | SA_SIGINFO +#ifdef DARWIN +#ifdef PPC64 + | SA_64REGSET +#endif +#endif + ; + + sigaction(signo, &sa, NULL); +} + +void +install_pmcl_exception_handlers() +{ +#ifdef DARWIN + extern Boolean use_mach_exception_handling; +#endif + + Boolean install_signal_handlers_for_exceptions = +#ifdef DARWIN + !use_mach_exception_handling +#else + true +#endif + ; + if (install_signal_handlers_for_exceptions) { + extern int no_sigtrap; + install_signal_handler(SIGILL, (void *)signal_handler); + if (no_sigtrap != 1) { + install_signal_handler(SIGTRAP, (void *)signal_handler); + } + install_signal_handler(SIGBUS, (void *)signal_handler); + install_signal_handler(SIGSEGV, (void *)signal_handler); + install_signal_handler(SIGFPE, (void *)signal_handler); + } + + install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, + (void *)interrupt_handler); + signal(SIGPIPE, SIG_IGN); +} + +void +thread_kill_handler(int signum, siginfo_t info, ExceptionInformation *xp) +{ + TCR *tcr = get_tcr(false); + area *a; + sigset_t mask; + + sigemptyset(&mask); + + if (tcr) { + tcr->valence = TCR_STATE_FOREIGN; + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + a = tcr->cs_area; + if (a) { + a->active = a->high; + } + } + + pthread_sigmask(SIG_SETMASK,&mask,NULL); + pthread_exit(NULL); +} + +void +thread_signal_setup() +{ + thread_suspend_signal = SIG_SUSPEND_THREAD; + thread_kill_signal = SIG_KILL_THREAD; + + install_signal_handler(thread_suspend_signal, (void *) suspend_resume_handler); + install_signal_handler(thread_kill_signal, (void *)thread_kill_handler); +} + + + +void +unprotect_all_areas() +{ + protected_area_ptr p; + + for(p = AllProtectedAreas, AllProtectedAreas = NULL; p; p = p->next) { + unprotect_area(p); + } +} + +/* + A binding subprim has just done "twlle limit_regno,idx_regno" and + the trap's been taken. Extend the tcr's tlb so that the index will + be in bounds and the new limit will be on a page boundary, filling + in the new page(s) with 'no_thread_local_binding_marker'. Update + the tcr fields and the registers in the xp and return true if this + all works, false otherwise. + + Note that the tlb was allocated via malloc, so realloc can do some + of the hard work. +*/ +Boolean +extend_tcr_tlb(TCR *tcr, + ExceptionInformation *xp, + unsigned limit_regno, + unsigned idx_regno) +{ + unsigned + index = (unsigned) (xpGPR(xp,idx_regno)), + old_limit = tcr->tlb_limit, + new_limit = align_to_power_of_2(index+1,12), + new_bytes = new_limit-old_limit; + LispObj + *old_tlb = tcr->tlb_pointer, + *new_tlb = realloc(old_tlb, new_limit), + *work; + + if (new_tlb == NULL) { + return false; + } + + work = (LispObj *) ((BytePtr)new_tlb+old_limit); + + while (new_bytes) { + *work++ = no_thread_local_binding_marker; + new_bytes -= sizeof(LispObj); + } + tcr->tlb_pointer = new_tlb; + tcr->tlb_limit = new_limit; + xpGPR(xp, limit_regno) = new_limit; + return true; +} + + + +void +exception_init() +{ + install_pmcl_exception_handlers(); +} + + + + + +#ifdef DARWIN + + +#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p)) +#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr))) + + + +#define LISP_EXCEPTIONS_HANDLED_MASK \ + (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC) + +/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */ +#define NUM_LISP_EXCEPTIONS_HANDLED 4 + +typedef struct { + int foreign_exception_port_count; + exception_mask_t masks[NUM_LISP_EXCEPTIONS_HANDLED]; + mach_port_t ports[NUM_LISP_EXCEPTIONS_HANDLED]; + exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED]; + thread_state_flavor_t flavors[NUM_LISP_EXCEPTIONS_HANDLED]; +} MACH_foreign_exception_state; + + + + +/* + Mach's exception mechanism works a little better than its signal + mechanism (and, not incidentally, it gets along with GDB a lot + better. + + Initially, we install an exception handler to handle each native + thread's exceptions. This process involves creating a distinguished + thread which listens for kernel exception messages on a set of + 0 or more thread exception ports. As threads are created, they're + added to that port set; a thread's exception port is destroyed + (and therefore removed from the port set) when the thread exits. + + A few exceptions can be handled directly in the handler thread; + others require that we resume the user thread (and that the + exception thread resumes listening for exceptions.) The user + thread might eventually want to return to the original context + (possibly modified somewhat.) + + As it turns out, the simplest way to force the faulting user + thread to handle its own exceptions is to do pretty much what + signal() does: the exception handlng thread sets up a sigcontext + on the user thread's stack and forces the user thread to resume + execution as if a signal handler had been called with that + context as an argument. We can use a distinguished UUO at a + distinguished address to do something like sigreturn(); that'll + have the effect of resuming the user thread's execution in + the (pseudo-) signal context. + + Since: + a) we have miles of code in C and in Lisp that knows how to + deal with Linux sigcontexts + b) Linux sigcontexts contain a little more useful information + (the DAR, DSISR, etc.) than their Darwin counterparts + c) we have to create a sigcontext ourselves when calling out + to the user thread: we aren't really generating a signal, just + leveraging existing signal-handling code. + + we create a Linux sigcontext struct. + + Simple ? Hopefully from the outside it is ... + + We want the process of passing a thread's own context to it to + appear to be atomic: in particular, we don't want the GC to suspend + a thread that's had an exception but has not yet had its user-level + exception handler called, and we don't want the thread's exception + context to be modified by a GC while the Mach handler thread is + copying it around. On Linux (and on Jaguar), we avoid this issue + because (a) the kernel sets up the user-level signal handler and + (b) the signal handler blocks signals (including the signal used + by the GC to suspend threads) until tcr->xframe is set up. + + The GC and the Mach server thread therefore contend for the lock + "mach_exception_lock". The Mach server thread holds the lock + when copying exception information between the kernel and the + user thread; the GC holds this lock during most of its execution + (delaying exception processing until it can be done without + GC interference.) + +*/ + +#ifdef PPC64 +#define C_REDZONE_LEN 320 +#define C_STK_ALIGN 32 +#else +#define C_REDZONE_LEN 224 +#define C_STK_ALIGN 16 +#endif +#define C_PARAMSAVE_LEN 64 +#define C_LINKAGE_LEN 48 + +#define TRUNC_DOWN(a,b,c) (((((natural)a)-(b))/(c)) * (c)) + +void +fatal_mach_error(char *format, ...); + +#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);} + + +void +restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext) +{ + kern_return_t kret; + MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext); + + /* Set the thread's FP state from the pseudosigcontext */ + kret = thread_set_state(thread, + PPC_FLOAT_STATE, + (thread_state_t)&(mc->__fs), + PPC_FLOAT_STATE_COUNT); + + MACH_CHECK_ERROR("setting thread FP state", kret); + + /* The thread'll be as good as new ... */ +#ifdef PPC64 + kret = thread_set_state(thread, + PPC_THREAD_STATE64, + (thread_state_t)&(mc->__ss), + PPC_THREAD_STATE64_COUNT); +#else + kret = thread_set_state(thread, + MACHINE_THREAD_STATE, + (thread_state_t)&(mc->__ss), + MACHINE_THREAD_STATE_COUNT); +#endif + MACH_CHECK_ERROR("setting thread state", kret); +} + +/* This code runs in the exception handling thread, in response + to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g., + in response to a call to pseudo_sigreturn() from the specified + user thread. + Find that context (the user thread's R3 points to it), then + use that context to set the user thread's state. When this + function's caller returns, the Mach kernel will resume the + user thread. +*/ + +kern_return_t +do_pseudo_sigreturn(mach_port_t thread, TCR *tcr) +{ + ExceptionInformation *xp; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr); +#endif + xp = tcr->pending_exception_context; + if (xp) { + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_LISP; + restore_mach_thread_state(thread, xp); + raise_pending_interrupt(tcr); + } else { + Bug(NULL, "no xp here!\n"); + } +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr); +#endif + return KERN_SUCCESS; +} + +ExceptionInformation * +create_thread_context_frame(mach_port_t thread, + natural *new_stack_top) +{ +#ifdef PPC64 + ppc_thread_state64_t ts; +#else + ppc_thread_state_t ts; +#endif + mach_msg_type_number_t thread_state_count; + kern_return_t result; + ExceptionInformation *pseudosigcontext; + MCONTEXT_T mc; + natural stackp, backlink; + +#ifdef PPC64 + thread_state_count = PPC_THREAD_STATE64_COUNT; + result = thread_get_state(thread, + PPC_THREAD_STATE64, + (thread_state_t)&ts, + &thread_state_count); +#else + thread_state_count = MACHINE_THREAD_STATE_COUNT; + result = thread_get_state(thread, + PPC_THREAD_STATE, /* GPRs, some SPRs */ + (thread_state_t)&ts, + &thread_state_count); +#endif + + if (result != KERN_SUCCESS) { + get_tcr(true); + Bug(NULL, "Exception thread can't obtain thread state, Mach result = %d", result); + } + stackp = ts.__r1; + backlink = stackp; + stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN); + stackp -= sizeof(*pseudosigcontext); + pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp); + + stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN); + mc = (MCONTEXT_T) ptr_from_lispobj(stackp); + memmove(&(mc->__ss),&ts,sizeof(ts)); + + thread_state_count = PPC_FLOAT_STATE_COUNT; + thread_get_state(thread, + PPC_FLOAT_STATE, + (thread_state_t)&(mc->__fs), + &thread_state_count); + + +#ifdef PPC64 + thread_state_count = PPC_EXCEPTION_STATE64_COUNT; +#else + thread_state_count = PPC_EXCEPTION_STATE_COUNT; +#endif + thread_get_state(thread, +#ifdef PPC64 + PPC_EXCEPTION_STATE64, +#else + PPC_EXCEPTION_STATE, +#endif + (thread_state_t)&(mc->__es), + &thread_state_count); + + + UC_MCONTEXT(pseudosigcontext) = mc; + stackp = TRUNC_DOWN(stackp, C_PARAMSAVE_LEN, C_STK_ALIGN); + stackp -= C_LINKAGE_LEN; + *(natural *)ptr_from_lispobj(stackp) = backlink; + if (new_stack_top) { + *new_stack_top = stackp; + } + return pseudosigcontext; +} + +/* + This code sets up the user thread so that it executes a "pseudo-signal + handler" function when it resumes. Create a linux sigcontext struct + on the thread's stack and pass it as an argument to the pseudo-signal + handler. + + Things are set up so that the handler "returns to" pseudo_sigreturn(), + which will restore the thread's context. + + If the handler invokes code that throws (or otherwise never sigreturn()'s + to the context), that's fine. + + Actually, check that: throw (and variants) may need to be careful and + pop the tcr's xframe list until it's younger than any frame being + entered. +*/ + +int +setup_signal_frame(mach_port_t thread, + void *handler_address, + int signum, + int code, + TCR *tcr) +{ +#ifdef PPC64 + ppc_thread_state64_t ts; +#else + ppc_thread_state_t ts; +#endif + ExceptionInformation *pseudosigcontext; + int old_valence = tcr->valence; + natural stackp; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr); +#endif + pseudosigcontext = create_thread_context_frame(thread, &stackp); + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + tcr->pending_exception_context = pseudosigcontext; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + + + /* + It seems like we've created a sigcontext on the thread's + stack. Set things up so that we call the handler (with appropriate + args) when the thread's resumed. + */ + + ts.__srr0 = (natural) handler_address; + ts.__srr1 = (int) xpMSR(pseudosigcontext) & ~MSR_FE0_FE1_MASK; + ts.__r1 = stackp; + ts.__r3 = signum; + ts.__r4 = (natural)pseudosigcontext; + ts.__r5 = (natural)tcr; + ts.__r6 = (natural)old_valence; + ts.__lr = (natural)pseudo_sigreturn; + + +#ifdef PPC64 + ts.__r13 = xpGPR(pseudosigcontext,13); + thread_set_state(thread, + PPC_THREAD_STATE64, + (thread_state_t)&ts, + PPC_THREAD_STATE64_COUNT); +#else + thread_set_state(thread, + MACHINE_THREAD_STATE, + (thread_state_t)&ts, + MACHINE_THREAD_STATE_COUNT); +#endif +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context); +#endif + return 0; +} + + +void +pseudo_signal_handler(int signum, ExceptionInformation *context, TCR *tcr, int old_valence) +{ + signal_handler(signum, NULL, context, tcr, old_valence); +} + + +int +thread_set_fp_exceptions_enabled(mach_port_t thread, Boolean enabled) +{ +#ifdef PPC64 + ppc_thread_state64_t ts; +#else + ppc_thread_state_t ts; +#endif + mach_msg_type_number_t thread_state_count; + +#ifdef PPC64 + thread_state_count = PPC_THREAD_STATE64_COUNT; +#else + thread_state_count = PPC_THREAD_STATE_COUNT; +#endif + thread_get_state(thread, +#ifdef PPC64 + PPC_THREAD_STATE64, /* GPRs, some SPRs */ +#else + PPC_THREAD_STATE, /* GPRs, some SPRs */ +#endif + (thread_state_t)&ts, + &thread_state_count); + if (enabled) { + ts.__srr1 |= MSR_FE0_FE1_MASK; + } else { + ts.__srr1 &= ~MSR_FE0_FE1_MASK; + } + /* + Hack-o-rama warning (isn't it about time for such a warning?): + pthread_kill() seems to want to lose the MSR's FE0/FE1 bits. + Our handler for lisp's use of pthread_kill() pushes a phony + lisp frame on the stack and force the context to resume at + the UUO in enable_fp_exceptions(); the "saveLR" field of that + lisp frame contains the -real- address that process_interrupt + should have returned to, and the fact that it's in a lisp + frame should convince the GC to notice that address if it + runs in the tiny time window between returning from our + interrupt handler and ... here. + If the top frame on the stack is a lisp frame, discard it + and set ts.srr0 to the saveLR field in that frame. Otherwise, + just adjust ts.srr0 to skip over the UUO. + */ + { + lisp_frame *tos = (lisp_frame *)ts.__r1, + *next_frame = tos->backlink; + + if (tos == (next_frame -1)) { + ts.__srr0 = tos->savelr; + ts.__r1 = (LispObj) next_frame; + } else { + ts.__srr0 += 4; + } + } + thread_set_state(thread, +#ifdef PPC64 + PPC_THREAD_STATE64, /* GPRs, some SPRs */ +#else + PPC_THREAD_STATE, /* GPRs, some SPRs */ +#endif + (thread_state_t)&ts, +#ifdef PPC64 + PPC_THREAD_STATE64_COUNT +#else + PPC_THREAD_STATE_COUNT +#endif + ); + + return 0; +} + +/* + This function runs in the exception handling thread. It's + called (by this precise name) from the library function "exc_server()" + when the thread's exception ports are set up. (exc_server() is called + via mach_msg_server(), which is a function that waits for and dispatches + on exception messages from the Mach kernel.) + + This checks to see if the exception was caused by a pseudo_sigreturn() + UUO; if so, it arranges for the thread to have its state restored + from the specified context. + + Otherwise, it tries to map the exception to a signal number and + arranges that the thread run a "pseudo signal handler" to handle + the exception. + + Some exceptions could and should be handled here directly. +*/ + +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_vector, + mach_msg_type_number_t code_count) +{ + int signum = 0, code = *code_vector, code1; + TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port); + kern_return_t kret; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "obtaining Mach exception lock in exception thread\n"); +#endif + + if (tcr->flags & (1<flags & (1<NDR = _NDR; + + out->msgh_bits = in->msgh_bits & MACH_MSGH_BITS_REMOTE_MASK; + out->msgh_remote_port = in->msgh_remote_port; + out->msgh_size = sizeof(mach_msg_header_t)+(3 * sizeof(unsigned)); + out->msgh_local_port = MACH_PORT_NULL; + out->msgh_id = in->msgh_id+100; + + /* Could handle other exception flavors in the range 2401-2403 */ + + + if (in->msgh_id != 2401) { + reply->RetCode = MIG_BAD_ID; + return FALSE; + } + handled = catch_exception_raise(req->Head.msgh_local_port, + req->thread.name, + req->task.name, + req->exception, + req->code, + req->codeCnt); + reply->RetCode = handled; + return TRUE; +} + +/* + The initial function for an exception-handling thread. +*/ + +void * +exception_handler_proc(void *arg) +{ + extern boolean_t exc_server(); + mach_port_t p = TCR_TO_EXCEPTION_PORT(arg); + + mach_msg_server(openmcl_exc_server, 2048, p, 0); + /* Should never return. */ + abort(); +} + + + +mach_port_t +mach_exception_port_set() +{ + static mach_port_t __exception_port_set = MACH_PORT_NULL; + kern_return_t kret; + if (__exception_port_set == MACH_PORT_NULL) { + kret = mach_port_allocate(mach_task_self(), + MACH_PORT_RIGHT_PORT_SET, + &__exception_port_set); + MACH_CHECK_ERROR("allocating thread exception_ports",kret); + create_system_thread(0, + NULL, + exception_handler_proc, + (void *)((natural)__exception_port_set)); + } + return __exception_port_set; +} + +/* + Setup a new thread to handle those exceptions specified by + the mask "which". This involves creating a special Mach + message port, telling the Mach kernel to send exception + messages for the calling thread to that port, and setting + up a handler thread which listens for and responds to + those messages. + +*/ + +/* + Establish the lisp thread's TCR as its exception port, and determine + whether any other ports have been established by foreign code for + exceptions that lisp cares about. + + If this happens at all, it should happen on return from foreign + code and on entry to lisp code via a callback. + + This is a lot of trouble (and overhead) to support Java, or other + embeddable systems that clobber their caller's thread exception ports. + +*/ +kern_return_t +tcr_establish_exception_port(TCR *tcr, mach_port_t thread) +{ + kern_return_t kret; + MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info; + int i; + unsigned n = NUM_LISP_EXCEPTIONS_HANDLED; + mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port; + exception_mask_t mask = 0; + + kret = thread_swap_exception_ports(thread, + LISP_EXCEPTIONS_HANDLED_MASK, + lisp_port, + EXCEPTION_DEFAULT, + THREAD_STATE_NONE, + fxs->masks, + &n, + fxs->ports, + fxs->behaviors, + fxs->flavors); + if (kret == KERN_SUCCESS) { + fxs->foreign_exception_port_count = n; + for (i = 0; i < n; i ++) { + foreign_port = fxs->ports[i]; + + if ((foreign_port != lisp_port) && + (foreign_port != MACH_PORT_NULL)) { + mask |= fxs->masks[i]; + } + } + tcr->foreign_exception_status = (int) mask; + } + return kret; +} + +kern_return_t +tcr_establish_lisp_exception_port(TCR *tcr) +{ + return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id)); +} + +/* + Do this when calling out to or returning from foreign code, if + any conflicting foreign exception ports were established when we + last entered lisp code. +*/ +kern_return_t +restore_foreign_exception_ports(TCR *tcr) +{ + exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status; + + if (m) { + MACH_foreign_exception_state *fxs = + (MACH_foreign_exception_state *) tcr->native_thread_info; + int i, n = fxs->foreign_exception_port_count; + exception_mask_t tm; + + for (i = 0; i < n; i++) { + if ((tm = fxs->masks[i]) & m) { + thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id), + tm, + fxs->ports[i], + fxs->behaviors[i], + fxs->flavors[i]); + } + } + } +} + + +/* + This assumes that a Mach port (to be used as the thread's exception port) whose + "name" matches the TCR's 32-bit address has already been allocated. +*/ + +kern_return_t +setup_mach_exception_handling(TCR *tcr) +{ + mach_port_t + thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr), + task_self = mach_task_self(); + kern_return_t kret; + + kret = mach_port_insert_right(task_self, + thread_exception_port, + thread_exception_port, + MACH_MSG_TYPE_MAKE_SEND); + MACH_CHECK_ERROR("adding send right to exception_port",kret); + + kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id)); + if (kret == KERN_SUCCESS) { + mach_port_t exception_port_set = mach_exception_port_set(); + + kret = mach_port_move_member(task_self, + thread_exception_port, + exception_port_set); + } + return kret; +} + +void +darwin_exception_init(TCR *tcr) +{ + void tcr_monitor_exception_handling(TCR*, Boolean); + kern_return_t kret; + MACH_foreign_exception_state *fxs = + calloc(1, sizeof(MACH_foreign_exception_state)); + + tcr->native_thread_info = (void *) fxs; + + if ((kret = setup_mach_exception_handling(tcr)) + != KERN_SUCCESS) { + fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret); + terminate_lisp(); + } + lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports; + lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port; +} + +/* + The tcr is the "name" of the corresponding thread's exception port. + Destroying the port should remove it from all port sets of which it's + a member (notably, the exception port set.) +*/ +void +darwin_exception_cleanup(TCR *tcr) +{ + void *fxs = tcr->native_thread_info; + extern Boolean use_mach_exception_handling; + + if (fxs) { + tcr->native_thread_info = NULL; + free(fxs); + } + if (use_mach_exception_handling) { + mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + } +} + + +Boolean +suspend_mach_thread(mach_port_t mach_thread) +{ + kern_return_t status; + Boolean aborted = false; + + do { + aborted = false; + status = thread_suspend(mach_thread); + if (status == KERN_SUCCESS) { + status = thread_abort_safely(mach_thread); + if (status == KERN_SUCCESS) { + aborted = true; + } else { + fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread); + thread_resume(mach_thread); + } + } else { + return false; + } + } while (! aborted); + return true; +} + +/* + Only do this if pthread_kill indicated that the pthread isn't + listening to signals anymore, as can happen as soon as pthread_exit() + is called on Darwin. The thread could still call out to lisp as it + is exiting, so we need another way to suspend it in this case. +*/ +Boolean +mach_suspend_tcr(TCR *tcr) +{ + mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id)); + ExceptionInformation *pseudosigcontext; + Boolean result = false; + + result = suspend_mach_thread(mach_thread); + if (result) { + pseudosigcontext = create_thread_context_frame(mach_thread, NULL); + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + tcr->suspend_context = pseudosigcontext; + } + return result; +} + +void +mach_resume_tcr(TCR *tcr) +{ + ExceptionInformation *xp; + mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id)); + + xp = tcr->suspend_context; +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + tcr->suspend_context = NULL; + restore_mach_thread_state(mach_thread, xp); +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + thread_resume(mach_thread); +} + +void +fatal_mach_error(char *format, ...) +{ + va_list args; + char s[512]; + + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + + Fatal("Mach error", s); +} + +void +pseudo_interrupt_handler(int signum, ExceptionInformation *context) +{ + interrupt_handler(signum, NULL, context); +} + +int +mach_raise_thread_interrupt(TCR *target) +{ + mach_port_t mach_thread = (mach_port_t)((natural)(target->native_thread_id)); + kern_return_t kret; + Boolean result = false; + TCR *current = get_tcr(false); + thread_basic_info_data_t info; + mach_msg_type_number_t info_count = THREAD_BASIC_INFO_COUNT; + + LOCK(lisp_global(TCR_AREA_LOCK), current); + + if (suspend_mach_thread(mach_thread)) { + if (thread_info(mach_thread, + THREAD_BASIC_INFO, + (thread_info_t)&info, + &info_count) == KERN_SUCCESS) { + if (info.suspend_count == 1) { + if ((target->valence == TCR_STATE_LISP) && + (!target->unwinding) && + (TCR_INTERRUPT_LEVEL(target) >= 0)) { + kret = setup_signal_frame(mach_thread, + (void *)pseudo_interrupt_handler, + SIGNAL_FOR_PROCESS_INTERRUPT, + 0, + target); + if (kret == KERN_SUCCESS) { + result = true; + } + } + } + } + if (! result) { + target->interrupt_pending = 1 << fixnumshift; + } + thread_resume(mach_thread); + + } + UNLOCK(lisp_global(TCR_AREA_LOCK), current); + return 0; +} + +#endif Index: /branches/qres/ccl/lisp-kernel/ppc-exceptions.h =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-exceptions.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-exceptions.h (revision 13564) @@ -0,0 +1,440 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ +#define UUO_MASK 0xfc00000f + +#define IS_UUO(i) (((i) & UUO_MASK) == 0xb) +/* If an instruction is a UUO, the minor opcode is in bits 21:27 */ +#define UUO_MINOR(u) (((u) >> 4) & 0x7f) + +typedef u_int32_t opcode, *pc; + +OSStatus +handle_uuo(ExceptionInformation *, opcode, pc); + + + +#ifdef LINUX +/* + Different (recent) versions of glibc disagree about how + a ucontext is laid out (and about what an mcontext is.) + There's something like a pointer to a pt_regs structure + in the 12th word in both cases. (Yes, this is an extremely + ugly hack; it would be better to conditionalize on the values + of GLIBC_VERSION/GLIBC_MINOR , but the discrepancy exists + in various flavors of glibc 2.3.) +*/ +#ifdef PPC64 +#define XP_PTREGS(x) ((x)->uc_mcontext.regs) +#define xpGPRvector(x) ((natural *)(XP_PTREGS(x))) +#else +#define XP_PTREGS(x) (((struct pt_regs **)(x))[12]) +#define xpGPRvector(x) (XP_PTREGS(x)->gpr) +#endif +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) (*((pc*)(&(XP_PTREGS(x)->nip)))) +#define set_xpPC(x,new) (xpPC(x) = (pc)(new)) +#define xpLR(x) (*((pc*)(&(XP_PTREGS(x)->link)))) +#define xpCTR(x) (*(pc*)(&(XP_PTREGS(x)->ctr))) +#define xpXER(x) (XP_PTREGS(x)->xer) +#define xpCCR(x) (XP_PTREGS(x)->ccr) +#define xpMSR(x) (XP_PTREGS(x)->msr) +#define xpDSISR(x) (XP_PTREGS(x)->dsisr) +#define xpDAR(x) (XP_PTREGS(x)->dar) +#define xpTRAP(x) (XP_PTREGS(x)->trap) +#define xpFPSCR(x) (XP_PTREGS(x)->gpr[PT_FPSCR]) +#define xpFPRvector(x) ((double *)(&(XP_PTREGS(x)->gpr[PT_FPR0]))) +#define xpFPR(x,fprno) (xpFPRvector(x)[fprno]) + +/* + Work around a Darwin G5 bug (present in OSX 10.2.7, 10.2.8, and later + versions. See below for details. +*/ +#define DarwinSigReturn(context) +#define SIGRETURN(context) +#endif + +#ifdef DARWIN +#define xpGPRvector(x) (&(UC_MCONTEXT(x)->__ss.__r0)) +#define xpGPR(x,gprno) ((xpGPRvector(x))[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (UInt32)(new) +#define xpPC(x) (*((pc*) &(UC_MCONTEXT(x)->__ss.__srr0))) +#define set_xpPC(x,new) (xpPC(x) = (pc)(new)) +#define xpLR(x) (*((pc*)(&(UC_MCONTEXT(x)->__ss.__lr)))) +#define xpCTR(x) (*(pc*)(&(UC_MCONTEXT(x)->__ss.__ctr))) +#define xpXER(x) (UC_MCONTEXT(x)->__ss.__xer) +#define xpCCR(x) (UC_MCONTEXT(x)->__ss.__cr) +#define xpMSR(x) (UC_MCONTEXT(x)->__ss.__srr1) +#define xpDSISR(x) (UC_MCONTEXT(x)->__es.__dsisr) +#define xpDAR(x) (UC_MCONTEXT(x)->__es.__dar) +#define xpTRAP(x) (UC_MCONTEXT(x)->__es.__exception) +#define xpFPSCR(x) (UC_MCONTEXT(x)->__fs.__fpscr) +#define xpFPRvector(x) (UC_MCONTEXT(x)->__fs.__fpregs) +#define xpFPR(x,fprno) (xpFPRvector(x)[fprno]) +/* There's a bug in some versions of Darwin on G5 processors: FP context + isn't restored correctly on exit from a signal handler if the integer + context appears to be unmodified (the 64-bit context isn't set up + correctly by the kernel: only the first N bytes are copied out of + the kernel, where N = size of 32-bit context. + + If the kernel pushed both a 32-bit and 64-bit context, the C + runtime "signal trampoline" code tries to determine if the 32-bit + GPRs and user-visible SPRs in the 32-bit context contain the same + values as their 64-bit counterparts on exit; if so, it tries to + call sigreturn with an extra argument that indicates that the + thread's state should be restored from the 64-bit context. + (Apparently that's more efficient; it'd be surprising if it'd be + more efficent when the cost of comparing values in the two contexts + is factored in ...). On some OS releases, the 64-bit context can't + be reliably restored (FPRs get trashed.) + + One way to work around this is to use a deprecated, 32-bit-context-only + version of the sigreturn syscall. There seems to be reason to be + reason to believe that the old sigreturn syscall will disappear + on OS releases >10.3. + + Another way to work around this is to make a "harmless" change to + an SPR or GPR value in the 32-bit context. There are lots of + "reserved" bits in the XER that make good candidates: 1's written + to reserved XER bits can't be reliably read anyway, so this may + or may not actually change the value in the XER in a way that + can be reliably detected. + + Note that both the old, deprecated version of sigreturn and the + new version take a first argument of type "struct ucontext *", + not "struct sigcontext *" as the man page and header files claim. + The new version takes a second argument, which is a small integer + which defines what "flavor" of context should be restored from. + The meaningful values that can be used here aren't defined in + a header file; the kernel (and the libc _sigtramp() function) + have (hopefully) matching, redundant hardwired definitions in + the source. +*/ +#ifdef PPC64 +#define DarwinSigReturn(x) +#else +#define DarwinSigReturn(x) (UC_MCONTEXT(x)->__ss.__xer)^=0x80 +#endif +#define SIGRETURN(context) DarwinSigReturn(context) +#endif + + + + + + +/* + Unconditional traps (tw, twi instructions) are used by the + operating system. We use conditional traps. + */ + +int +is_conditional_trap(opcode); + +#define kNameBufLen 256 +#define TRAP_LOOKUP_TRIES 5 /* # instrs to scan before trap instr */ + +void +callback_for_trap (LispObj, ExceptionInformation *, pc, natural, natural, natural); + +natural +register_codevector_contains_pc (natural, pc); + +void +callback_to_lisp (LispObj, ExceptionInformation *, natural, natural, natural, natural, natural); + +OSStatus +handle_trap(ExceptionInformation *, opcode, pc, siginfo_t *); + +unsigned +scan_for_instr( unsigned, unsigned, pc ); + + + +#define UUO_INTERR (11) +#define UUO_INTCERR (12) +#define UUO_INTERR2 (13) +#define UUO_INTCERR2 (14) + +#define UUO_FPUX_BINOP (22) +#define UUO_ZERO_FPSCR (25) + + +/* PPC instructions */ +#define match_instr(instr, mask, target) (((instr) & (mask)) == (target)) +#define RS_field(instr) (((instr) >> 21) & 0x1f) +#define RT_field(instr) (RS_field(instr)) +#define TO_field(instr) (RT_field(instr)) +#define RA_field(instr) (((instr) >> 16) & 0x1f) +#define RB_field(instr) (((instr) >> 11) & 0x1f) +#define D_field(instr) ((instr) & 0xffff) +#define DS_field(instr) ((instr) & 0xfffc) +#define DS_VARIANT_FIELD(instr) ((instr) & 3) + +#define RT(val) ((val & 0x1f) << 21) +#define RS(val) (RT(val)) +#define RA(val) ((val & 0x1f) << 16) +#define RB(val) ((val & 0x1f) << 11) +#define D(val) (val & 0xffff) + +#define RS_MASK RS(-1) +#define RT_MASK RS_MASK +#define TO_MASK RS_MASK +#define RA_MASK RA(-1) +#define RB_MASK RB(-1) +#define D_MASK D(-1) + + + +#define OP(x) (((x) & 0x3f) << 26) +#define OP_MASK OP (0x3f) + +/* Main opcode + TO field of a D form instruction */ +#define OPTO(x,to) (OP(x) | (((to) & 0x1f) << 21)) +#define OPTO_MASK (OP_MASK | TO_MASK) +#define OPTORA(x,to,ra) (OPTO(x,to) | RA(ra)) +#define OPTORA_MASK (OP_TO_MASK | RA_MASK) + + + + +/* An X form instruction. */ +#define X(op, xop) (OP (op) | (((xop) & 0x3ff) << 1)) + +/* An X form instruction with the RC bit specified. */ +#define XRC(op, xop, rc) (X ((op), (xop)) | ((rc) & 1)) + +/* The mask for an X form instruction. */ +#define X_MASK XRC(0x3f, 0x3ff, 1) + +/* An XO form instruction */ +#define XO(op, xop, oe, rc) \ + (OP (op) | ((((unsigned long)(xop)) & 0x1ff) << 1) | ((((unsigned long)(oe)) & 1) << 10) | (((unsigned long)(rc)) & 1)) +#define XO_MASK XO (0x3f, 0x1ff, 1, 1) + + + +/* The bits in the TO field of a TW or TWI instruction */ +#define TO_LT (1<<4) /* signed < */ +#define TO_GT (1<<3) /* signed > */ +#define TO_EQ (1<<2) /* = */ +#define TO_LO (1<<1) /* unsigned < */ +#define TO_HI (1<<0) /* unsigned > */ +#define TO_NE (TO_LT|TO_GT) + +/* True if major opcode of "instr" is "op" */ +#define major_opcode_p(instr, op) match_instr((instr),OP_MASK,OP(op)) + +/* True if "instr" is an X form instruction with major opcode "major" + and minor opcode "minor" */ +#define X_opcode_p(instr,major,minor) match_instr((instr),X_MASK,X(major,minor)) + +#define major_opcode_TDI 2 +#define major_opcode_TWI 3 +#ifdef PPC64 +#define major_opcode_TRI major_opcode_TDI +#else +#define major_opcode_TRI major_opcode_TWI +#endif +#define major_opcode_ADDI 14 +#define major_opcode_RLWINM 21 +#define major_opcode_X31 31 /* an "X" form instruction; see minor opcode */ +#define major_opcode_LWZ 32 +#define major_opcode_LBZ 34 +#define major_opcode_STW 36 +#define major_opcode_STWU 37 +#define major_opcode_LD_LDU_LWA 58 +#define major_opcode_FPU_SINGLE 59 +#define major_opcode_FPU_DOUBLE 63 + +#define minor_opcode_TW 4 +#define minor_opcode_TD 68 +#ifdef PPC64 +#define minor_opcode_TR minor_opcode_TD +#else +#define minor_opcode_TR minor_opcode_TW +#endif +#define minor_opcode_SUBF 40 +#define minor_opcode_STWX 151 +#define minor_opcode_STWUX 183 + +#define major_opcode_DS_LOAD64 58 +#define DS_LOAD64_VARIANT_LD 0 + +#define major_opcode_DS_STORE64 62 +#define DS_STORE64_VARIANT_STD 0 + + + +#define D_instruction(major,rt,ra,imm) (OP(major)|((rt)<<21)|((ra)<<16)|((imm)&D_MASK)) +#define DS_instruction(major,rt,ra,imm,minor) (OP(major)|((rt)<<21)|((ra)<<16)|(((imm)&D_MASK)&~3)|((minor)&3)) +#define TRI_instruction(rt,ra,imm) D_instruction(major_opcode_TRI,rt,ra,imm) +#define LBZ_instruction(rt,ra,imm) D_instruction(major_opcode_LBZ,rt,ra,imm) +#define LWZ_instruction(rt,ra,imm) D_instruction(major_opcode_LWZ,rt,ra,imm) +#define LD_instruction(rt,ra,imm) DS_instruction(58,rt,ra,imm,0) + +#define D_RT_IMM_MASK (OP_MASK|RT_MASK|D_MASK) +#define D_RA_IMM_MASK (OP_MASK|RA_MASK|D_MASK) + +#define X_instruction(major,minor,rt,ra,rb) (X(major,minor)|((rt)<<21)|((ra)<<16)|((rb)<<11)) + +#define unmasked_register 0 + +#define LISP_BREAK_INSTRUCTION 0x7f810808 +#define QUIET_LISP_BREAK_INSTRUCTION 0x7c800008 + +#ifdef PPC64 +/* Have to use signed comparisons on PPC64; if we decrememt + allocptr and it "wraps around" address 0, that's an + attempt to allocate a large object. Note that this + means that valid heap addresses can't have the high + bit set. */ +/* tdlt allocptr,allocbase */ +#define ALLOC_TRAP_INSTRUCTION 0x7e095088 +#else +/* On PPC32, we can use an unsigned comparison, as long + as HEAP_IMAGE_BASE+PURESPACE_RESERVE is greater than + the maximum possible allocation (around 27 bits). + Decrementing allocptr may cause it to wrap around + #x80000000, but it should never wrap around 0. */ +/* twllt allocptr,allocbase */ +#define ALLOC_TRAP_INSTRUCTION 0x7c495008 +#endif + +#ifdef PPC64 +/* tdlgei allocptr,0 */ +#define GC_TRAP_INSTRUCTION 0x08a90000 +#else +/* twlgei allocptr,0 */ +#define GC_TRAP_INSTRUCTION 0x0ca90000 +#endif + +#ifdef PPC64 +/* clrrdi allocptr,allocptr,4 */ +#define UNTAG_ALLOCPTR_INSTRUCTION 0x792906e4 +#else +/* clrrwi allocptr,allocptr,3 */ +#define UNTAG_ALLOCPTR_INSTRUCTION 0x55290038 +#endif + +#ifdef PPC64 +/* std rX,misc_header_offset(allocptr) */ +#define STORE_HEADER_ALLOCPTR_INSTRUCTION 0xf809fff4 +#else +/* stw rX,misc_header_offset(allocptr) */ +#define STORE_HEADER_ALLOCPTR_INSTRUCTION 0x9009fffa +#endif +#define STORE_HEADER_ALLOCPTR_MASK D_RA_IMM_MASK + +#ifdef PPC64 +/* std rX,cons.cXr(allocptr) */ +#define STORE_CAR_ALLOCPTR_INSTRUCTION 0xf8090004 +#define STORE_CDR_ALLOCPTR_INSTRUCTION 0xf809fffc +#else +/* stw rX,cons.cXr(allocptr) */ +#define STORE_CAR_ALLOCPTR_INSTRUCTION 0x90090003 +#define STORE_CDR_ALLOCPTR_INSTRUCTION 0x9009ffff +#endif +#define STORE_CXR_ALLOCPTR_MASK D_RA_IMM_MASK + + +#ifdef PPC64 +/* stdu sp,-32(sp) */ +#define CREATE_LISP_FRAME_INSTRUCTION 0xf821ffe1 +#else +/* stwu sp,-16(sp) */ +#define CREATE_LISP_FRAME_INSTRUCTION 0x9421fff0 +#endif + +#ifdef PPC64 +/* std tsp,tsp_frame.type(tsp) */ +#define MARK_TSP_FRAME_INSTRUCTION 0xf98c0008 +#else +/* stw tsp,tsp_frame.type(tsp) */ +#define MARK_TSP_FRAME_INSTRUCTION 0x918c0004 +#endif + +#ifdef PPC64 +#define INIT_CATCH_FRAME_INSTRUCTION (0xf8000000 | RA(nargs)) +#define INIT_CATCH_FRAME_MASK (OP_MASK | RA_MASK) +#else +#define INIT_CATCH_FRAME_INSTRUCTION (0x90000000 | RA(nargs)) +#define INIT_CATCH_FRAME_MASK (OP_MASK | RA_MASK) +#endif + +OSStatus +handle_error(ExceptionInformation *, unsigned, unsigned, unsigned, pc); + +typedef char* vector_buf; + +void put_altivec_registers(vector_buf); +void get_altivec_registers(vector_buf); + + +int altivec_available; + +#ifdef DARWIN +#include +#include +#include +#include + +#endif + +/* Yet another way to look at a branch instruction ... */ +typedef union { + struct {unsigned op:6, li:24, aa:1, lk:1;} b; + unsigned opcode; +} branch_instruction; + + + + /* Enable exceptions (at least, enable another thread's attempts to + suspend this one) by restoring the signal mask. + */ + + + +#ifdef DARWIN +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGUSR1 +#endif +#ifdef LINUX +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGPWR +#endif + + +#ifdef LINUX +register void *current_r2 __asm__("r2"); +#endif + +Boolean +extend_tcr_tlb(TCR *, ExceptionInformation *, unsigned, unsigned); + +void +pc_luser_xp(ExceptionInformation *, TCR *, signed_natural *); + + +#ifdef PPC64 +#define codevec_hdr_p(value) ((value) == (('C'<<24)|('O'<<16)|('D'<<8)|'E')) +#else +/* top 6 bits will be zero, subtag will be subtag_code_vector */ +#define CV_HDR_MASK (OP_MASK | subtagmask) +#define CV_HDR_VALUE subtag_code_vector +#define codevec_hdr_p(value) (((value) & CV_HDR_MASK) == CV_HDR_VALUE) +#endif + + Index: /branches/qres/ccl/lisp-kernel/ppc-gc.c =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-gc.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-gc.c (revision 13564) @@ -0,0 +1,2380 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "bits.h" +#include "gc.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include +#include + +/* Heap sanity checking. */ + +void +check_node(LispObj n) +{ + int tag = fulltag_of(n), header_tag; + area *a; + LispObj header; + + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + + +#ifdef PPC64 + case fulltag_imm_0: + case fulltag_imm_1: + case fulltag_imm_2: + case fulltag_imm_3: +#else + case fulltag_imm: +#endif + + + return; + +#ifndef PPC64 + case fulltag_nil: + if (n != lisp_nil) { + Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n); + } + return; +#endif + + +#ifdef PPC64 + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: + case fulltag_nodeheader_2: + case fulltag_nodeheader_3: + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: + case fulltag_immheader_3: +#else + case fulltag_nodeheader: + case fulltag_immheader: +#endif + + + Bug(NULL, "Header not expected : 0x%lx", n); + return; + + case fulltag_misc: + case fulltag_cons: + a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); + + if (a == NULL) { + /* Can't do as much sanity checking as we'd like to + if object is a defunct stack-consed object. + If a dangling reference to the heap, that's + bad .. */ + a = active_dynamic_area; + if ((n > (ptr_to_lispobj(a->active))) && + (n < (ptr_to_lispobj(a->high)))) { + Bug(NULL, "Node points to heap free space: 0x%lx", n); + } + return; + } + break; + } + /* Node points to heap area, so check header/lack thereof. */ + header = header_of(n); + header_tag = fulltag_of(header); + if (tag == fulltag_cons) { + if ((nodeheader_tag_p(header_tag)) || + (immheader_tag_p(header_tag))) { + Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header); + } + return; + } + + if ((!nodeheader_tag_p(header_tag)) && + (!immheader_tag_p(header_tag))) { + Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header); + } + return; +} + + + + +void +check_range(LispObj *start, LispObj *end, Boolean header_allowed) +{ + LispObj node, *current = start, *prev = NULL; + int tag; + natural elements; + + while (current < end) { + prev = current; + node = *current++; + tag = fulltag_of(node); + if (immheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x%lx\n", prev); + } + current = (LispObj *)skip_over_ivector((natural)prev, node); + } else if (nodeheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x%lx\n", prev); + } + elements = header_element_count(node) | 1; + while (elements--) { + check_node(*current++); + } + } else { + check_node(node); + check_node(*current++); + } + } + + if (current != end) { + Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x", + start, end, prev, current); + } +} + +void +check_all_areas(TCR *tcr) +{ + area *a = active_dynamic_area; + area_code code = a->code; + + while (code != AREA_VOID) { + switch (code) { + case AREA_DYNAMIC: + case AREA_STATIC: + case AREA_MANAGED_STATIC: + check_range((LispObj *)a->low, (LispObj *)a->active, true); + break; + + case AREA_VSTACK: + { + LispObj* low = (LispObj *)a->active; + LispObj* high = (LispObj *)a->high; + + if (((natural)low) & node_size) { + check_node(*low++); + } + check_range(low, high, false); + } + break; + + case AREA_TSTACK: + { + LispObj *current, *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) a->high; + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + check_range(current+2, end, true); + } + } + } + break; + } + a = a->succ; + code = (a->code); + } +} + + + + + + + + + + + +/* Sooner or later, this probably wants to be in assembler */ +/* Return false if n is definitely not an ephemeral node, true if + it might be */ +void +mark_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (tag_n == fulltag_cons) { + cons *c = (cons *) ptr_from_lispobj(untag(n)); + rmark(c->car); + rmark(c->cdr); + return; + } + { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, /* including 4/8-byte header */ + suffix_dnodes; + tag_n = fulltag_of(header); + + +#ifdef PPC64 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_8_bit) { + total_size_in_bytes = 8 + element_count; + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (nodeheader_tag_p(tag_n)) { + if (subtag == subtag_hash_vector) { + /* Don't invalidate the cache here. It should get + invalidated on the lisp side, if/when we know + that rehashing is necessary. */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(ptr_to_lispobj(base), 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) { + element_count -= 2; + } else { + element_count -= 1; + } + } + + base += (1+element_count); + + + while(element_count--) { + rmark(*--base); + } + if (subtag == subtag_weak) { + deref(n, 1) = GCweakvll; + GCweakvll = untag(n); + } + } + } +} + + +/* + This marks the node if it needs to; it returns true if the node + is either a hash table vector header or a cons/misc-tagged pointer + to ephemeral space. + Note that it might be a pointer to ephemeral space even if it's + not pointing to the current generation. +*/ + +Boolean +mark_ephemeral_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural eph_dnode; + + if (nodeheader_tag_p(tag_n)) { + return (header_subtag(n) == subtag_hash_vector); + } + + if ((tag_n == fulltag_cons) || + (tag_n == fulltag_misc)) { + eph_dnode = area_dnode(n, GCephemeral_low); + if (eph_dnode < GCn_ephemeral_dnodes) { + mark_root(n); /* May or may not mark it */ + return true; /* but return true 'cause it's an ephemeral node */ + } + } + return false; /* Not a heap pointer or not ephemeral */ +} + + +#ifdef PPC64 +/* Any register (srr0, the lr or ctr) or stack location that + we're calling this on should have its low 2 bits clear; it'll + be tagged as a "primary" object, but the pc/lr/ctr should + never point to a tagged object or contain a fixnum. + + If the "pc" appears to be pointing into a heap-allocated + code vector that's not yet marked, back up until we find + the code-vector's prefix (the 32-bit word containing the + value 'CODE' whic precedes the code-vector's first instruction) + and mark the entire code-vector. +*/ +void +mark_pc_root(LispObj xpc) +{ + if ((xpc & 3) != 0) { + Bug(NULL, "Bad PC locative!"); + } else { + natural dnode = gc_area_dnode(xpc); + if ((dnode < GCndnodes_in_area) && + !ref_bit(GCmarkbits,dnode)) { + LispObj + *headerP, + header; + opcode *program_counter; + + for(program_counter=(opcode *)ptr_from_lispobj(xpc & ~7); + (LispObj)program_counter >= GCarealow; + program_counter-=2) { + if (*program_counter == PPC64_CODE_VECTOR_PREFIX) { + headerP = ((LispObj *)program_counter)-1; + header = *headerP; + dnode = gc_area_dnode(headerP); + set_n_bits(GCmarkbits, dnode, (8+(header_element_count(header)<<2)+(dnode_size-1))>>dnode_shift); + return; + } + } + /* + Expected to have found a header by now, but didn't. + That's a bug. + */ + Bug(NULL, "code_vector header not found!"); + } + } +} +#else /* PPC64 */ +/* + Some objects (saved LRs on the control stack, the LR, PC, and CTR + in exception frames) may be tagged as fixnums but are really + locatives into code_vectors. + + If "pc" is not tagged as a fixnum, mark it as a "normal" root. + If "pc" doesn't point at an unmarked doubleword in the area + being GCed, return. + Else back up until the code_vector's header is found and mark + all doublewords in the code_vector. +*/ +void +mark_pc_root(LispObj pc) +{ + if (tag_of(pc) != tag_fixnum) { + mark_root(pc); + } else { + natural dnode = gc_area_dnode(pc); + if ((dnode < GCndnodes_in_area) && + !ref_bit(GCmarkbits,dnode)) { + LispObj + *headerP, + header; + + for(headerP = (LispObj*)ptr_from_lispobj(untag(pc)); + dnode < GCndnodes_in_area; + headerP-=2, --dnode) { + header = *headerP; + + if ((header & code_header_mask) == subtag_code_vector) { + set_n_bits(GCmarkbits, dnode, (2+header_element_count(header))>>1); + return; + } + } + /* + Expected to have found a header by now, but didn't. + That's a bug. + */ + Bug(NULL, "code_vector header not found!"); + } + } +} +#endif /* PPC64 */ + + + +#ifdef PPC64 +#define RMARK_PREV_ROOT fulltag_imm_3 +#define RMARK_PREV_CAR fulltag_misc +#else +#define RMARK_PREV_ROOT fulltag_imm +#define RMARK_PREV_CAR fulltag_nil +#endif + + + + + +/* + This wants to be in assembler even more than "mark_root" does. + For now, it does link-inversion: hard as that is to express in C, + reliable stack-overflow detection may be even harder ... +*/ +void +rmark(LispObj n) +{ + int tag_n = fulltag_of(n); + bitvector markbits = GCmarkbits; + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (current_stack_pointer() > GCstack_limit) { + if (tag_n == fulltag_cons) { + rmark(deref(n,1)); + rmark(deref(n,0)); + } else { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, + suffix_dnodes; + tag_n = fulltag_of(header); +#ifdef PPC64 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_8_bit) { + total_size_in_bytes = 8 + element_count; + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) return; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then return */ + /* In general, there's no reason to invalidate the cached + key/value pair here. However, if the hash table's weak, + we don't want to retain an otherwise unreferenced key + or value simply because they're referenced from the + cache. Clear the cached entries iff the hash table's + weak in some sense. + */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if ((flags & nhash_keys_frozen_mask) && + (((hash_table_vector_header *) base)->deleted_count > 0)) { + /* We're responsible for clearing out any deleted keys, since + lisp side can't do it without breaking the state machine + */ + LispObj *pairp = base + hash_table_vector_header_count; + natural + npairs = (element_count - (hash_table_vector_header_count - 1)) >> 1; + + while (npairs--) { + if ((pairp[1] == unbound) && (pairp[0] != unbound)) { + pairp[0] = slot_unbound; + } + pairp +=2; + } + ((hash_table_vector_header *) base)->deleted_count = 0; + } + + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(n, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + while (element_count) { + rmark(deref(n,element_count)); + element_count--; + } + + if (subtag == subtag_weak) { + deref(n, 1) = GCweakvll; + GCweakvll = untag(n); + } + + } + } else { + LispObj prev = undefined; + LispObj this = n, next; + /* + This is an FSM. The basic states are: + (0) Just marked the cdr of a cons; mark the car next; + (1) Just marked the car of a cons; back up. + (2) Hit a gvector header. Back up. + (3) Marked a gvector element; mark the preceding one. + (4) Backed all the way up to the object that got us here. + + This is all encoded in the fulltag of the "prev" pointer. + */ + + if (tag_n == fulltag_cons) goto MarkCons; + goto MarkVector; + + ClimbCdr: + prev = deref(this,0); + deref(this,0) = next; + + Climb: + next = this; + this = prev; + tag_n = fulltag_of(prev); + switch(tag_n) { + case fulltag_odd_fixnum: + case fulltag_even_fixnum: + goto ClimbVector; + + case RMARK_PREV_ROOT: + return; + + case fulltag_cons: + goto ClimbCdr; + + case RMARK_PREV_CAR: + goto ClimbCar; + + /* default: abort() */ + } + + DescendCons: + prev = this; + this = next; + + MarkCons: + next = deref(this,1); + this += node_size; + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto MarkCdr; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkCdr; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkCdr; + *bitsp = (bits | mask); + deref(this,1) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + ClimbCar: + prev = deref(this,1); + deref(this,1) = next; + + MarkCdr: + next = deref(this, 0); + this -= node_size; + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto Climb; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto Climb; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto Climb; + *bitsp = (bits | mask); + deref(this, 0) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + /* goto DescendVector; */ + + DescendVector: + prev = this; + this = next; + + MarkVector: + { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(this)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, + suffix_dnodes; + + tag_n = fulltag_of(header); + +#ifdef PPC64 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_8_bit) { + total_size_in_bytes = 8 + element_count; + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) goto Climb; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then climb */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + dws_mark_weak_htabv(this); + element_count = hash_table_vector_header_count; + } + } + + if (subtag == subtag_pool) { + deref(this, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + + this = untag(this) + ((element_count+1) << node_shift); + goto MarkVectorLoop; + } + + ClimbVector: + prev = *((LispObj *) ptr_from_lispobj(this)); + *((LispObj *) ptr_from_lispobj(this)) = next; + + MarkVectorLoop: + this -= node_size; + next = *((LispObj *) ptr_from_lispobj(this)); + tag_n = fulltag_of(next); + if (nodeheader_tag_p(tag_n)) goto MarkVectorDone; + if (!is_node_fulltag(tag_n)) goto MarkVectorLoop; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkVectorLoop; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkVectorLoop; + *bitsp = (bits | mask); + *(ptr_from_lispobj(this)) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + MarkVectorDone: + /* "next" is vector header; "this" is fixnum-aligned. + If header subtag = subtag_weak_header, put it on weakvll */ + this += fulltag_misc; + + if (header_subtag(next) == subtag_weak) { + deref(this, 1) = GCweakvll; + GCweakvll = untag(this); + } + goto Climb; + } +} + +LispObj * +skip_over_ivector(natural start, LispObj header) +{ + natural + element_count = header_element_count(header), + subtag = header_subtag(header), + nbytes; + +#ifdef PPC64 + switch (fulltag_of(header)) { + case ivector_class_64_bit: + nbytes = element_count << 3; + break; + case ivector_class_32_bit: + nbytes = element_count << 2; + break; + case ivector_class_8_bit: + nbytes = element_count; + break; + case ivector_class_other_bit: + default: + if (subtag == subtag_bit_vector) { + nbytes = (element_count+7)>>3; + } else { + nbytes = element_count << 1; + } + } + return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15))); +#else + if (subtag <= max_32_bit_ivector_subtag) { + nbytes = element_count << 2; + } else if (subtag <= max_8_bit_ivector_subtag) { + nbytes = element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + nbytes = element_count << 1; + } else if (subtag == subtag_double_float_vector) { + nbytes = 4 + (element_count << 3); + } else { + nbytes = (element_count+7) >> 3; + } + return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7))); +#endif + + + +} + + +void +check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits) +{ + LispObj x1, *base = start; + int tag; + natural ref_dnode, node_dnode; + Boolean intergen_ref; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = skip_over_ivector(ptr_to_lispobj(start), x1); + } else { + intergen_ref = false; + if ((tag == fulltag_misc) || (tag == fulltag_cons)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + if (intergen_ref == false) { + x1 = start[1]; + tag = fulltag_of(x1); + if ((tag == fulltag_misc) || (tag == fulltag_cons)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + } + if (intergen_ref) { + ref_dnode = area_dnode(start, base); + if (!ref_bit(refbits, ref_dnode)) { + Bug(NULL, "Missing memoization in doublenode at 0x%08X", start); + set_bit(refbits, ref_dnode); + } + } + start += 2; + } + } +} + + + +void +mark_memoized_area(area *a, natural num_memo_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2; + natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0; + Boolean keep_x1, keep_x2; + + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + /* The distinction between "inbits" and "outbits" is supposed to help us + detect cases where "uninteresting" setfs have been memoized. Storing + NIL, fixnums, immediates (characters, etc.) or node pointers to static + or readonly areas is definitely uninteresting, but other cases are + more complicated (and some of these cases are hard to detect.) + + Some headers are "interesting", to the forwarder if not to us. + + We -don't- give anything any weak treatment here. Weak things have + to be seen by a full gc, for some value of 'full'. + */ + + /* + We need to ensure that there are no bits set at or beyond + "num_memo_dnodes" in the bitvector. (This can happen as the EGC + tenures/untenures things.) We find bits by grabbing a fullword at + a time and doing a cntlzw instruction; and don't want to have to + check for (< memo_dnode num_memo_dnodes) in the loop. + */ + + { + natural + bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask), + index_of_last_word = (num_memo_dnodes >> bitmap_shift); + + if (bits_in_last_word != 0) { + natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L); + refbits[index_of_last_word] &= mask; + } + } + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + inbits = outbits = bits; + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + if (outbits != inbits) { + *bitsp = outbits; + } + bits = *++bitsp; + inbits = outbits = bits; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = *p++; + x2 = *p++; + bits &= ~(BIT0_MASK >> bitidx); + + if (header_subtag(x1) == subtag_hash_vector) { + LispObj flags = ((hash_table_vector_header *) p-2)->flags; + if (flags & nhash_weak_mask) { + *(p-1) = GCweakvll; + GCweakvll = ptr_to_lispobj(p - 1); + x2 = 0; + } + } + + keep_x1 = mark_ephemeral_root(x1); + keep_x2 = mark_ephemeral_root(x2); + if ((keep_x1 == false) && + (keep_x2 == false)) { + outbits &= ~(BIT0_MASK >> bitidx); + } + memo_dnode++; + bitidx++; + } + } + if (GCDebug) { + p = (LispObj *) a->low; + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } +} + + + +void +mark_simple_area_range(LispObj *start, LispObj *end) +{ + LispObj x1, *base; + int tag; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1)); + } else if (!nodeheader_tag_p(tag)) { + ++start; + mark_root(x1); + mark_root(*start++); + } else { + int subtag = header_subtag(x1); + natural element_count = header_element_count(x1); + natural size = (element_count+1 + 1) & ~1; + + if (subtag == subtag_hash_vector) { + LispObj flags = ((hash_table_vector_header *) start)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) start)->cache_key = undefined; + ((hash_table_vector_header *) start)->cache_value = lisp_nil; + mark_weak_htabv((LispObj)start); + element_count = 0; + } + } + if (subtag == subtag_pool) { + start[1] = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) start[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + start[1] = GCweakvll; + GCweakvll = ptr_to_lispobj(start); + } + + base = start + element_count + 1; + while(element_count--) { + mark_root(*--base); + } + start += size; + } + } +} + + +/* Mark a tstack area */ +void +mark_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + mark_simple_area_range(current+2, end); + } + } +} + +/* + It's really important that headers never wind up in tagged registers. + Those registers would (possibly) get pushed on the vstack and confuse + the hell out of this routine. + + vstacks are just treated as a "simple area range", possibly with + an extra word at the top (where the area's active pointer points.) + */ + +void +mark_vstack_area(area *a) +{ + LispObj + *start = (LispObj *) a->active, + *end = (LispObj *) a->high; + +#if 0 + fprintf(dbgout, "mark VSP range: 0x%lx:0x%lx\n", start, end); +#endif + if (((natural)start) & (sizeof(natural))) { + /* Odd number of words. Mark the first (can't be a header) */ + mark_root(*start); + ++start; + } + mark_simple_area_range(start, end); +} + + +/* + Mark lisp frames on the control stack. + Ignore emulator frames (odd backpointer) and C frames (size != 4). +*/ + +void +mark_cstack_area(area *a) +{ + BytePtr + current, + next, + limit = a->high, + low = a->low; + + for (current = a->active; (current >= low) && (current < limit); current = next) { + next = *((BytePtr *)current); +#if 0 + if (next < current) { + Bug(NULL, "Child stack frame older than parent"); + } +#endif + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + /* mark fn, then saved lr */ + mark_root(((lisp_frame *)current)->savefn); + mark_pc_root(((lisp_frame *)current)->savelr); + } else { + /* Clear low 2 bits of "next", just in case */ + next = (BytePtr) (((natural)next) & ~3); + } + } +} + + + +/* Mark the lisp objects in an exception frame */ +void +mark_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp); + +#ifdef PPC + int r; + /* registers >= fn should be tagged and marked as roots. + the PC, LR, loc_pc, and CTR should be treated as "pc_locatives". + + In general, marking a locative is more expensive than marking + a node is, since it may be neccessary to back up and find the + containing object's header. Since exception frames contain + many locatives, it'd be wise to mark them *after* marking the + stacks, nilreg-relative globals, etc. + */ + + for (r = fn; r < 32; r++) { + mark_root((regs[r])); + } + + + + mark_pc_root((regs[loc_pc])); + mark_pc_root(ptr_to_lispobj(xpPC(xp))); + mark_pc_root(ptr_to_lispobj(xpLR(xp))); + mark_pc_root(ptr_to_lispobj(xpCTR(xp))); +#endif /* PPC */ + +} + +/* A "pagelet" contains 32 doublewords. The relocation table contains + a word for each pagelet which defines the lowest address to which + dnodes on that pagelet will be relocated. + + The relocation address of a given pagelet is the sum of the relocation + address for the preceding pagelet and the number of bytes occupied by + marked objects on the preceding pagelet. +*/ + +LispObj +calculate_relocation() +{ + LispObj *relocptr = GCrelocptr; + LispObj current = GCareadynamiclow; + bitvector + markbits = GCdynamic_markbits; + qnode *q = (qnode *) markbits; + natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift); + natural thesebits; + LispObj first = 0; + + do { + *relocptr++ = current; + thesebits = *markbits++; + if (thesebits == ALL_ONES) { + current += nbits_in_word*dnode_size; + q += 4; /* sic */ + } else { + if (!first) { + first = current; + while (thesebits & BIT0_MASK) { + first += dnode_size; + thesebits += thesebits; + } + } + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + } + } while(--npagelets); + *relocptr++ = current; + return first ? first : current; +} + +#ifdef PPC64 +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned int near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> bitmap_shift; + nbits = dnode & bitmap_shift_count_mask; + near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)]; + + if (nbits < 32) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffffffff) { + return (new + (nbits << 4)); + } else { + near_bits &= (0xffffffff00000000 >> nbits); + if (nbits > 15) { + new += one_bits(near_bits & 0xffff); + } + return (new + (one_bits(near_bits >> 16))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 64-nbits; + + if (near_bits == 0xffffffff) { + return (new - (nbits << 4)); + } else { + near_bits &= (1< 15) { + new -= one_bits(near_bits >> 16); + } + return (new - one_bits(near_bits & 0xffff)); + } + } +} +#else +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned short near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> 5; + nbits = dnode & 0x1f; + near_bits = ((unsigned short *)GCdynamic_markbits)[dnode>>4]; + + if (nbits < 16) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffff) { + return (new + (nbits << 3)); + } else { + near_bits &= (0xffff0000 >> nbits); + if (nbits > 7) { + new += one_bits(near_bits & 0xff); + } + return (new + (one_bits(near_bits >> 8))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 32-nbits; + + if (near_bits == 0xffff) { + return (new - (nbits << 3)); + } else { + near_bits &= (1< 7) { + new -= one_bits(near_bits >> 8); + } + return (new - one_bits(near_bits & 0xff)); + } + } +} +#endif + + +LispObj +locative_forwarding_address(LispObj obj) +{ + int tag_n = fulltag_of(obj); + natural dnode; + + +#ifdef PPC + /* Locatives can be tagged as conses, "fulltag_misc" + objects, or as fixnums. Immediates, headers, and nil + shouldn't be "forwarded". Nil never will be, but it + doesn't hurt to check ... */ +#ifdef PPC64 + if ((tag_n & lowtag_mask) != lowtag_primary) { + return obj; + } +#else + if ((1<= GCndynamic_dnodes_in_area) || + (obj < GCfirstunmarked)) { + return obj; + } + + return dnode_forwarding_address(dnode, tag_n); +} + + + + +void +forward_range(LispObj *range_start, LispObj *range_end) +{ + LispObj *p = range_start, node, new; + int tag_n; + natural nwords; + hash_table_vector_header *hashp; + + while (p < range_end) { + node = *p; + tag_n = fulltag_of(node); + if (immheader_tag_p(tag_n)) { + p = (LispObj *) skip_over_ivector((natural) p, node); + } else if (nodeheader_tag_p(tag_n)) { + nwords = header_element_count(node); + nwords += (1 - (nwords&1)); + if ((header_subtag(node) == subtag_hash_vector) && + ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { + natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + hashp = (hash_table_vector_header *) p; + p++; + nwords -= skip; + while(skip--) { + update_noderef(p); + p++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "p" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (update_noderef(p) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + p++; + update_noderef(p); + p++; + } + *p++ = 0; + } else { + p++; + while(nwords--) { + update_noderef(p); + p++; + } + } + } else { + new = node_forwarding_address(node); + if (new != node) { + *p = new; + } + p++; + update_noderef(p); + p++; + } + } +} + + + + +/* Forward a tstack area */ +void +forward_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + forward_range(current+2, end); + } + } +} + +/* Forward a vstack area */ +void +forward_vstack_area(area *a) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + +#ifdef DEBUG + fprintf(dbgout,"Forward range 0x%x/0x%x (owner 0x%x)\n",p,q,a->owner); +#endif + if (((natural)p) & sizeof(natural)) { + update_noderef(p); + p++; + } + forward_range(p, q); +} + +void +forward_cstack_area(area *a) +{ + BytePtr + current, + next, + limit = a->high, + low = a->low; + + for (current = a->active; (current >= low) && (current < limit); current = next) { + next = *((BytePtr *)current); + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + update_noderef(&((lisp_frame *) current)->savefn); + update_locref(&((lisp_frame *) current)->savelr); + } + } +} + + + +void +forward_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp); + + int r; + + /* registers >= fn should be tagged and forwarded as roots. + the PC, LR, loc_pc, and CTR should be treated as "locatives". + */ + + for (r = fn; r < 32; r++) { + update_noderef((LispObj*) (&(regs[r]))); + } + + update_locref((LispObj*) (&(regs[loc_pc]))); + + update_locref((LispObj*) (&(xpPC(xp)))); + update_locref((LispObj*) (&(xpLR(xp)))); + update_locref((LispObj*) (&(xpCTR(xp)))); + +} + + +void +forward_tcr_xframes(TCR *tcr) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + forward_xp(xp); + } + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + if (xframes->curr == xp) { + Bug(NULL, "forward xframe twice ???"); + } + forward_xp(xframes->curr); + } +} + + + +/* + Compact the dynamic heap (from GCfirstunmarked through its end.) + Return the doublenode address of the new freeptr. + */ + +LispObj +compact_dynamic_heap() +{ + LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new; + natural + elements, + dnode = gc_area_dnode(GCfirstunmarked), + node_dnodes = 0, + imm_dnodes = 0, + bitidx, + *bitsp, + bits, + nextbit, + diff; + int tag; + bitvector markbits = GCmarkbits; + /* keep track of whether or not we saw any + code_vector headers, and only flush cache if so. */ + Boolean GCrelocated_code_vector = false; + + if (dnode < GCndnodes_in_area) { + lisp_global(FWDNUM) += (1<>1; + dnode += node_dnodes; + if ((header_subtag(node) == subtag_hash_vector) && + (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) { + hash_table_vector_header *hashp = (hash_table_vector_header *) dest; + int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + *dest++ = node; + elements -= skip; + while(skip--) { + *dest++ = node_forwarding_address(*src++); + } + /* There should be an even number of (key/value) pairs in elements; + an extra alignment word follows. */ + elements >>= 1; + while (elements--) { + if (hashp) { + node = *src++; + new = node_forwarding_address(node); + if (new != node) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + *dest++ = new; + } else { + *dest++ = node; + } + } else { + *dest++ = node_forwarding_address(*src++); + } + *dest++ = node_forwarding_address(*src++); + } + *dest++ = 0; + src++; + } else { + *dest++ = node; + *dest++ = node_forwarding_address(*src++); + while(--node_dnodes) { + *dest++ = node_forwarding_address(*src++); + *dest++ = node_forwarding_address(*src++); + } + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else if (immheader_tag_p(tag)) { + *dest++ = node; + *dest++ = *src++; + elements = header_element_count(node); + tag = header_subtag(node); + +#ifdef PPC +#ifdef PPC64 + switch(fulltag_of(tag)) { + case ivector_class_64_bit: + imm_dnodes = ((elements+1)+1)>>1; + break; + case ivector_class_32_bit: + if (tag == subtag_code_vector) { + GCrelocated_code_vector = true; + } + imm_dnodes = (((elements+2)+3)>>2); + break; + case ivector_class_8_bit: + imm_dnodes = (((elements+8)+15)>>4); + break; + case ivector_class_other_bit: + if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+64)+127)>>7); + } else { + imm_dnodes = (((elements+4)+7)>>3); + } + } +#else + if (tag <= max_32_bit_ivector_subtag) { + if (tag == subtag_code_vector) { + GCrelocated_code_vector = true; + } + imm_dnodes = (((elements+1)+1)>>1); + } else if (tag <= max_8_bit_ivector_subtag) { + imm_dnodes = (((elements+4)+7)>>3); + } else if (tag <= max_16_bit_ivector_subtag) { + imm_dnodes = (((elements+2)+3)>>2); + } else if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+32)+63)>>6); + } else { + imm_dnodes = elements+1; + } +#endif +#endif + + dnode += imm_dnodes; + while (--imm_dnodes) { + *dest++ = *src++; + *dest++ = *src++; + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else { + *dest++ = node_forwarding_address(node); + *dest++ = node_forwarding_address(*src++); + bits &= ~(BIT0_MASK >> bitidx); + dnode++; + bitidx++; + } + } + + } + + { + natural nbytes = (natural)ptr_to_lispobj(dest) - (natural)GCfirstunmarked; + if ((nbytes != 0) && GCrelocated_code_vector) { + xMakeDataExecutable((LogicalAddress)ptr_from_lispobj(GCfirstunmarked), nbytes); + } + } + } + return ptr_to_lispobj(dest); +} + + + + + + +/* + Total the (physical) byte sizes of all ivectors in the indicated memory range +*/ + +natural +unboxed_bytes_in_range(LispObj *start, LispObj *end) +{ + natural total=0, elements, tag, subtag, bytes; + LispObj header; + + while (start < end) { + header = *start; + tag = fulltag_of(header); + + if ((nodeheader_tag_p(tag)) || + (immheader_tag_p(tag))) { + elements = header_element_count(header); + if (nodeheader_tag_p(tag)) { + start += ((elements+2) & ~1); + } else { + subtag = header_subtag(header); + +#ifdef PPC64 + switch(fulltag_of(header)) { + case ivector_class_64_bit: + bytes = 8 + (elements<<3); + break; + case ivector_class_32_bit: + bytes = 8 + (elements<<2); + break; + case ivector_class_8_bit: + bytes = 8 + elements; + break; + case ivector_class_other_bit: + default: + if (subtag == subtag_bit_vector) { + bytes = 8 + ((elements+7)>>3); + } else { + bytes = 8 + (elements<<1); + } + } +#else + if (subtag <= max_32_bit_ivector_subtag) { + bytes = 4 + (elements<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + bytes = 4 + elements; + } else if (subtag <= max_16_bit_ivector_subtag) { + bytes = 4 + (elements<<1); + } else if (subtag == subtag_double_float_vector) { + bytes = 8 + (elements<<3); + } else { + bytes = 4 + ((elements+7)>>3); + } +#endif + + + bytes = (bytes+dnode_size-1) & ~(dnode_size-1); + total += bytes; + start += (bytes >> node_shift); + } + } else { + start += 2; + } + } + return total; + } + + + /* + This assumes that it's getting called with an ivector + argument and that there's room for the object in the + destination area. + */ + + +LispObj +purify_displaced_object(LispObj obj, area *dest, natural disp) +{ + BytePtr + free = dest->active, + *old = (BytePtr *) ptr_from_lispobj(untag(obj)); + LispObj + header = header_of(obj), + new; + natural + start = (natural)old, + physbytes; + + physbytes = ((natural)(skip_over_ivector(start,header))) - start; + dest->active += physbytes; + + new = ptr_to_lispobj(free)+disp; + + memcpy(free, (BytePtr)old, physbytes); + /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ + /* Actually, it's best to always leave a trail, for two reasons. + a) We may be walking the same heap that we're leaving forwaring + pointers in, so we don't want garbage that we leave behind to + look like a header. + b) We'd like to be able to forward code-vector locatives, and + it's easiest to do so if we leave a {forward_marker, dnode_locative} + pair at every doubleword in the old vector. + */ + while(physbytes) { + *old++ = (BytePtr) forward_marker; + *old++ = (BytePtr) free; + free += dnode_size; + physbytes -= dnode_size; + } + return new; +} + +LispObj +purify_object(LispObj obj, area *dest) +{ + return purify_displaced_object(obj, dest, fulltag_of(obj)); +} + + + +void +copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest) +{ + LispObj obj = *ref, header; + natural tag = fulltag_of(obj), header_tag; + + if ((tag == fulltag_misc) && + (((BytePtr)ptr_from_lispobj(obj)) > low) && + (((BytePtr)ptr_from_lispobj(obj)) < high)) { + header = deref(obj, 0); + if (header == forward_marker) { /* already copied */ + *ref = (untag(deref(obj,1)) + tag); + } else { + header_tag = fulltag_of(header); + if (immheader_tag_p(header_tag)) { + if (header_subtag(header) != subtag_macptr) { + *ref = purify_object(obj, dest); + } + } + } + } +} + +void +purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to) +{ +#ifdef PPC + LispObj + loc = *locaddr, + *headerP; + opcode + *p, + insn; + natural + tag = fulltag_of(loc); + + if (((BytePtr)ptr_from_lispobj(loc) > low) && + ((BytePtr)ptr_from_lispobj(loc) < high)) { + + headerP = (LispObj *)ptr_from_lispobj(untag(loc)); + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: +#ifdef PPC64 + case fulltag_cons: + case fulltag_misc: +#endif + if (*headerP == forward_marker) { + *locaddr = (headerP[1]+tag); + } else { + /* Grovel backwards until the header's found; copy + the code vector to to space, then treat it as if it + hasn't already been copied. */ + p = (opcode *)headerP; + do { + p -= 2; + tag += 8; + insn = *p; +#ifdef PPC64 + } while (insn != PPC64_CODE_VECTOR_PREFIX); + headerP = ((LispObj*)p)-1; + *locaddr = purify_displaced_object(((LispObj)headerP), to, tag); +#else + } while ((insn & code_header_mask) != subtag_code_vector); + *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag); +#endif + } + break; + +#ifndef PPC64 + case fulltag_misc: + copy_ivector_reference(locaddr, low, high, to); + break; +#endif + } +} +#endif +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) +{ + LispObj header; + unsigned tag; + + while (start < end) { + header = *start; + if (header == forward_marker) { + start += 2; + } else { + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else { + if (!nodeheader_tag_p(tag)) { + copy_ivector_reference(start, low, high, to); + } + start++; + copy_ivector_reference(start, low, high, to); + start++; + } + } + } +} + +/* Purify references from tstack areas */ +void +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + purify_range(current+2, end, low, high, to); + } + } +} + +/* Purify a vstack area */ +void +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + if (((natural)p) & sizeof(natural)) { + copy_ivector_reference(p, low, high, to); + p++; + } + purify_range(p, q, low, high, to); +} + + +void +purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + BytePtr + current, + next, + limit = a->high; + + for (current = a->active; current != limit; current = next) { + next = *((BytePtr *)current); + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + purify_locref(&((lisp_frame *) current)->savelr, low, high, to); + } else { + /* Clear low bits of "next", just in case */ + next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1)); + } + } +} + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to) +{ + unsigned long *regs = (unsigned long *) xpGPRvector(xp); + + int r; + + /* registers >= fn should be treated as roots. + The PC, LR, loc_pc, and CTR should be treated as "locatives". + */ + + for (r = fn; r < 32; r++) { + copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to); + }; + + purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to); + + purify_locref((LispObj*) (&(xpPC(xp))), low, high, to); + purify_locref((LispObj*) (&(xpLR(xp))), low, high, to); + purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to); +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + purify_range(start, end, low, high, to); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + purify_xp(xp, low, high, to); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + purify_xp(xframes->curr, low, high, to); + } +} + +void +purify_gcable_ptrs(BytePtr low, BytePtr high, area *to) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + copy_ivector_reference(prev, low, high, to); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + purify_tstack_area(next_area, low, high, target); + break; + + case AREA_VSTACK: + purify_vstack_area(next_area, low, high, target); + break; + + case AREA_CSTACK: + purify_cstack_area(next_area, low, high, target); + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target); + break; + + default: + break; + } + } +} + +/* + So far, this is mostly for save_application's benefit. + We -should- be able to return to lisp code after doing this, + however. + +*/ + + +signed_natural +purify(TCR *tcr, signed_natural param) +{ + extern area *extend_readonly_area(unsigned); + area + *a = active_dynamic_area, + *new_pure_area; + + TCR *other_tcr; + natural max_pure_size; + BytePtr new_pure_start; + + + max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), + (LispObj *) a->active); + new_pure_area = extend_readonly_area(max_pure_size); + if (new_pure_area) { + new_pure_start = new_pure_area->active; + lisp_global(IN_GC) = (1<low, a->active, new_pure_area); + + other_tcr = tcr; + do { + purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area); + purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + purify_gcable_ptrs(a->low, a->active, new_pure_area); + + { + natural puresize = (unsigned) (new_pure_area->active-new_pure_start); + if (puresize != 0) { + xMakeDataExecutable(new_pure_start, puresize); + + } + } + ProtectMemory(new_pure_area->low, + align_to_power_of_2(new_pure_area->active-new_pure_area->low, + log2_page_size)); + lisp_global(IN_GC) = 0; + just_purified_p = true; + return 0; + } + return -1; +} + +void +impurify_locref(LispObj *p, LispObj low, LispObj high, int delta) +{ + LispObj q = *p; + + switch (fulltag_of(q)) { +#ifdef PPC64 + case fulltag_cons: +#endif + case fulltag_misc: + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + if ((q >= low) && (q < high)) { + *p = (q+delta); + } + } +} + + +void +impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta) +{ + LispObj q = *p; + + if ((fulltag_of(q) == fulltag_misc) && + (q >= low) && + (q < high)) { + *p = (q+delta); + } +} + + +#ifdef PPC +void +impurify_cstack_area(area *a, LispObj low, LispObj high, int delta) +{ + BytePtr + current, + next, + limit = a->high; + + for (current = a->active; current != limit; current = next) { + next = *((BytePtr *)current); + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + impurify_locref(&((lisp_frame *) current)->savelr, low, high, delta); + } else { + /* Clear low bits of "next", just in case */ + next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1)); + } + } +} +#endif + +void +impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta) +{ + natural *regs = (natural *) xpGPRvector(xp); + +#ifdef PPC + int r; + /* registers >= fn should be treated as roots. + The PC, LR, loc_pc, and CTR should be treated as "locatives". + */ + + for (r = fn; r < 32; r++) { + impurify_noderef((LispObj*) (&(regs[r])), low, high, delta); + }; + + impurify_locref((LispObj*) (&(regs[loc_pc])), low, high, delta); + + impurify_locref((LispObj*) (&(xpPC(xp))), low, high, delta); + impurify_locref((LispObj*) (&(xpLR(xp))), low, high, delta); + impurify_locref((LispObj*) (&(xpCTR(xp))), low, high, delta); +#endif + +} + + +void +impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta) +{ + LispObj header; + unsigned tag; + + while (start < end) { + header = *start; + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else { + if (!nodeheader_tag_p(tag)) { + impurify_noderef(start, low, high, delta); + } + start++; + impurify_noderef(start, low, high, delta); + start++; + } + } +} + + + + +void +impurify_tcr_tlb(TCR *tcr, LispObj low, LispObj high, int delta) +{ + unsigned n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + impurify_range(start, end, low, high, delta); +} + +void +impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + impurify_xp(xp, low, high, delta); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + impurify_xp(xframes->curr, low, high, delta); + } +} + +void +impurify_tstack_area(area *a, LispObj low, LispObj high, int delta) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + impurify_range(current+2, end, low, high, delta); + } + } +} +void +impurify_vstack_area(area *a, LispObj low, LispObj high, int delta) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + if (((natural)p) & sizeof(natural)) { + impurify_noderef(p, low, high, delta); + p++; + } + impurify_range(p, q, low, high, delta); +} + + +void +impurify_areas(LispObj low, LispObj high, int delta) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + impurify_tstack_area(next_area, low, high, delta); + break; + + case AREA_VSTACK: + impurify_vstack_area(next_area, low, high, delta); + break; + + case AREA_CSTACK: +#ifdef PPC + impurify_cstack_area(next_area, low, high, delta); +#endif + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta); + break; + + default: + break; + } + } +} + +void +impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + impurify_noderef(prev, low, high, delta); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + +signed_natural +impurify(TCR *tcr, signed_natural param) +{ + area *r = readonly_area; + + if (r) { + area *a = active_dynamic_area; + BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active, + oldhigh = a->high, newhigh; + unsigned n = ro_limit - ro_base; + int delta = oldfree-ro_base; + TCR *other_tcr; + + if (n) { + lisp_global(IN_GC) = 1; + newhigh = (BytePtr) (align_to_power_of_2(oldfree+n, + log2_heap_segment_size)); + if (newhigh > oldhigh) { + grow_dynamic_area(newhigh-oldhigh); + } + a->active += n; + memmove(oldfree, ro_base, n); + munmap(ro_base, n); + a->ndnodes = area_dnode(a, a->active); + pure_space_active = r->active = r->low; + r->ndnodes = 0; + + impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + + other_tcr = tcr; + do { + impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + lisp_global(IN_GC) = 0; + } + return 0; + } + return -1; +} + Index: /branches/qres/ccl/lisp-kernel/ppc-macros.s =================================================================== --- /branches/qres/ccl/lisp-kernel/ppc-macros.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/ppc-macros.s (revision 13564) @@ -0,0 +1,744 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + +/* The assembler has to do the arithmetic here: the expression */ +/* may not be evaluable by m4. */ +define(`lwi',`ifdef(`DARWIN',` + .if ((($2) & 0xffff8000) == 0xffff8000) + li $1,($2) + .elseif ((($2) & 0xffff8000) == 0) + li $1,$2 + .else + lis $1,(($2)>>16) + .if (($2) & 0xffff) <> 0 + ori $1,$1,(($2) & 0xffff) + .endif + .endif',` + .ifeq (($2) & 0xffff8000)-0xffff8000 + li $1,$2 + .else + .ifeq (($2) & 0xffff8000) + li $1,$2 + .else + lis $1,($2>>16) + .ifne ($2 & 0xffff) + ori $1,$1,$2 & 0xffff + .endif + .endif + .endif +')') + +ifdef(`PPC64',` + define(`clrrri',`clrrdi $@') + define(`clrlri',`clrldi $@') + define(`clrlri_',`clrldi. $@') + define(`ldr',`ld $@') + define(`ldrx',`ldx $@') + define(`ldru',`ldu $@') + define(`str',`std $@') + define(`strx',`stdx $@') + define(`stru',`stdu $@') + define(`strux',`stdux $@') + define(`cmpr',`cmpd $@') + define(`cmpri',`cmpdi $@') + define(`cmplr',`cmpld $@') + define(`cmplri',`cmpldi $@') + define(`trlge',`tdlge $@') + define(`trllt',`tdllt $@') + define(`trlt',`tdlt $@') + define(`trlle',`tdlle $@') + define(`treqi',`tdeqi $@') + define(`trnei',`tdnei $@') + define(`trgti',`tdgti $@') + define(`srari',`sradi $@') + define(`srri',`srdi $@') + define(`srr',`srd $@') + define(`slri',`sldi $@') + define(`lrarx',`ldarx $@') + define(`strcx',`stdcx. $@') + define(`load_highbit',` + __(lis $1,0x8000) + __(sldi $1,$1,32) + ') + define(`extract_bit_shift_count',` + __(clrldi $1,$2,64-bitmap_shift) + ') + define(`alloc_trap',` + __(tdlt allocptr,allocbase) + ') + define(`mullr',`mulld $@') +',` + define(`clrrri',`clrrwi $@') + define(`clrlri',`clrlwi $@') + define(`clrlri_',`clrlwi. $@') + define(`ldr',`lwz $@') + define(`ldrx',`lwzx $@') + define(`ldru',`lwzu $@') + define(`str',`stw $@') + define(`strx',`stwx $@') + define(`stru',`stwu $@') + define(`strux',`stwux $@') + define(`cmpr',`cmpw $@') + define(`cmpri',`cmpwi $@') + define(`cmplr',`cmplw $@') + define(`cmplri',`cmplwi $@') + define(`trlge',`twlge $@') + define(`trllt',`twllt $@') + define(`trlt',`twlt $@') + define(`trlle',`twlle $@') + define(`treqi',`tweqi $@') + define(`trnei',`twnei $@') + define(`trgti',`twgti $@') + define(`srari',`srawi $@') + define(`srri',`srwi $@') + define(`srr',`srw $@') + define(`slri',`slwi $@') + define(`lrarx',`lwarx $@') + define(`strcx',`stwcx. $@') + define(`load_highbit',` + __(lis $1,0x8000) + ') + define(`extract_bit_shift_count',` + __(clrlwi $1,$2,32-bitmap_shift) + ') + define(`alloc_trap',` + __(twllt allocptr,allocbase) + ') + define(`mullr',`mullw $@') +') + +/* dnode_align(dest,src,delta) */ + define(`dnode_align',` + __(la $1,($3+(dnode_size-1))($2)) + __(clrrri($1,$1,dnode_align_bits)) +') + +define(`extract_fulltag',` + __(clrlri($1,$2,nbits_in_word-ntagbits)) + ') + +define(`extract_lisptag',` + __(clrlri($1,$2,nbits_in_word-nlisptagbits)) + ') + +define(`extract_lisptag_',` + __(clrlri_($1,$2,nbits_in_word-nlisptagbits)) + ') + +define(`extract_subtag',` + __(lbz $1,misc_subtag_offset($2)) + ') + +ifdef(`PPC64',` +define(`extract_lowtag',` + __(clrldi $1,$2,nbits_in_word-nlowtagbits) +') +define(`trap_unless_lowtag_equal',` + __(clrldi $3,$1,nbits_in_word-nlowtagbits) + __(tdnei $3,$2) +') + ') + +define(`extract_lowbyte',` + __(clrlri($1,$2,nbits_in_word-num_subtag_bits)) + ') + +define(`extract_header',` + __(ldr($1,misc_header_offset($2))) + ') + + +ifdef(`PPC64',` +define(`extract_typecode',` + new_macro_labels() + __(extract_fulltag($1,$2)) + __(cmpdi cr0,$1,fulltag_misc) + __(extract_lisptag($1,$1)) + __(bne cr0,macro_label(not_misc)) + __(extract_subtag($1,$2)) +macro_label(not_misc): +')',` +define(`extract_typecode',` + new_macro_labels() + __(extract_lisptag($1,$2)) + __(cmpwi cr0,$1,tag_misc) + __(bne cr0,macro_label(not_misc)) + __(extract_subtag($1,$2)) +macro_label(not_misc): +')') + +define(`box_fixnum',` + __(slri($1,$2,fixnumshift)) + ') + +define(`unbox_fixnum',` + __(srari($1,$2,fixnumshift)) + ') + +define(`loaddf',` + __(lfd $1,dfloat.value($2))') + +define(`storedf',` + __(stfd $1,dfloat.value($2)) + ') + +define(`push',` + __(stru($1,-node_size($2))) + ') + + /* Generally not a great idea. */ +define(`pop',` + __(ldr($1,0($2))) + __(la $2,node_size($2)) + ') + +define(`vpush',` + __(push($1,vsp)) + ') + +define(`vpop',` + __(pop($1,vsp)) + ') + + +define(`unlink',` + __(ldr($1,0($1))) + ') + + +define(`set_nargs',` + __(lwi(nargs,($1)< nil. */ + __(li arg_z,nil_value) + __(neg imm1,imm1) + __(subi imm1,imm1,node_size) + __(bge 1f) + __(ldrx(arg_z,imm0,imm1)) +1: + __(la vsp,node_size(imm0)) + __(blr) + + +/* Come here to return multiple values when */ +/* the caller's context isn't saved in a lisp_frame. */ +/* lr, fn valid; temp0 = entry vsp */ + +_spentry(values) + __(mflr loc_pc) +local_label(return_values): + __(ref_global(imm0,ret1val_addr)) + __(li arg_z,nil_value) + /* max tsp frame is 4K. 8+8 is overhead for save_values_to_tsp below */ + /* and @do_unwind in nthrowvalues in "sp_catch.s". */ + __(cmpri(cr2,nargs,4096-(dnode_size+dnode_size))) + __(cmpr(cr1,imm0,loc_pc)) + __(cmpri(cr0,nargs,fixnum_one)) + __(bge cr2,2f) + __(beq+ cr1,3f) + __(mtlr loc_pc) + __(add imm0,nargs,vsp) + __(blt- cr0,1f) + __(ldr(arg_z,-node_size(imm0))) +1: + __(mr vsp,temp0) + __(blr) + +2: + __(uuo_interr(error_too_many_values,nargs)) + __(b 2b) + +/* Return multiple values to real caller. */ +3: + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(add imm1,nargs,vsp) + __(ldr(imm0,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(cmpr(cr0,imm1,imm0)) /* a fairly common case */ + __(mtlr loc_pc) + __(cmpri(cr1,nargs,fixnum_one)) /* sadly, a very common case */ + __(discard_lisp_frame()) + __(beqlr cr0) /* already in the right place */ + __(bne cr1,4f) + __(ldr(arg_z,0(vsp))) + __(mr vsp,imm0) + __(vpush(arg_z)) + __(blr) +4: + __(blt cr1,6f) + __(li imm2,fixnum_one) +5: + __(cmpr(cr0,imm2,nargs)) + __(addi imm2,imm2,fixnum_one) + __(ldru(arg_z,-node_size(imm1))) + __(push(arg_z,imm0)) + __(bne cr0,5b) +6: + __(mr vsp,imm0) + __(blr) + + .globl C(nvalret) + +/* Come here with saved context on top of stack. */ +_spentry(nvalret) +C(nvalret): + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(ldr(temp0,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(b local_label(return_values)) + +/* Provide default (NIL) values for &optional arguments; imm0 is */ +/* the (fixnum) upper limit on the total of required and &optional */ +/* arguments. nargs is preserved, all arguments wind up on the */ +/* vstack. */ +_spentry(default_optional_args) + __(cmplr( cr7,nargs,imm0)) + __(li imm5,nil_value) + __(vpush_argregs()) + __(mr imm1,nargs) + __(bgelr cr7) +1: + __(addi imm1,imm1,fixnum_one) + __(cmpr(cr0,imm1,imm0)) + __(vpush(imm5)) + __(bne cr0,1b) + __(blr) + +/* Indicate whether &optional arguments were actually supplied. nargs */ +/* contains the actual arg count (minus the number of required args); */ +/* imm0 contains the number of &optional args in the lambda list. */ +/* Note that nargs may be > imm0 if &rest/&key is involved. */ +_spentry(opt_supplied_p) + __(li imm1,0) +1: + /* (vpush (< imm1 nargs)) */ + __ifdef(`PPC64') + __(xor imm2,imm1,nargs) + __(sradi imm2,imm2,63) + __(or imm2,imm2,imm1) + __(addi imm1,imm1,fixnumone) + __(cmpr(cr0,imm1,imm0)) + __(subf imm2,nargs,imm2) + __(srdi imm2,imm2,63) + __(mulli imm2,imm2,t_offset) + __(addi imm2,imm2,nil_value) + __(vpush(imm2)) + __(bne cr0,1b) + __(blr) + __else + __(xor imm2,imm1,nargs) + __(srawi imm2,imm2,31) + __(or imm2,imm2,imm1) + __(addi imm1,imm1,fixnumone) + __(cmpr(cr0,imm1,imm0)) + __(subf imm2,nargs,imm2) + __(srwi imm2,imm2,31) + __(insrwi imm2,imm2,1,27) + __(addi imm2,imm2,nil_value) + __(vpush(imm2)) + __(bne cr0,1b) + __(blr) + __endif + + + +/* If nargs is <= imm0, vpush a nil. Otherwise, cons a list of length */ +/* (- nargs imm0) and vpush it. */ +/* Use this entry point to heap-cons a simple &rest arg. */ +_spentry(heap_rest_arg) + __(li imm0,0) + __(vpush_argregs()) + __(sub imm1,nargs,imm0) + __(cmpri(imm1,0)) + __(li arg_z,nil_value) + __(b 2f) +1: + __(ldr(temp0,0(vsp))) + __(cmpri(imm1,fixnum_one)) + __(la vsp,node_size(vsp)) + __(Cons(arg_z,temp0,arg_z)) + __(subi imm1,imm1,fixnum_one) +2: + __(bgt 1b) + __(vpush(arg_z)) + __(blr) + + +/* And this entry point when the argument registers haven't yet been */ +/* vpushed (as is typically the case when required/&rest but no */ +/* &optional/&key.) */ +_spentry(req_heap_rest_arg) + __(vpush_argregs()) + __(sub imm1,nargs,imm0) + __(cmpri(imm1,0)) + __(li arg_z,nil_value) + __(b 2f) +1: + __(ldr(temp0,0(vsp))) + __(cmpri(imm1,fixnum_one)) + __(la vsp,node_size(vsp)) + __(Cons(arg_z,temp0,arg_z)) + __(subi imm1,imm1,fixnum_one) +2: + __(bgt 1b) + __(vpush(arg_z)) + __(blr) + + +_spentry(heap_cons_rest_arg) + __(sub imm1,nargs,imm0) + __(cmpri(imm1,0)) + __(li arg_z,nil_value) + __(b 2f) +1: + __(ldr(temp0,0(vsp))) + __(cmpri(imm1,fixnum_one)) + __(la vsp,node_size(vsp)) + __(Cons(arg_z,temp0,arg_z)) + __(subi imm1,imm1,fixnum_one) +2: + __(bgt 1b) + __(vpush(arg_z)) + __(blr) + + +_spentry(simple_keywords) + __(li imm0,0) + __(vpush_argregs()) + __(b _SPkeyword_bind) + +_spentry(keyword_args) + __(vpush_argregs()) + __(b _SPkeyword_bind) + +/* Treat the last (- nargs imm0) values on the vstack as keyword/value */ +/* pairs. There'll be imm3 keyword arguments. Imm2 contains flags */ +/* that indicate whether &allow-other-keys was specified and whether */ +/* or not to leave the keyword/value pairs on the vstack for an &rest */ +/* argument. Temp3 contains a vector of keyword specifiers which we */ +/* must (in general) match. */ +/* If the number of arguments is greater than imm0, the difference must */ +/* be even. */ +/* Note that the caller hasn't yet saved its caller's context and that */ +/* the temp registers used to pass next_method_context */ +/* (temp1) may still have "live" values in them, as does nfn (temp2). */ + +define(`keyword_flags',`imm2') +define(`keyword_vector',`temp3') +define(`keyword_count',`imm3') + + + +define(`varptr',`save0') +define(`valptr',`save1') +define(`limit',`save2') + +_spentry(keyword_bind) + /* Before we can really do anything, we have to */ + /* save the caller's context. To do so, we need to know */ + /* how many args have actually been pushed. Ordinarily, that'd */ + /* be "nargs", but we may have pushed more args than we received */ + /* if we had to default any &optionals. */ + /* So, the number of args pushed so far is the larger of nargs */ + /* and the (canonical) total of required/&optional args received. */ + __(cmpr(cr0,nargs,imm0)) + __(add arg_z,vsp,nargs) + __(bge+ cr0,1f) + __(add arg_z,vsp,imm0) +1: + __(build_lisp_frame(fn,loc_pc,arg_z)) + __(mr fn,nfn) + /* If there are key/value pairs to consider, we slide them down */ + /* the vstack to make room for the value/supplied-p pairs. */ + /* The first step in that operation involves pushing imm3 pairs */ + /* of NILs. */ + /* If there aren't any such pairs, the first step is the last */ + /* step. */ + __(cmpri(cr0,imm3,0)) + __(li arg_z,0) + __(sub imm1,nargs,imm0) + __(mr imm4,vsp) /* in case odd keywords error */ + __(cmpri(cr1,imm1,0)) + __(b 3f) +2: + __(addi arg_z,arg_z,fixnum_one) + __(cmplr(cr0,arg_z,imm3)) + __(li imm5,nil_value) + __(vpush(imm5)) + __(vpush(imm5)) +3: + __(bne cr0,2b) + __(andi. arg_z,imm1,fixnum_one) + __(blelr cr1) /* no keyword/value pairs to consider. */ + __(bne cr0,odd_keywords) + /* We have key/value pairs. Move them to the top of the vstack, */ + /* then set the value/supplied-p vars to NIL. */ + /* Have to use some save regs to do this. */ + __(vpush(limit)) + __(vpush(valptr)) + __(vpush(varptr)) + /* recompute ptr to user args in case stack overflowed */ + __(add imm4,vsp,imm3) + __(add imm4,imm4,imm3) + __(addi imm4,imm4,3*node_size) + /* error if odd number of keyword/value args */ + __(mr varptr,imm4) + __(la limit,3*node_size(vsp)) + __(mr valptr,limit) + __(mr arg_z,imm1) +4: + __(li imm4,nil_value) + __(subi arg_z,arg_z,2< 1 (and we know that it was < 3), it must have */ + /* been 2. Set arg_x, then vpush the remaining args. */ + __(ble cr1,local_label(set_y_z)) +local_label(set_arg_x): + __(subi imm0,imm0,fixnum_one) + __(cmpri(cr0,imm0,0)) + __(subi imm2,imm2,fixnum_one) + __(ldrx(arg_x,nfn,imm2)) + __(addi nargs,nargs,fixnum_one) + __(bne cr0,local_label(vpush_remaining)) + __(b local_label(go)) + /* Maybe set arg_y or arg_z, preceding args */ +local_label(set_y_z): + __(bne cr1,local_label(set_arg_z)) + /* Set arg_y, maybe arg_x, preceding args */ +local_label(set_arg_y): + __(subi imm0,imm0,fixnum_one) + __(cmpri(cr0,imm0,0)) + __(subi imm2,imm2,fixnum_one) + __(ldrx(arg_y,nfn,imm2)) + __(addi nargs,nargs,fixnum_one) + __(bne cr0,local_label(set_arg_x)) + __(b local_label(go)) +local_label(set_arg_z): + __(subi imm0,imm0,fixnum_one) + __(cmpri(cr0,imm0,0)) + __(subi imm2,imm2,fixnum_one) + __(ldrx(arg_z,nfn,imm2)) + __(addi nargs,nargs,fixnum_one) + __(bne cr0,local_label(set_arg_y)) + +local_label(go): + __(vrefr(nfn,nfn,1)) + __(ldr(loc_pc,_function.codevector(nfn))) + __(mtctr loc_pc) + __(bctr) + +/* This treats anything that's either */ +/* #+ppc32 (signed-byte 32), (unsigned-byte 32) */ +/* #+ppc64 (signed-byte 64), (unsigned-byte 64) */ +/* as if it denoted a "natural-sized" value. */ +/* Argument in arg_z, result in imm0. May use temp0. */ +_spentry(getxlong) + __ifdef(`PPC64') + __else + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm0,subtag_bignum)) + __(unbox_fixnum(imm0,arg_z)) + __(beqlr cr0) + __(mr temp0,arg_z) + __(bne- cr1,local_label(error)) + __(getvheader(imm0,temp0)) + __(cmpri(cr1,imm0,one_digit_bignum_header)) + __(cmpri(cr7,imm0,two_digit_bignum_header)) + __(beq cr1,local_label(big1)) + __(beq cr7,local_label(big2)) +local_label(error): + __(uuo_interr(error_object_not_integer,arg_z)) /* not quite right but what 68K MCL said */ + + + +local_label(big2): + __(vrefr(imm0,temp0,1)) /* sign digit must be 0 */ + __(cmpri(imm0,0)) + __(bne local_label(error)) +local_label(big1): + __(vrefr(imm0,temp0,0)) + __(blr) + + + __endif + +/* Everything up to the last arg has been vpushed, nargs is set to */ +/* the (boxed) count of things already pushed. */ +/* On exit, arg_x, arg_y, arg_z, and nargs are set as per a normal */ +/* function call (this may require vpopping a few things.) */ +/* ppc2-invoke-fn assumes that temp1 is preserved here. */ +_spentry(spreadargz) + __ifdef(`PPC64') + __(extract_fulltag(imm1,arg_z)) + __(cmpri(cr1,imm1,fulltag_cons)) + __else + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr1,imm1,tag_list)) + __endif + __(cmpri(cr0,arg_z,nil_value)) + __(li imm0,0) + __(mr arg_y,arg_z) /* save in case of error */ + __(beq cr0,2f) +1: + __(bne- cr1,3f) + __(_car(arg_x,arg_z)) + __(_cdr(arg_z,arg_z)) + __(cmpri(cr0,arg_z,nil_value)) + __ifdef(`PPC64') + __(extract_fulltag(imm1,arg_z)) + __(cmpri(cr1,imm1,fulltag_cons)) + __else + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr1,imm1,tag_list)) + __endif + __(vpush(arg_x)) + __(addi imm0,imm0,fixnum_one) + __(bne cr0,1b) +2: + __(add. nargs,nargs,imm0) + __(cmpri(cr2,nargs,2< bytes */ + __(add imm2,vsp,imm2) /* imm2 points below pairs */ + __(li imm0,0) /* count unknown keywords so far */ + __(extrwi imm1,nargs,1,mask_aok) /* unknown keywords allowed */ + __(extrwi nargs,nargs,mask_key_width,mask_key_start) + /* Now, for each keyword/value pair in the list */ + /* a) if the keyword is found in the keyword vector, set the */ + /* corresponding entry on the vstack to the value and the */ + /* associated supplied-p var to T. */ + /* b) Regardless of whether or not the keyword is found, */ + /* if :ALLOW-OTHER-KEYS is provided with a non-nil value, */ + /* set the low bit of imm1 to indicate that unknown keywords */ + /* are acceptable. (This bit is pre-set above to the value */ + /* the encoded value of &allow_other_keys.) */ + /* c) If the keyword is not found (and isn't :ALLOW-OTHER-KEYS), increment */ + /* the count of unknown keywords in the high bits of imm1*/ + /* At the end of the list, signal an error if any unknown keywords were seen */ + /* but not allowed. Otherwise, return. */ + +match_keys_loop: + __(cmpri(cr0,arg_reg,nil_value)) + __(li imm0,0) + __(li imm3,misc_data_offset) + __(beq cr0,matched_keys) + __(ldr(arg_x,cons.car(arg_reg))) + __(li arg_y,nrs.kallowotherkeys) + __(cmpr(cr3,arg_x,arg_y)) /* :ALLOW-OTHER-KEYS ? */ + __(ldr(arg_reg,cons.cdr(arg_reg))) + __(ldr(arg_y,cons.car(arg_reg))) + __(cmpr(cr4,imm0,nargs)) + __(ldr(arg_reg,cons.cdr(arg_reg))) + __(b match_test) +match_loop: + __(ldrx(temp0,keyvect_reg,imm3)) + __(cmpr(cr0,arg_x,temp0)) + __(addi imm0,imm0,1) + __(cmpr(cr4,imm0,nargs)) + __(addi imm3,imm3,node_size) + __(bne cr0,match_test) + /* Got a hit. Unless this keyword's been seen already, set it. */ + __(slwi imm0,imm0,dnode_shift) + __(subf imm0,imm0,imm2) + __(ldr(temp0,0(imm0))) + __(cmpri(cr0,temp0,nil_value)) + __(li temp0,t_value) + __(bne cr0,match_keys_loop) /* already saw this */ + __(str(arg_y,node_size*1(imm0))) + __(str(temp0,node_size*0(imm0))) + __(bne cr3,match_keys_loop) + __(b match_keys_check_aok) +match_test: + __(bne cr4,match_loop) + __(beq cr3,match_keys_check_aok) + __(addi imm1,imm1,node_size) + __(b match_keys_loop) +match_keys_check_aok: + __(andi. imm0,imm1,2) /* check "seen-aok" bit in imm1 */ + __(cmpri cr1,arg_y,nil_value) /* check value */ + __(ori imm1,imm1,2) + __(bne cr0,match_keys_loop) /* duplicate aok */ + __(beq cr1,match_keys_loop) + __(ori imm1,imm1,1) + __(b match_keys_loop) +matched_keys: + __(clrrwi. imm0,imm1,2) + __(beqlr) + __(andi. imm1,imm1,1) + __(bnelr) + /* Some unrecognized keywords. Complain generically about */ + /* invalid keywords. */ +db_badkeys: + __(li arg_y,XBADKEYS) + __(b destructure_error) +toomany: + __(li arg_y,XCALLTOOMANY) + __(b destructure_error) +toofew: + __(li arg_y,XCALLTOOFEW) + __(b destructure_error) +badlist: + __(li arg_y,XCALLNOMATCH) + /* b destructure_error */ +destructure_error: + __(mr vsp,imm4) /* undo everything done to the stack */ + __(mr arg_z,whole_reg) + __(set_nargs(2)) + __(b _SPksignalerr) + +/* vpush the values in the value set atop the vsp, incrementing nargs. */ +/* Discard the tsp frame; leave values atop the vsp. */ + +_spentry(recover_values) + +/* First, walk the segments reversing the pointer to previous segment pointers */ +/* Can tell the end because that previous segment pointer is the prev tsp pointer */ + __(ldr(imm0,tsp_frame.backlink(tsp))) /* previous tsp */ + __(mr imm1,tsp) /* current segment */ + __(mr imm2,tsp) /* last segment */ +local_label(walkloop): + __(ldr(imm3,tsp_frame.fixed_overhead+node_size(imm1))) /* next segment */ + __(cmpr(cr0,imm0,imm3)) /* last segment? */ + __(str(imm2,tsp_frame.fixed_overhead+node_size(imm1))) /* reverse pointer */ + __(mr imm2,imm1) /* last segment <- current segment */ + __(mr imm1,imm3) /* current segment <- next segment */ + __(bne cr0,local_label(walkloop)) + + /* the final segment ptr is now in imm2 */ + /* walk backwards, pushing values on VSP and incrementing NARGS */ +local_label(pushloop): + __(ldr(imm0,tsp_frame.data_offset(imm2))) /* nargs in segment */ + __(cmpri(cr0,imm0,0)) + __(cmpr(cr1,imm2,tsp)) + __(la imm3,tsp_frame.data_offset+(2*node_size)(imm2)) + __(add imm3,imm3,imm0) + __(add nargs,nargs,imm0) + __(b 2f) +1: + __(ldru(arg_z,-node_size(imm3))) + __(cmpri(cr0,imm0,fixnum_one)) + __(subi imm0,imm0,fixnum_one) + __(vpush(arg_z)) +2: + __(bne cr0,1b) + __(ldr(imm2,tsp_frame.data_offset+node_size(imm2))) /* previous segment */ + __(bne cr1,local_label(pushloop)) + __(unlink(tsp)) + __(blr) + + +/* Go out of line to do this. Sheesh. */ + +_spentry(vpopargregs) + __(cmpri(cr0,nargs,0)) + __(cmpri(cr1,nargs,2<callback-index */ +/* Restore lisp context, then funcall #'%pascal-functions% with */ +/* two args: callback-index, args-ptr (a macptr pointing to the args on the stack) */ +_spentry(poweropen_callback) + __ifdef(`rTOC') + __(mr r11,rTOC) + __endif + /* Save C argument registers */ + __(str(r3,c_frame.param0(sp))) + __(str(r4,c_frame.param1(sp))) + __(str(r5,c_frame.param2(sp))) + __(str(r6,c_frame.param3(sp))) + __(str(r7,c_frame.param4(sp))) + __(str(r8,c_frame.param5(sp))) + __(str(r9,c_frame.param6(sp))) + __(str(r10,c_frame.param7(sp))) + __(mflr imm3) + __(str(imm3,c_frame.savelr(sp))) + __(mfcr imm0) + __(str(imm0,c_frame.crsave(sp))) + + /* Save the non-volatile registers on the sp stack */ + /* This is a non-standard stack frame, but noone will ever see it, */ + /* so it doesn't matter. It will look like more of the stack frame pushed below. */ + __(stru(sp,-(stack_align(c_reg_save.size))(sp))) + __(str(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(str(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(str(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(str(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(str(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(str(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(str(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(str(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(str(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(str(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(str(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(str(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(str(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(str(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(str(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(str(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(str(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(str(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(str(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(stfd f1,c_reg_save.save_fprs+(0*8)(sp)) + __(stfd f2,c_reg_save.save_fprs+(1*8)(sp)) + __(stfd f3,c_reg_save.save_fprs+(2*8)(sp)) + __(stfd f4,c_reg_save.save_fprs+(3*8)(sp)) + __(stfd f5,c_reg_save.save_fprs+(4*8)(sp)) + __(stfd f6,c_reg_save.save_fprs+(5*8)(sp)) + __(stfd f7,c_reg_save.save_fprs+(6*8)(sp)) + __(stfd f8,c_reg_save.save_fprs+(7*8)(sp)) + __(stfd f9,c_reg_save.save_fprs+(8*8)(sp)) + __(stfd f10,c_reg_save.save_fprs+(9*8)(sp)) + __(stfd f11,c_reg_save.save_fprs+(10*8)(sp)) + __(stfd f12,c_reg_save.save_fprs+(11*8)(sp)) + __(stfd f13,c_reg_save.save_fprs+(12*8)(sp)) + __(check_stack_alignment(r0)) + __(mffs f0) + __(stfd f0,c_reg_save.save_fp_zero(sp)) + __(lwz r31,c_reg_save.save_fp_zero+4(sp)) /* recover FPSCR image */ + __(stw r31,c_reg_save.save_fpscr(sp)) + __(lwi(r30,0x43300000)) + __(lwi(r31,0x80000000)) + __(stw r30,c_reg_save.save_fp_zero(sp)) + __(stw r31,c_reg_save.save_fp_zero+4(sp)) + __(stfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(lfd fp_s32conv,c_reg_save.save_fp_zero(sp)) + __(stfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(lfs fp_zero,lisp_globals.short_float_zero(0)) /* ensure that fp_zero contains 0.0 */ + +/* Restore rest of Lisp context. */ +/* Could spread out the memory references here to gain a little speed */ + + __(li loc_pc,0) + __(li fn,0) /* subprim, not a lisp function */ + __(li temp3,0) + __(li temp2,0) + __(li temp1,0) + __(li temp0,0) + __(li arg_x,0) + __(box_fixnum(arg_y,r11)) /* callback-index */ + __(la arg_z,c_reg_save.save_fprs(sp)) + __(str(arg_z,stack_align(c_reg_save.size)+c_frame.unused(sp))) + __(la arg_z,stack_align(c_reg_save.size)+c_frame.param0(sp)) /* parameters (tagged as a fixnum) */ + + /* Recover lisp thread context. Have to call C code to do so. */ + __(ref_global(r12,get_tcr)) + __ifdef(`rTOC') + __(ld rTOC,8(r12)) + __(ld r12,0(r12)) + __endif + __(mtctr r12) + __(li r3,1) + __(stru(sp,-(stack_align(c_frame.minsiz))(sp))) + __(bctrl) + __(la rcontext,TCR_BIAS(r3)) + __(la sp,(stack_align(c_frame.minsiz))(sp)) + + __(ldr(vsp,tcr.save_vsp(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li rzero,0) + __(li imm0,TCR_STATE_LISP) + __(mtxer rzero) /* lisp wants the overflow bit being clear */ + __(mtctr rzero) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(lfd f0,tcr.lisp_fpscr(rcontext)) + __(mtfsf 0xff,f0) + __(li allocbase,0) + __(li allocptr,0) + __(str(imm0,tcr.valence(rcontext))) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + + __(restore_saveregs(vsp)) + + /* load nargs and callback to the lisp */ + __(set_nargs(2)) + __(ldr(imm2,tcr.cs_area(rcontext))) + __(ldr(imm4,area.active(imm2))) + __(stru(imm4,-lisp_frame.size(sp))) + __(str(imm3,lisp_frame.savelr(sp))) + __(li fname,nrs.callbacks) /* %pascal-functions% */ + __(call_fname) + __(ldr(imm2,lisp_frame.backlink(sp))) + __(ldr(imm3,tcr.cs_area(rcontext))) + __(str(imm2,area.active(imm3))) + __(discard_lisp_frame()) + /* save_vsp will be restored from ff_call's stack frame, but */ + /* I included it here for consistency. */ + /* save_tsp is set below after we exit Lisp context. */ + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + /* Exit lisp context */ + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + /* Restore the non-volatile registers & fpscr */ + __(lfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(lwz r31,c_reg_save.save_fpscr(sp)) + __(stw r31,c_reg_save.save_fp_zero+4(sp)) + __(lfd f0,c_reg_save.save_fp_zero(sp)) + __(mtfsf 0xff,f0) + __(ldr(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(ldr(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(ldr(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(ldr(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(ldr(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(ldr(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(ldr(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(ldr(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(ldr(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(ldr(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(ldr(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(ldr(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(ldr(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(ldr(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(ldr(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(ldr(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(ldr(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(ldr(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(ldr(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(lfd f1,c_reg_save.save_fprs+(0*8)(sp)) + __(lfd f2,c_reg_save.save_fprs+(1*8)(sp)) + __(lfd f3,c_reg_save.save_fprs+(2*8)(sp)) + __(lfd f4,c_reg_save.save_fprs+(3*8)(sp)) + __(lfd f5,c_reg_save.save_fprs+(4*8)(sp)) + __(lfd f6,c_reg_save.save_fprs+(5*8)(sp)) + __(lfd f7,c_reg_save.save_fprs+(6*8)(sp)) + __(lfd f8,c_reg_save.save_fprs+(7*8)(sp)) + __(lfd f9,c_reg_save.save_fprs+(8*8)(sp)) + __(lfd f10,c_reg_save.save_fprs+(9*8)(sp)) + __(lfd f11,c_reg_save.save_fprs+(10*8)(sp)) + __(lfd f12,c_reg_save.save_fprs+(11*8)(sp)) + __(lfd f13,c_reg_save.save_fprs+(12*8)(sp)) + __(lfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(ldr(sp,0(sp))) + __(ldr(r3,c_frame.param0(sp))) + __(ldr(r4,c_frame.param1(sp))) + __(ldr(r5,c_frame.param2(sp))) + __(ldr(r6,c_frame.param3(sp))) + __(ldr(r7,c_frame.param4(sp))) + __(ldr(r8,c_frame.param5(sp))) + __(ldr(r9,c_frame.param6(sp))) + __(ldr(r10,c_frame.param7(sp))) + __(ldr(r11,c_frame.savelr(sp))) + __(mtlr r11) + __(ldr(r11,c_frame.crsave(sp))) + __(mtcr r11) + __(blr) + +/* Like misc_alloc (a LOT like it, since it does most of the work), but takes */ +/* an initial-value arg in arg_z, element_count in arg_x, subtag in arg_y. */ +/* Calls out to %init-misc, which does the rest of the work. */ + +_spentry(misc_alloc_init) + __(mflr loc_pc) + __(build_lisp_frame(fn,loc_pc,vsp)) + __(li fn,0) + __(mr temp0,arg_z) /* initval */ + __(mr arg_z,arg_y) /* subtag */ + __(mr arg_y,arg_x) /* element-count */ + __(bl _SPmisc_alloc) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(discard_lisp_frame()) + __(li fname,nrs.init_misc) + __(set_nargs(2)) + __(mr arg_y,temp0) + __(jump_fname()) + +/* As in stack_misc_alloc above, only with a non-default initial-value. */ + +_spentry(stack_misc_alloc_init) + __(mflr loc_pc) + __(build_lisp_frame(fn,loc_pc,vsp)) + __(li fn,0) + __(mr temp0,arg_z) /* initval */ + __(mr arg_z,arg_y) /* subtag */ + __(mr arg_y,arg_x) /* element-count */ + __(bl _SPstack_misc_alloc) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(discard_lisp_frame()) + __(li fname,nrs.init_misc) + __(set_nargs(2)) + __(mr arg_y,temp0) + __(jump_fname()) + + +_spentry(callbuiltin) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + +/* the value of the nilreg-relative symbol %builtin-functions% should be */ +/* a vector of symbols. Call the symbol indexed by imm0 (boxed) and */ +/* return a single value. */ + +_spentry(callbuiltin0) + __(set_nargs(0)) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + +_spentry(callbuiltin1) + __(ref_nrs_value(fname,builtin_functions)) + __(set_nargs(1)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + +_spentry(callbuiltin2) + __(set_nargs(2)) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + + +_spentry(callbuiltin3) + __(set_nargs(3)) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + + +_spentry(popj) + .globl C(popj) +C(popj): + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(blr) + +_spentry(restorefullcontext) + __(mflr loc_pc) + __(mtctr loc_pc) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(bctr) + +_spentry(savecontextvsp) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(build_lisp_frame(fn,loc_pc,vsp)) + __(mr fn,nfn) + __(trllt(sp,imm0)) + __(blr) + +_spentry(savecontext0) + __(add imm0,vsp,imm0) + __(build_lisp_frame(fn,loc_pc,imm0)) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(mr fn,nfn) + __(trllt(sp,imm0)) + __(blr) + + +/* Like .SPrestorefullcontext, only the saved return address */ +/* winds up in loc-pc instead of getting thrashed around ... */ +_spentry(restorecontext) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(blr) + + +/* Nargs is valid; all arg regs, lexpr-count pushed by caller. */ +/* imm0 = vsp to restore. */ +/* Return all values returned by caller to its caller, hiding */ +/* the variable-length arglist. */ +/* If we can detect that the caller's caller didn't expect */ +/* multiple values, then things are even simpler. */ +_spentry(lexpr_entry) + __(ref_global(imm1,ret1val_addr)) + __(cmpr(cr0,imm1,loc_pc)) + __(build_lisp_frame(fn,loc_pc,imm0)) + __(bne cr0,1f) + __(ref_global(imm0,lexpr_return)) + __(build_lisp_frame(rzero,imm0,vsp)) + __(mr loc_pc,imm1) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(trllt(sp,imm0)) + __(li fn,0) + __(blr) + + /* The single-value case just needs to return to something that'll pop */ + /* the variable-length frame off of the vstack. */ +1: + __(ref_global(loc_pc,lexpr_return1v)) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(trllt(sp,imm0)) + __(li fn,0) + __(blr) + +/* */ +/* Do a system call in Darwin. The stack is set up much as it would be */ +/* for a PowerOpen ABI ff-call: register parameters are in the stack */ +/* frame, and there are 4 extra words at the bottom of the frame that */ +/* we can carve a lisp frame out of. */ +/* */ +/* System call return conventions are a little funky in Darwin: if "@sc" */ +/* is the address of the "sc" instruction, errors return to @sc+4 and */ +/* non-error cases return to @sc+8. Error values are returned as */ +/* positive values in r3; this is true even if the system call returns */ +/* a doubleword (64-bit) result. Since r3 would ordinarily contain */ +/* the high half of a doubleword result, this has to be special-cased. */ +/* */ +/* The caller should set the c_frame.crsave field of the stack frame */ +/* to 0 if the result is to be interpreted as anything but a doubleword */ +/* and to non-zero otherwise. (This only matters on an error return.) */ + + +_spentry(poweropen_syscall) + __(mflr loc_pc) + __(vpush_saveregs()) + __(ldr(imm1,0(sp))) + __(la imm2,-lisp_frame.size(imm1)) + __(zero_doublewords imm2,0,lisp_frame.size) + __(str(imm1,lisp_frame.backlink(imm2))) + __(str(imm2,c_frame.backlink(sp))) + __(str(fn,lisp_frame.savefn(imm2))) + __(str(loc_pc,lisp_frame.savelr(imm2))) + __(str(vsp,lisp_frame.savevsp(imm2))) + __(ldr(imm3,tcr.cs_area(rcontext))) + __(str(imm2,area.active(imm3))) + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(rzero,tcr.ffi_exception(rcontext))) + __(mr save0,rcontext) + __(li r3,TCR_STATE_FOREIGN) + __(str(r3,tcr.valence(rcontext))) + __(li rcontext,0) + __(ldr(r3,c_frame.param0(sp))) + __(ldr(r4,c_frame.param1(sp))) + __(ldr(r5,c_frame.param2(sp))) + __(ldr(r6,c_frame.param3(sp))) + __(ldr(r7,c_frame.param4(sp))) + __(ldr(r8,c_frame.param5(sp))) + __(ldr(r9,c_frame.param6(sp))) + __(ldr(r10,c_frame.param7(sp))) + __(unbox_fixnum(r0,arg_z)) + __(sc) + __ifdef(`LINUX') + __(bns+ 9f) + __else + __(b 1f) + __(b 9f) + __endif +1: + __ifdef(`PPC64') + __(neg r3,r3) + __else + __(ldr(imm2,c_frame.crsave(sp))) + __(cmpri(cr0,imm2,0)) + __(bne cr0,2f) + /* 32-bit result */ + __(neg r3,r3) + __(b 9f) +2: + /* 64-bit result */ + __(neg r4,r3) + __(li r3,-1) + __endif +9: + __(mr imm2,save0) /* recover context */ + __(ldr(sp,c_frame.backlink(sp))) + __(li imm4,TCR_STATE_LISP) + __(li rzero,0) + __(li loc_pc,0) + __(li arg_x,nil_value) + __(li arg_y,nil_value) + __(li arg_z,nil_value) + __(li temp0,nil_value) + __(li temp1,nil_value) + __(li temp2,nil_value) + __(li temp3,nil_value) + __(li fn,nil_value) + __(mr rcontext,imm2) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(str(imm4,tcr.valence(rcontext))) + __(vpop_saveregs) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame) + __(mtxer rzero) + __(check_pending_interrupt(`cr1')) + __(blr) + + +_spentry(builtin_plus) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(addo. arg_z,arg_y,arg_z) + __(bnslr+) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef(`PPC64') + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) +1: + __(jump_builtin(_builtin_plus,2)) +_spentry(builtin_minus) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(subo. arg_z,arg_y,arg_z) + __(bnslr+) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef(`PPC64') + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) +1: + __(jump_builtin(_builtin_minus,2)) +_spentry(builtin_times) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(unbox_fixnum(imm2,arg_y)) + __(bne cr0,1f) + __(bne cr1,1f) + __ifdef(`PPC64') + __(mulldo. imm3,arg_z,imm2) + __(bso 2f) + __(mr arg_z,imm3) + __(blr) + /* Args are fixnums; result can't be */ +2: __(mtxer rzero) + __(unbox_fixnum(imm3,arg_z)) + __(mulld imm1,imm3,imm2) /* imm1 = low 64 bits */ + __(mulhd imm0,imm3,imm2) /* imm0 = high 64 bits */ + __(b _SPmakes128) + __else + __(mullwo. imm3,arg_z,imm2) + __(bso 2f) /* SO set if result would overflow a fixnum */ + __(mr arg_z,imm3) + __(blr) + /* Args are fixnums; result can't be */ +2: __(mtxer rzero) + __(unbox_fixnum(imm3,arg_z)) + __(mullw imm1,imm3,imm2) /* imm1 = low 32 bits */ + __(mulhw imm0,imm3,imm2) /* imm0 = high 32 bits */ + __(b _SPmakes64) + __endif + +1: __(jump_builtin(_builtin_times,2)) + +_spentry(builtin_div) + __(jump_builtin(_builtin_div,2)) + +_spentry(builtin_eq) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bnelr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_eq,2)) + +_spentry(builtin_ne) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(beqlr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_ne,2)) + +_spentry(builtin_gt) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bnglr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_gt,2)) + +_spentry(builtin_ge) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bltlr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_ge,2)) + +_spentry(builtin_lt) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bnllr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_lt,2)) + +_spentry(builtin_le) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bgtlr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_le,2)) + + +_spentry(builtin_eql) + __(cmpr(cr1,arg_y,arg_z)) + __(extract_fulltag(imm2,arg_y)) + __(extract_fulltag(imm3,arg_z)) + __(beq cr1,1f) + __(cmpri(cr1,imm2,fulltag_misc)) + __(cmpri(cr0,imm3,fulltag_misc)) + __(bne cr1,2f) + __(extract_subtag(imm0,arg_y)) + __(bne cr0,2f) + __(extract_subtag(imm1,arg_z)) + __(cmpr(cr0,imm0,imm1)) + __(bne cr0,2f) + __(jump_builtin(_builtin_eql,2)) +1: __(li arg_z,t_value) + __(blr) +2: __(li arg_z,nil_value) + __(blr) + +_spentry(builtin_length) + __(cmpri(cr1,arg_z,nil_value)) + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,min_vector_subtag)) + __(beq cr1,1f) + __ifdef(`PPC64') + __(cmpdi cr2,imm0,fulltag_cons) + __else + __(cmpwi cr2,imm0,tag_list) + __endif + __(beq- cr0,2f) + __(blt- cr0,3f) + /* (simple-array * (*)) */ + __(vector_length(arg_z,arg_z,imm0)) + __(blr) +1: __(li arg_z,0) + __(blr) +2: + __(ldr(arg_z,vectorH.logsize(arg_z))) + __(blr) +3: __(bne cr2,8f) + __(li temp2,-1< n */ + __(blr) +0: + __(unbox_fixnum(imm1,arg_y)) + __(unbox_fixnum(imm0,arg_z)) + __(bgt cr1,2f) + /* (ash n -count) => fixnum */ + __(neg imm2,imm0) + __(bgt cr2,1f) + __(li imm2,63) +1: + __(srad imm0,imm1,imm2) + __(box_fixnum(arg_z,imm0)) + __(blr) + /* Integer-length of arg_y/imm1 to imm2 */ +2: + __(cntlzd. imm2,imm1) + __(bne 3f) /* cr0`eq' set if negative */ + __(not imm2,imm1) + __(cntlzd imm2,imm2) +3: + __(subfic imm2,imm2,64) + __(add imm2,imm2,imm0) /* imm2 <- integer-length(imm1) + count */ + __(cmpdi cr1,imm2,63-fixnumshift) + __(cmpdi cr2,imm0,64) + __(sld imm2,imm1,imm0) + __(bgt cr1,6f) + __(box_fixnum(arg_z,imm2)) + __(blr) +6: + __(bgt cr2,9f) + __(bne cr2,7f) + /* Shift left by 64 bits exactly */ + __(mr imm0,imm1) + __(li imm1,0) + __(beq _SPmakes128) + __(b _SPmakeu128) +7: + /* Shift left by fewer than 64 bits, result not a fixnum */ + __(subfic imm0,imm0,64) + __(beq 8f) + __(srd imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakeu128) +8: + __(srad imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakes128) + __else + __(cmpri(cr1,arg_z,0)) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr3,imm1,tag_fixnum)) + __(cmpri(cr2,arg_z,-(29<<2))) /* !! 2 = fixnumshift */ + __(bne- cr0,9f) + __(bne- cr3,9f) + __(bne cr1,0f) + __(mr arg_z,arg_y) /* (ash n 0) => n */ + __(blr) +0: + __(unbox_fixnum(imm1,arg_y)) + __(unbox_fixnum(imm0,arg_z)) + __(bgt cr1,2f) + /* (ash n -count) => fixnum */ + __(neg imm2,imm0) + __(bgt cr2,1f) + __(li imm2,31) +1: + __(sraw imm0,imm1,imm2) + __(box_fixnum(arg_z,imm0)) + __(blr) + /* Integer-length of arg_y/imm1 to imm2 */ +2: + __(cntlzw. imm2,imm1) + __(bne 3f) /* cr0`eq' set if negative */ + __(not imm2,imm1) + __(cntlzw imm2,imm2) +3: + __(subfic imm2,imm2,32) + __(add imm2,imm2,imm0) /* imm2 <- integer-length(imm1) + count */ + __(cmpri(cr1,imm2,31-fixnumshift)) + __(cmpri(cr2,imm0,32)) + __(slw imm2,imm1,imm0) + __(bgt cr1,6f) + __(box_fixnum(arg_z,imm2)) + __(blr) +6: + __(bgt cr2,9f) + __(bne cr2,7f) + /* Shift left by 32 bits exactly */ + __(mr imm0,imm1) + __(li imm1,0) + __(beq _SPmakes64) + __(b _SPmakeu64) +7: + /* Shift left by fewer than 32 bits, result not a fixnum */ + __(subfic imm0,imm0,32) + __(beq 8f) + __(srw imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakeu64) +8: + __(sraw imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakes64) + __endif +9: + __(jump_builtin(_builtin_ash,2)) + +_spentry(builtin_negate) + __(extract_lisptag_(imm0,arg_z)) + __(bne- cr0,1f) + __(nego. arg_z,arg_z) + __(bnslr+) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef(`PPC64') + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) +1: + __(jump_builtin(_builtin_negate,1)) + +_spentry(builtin_logxor) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(xor arg_z,arg_y,arg_z) + __(blr) +1: + __(jump_builtin(_builtin_logxor,2)) + + + + +_spentry(builtin_aset1) + __(extract_typecode(imm0,arg_x)) + __(cmpri(cr0,imm0,min_vector_subtag)) + __(box_fixnum(temp0,imm0)) + __(bgt cr0,1f) + __(jump_builtin(_builtin_aset1,3)) +1: + __(b _SPsubtag_misc_set) + +/* Enter the debugger */ +_spentry(breakpoint) + __(li r3,0) + __(tw 28,sp,sp) /* 28 = lt|gt|eq (assembler bug for the latter) */ + __(blr) /* if handler didn't */ + +/* */ +/* We're entered with an eabi_c_frame on the C stack. There's a */ +/* lisp_frame reserved underneath it; we'll link it in in a minute. */ +/* Load the outgoing GPR arguments from eabi_c_frame.param`0-7', */ +/* then shrink the eabi_c_frame. */ +/* */ + +_spentry(eabi_ff_call) + __(mflr loc_pc) + __(str(sp,eabi_c_frame.savelr(sp))) + __(vpush_saveregs()) /* Now we can use save0-save7 to point to stacks */ + __(mr save0,rcontext) /* or address globals. */ + __(extract_typecode(imm0,arg_z)) + __(cmpri(imm0,subtag_macptr)) + __(ldr(save1,0(sp))) /* bottom of reserved lisp frame */ + __(la save2,-lisp_frame.size(save1)) /* top of lisp frame */ + __(zero_doublewords save2,0,lisp_frame.size) + __(str(save1,lisp_frame.backlink(save2))) + __(str(save2,c_frame.backlink(sp))) + __(str(fn,lisp_frame.savefn(save2))) + __(str(loc_pc,lisp_frame.savelr(save2))) + __(str(vsp,lisp_frame.savevsp(save2))) + __(bne 1f) + __(ldr(arg_z,macptr.address(arg_z))) +1: + __(ldr(save3,tcr.cs_area(rcontext))) + __(str(save2,area.active(save3))) + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(mtctr arg_z) + __(str(rzero,tcr.ffi_exception(rcontext))) + __(mffs f0) + __(stfd f0,tcr.lisp_fpscr(rcontext)) /* remember lisp's fpscr */ + __(mtfsf 0xff,fp_zero) /* zero foreign fpscr */ + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + __(ldr(r2,tcr.native_thread_info(rcontext))) + __(ldr(r13,lisp_globals.saveR13(0))) + __(ldr(r3,eabi_c_frame.param0(sp))) + __(ldr(r4,eabi_c_frame.param1(sp))) + __(ldr(r5,eabi_c_frame.param2(sp))) + __(ldr(r6,eabi_c_frame.param3(sp))) + __(ldr(r7,eabi_c_frame.param4(sp))) + __(ldr(r8,eabi_c_frame.param5(sp))) + __(ldr(r9,eabi_c_frame.param6(sp))) + __(ldr(r10,eabi_c_frame.param7(sp))) + __(la save1,eabi_c_frame.minsiz-eabi_c_frame.param0(sp)) + __(str(rzero,eabi_c_frame.savelr(save1))) + __(str(save2,eabi_c_frame.backlink(save1))) + __(mr sp,save1) + /* If we're calling a varargs C function, it'll want to */ + /* know whether or not we've passed any args in FP regs. */ + /* Better to say that we did (and force callee to save FP */ + /* arg regs on entry) than to say that we didn't and get */ + /* garbage results */ + __(crset 6) + __(bctrl) + /* C should have preserved save0 (= rcontext) for us. */ + __(ldr(sp,0(sp))) + __(mr imm2,save0) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(li rzero,0) + __(mr loc_pc,rzero) + __(li arg_x,nil_value) + __(li arg_y,nil_value) + __(li arg_z,nil_value) + __(li temp0,nil_value) + __(li temp1,nil_value) + __(li temp2,nil_value) + __(li temp3,nil_value) + __(li fn,nil_value) + __(mr rcontext,imm2) + __(li imm2,TCR_STATE_LISP) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(li allocptr,-dnode_size) + __(li allocbase,-dnode_size) + __(str(imm2,tcr.valence(rcontext))) + __(vpop_saveregs()) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(mffs f0) + __(stfd f0,8(sp)) + __(lwz imm3,12(sp)) /* imm3 = FPSCR after call */ + __(clrrwi imm2,imm3,8) + __(discard_lisp_frame()) + __(str(imm2,tcr.ffi_exception(rcontext))) + __(lfd f0,tcr.lisp_fpscr(rcontext)) + __(mtfsf 0xff,f0) + __(check_pending_interrupt(`cr1')) + __(mtxer rzero) + __(mtctr rzero) + __(blr) + +/* */ +/* This gets called with R11 holding the unboxed callback index. */ +/* */ + +_spentry(eabi_callback) + /* First, we extend the C frame so that it has room for */ + /* incoming arg regs. */ + __(ldr(r0,eabi_c_frame.backlink(sp))) + __(stru(r0,eabi_c_frame.param0-varargs_eabi_c_frame.incoming_stack_args(sp))) + __(mflr r0) + __(str(r0,varargs_eabi_c_frame.savelr(sp))) + __(str(r3,varargs_eabi_c_frame.gp_save+(0*4)(sp))) + __(str(r4,varargs_eabi_c_frame.gp_save+(1*4)(sp))) + __(str(r5,varargs_eabi_c_frame.gp_save+(2*4)(sp))) + __(str(r6,varargs_eabi_c_frame.gp_save+(3*4)(sp))) + __(str(r7,varargs_eabi_c_frame.gp_save+(4*4)(sp))) + __(str(r8,varargs_eabi_c_frame.gp_save+(5*4)(sp))) + __(str(r9,varargs_eabi_c_frame.gp_save+(6*4)(sp))) + __(str(r10,varargs_eabi_c_frame.gp_save+(7*4)(sp))) + /* Could check the appropriate CR bit and skip saving FP regs here */ + __(stfd f1,varargs_eabi_c_frame.fp_save+(0*8)(sp)) + __(stfd f2,varargs_eabi_c_frame.fp_save+(1*8)(sp)) + __(stfd f3,varargs_eabi_c_frame.fp_save+(2*8)(sp)) + __(stfd f4,varargs_eabi_c_frame.fp_save+(3*8)(sp)) + __(stfd f5,varargs_eabi_c_frame.fp_save+(4*8)(sp)) + __(stfd f6,varargs_eabi_c_frame.fp_save+(5*8)(sp)) + __(stfd f7,varargs_eabi_c_frame.fp_save+(6*8)(sp)) + __(stfd f8,varargs_eabi_c_frame.fp_save+(7*8)(sp)) + __(la r0,varargs_eabi_c_frame.incoming_stack_args(sp)) + __(str(r0,varargs_eabi_c_frame.overflow_arg_area(sp))) + __(la r0,varargs_eabi_c_frame.regsave(sp)) + __(str(r0,varargs_eabi_c_frame.reg_save_area(sp))) + __(li r0,0) + __(str(r0,varargs_eabi_c_frame.flags(sp))) + + /* Save the non-volatile registers on the sp stack */ + /* This is a non-standard stack frame, but noone will ever see it, */ + /* so it doesn't matter. It will look like more of the stack frame pushed below. */ + __(stru(sp,-(c_reg_save.size)(sp))) + __(str(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(str(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(str(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(str(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(str(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(str(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(str(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(str(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(str(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(str(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(str(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(str(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(str(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(str(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(str(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(str(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(str(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(str(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(str(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(mffs f0) + __(stfd f0,c_reg_save.save_fp_zero(sp)) + __(ldr(r31,c_reg_save.save_fp_zero+4(sp))) /* recover FPSCR image */ + __(str(r31,c_reg_save.save_fpscr(sp))) + __(lwi(r30,0x43300000)) + __(lwi(r31,0x80000000)) + __(str(r30,c_reg_save.save_fp_zero(sp))) + __(str(r31,c_reg_save.save_fp_zero+4(sp))) + __(stfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(lfd fp_s32conv,c_reg_save.save_fp_zero(sp)) + __(stfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(lfs fp_zero,lisp_globals.short_float_zero(0)) /* ensure that fp_zero contains 0.0 */ + + +/* Restore rest of Lisp context. */ +/* Could spread out the memory references here to gain a little speed */ + __(li loc_pc,0) + __(li fn,0) /* subprim, not a lisp function */ + __(li temp3,0) + __(li temp2,0) + __(li temp1,0) + __(li temp0,0) + __(li arg_x,0) + __(box_fixnum(arg_y,r11)) /* callback-index */ + __(la arg_z,c_reg_save.size+varargs_eabi_c_frame.gp_save(sp)) /* parameters (tagged as a fixnum) */ + + /* Recover lisp thread context. Have to call C code to do so. */ + __(ref_global(r12,get_tcr)) + __(mtctr r12) + __(li r3,1) + __(stru(sp,-(stack_align(eabi_c_frame.minsiz))(sp))) + __(bctrl) + __(la sp,(stack_align(eabi_c_frame.minsiz))(sp)) + __(la rcontext,TCR_BIAS(r3)) + __(li allocptr,0) + __(li allocbase,0) + __(ldr(vsp,tcr.save_vsp(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li rzero,0) + __(mtxer rzero) /* lisp wants the overflow bit clear */ + __(li imm0,TCR_STATE_LISP) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(mtctr rzero) + __(str(imm0,tcr.valence(rcontext))) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(lfd f0,tcr.lisp_fpscr(rcontext)) + __(mtfsf 0xff,f0) + + __(restore_saveregs(vsp)) + /* load nargs and callback to the lisp */ + __(set_nargs(2)) + __(ldr(imm2,tcr.cs_area(rcontext))) + __(ldr(imm4,area.active(imm2))) + __(stru(imm4,-lisp_frame.size(sp))) + __(str(imm3,lisp_frame.savelr(sp))) + __(str(vsp,lisp_frame.savevsp(sp))) /* for stack overflow code */ + __(li fname,nrs.callbacks) /* %pascal-functions% */ + __(call_fname) + __(ldr(imm2,lisp_frame.backlink(sp))) + __(ldr(imm3,tcr.cs_area(rcontext))) + __(str(imm2,area.active(imm3))) + __(discard_lisp_frame()) + /* save_vsp will be restored from ff_call's stack frame, but */ + /* I included it here for consistency. */ + /* save_tsp is set below after we exit Lisp context. */ + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + /* Exit lisp context */ + /* This is not necessary yet, but will be once we can be interrupted */ + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + /* Restore the non-volatile registers & fpscr */ + __(lfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(ldr(r31,c_reg_save.save_fpscr(sp))) + __(str(r31,c_reg_save.save_fp_zero+4(sp))) + __(lfd f0,c_reg_save.save_fp_zero(sp)) + __(mtfsf 0xff,f0) + __(ldr(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(ldr(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(ldr(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(ldr(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(ldr(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(ldr(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(ldr(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(ldr(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(ldr(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(ldr(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(ldr(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(ldr(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(ldr(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(ldr(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(ldr(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(ldr(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(ldr(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(ldr(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(ldr(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(lfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(ldr(sp,0(sp))) + + __(ldr(r3,varargs_eabi_c_frame.gp_save+(0*4)(sp))) + __(ldr(r4,varargs_eabi_c_frame.gp_save+(1*4)(sp))) + __(lfd f1,varargs_eabi_c_frame.gp_save+(2*4)(sp)) + __(ldr(r5,varargs_eabi_c_frame.savelr(sp))) + __(str(r5,varargs_eabi_c_frame.old_savelr(sp))) + __(mtlr r5) + __(ldr(r5,varargs_eabi_c_frame.backlink(sp))) + __(str(r5,varargs_eabi_c_frame.old_backlink(sp))) + __(la sp,varargs_eabi_c_frame.old_backlink(sp)) + __(blr) + + +/* Do a linux system call: the system call index is (boxed) */ +/* in arg_z, and other arguments are in an eabi_c_frame on */ +/* the C stack. As is the case with an eabi_ff_call, there's */ +/* a lisp frame reserved underneath the eabi_c_frame. */ + +/* This is a little simpler than eabi_ff_call, because we */ +/* can assume that there are no synchronous callbacks to */ +/* lisp (that might cause a GC.) It's also simpler for the */ +/* caller, since we return error status atomically. */ + +/* A system call can clobber any or all of r9-r12, so we need */ +/* to save and restore allocptr, allocbase, and tsp. */ + +_spentry(eabi_syscall) +/* We're entered with an eabi_c_frame on the C stack. There's a */ +/* lisp_frame reserved underneath it; we'll link it in in a minute. */ +/* Load the outgoing GPR arguments from eabi_c_frame.param`0-7', */ +/* then shrink the eabi_c_frame. */ + + __(mflr loc_pc) + __(vpush_saveregs()) + __(str(sp,eabi_c_frame.savelr(sp))) + __(li arg_x,nil_value) + __(mr temp0,rcontext) + __(ldr(temp1,c_frame.backlink(sp))) /* bottom of reserved lisp frame */ + __(la temp2,-lisp_frame.size(temp1)) /* top of lisp frame */ + __(zero_doublewords temp2,0,lisp_frame.size) + __(str(temp1,lisp_frame.backlink(temp2))) + __(str(temp2,c_frame.backlink(sp))) + __(str(fn,lisp_frame.savefn(temp2))) + __(str(loc_pc,lisp_frame.savelr(temp2))) + __(str(vsp,lisp_frame.savevsp(temp2))) + __(ldr(temp3,tcr.cs_area(rcontext))) + __(str(temp2,area.active(temp3))) + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(rzero,tcr.ffi_exception(rcontext))) + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + __(ldr(r13,lisp_globals.saveR13(0))) + __(ldr(r3,eabi_c_frame.param0(sp))) + __(ldr(r4,eabi_c_frame.param1(sp))) + __(ldr(r5,eabi_c_frame.param2(sp))) + __(ldr(r6,eabi_c_frame.param3(sp))) + __(ldr(r7,eabi_c_frame.param4(sp))) + __(ldr(r8,eabi_c_frame.param5(sp))) + __(ldr(r9,eabi_c_frame.param6(sp))) + __(ldr(r10,eabi_c_frame.param7(sp))) + __(la temp1,eabi_c_frame.minsiz-eabi_c_frame.param0(sp)) + __(str(rzero,eabi_c_frame.savelr(temp1))) + __(str(temp2,eabi_c_frame.backlink(temp1))) + __(mr sp,temp1) + __(unbox_fixnum(r0,arg_z)) + __(sc) + __(nop) + /* C should have preserved temp0 (= rcontext) for us. */ + __(ldr(sp,0(sp))) + __(mr imm2,temp0) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(li rzero,0) + __(mr loc_pc,rzero) + __(mr fn,rzero) + __(li arg_x,nil_value) + __(li arg_y,nil_value) + __(li arg_z,nil_value) + __(li temp0,nil_value) + __(li temp1,nil_value) + __(li temp2,nil_value) + __(li temp3,nil_value) + __(li fn,nil_value) + + __(li imm3,TCR_STATE_LISP) + __(mr rcontext,imm2) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(str(imm3,tcr.valence(rcontext))) + __(vpop_saveregs) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(bns 1f) + __(neg r3,r3) +1: + __(check_pending_interrupt(`cr1')) + __(mtxer rzero) + __(blr) + +/* arg_z should be of type (UNSIGNED-BYTE 64); */ +/* On PPC32, return high 32 bits in imm0, low 32 bits in imm1 */ +/* On PPC64, return unboxed value in imm0 */ + +_spentry(getu64) + __ifdef(`PPC64') + __(extract_typecode(imm0,arg_z)) + __(cmpdi cr0,imm0,tag_fixnum) + __(cmpdi cr2,arg_z,0) + __(cmpdi cr1,imm0,subtag_bignum) + __(bne cr0,1f) + __(unbox_fixnum(imm0,arg_z)) + __(bgelr cr2) +0: + __(uuo_interr(error_object_not_u64,arg_z)) + +1: __(bne cr1,0b) + __(getvheader(imm1,arg_z)) + __(ld imm0,misc_data_offset(arg_z)) + __(cmpdi cr2,imm1,two_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(cmpdi cr1,imm1,three_digit_bignum_header) + __(cmpdi cr0,imm0,0) + __(beq cr2,2f) + __(lwz imm1,misc_data_offset+8(arg_z)) + __(bne cr1,0b) + __(cmpwi imm1,0) + __(bne 0b) + __(blr) +2: __(blt 0b) + __(blr) + __else + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,arg_z,0)) + __(cmpri(cr2,imm0,subtag_bignum)) + __(unbox_fixnum(imm1,arg_z)) + __(bne cr0,8f) + __(bgelr cr1) +9: + __(uuo_interr(error_object_not_u64,arg_z)) +8: + __(bne- cr2,9b) + __(getvheader(imm2,arg_z)) + __(cmpri(cr2,imm2,two_digit_bignum_header)) + __(vrefr(imm1,arg_z,0)) + __(cmpri(cr1,imm1,0)) + __(li imm0,0) + __(bge cr2,2f) + __(blt- cr1,9b) + __(blr) +2: + __(cmpri(cr0,imm2,three_digit_bignum_header)) + __(vrefr(imm0,arg_z,1)) + __(cmpri(cr1,imm0,0)) + __(bne cr2,3f) + __(blt- cr1,9b) + __(blr) +3: + __(vrefr(imm2,arg_z,2)) + __(cmpri(cr1,imm2,0)) + __(bne- cr0,9b) + __(bne- cr1,9b) + __(blr) + __endif + +/* arg_z should be of type (SIGNED-BYTE 64); */ +/* PPC32: return high 32 bits in imm0, low 32 bits in imm1 */ +/* PPC64: return unboxed value in imm0 */ + +_spentry(gets64) + __ifdef(`PPC64') + __(extract_typecode(imm1,arg_z)) + __(unbox_fixnum(imm0,arg_z)) + __(cmpri(cr0,imm1,tag_fixnum)) + __(cmpri(cr2,imm1,subtag_bignum)) + __(beqlr cr0) + __(bne cr2,9f) + __(ld imm1,misc_header_offset(arg_z)) + __(ld imm0,misc_data_offset(arg_z)) + __(cmpdi imm1,two_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(beqlr) + __else + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr2,imm0,subtag_bignum)) + __(unbox_fixnum(imm1,arg_z)) + __(srawi imm0,imm1,31) + __(beqlr cr0) + __(bne cr2,9f) + __(getvheader(imm2,arg_z)) + __(cmpri(cr2,imm2,two_digit_bignum_header)) + __(vrefr(imm1,arg_z,0)) + __(srawi imm0,imm1,31) + __(bltlr cr2) + __(vrefr(imm0,arg_z,1)) + __(beqlr cr2) + __endif +9: + __(uuo_interr(error_object_not_s64,arg_z)) + + +/* Construct a lisp integer out of the 64-bit unsigned value in */ +/* ppc32: imm0 (high 32 bits) and imm1 (low 32 bits) */ +/* ppc64: imm0 (64 bits) . */ +_spentry(makeu64) + __ifdef(`PPC64') + __(clrrdi. imm1,imm0,63-nfixnumtagbits) + __(cmpri(cr1,imm0,0)) + __(box_fixnum(arg_z,imm0)) + __(beqlr cr0) /* A fixnum */ + __(rotldi imm1,imm0,32) + __(li imm2,two_digit_bignum_header) + __(blt cr1,2f) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) +2: + __(li imm2,three_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) + __else + __(cmpri(cr1,imm0,0)) + __(rlwinm. imm2,imm1,0,0,fixnum_shift) + __(li imm2,three_digit_bignum_header) + __(box_fixnum(arg_z,imm1)) + __(blt cr1,3f) + __(bne cr1,2f) + __(beqlr cr0) /* A fixnum */ + __(blt cr0,2f) + __(li imm2,one_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) +2: + __(li imm2,two_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __(str(imm0,misc_data_offset+4(arg_z))) + __(blr) +3: + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(str(imm1,misc_data_offset(arg_z))) + __(str(imm0,misc_data_offset+4(arg_z))) + __(blr) + __endif + + + +/* Construct a lisp integer out of the 64-bit signed value in */ +/* ppc32: imm0 (high 32 bits) and imm1 (low 32 bits). */ +/* ppc64: imm0 */ +_spentry(makes64) + __ifdef(`PPC64') + __(addo imm1,imm0,imm0) + __(addo imm1,imm1,imm1) + __(addo. arg_z,imm1,imm1) + __(bnslr+) + __(mtxer rzero) + __(li imm1,two_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(Misc_Alloc_Fixed(arg_z,imm1,aligned_bignum_size(2))) + __(str(imm0,misc_data_offset(arg_z))) + __(blr) + __else + __(srawi imm2,imm1,31) + __(cmpr(cr1,imm2,imm0)) + __(addo imm2,imm1,imm1) + __(addo. arg_z,imm2,imm2) + __(bne cr1,2f) /* High word is significant */ + __(li imm2,one_digit_bignum_header) + __(bnslr cr0) /* No overflow: fixnum */ + __(mtxer rzero) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) +2: + __(mtxer rzero) + __(li imm2,two_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __(str(imm0,misc_data_offset+4(arg_z))) + __(blr) + __endif + +/* imm0:imm1 constitute an unsigned integer, almost certainly a bignum. */ +/* Make a lisp integer out of those 128 bits .. */ +_spentry(makeu128) + __ifdef(`PPC64') + __(cmpdi imm0,0) + __(cmpdi cr1,imm1,0) + __(srdi imm3,imm0,32) + __(srawi imm4,imm0,31) + __(cmpdi cr3,imm3,0) + __(cmpdi cr4,imm4,0) + __(li imm2,five_digit_bignum_header) + __(blt cr1,0f) + __(beq 3f) +0: + __(bge 1f) + /* All 128 bits are significant, and the most significant */ + /* bit is set. Allocate a 5-digit bignum (with a zero */ + /* sign digit */ + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(5))) + __(rotldi imm0,imm0,32) + __(rotldi imm1,imm1,32) + __(std imm1,misc_data_offset(arg_z)) + __(std imm0,misc_data_offset+8(arg_z)) + __(blr) +1: /* If the high word of imm0 is a zero-extension of the low */ + /* word, we only need 3 digits ; otherwise, we need 4. */ + __(li imm2,three_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(bne cr3,2f) /* high word of imm0 is non-zero */ + __(bne cr4,2f) /* sign bit is on in low word of imm0 */ + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(std imm1,misc_data_offset(arg_z)) + __(stw imm0,misc_data_offset+8(arg_z)) + __(blr) +2: __(li imm2,four_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(4))) + __(std imm1,misc_data_offset(arg_z)) + __(std imm0,misc_data_offset+8(arg_z)) + __(blr) +3: __(mr imm0,imm1) + __(b _SPmakeu64) + __else + __(twgei r0,r0) + __endif + +/* imm0:imm1 constitute a signed integer, almost certainly a bignum. */ +/* Make a lisp integer out of those 128 bits .. */ +_spentry(makes128) + __ifdef(`PPC64') + /* Is imm0 just a sign-extension of imm1 ? */ + __(sradi imm2,imm1,63) + /* Is the high word of imm0 just a sign-extension of the low word ? */ + __(extsw imm3,imm0) + __(cmpd imm2,imm0) + __(cmpd cr1,imm3,imm0) + __(beq 2f) + __(rotldi imm0,imm0,32) + __(rotldi imm1,imm1,32) + __(beq cr1,1f) + __(li imm2,four_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(4))) + __(std imm1,misc_data_offset(arg_z)) + __(std imm0,misc_data_offset+8(arg_z)) + __(blr) +1: __(li imm2,three_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(std imm1,misc_data_offset(arg_z)) + __(stw imm3,misc_data_offset+8(arg_z)) + __(blr) +2: __(mr imm0,imm1) + __(b _SPmakes64) + __else + __(twgei r0,r0) + __endif + +/* on entry: arg_z = symbol. On exit, arg_z = value (possibly */ +/* unbound_marker), arg_y = symbol, imm3 = symbol.binding-index */ +_spentry(specref) + __(ldr(imm3,symbol.binding_index(arg_z))) + __(ldr(imm0,tcr.tlb_limit(rcontext))) + __(cmpr(imm3,imm0)) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(mr arg_y,arg_z) + __(bge 1f) + __(ldrx(arg_z,imm2,imm3)) + __(cmpri(arg_z,no_thread_local_binding_marker)) + __(bnelr) +1: __(ldr(arg_z,symbol.vcell(arg_y))) + __(blr) + + +_spentry(specrefcheck) + __(ldr(imm3,symbol.binding_index(arg_z))) + __(ldr(imm0,tcr.tlb_limit(rcontext))) + __(cmpr(imm3,imm0)) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(mr arg_y,arg_z) + __(bge 1f) + __(ldrx(arg_z,imm2,imm3)) + __(cmpri(arg_z,no_thread_local_binding_marker)) + __(bne 2f) +1: __(ldr(arg_z,symbol.vcell(arg_y))) +2: __(treqi(arg_z,unbound_marker)) + __(blr) + +/* arg_y = special symbol, arg_z = new value. */ +_spentry(specset) + __(ldr(imm3,symbol.binding_index(arg_y))) + __(ldr(imm0,tcr.tlb_limit(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(cmpr(imm3,imm0)) + __(bge 1f) + __(ldrx(temp1,imm2,imm3)) + __(cmpri(temp1,no_thread_local_binding_marker)) + __(beq 1f) + __(strx(arg_z,imm2,imm3)) + __(blr) +1: __(mr arg_x,arg_y) + __(li arg_y,symbol.vcell-misc_data_offset) + __(b _SPgvset) + +/* Restore current thread's interrupt level to arg_z, */ +/* noting whether the tcr's interrupt_pending flag was set. */ +_spentry(restoreintlevel) + __(cmpri(cr1,arg_z,0)) + __(ldr(imm0,tcr.interrupt_pending(rcontext))) + __(cmpri(cr0,imm0,0)) + __(bne cr1,1f) + __(beq cr0,1f) + __(str(rzero,tcr.interrupt_pending(rcontext))) + __(li nargs,fixnum_one) + __(trgti(nargs,0)) + __(blr) +1: + __(ldr(nargs,tcr.tlb_pointer(rcontext))) + __(str(arg_z,INTERRUPT_LEVEL_BINDING_INDEX(nargs))) + __(blr) + + +/* Construct a lisp integer out of the 32-bit signed value in imm0 */ + + +_spentry(makes32) + __ifdef(`PPC64') + __(box_fixnum(arg_z,imm0)) + __else + __(addo imm1,imm0,imm0) + __(addo. arg_z,imm1,imm1) + __(bnslr+) + __(mtxer rzero) + __(li imm1,one_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm1,aligned_bignum_size(1))) + __(str(imm0,misc_data_offset(arg_z))) + __endif + __(blr) + + +/* Construct a lisp integer out of the 32-bit unsigned value in imm0 */ + + +_spentry(makeu32) + __ifdef(`PPC64') + __(box_fixnum(arg_z,imm0)) + __(blr) + __else + __(clrrwi. imm1,imm0,31-nfixnumtagbits) + __(cmpri(cr1,imm0,0)) + __(box_fixnum(arg_z,imm0)) + __(beqlr cr0) /* A fixnum */ + __(blt cr1,2f) + __(li imm2,one_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(1))) + __(str(imm0,misc_data_offset(arg_z))) + __(blr) +2: + __(li imm2,two_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm0,misc_data_offset(arg_z))) + __(blr) + __endif + +/* */ +/* arg_z should be of type (SIGNED-BYTE 32); return unboxed result in imm0 */ +/* */ +_spentry(gets32) + __ifdef(`PPC64') + __(sldi imm1,arg_z,32-fixnumshift) + __(extract_lisptag_(imm0,arg_z)) + __(sradi imm1,imm1,32-fixnumshift) + __(box_fixnum(imm0,arg_z)) + __(cmpd cr1,imm1,arg_z) + __(bne cr0,9f) + __(beqlr cr1) + __(b 9f) + __else + __(extract_typecode(imm1,arg_z)) + __(cmpri(cr0,imm1,tag_fixnum)) + __(cmpri(cr2,imm1,subtag_bignum)) + __(unbox_fixnum(imm0,arg_z)) + __(beqlr+ cr0) + __(bne cr2,9f) + __(getvheader(imm1,arg_z)) + __(cmpri(cr1,imm1,one_digit_bignum_header)) + __(vrefr(imm0,arg_z,0)) + __(beqlr+ cr1) + __endif +9: + __(uuo_interr(error_object_not_signed_byte_32,arg_z)) + +/* */ +/* arg_z should be of type (UNSIGNED-BYTE 32); return unboxed result in imm0 */ +/* */ + +_spentry(getu32) + __(extract_typecode(imm1,arg_z)) + __(cmpri(cr0,imm1,tag_fixnum)) + __(cmpri(cr1,arg_z,0)) + __(cmpri(cr2,imm1,subtag_bignum)) + __(unbox_fixnum(imm0,arg_z)) + __(bne cr0,8f) + __(bgelr cr1) +8: + __(bne- cr2,9f) + __(getvheader(imm2,arg_z)) + __(cmpri(cr2,imm2,two_digit_bignum_header)) + __(vrefr(imm0,arg_z,0)) + __(cmpri(cr0,imm0,0)) + __(bgt cr2,9f) + __(beq cr2,2f) + __(blt cr0,9f) + __(blr) +2: + __(vrefr(imm1,arg_z,1)) + __(cmpri(cr0,imm1,0)) + __(beqlr+ cr0) + +9: + __(uuo_interr(error_object_not_unsigned_byte_32,arg_z)) + +/* */ +/* arg_z has overflowed (by one bit) as the result of an addition or subtraction. */ +/* Make a bignum out of it. */ + +_spentry(fix_overflow) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef(`PPC64') + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) + + + +/* */ +/* As per mvpass above, but in this case fname is known to be a */ +/* symbol. */ + +_spentry(mvpasssym) + __(cmpri(cr0,nargs,node_size*nargregs)) + __(mflr loc_pc) + __(mr imm0,vsp) + __(ble+ cr0,1f) + __(subi imm0,imm0,node_size*nargregs) + __(add imm0,imm0,nargs) +1: + __(build_lisp_frame(fn,loc_pc,imm0)) + __(ref_global(loc_pc,ret1val_addr)) + __(li fn,0) + __(mtlr loc_pc) + __(jump_fname()) + + + +_spentry(unbind) + __(ldr(imm1,tcr.db_link(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(ldr(imm3,binding.sym(imm1))) + __(ldr(temp1,binding.val(imm1))) + __(ldr(imm1,binding.link(imm1))) + __(strx(temp1,imm2,imm3)) + __(str(imm1,tcr.db_link(rcontext))) + __(blr) + +_spentry(unbind_n) + __(ldr(imm1,tcr.db_link(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) +1: __(subi imm0,imm0,1) + __(ldr(imm3,binding.sym(imm1))) + __(ldr(temp1,binding.val(imm1))) + __(cmpri(imm0,0)) + __(ldr(imm1,binding.link(imm1))) + __(strx(temp1,imm2,imm3)) + __(bne 1b) + __(str(imm1,tcr.db_link(rcontext))) + __(blr) + +/* */ +/* Clobbers imm1,imm2,imm5,arg_x, arg_y */ + +_spentry(unbind_to) + __(ldr(imm1,tcr.db_link(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) +1: __(ldr(imm5,binding.sym(imm1))) + __(ldr(arg_y,binding.val(imm1))) + __(ldr(imm1,binding.link(imm1))) + __(cmpr(imm0,imm1)) + __(strx(arg_y,imm2,imm5)) + __(bne 1b) + __(str(imm1,tcr.db_link(rcontext))) + __(blr) + + + +/* */ +/* Restore the special bindings from the top of the tstack, */ +/* leaving the tstack frame allocated. */ +/* Note that there might be 0 saved bindings, in which case */ +/* do nothing. */ +/* Note also that this is -only- called from an unwind-protect */ +/* cleanup form, and that .SPnthrowXXX is keeping one or more */ +/* values in a frame on top of the tstack. */ +/* */ + +_spentry(progvrestore) + __(ldr(imm0,tsp_frame.backlink(tsp))) /* ignore .SPnthrowXXX values frame */ + __(ldr(imm0,tsp_frame.data_offset(imm0))) + __(cmpri(cr0,imm0,0)) + __(unbox_fixnum(imm0,imm0)) + __(bne+ cr0,_SPunbind_n) + __(blr) + +/* Bind CCL::*INTERRUPT-LEVEL* to 0. If its value had been negative, check */ +/* for pending interrupts after doing so. "nargs" can be freely used for an */ +/* interrupt trap in this context. */ +_spentry(bind_interrupt_level_0) + __(ldr(imm4,tcr.tlb_pointer(rcontext))) + __(ldr(temp0,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(ldr(imm1,tcr.db_link(rcontext))) + __(cmpri(temp0,0)) + __(li imm3,INTERRUPT_LEVEL_BINDING_INDEX) + __(vpush(temp0)) + __(vpush(imm3)) + __(vpush(imm1)) + __(str(rzero,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(str(vsp,tcr.db_link(rcontext))) + __(beqlr) + __(mr nargs,temp0) + __(bgt 1f) + __(ldr(nargs,tcr.interrupt_pending(rcontext))) +1: __(trgti(nargs,0)) + __(blr) + +/* Bind CCL::*INTERRUPT-LEVEL* to the fixnum -1. (This has the effect */ +/* of disabling interrupts.) */ +_spentry(bind_interrupt_level_m1) + __(li imm2,-fixnumone) + __(li imm3,INTERRUPT_LEVEL_BINDING_INDEX) + __(ldr(imm4,tcr.tlb_pointer(rcontext))) + __(ldr(temp0,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(ldr(imm1,tcr.db_link(rcontext))) + __(vpush(temp0)) + __(vpush(imm3)) + __(vpush(imm1)) + __(str(imm2,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(str(vsp,tcr.db_link(rcontext))) + __(blr) + + +/* Bind CCL::*INTERRUPT-LEVEL* to the value in arg_z. If that value's 0, */ +/* do what _SPbind_interrupt_level_0 does */ +_spentry(bind_interrupt_level) + __(cmpri(arg_z,0)) + __(li imm3,INTERRUPT_LEVEL_BINDING_INDEX) + __(ldr(imm4,tcr.tlb_pointer(rcontext))) + __(ldr(temp0,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(ldr(imm1,tcr.db_link(rcontext))) + __(beq _SPbind_interrupt_level_0) + __(vpush(temp0)) + __(vpush(imm3)) + __(vpush(imm1)) + __(str(arg_z,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(str(vsp,tcr.db_link(rcontext))) + __(blr) + +/* Unbind CCL::*INTERRUPT-LEVEL*. If the value changes from negative to */ +/* non-negative, check for pending interrupts. This is often called in */ +/* a context where nargs is significant, so save and restore nargs around */ +/* any interrupt polling */ + +_spentry(unbind_interrupt_level) + __(ldr(imm0,tcr.flags(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(andi. imm0,imm0,1< | 11 | */ +/* +--------+-----------------------------+--------------+------+ */ +/* */ +/* e.g., the major opcode (bits 0-5) is 0, the low 4 bits (bits 28-31) */ +/* have the value "11" decimal (that's tagged as an immediate as far */ +/* as lisp is concerned, a 7-bit opcode in bits 21-27, and the format */ +/* of bits 6-20 depend on the value of the minor opcode, though typically */ +/* bits 16-20 are used to specify a register value between 0 and 31. */ +/* */ +/* There are a few cases where bits 6-15 are also used to denote registers */ +/* (RT and RA, as in an X-form PPC instruction), some where bits 6-10 are */ +/* to be interpreted as a constant (error number or type code), and some */ +/* where bits 6-15 do so. */ +/* */ +/* Since C code is typically more interested in disassembling UUOs, the */ +/* full list of UUOs is in "uuo.h". This file contains macros for creating */ +/* them. */ +/* */ +/* Of course, there -is- no such file as "uuo.h". That's a stale comment. */ +/* For all anyone knows, so is this one. */ + +UUO_TAG = 11 +UUU_MINOR_SHIFT = 4 +UUO_RB_SHIFT = 11 +UUO_RA_SHIFT = 16 +UUO_RT_SHIFT = 21 + +define(`rt_ra_uuo',` + .long (UUO_TAG|(($1)< +#include +#include + +#include "lisp.h" +#include "area.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" + +void +sprint_lisp_object(LispObj, int); + +#define PBUFLEN 252 + +char printbuf[PBUFLEN + 4]; +int bufpos = 0; + +jmp_buf escape; + +void +add_char(char c) +{ + if (bufpos >= PBUFLEN) { + longjmp(escape, 1); + } else { + printbuf[bufpos++] = c; + } +} + +void +add_string(char *s, int len) +{ + while(len--) { + add_char(*s++); + } +} + +void +add_lisp_base_string(LispObj str) +{ + lisp_char_code *src = (lisp_char_code *) (ptr_from_lispobj(str + misc_data_offset)); + natural i, n = header_element_count(header_of(str)); + + for (i=0; i < n; i++) { + add_char((char)(*src++)); + } +} + +void +add_c_string(char *s) +{ + add_string(s, strlen(s)); +} + +char numbuf[64]; + +void +sprint_signed_decimal(signed_natural n) +{ + sprintf(numbuf, "%ld", n); + add_c_string(numbuf); +} + +void +sprint_unsigned_decimal(natural n) +{ + sprintf(numbuf, "%lu", n); + add_c_string(numbuf); +} + +void +sprint_unsigned_hex(natural n) +{ +#ifdef PPC64 + sprintf(numbuf, "#x%016lx", n); +#else + sprintf(numbuf, "#x%08lx", n); +#endif + add_c_string(numbuf); +} + +void +sprint_list(LispObj o, int depth) +{ + LispObj the_cdr; + + add_char('('); + while(1) { + if (o != lisp_nil) { + sprint_lisp_object(ptr_to_lispobj(car(o)), depth); + the_cdr = ptr_to_lispobj(cdr(o)); + if (the_cdr != lisp_nil) { + add_char(' '); + if (fulltag_of(the_cdr) == fulltag_cons) { + o = the_cdr; + continue; + } + add_c_string(". "); + sprint_lisp_object(the_cdr, depth); + break; + } + } + break; + } + add_char(')'); +} + +/* + Print a list of method specializers, using the class name instead of the class object. +*/ + +void +sprint_specializers_list(LispObj o, int depth) +{ + LispObj the_cdr, the_car; + + add_char('('); + while(1) { + if (o != lisp_nil) { + the_car = car(o); + if (fulltag_of(the_car) == fulltag_misc) { + sprint_lisp_object(deref(deref(the_car,3), 4), depth); + } else { + sprint_lisp_object(the_car, depth); + } + the_cdr = cdr(o); + if (the_cdr != lisp_nil) { + add_char(' '); + if (fulltag_of(the_cdr) == fulltag_cons) { + o = the_cdr; + continue; + } + add_c_string(". "); + sprint_lisp_object(the_cdr, depth); + break; + } + } + break; + } + add_char(')'); +} + +char * +vector_subtag_name(unsigned subtag) +{ + switch (subtag) { + case subtag_bit_vector: + return "BIT-VECTOR"; + break; + case subtag_instance: + return "INSTANCE"; + break; + case subtag_bignum: + return "BIGNUM"; + break; + case subtag_u8_vector: + return "(UNSIGNED-BYTE 8)"; + break; + case subtag_s8_vector: + return "(SIGNED-BYTE 8)"; + break; + case subtag_u16_vector: + return "(UNSIGNED-BYTE 16)"; + break; + case subtag_s16_vector: + return "(SIGNED-BYTE 16)"; + break; + case subtag_u32_vector: + return "(UNSIGNED-BYTE 32)"; + break; + case subtag_s32_vector: + return "(SIGNED-BYTE 32)"; + break; +#ifdef PPC64 + case subtag_u64_vector: + return "(UNSIGNED-BYTE 64)"; + break; + case subtag_s64_vector: + return "(SIGNED-BYTE 64)"; + break; +#endif + case subtag_package: + return "PACKAGE"; + break; + case subtag_code_vector: + return "CODE-VECTOR"; + break; + case subtag_slot_vector: + return "SLOT-VECTOR"; + break; + default: + return ""; + break; + } +} + + +void +sprint_random_vector(LispObj o, unsigned subtag, natural elements) +{ + add_c_string("#<"); + sprint_unsigned_decimal(elements); + add_c_string("-element vector subtag = "); + sprintf(numbuf, "%02X @", subtag); + add_c_string(numbuf); + sprint_unsigned_hex(o); + add_c_string(" ("); + add_c_string(vector_subtag_name(subtag)); + add_c_string(")>"); +} + +void +sprint_symbol(LispObj o) +{ + lispsymbol *rawsym = (lispsymbol *) ptr_from_lispobj(untag(o)); + LispObj + pname = rawsym->pname, + package = rawsym->package_predicate; + +#ifdef PPC64 + if (o == lisp_nil) { + add_c_string("()"); + return; + } +#endif + if (fulltag_of(package) == fulltag_cons) { + package = car(package); + } + + if (package == nrs_KEYWORD_PACKAGE.vcell) { + add_char(':'); + } + add_lisp_base_string(pname); +} + +void +sprint_function(LispObj o, int depth) +{ + LispObj lfbits, header, name = lisp_nil; + natural elements; + + header = header_of(o); + elements = header_element_count(header); + lfbits = deref(o, elements); + + if ((lfbits & lfbits_noname_mask) == 0) { + name = deref(o, elements-1); + } + + add_c_string("#<"); + if (name == lisp_nil) { + add_c_string("Anonymous Function "); + } else { + if (lfbits & lfbits_method_mask) { + LispObj + slot_vector = deref(name,3), + method_name = deref(slot_vector, 6), + method_qualifiers = deref(slot_vector, 2), + method_specializers = deref(slot_vector, 3); + add_c_string("Method-Function "); + sprint_lisp_object(method_name, depth); + add_char(' '); + if (method_qualifiers != lisp_nil) { + if (cdr(method_qualifiers) == lisp_nil) { + sprint_lisp_object(car(method_qualifiers), depth); + } else { + sprint_lisp_object(method_qualifiers, depth); + } + add_char(' '); + } + sprint_specializers_list(method_specializers, depth); + add_char(' '); + } else { + add_c_string("Function "); + sprint_lisp_object(name, depth); + add_char(' '); + } + } + sprint_unsigned_hex(o); + add_char('>'); +} + +void +sprint_gvector(LispObj o, int depth) +{ + LispObj header = header_of(o); + unsigned + elements = header_element_count(header), + subtag = header_subtag(header); + + switch(subtag) { + case subtag_function: + sprint_function(o, depth); + break; + + case subtag_symbol: + sprint_symbol(o); + break; + + case subtag_struct: + case subtag_istruct: + add_c_string("#<"); + sprint_lisp_object(deref(o,1), depth); + add_c_string(" @"); + sprint_unsigned_hex(o); + add_c_string(">"); + break; + + case subtag_simple_vector: + { + int i; + add_c_string("#("); + for(i = 1; i <= elements; i++) { + if (i > 1) { + add_char(' '); + } + sprint_lisp_object(deref(o, i), depth); + } + add_char(')'); + break; + } + + default: + sprint_random_vector(o, subtag, elements); + break; + } +} + +void +sprint_ivector(LispObj o) +{ + LispObj header = header_of(o); + unsigned + elements = header_element_count(header), + subtag = header_subtag(header); + + switch(subtag) { + case subtag_simple_base_string: + add_char('"'); + add_lisp_base_string(o); + add_char('"'); + return; + + case subtag_bignum: + if (elements == 1) { + sprint_signed_decimal((signed_natural)(deref(o, 1))); + return; + } + if ((elements == 2) && (deref(o, 2) == 0)) { + sprint_unsigned_decimal(deref(o, 1)); + return; + } + break; + + case subtag_double_float: + break; + + case subtag_macptr: + add_c_string("#"); + break; + + default: + sprint_random_vector(o, subtag, elements); + } +} + +void +sprint_vector(LispObj o, int depth) +{ + LispObj header = header_of(o); + + if (immheader_tag_p(fulltag_of(header))) { + sprint_ivector(o); + } else { + sprint_gvector(o, depth); + } +} + +void +sprint_lisp_object(LispObj o, int depth) +{ + if (--depth < 0) { + add_char('#'); + } else { + switch (fulltag_of(o)) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + sprint_signed_decimal(unbox_fixnum(o)); + break; + +#ifdef PPC64 + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: + case fulltag_immheader_3: + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: + case fulltag_nodeheader_2: + case fulltag_nodeheader_3: +#else + case fulltag_immheader: + case fulltag_nodeheader: +#endif + add_c_string("#

"); + break; + +#ifdef PPC64 + case fulltag_imm_0: + case fulltag_imm_1: + case fulltag_imm_2: + case fulltag_imm_3: +#else + case fulltag_imm: +#endif + if (o == unbound) { + add_c_string("#"); + } else { + if (header_subtag(o) == subtag_character) { + unsigned c = (o >> charcode_shift); + add_c_string("#\\"); + if ((c >= ' ') && (c < 0x7f)) { + add_char(c); + } else { + sprintf(numbuf, "%o", c); + add_c_string(numbuf); + } +#ifdef PPC64 + } else if (header_subtag(o) == subtag_single_float) { + sprintf(numbuf, "%f", o>>32); + add_c_string(numbuf); +#endif + } else { + + add_c_string("#"); + } + } + break; + +#ifndef PPC64 + case fulltag_nil: +#endif + case fulltag_cons: + sprint_list(o, depth); + break; + + case fulltag_misc: + sprint_vector(o, depth); + break; + } + } +} + +char * +print_lisp_object(LispObj o) +{ + bufpos = 0; + if (setjmp(escape) == 0) { + sprint_lisp_object(o, 5); + printbuf[bufpos] = 0; + } else { + printbuf[PBUFLEN+0] = '.'; + printbuf[PBUFLEN+1] = '.'; + printbuf[PBUFLEN+2] = '.'; + printbuf[PBUFLEN+3] = 0; + } + return printbuf; +} Index: /branches/qres/ccl/lisp-kernel/thread_manager.c =================================================================== --- /branches/qres/ccl/lisp-kernel/thread_manager.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/thread_manager.c (revision 13564) @@ -0,0 +1,2690 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + +#include "Threads.h" + + +typedef struct { + TCR *tcr; + natural vsize, tsize; + void *created; +} thread_activation; + +#ifdef HAVE_TLS +__thread char tcrbuf[sizeof(TCR)+16]; +__thread TCR *current_tcr; +#endif + +/* This is set to true when running a 32-bit Lisp on 64-bit FreeBSD */ +Boolean rcontext_readonly = false; + +extern natural +store_conditional(natural*, natural, natural); + +extern signed_natural +atomic_swap(signed_natural*, signed_natural); + +#ifdef USE_FUTEX +#define futex_wait(futex,val) syscall(SYS_futex,futex,FUTEX_WAIT,val) +#define futex_wake(futex,n) syscall(SYS_futex,futex,FUTEX_WAKE,n) +#define FUTEX_AVAIL (0) +#define FUTEX_LOCKED (1) +#define FUTEX_CONTENDED (2) +#endif + +#ifdef WINDOWS +extern pc spentry_start, spentry_end,subprims_start,subprims_end; +extern pc restore_windows_context_start, restore_windows_context_end, + restore_windows_context_iret; + + +extern void interrupt_handler(int, siginfo_t *, ExceptionInformation *); + +void CALLBACK +nullAPC(ULONG_PTR arg) +{ +} + +BOOL (*pCancelIoEx)(HANDLE, OVERLAPPED*) = NULL; +BOOL (*pCancelSynchronousIo)(HANDLE) = NULL; + + + +extern void *windows_find_symbol(void*, char*); + +int +raise_thread_interrupt(TCR *target) +{ + /* GCC doesn't align CONTEXT corrcectly */ + char _contextbuf[sizeof(CONTEXT)+__alignof(CONTEXT)]; + CONTEXT *pcontext; + HANDLE hthread = (HANDLE)(target->osid); + pc where; + area *cs = target->cs_area, *ts = target->cs_area; + DWORD rc; + BOOL io_pending; + + pcontext = (CONTEXT *)((((natural)&_contextbuf)+15)&~15); + rc = SuspendThread(hthread); + if (rc == -1) { + return -1; + } + /* What if the suspend count is > 1 at this point ? I don't think + that that matters, but I'm not sure */ + pcontext->ContextFlags = CONTEXT_ALL; + rc = GetThreadContext(hthread, pcontext); + if (rc == 0) { + return ESRCH; + } + + where = (pc)(xpPC(pcontext)); + + if ((target->valence != TCR_STATE_LISP) || + (TCR_INTERRUPT_LEVEL(target) < 0) || + (target->unwinding != 0) || + (!((where < (pc)lisp_global(HEAP_END)) && + (where >= (pc)lisp_global(HEAP_START))) && + !((where < spentry_end) && (where >= spentry_start)) && + !((where < subprims_end) && (where >= subprims_start)) && + !((where < (pc) 0x16000) && + (where >= (pc) 0x15000)) && + !((where < (pc) (ts->high)) && + (where >= (pc) (ts->low))))) { + + target->interrupt_pending = (1LL << (nbits_in_word - 1LL)); + +#if 0 + /* If the thread's in a blocking syscall, it'd be nice to + get it out of that state here. */ + GetThreadIOPendingFlag(hthread,&io_pending); + if (io_pending) { + pending_io * pending = (pending_io *) (target->pending_io_info); + if (pending) { + if (pCancelIoEx) { + pCancelIoEx(pending->h, pending->o); + } else { + CancelIo(pending->h); + } + } + } +#endif + if (pCancelSynchronousIo) { + pCancelSynchronousIo(hthread); + } + QueueUserAPC(nullAPC, hthread, 0); + ResumeThread(hthread); + return 0; + } else { + /* Thread is running lisp code with interupts enabled. Set it + so that it calls out and then returns to the context, + handling any necessary pc-lusering. */ + LispObj foreign_rsp = (((LispObj)(target->foreign_sp))-0x200)&~15; + CONTEXT *icontext = ((CONTEXT *) foreign_rsp) -1; + icontext = (CONTEXT *)(((LispObj)icontext)&~15); + + *icontext = *pcontext; + +#ifdef WIN_64 + xpGPR(pcontext,REG_RCX) = SIGNAL_FOR_PROCESS_INTERRUPT; + xpGPR(pcontext,REG_RDX) = 0; + xpGPR(pcontext,REG_R8) = (LispObj) icontext; + xpGPR(pcontext,REG_RSP) = (LispObj)(((LispObj *)icontext)-1); + *(((LispObj *)icontext)-1) = (LispObj)raise_thread_interrupt; +#else + { + LispObj *p = (LispObj *)icontext; + p -= 4; + p[0] = SIGNAL_FOR_PROCESS_INTERRUPT; + p[1] = 0; + p[2] = (DWORD)icontext; + *(--p) = (LispObj)raise_thread_interrupt;; + xpGPR(pcontext,Isp) = (DWORD)p; +#ifdef WIN32_ES_HACK + pcontext->SegEs = pcontext->SegDs; +#endif + } +#endif + pcontext->EFlags &= ~0x400; /* clear direction flag */ + xpPC(pcontext) = (LispObj)interrupt_handler; + SetThreadContext(hthread,pcontext); + ResumeThread(hthread); + return 0; + } +} +#else +int +raise_thread_interrupt(TCR *target) +{ + pthread_t thread = (pthread_t)target->osid; +#ifdef DARWIN_not_yet + if (use_mach_exception_handling) { + return mach_raise_thread_interrupt(target); + } +#endif + if (thread != (pthread_t) 0) { + return pthread_kill(thread, SIGNAL_FOR_PROCESS_INTERRUPT); + } + return ESRCH; +} +#endif + +signed_natural +atomic_incf_by(signed_natural *ptr, signed_natural by) +{ + signed_natural old, new; + do { + old = *ptr; + new = old+by; + } while (store_conditional((natural *)ptr, (natural) old, (natural) new) != + (natural) old); + return new; +} + +signed_natural +atomic_incf(signed_natural *ptr) +{ + return atomic_incf_by(ptr, 1); +} + +signed_natural +atomic_decf(signed_natural *ptr) +{ + signed_natural old, new; + do { + old = *ptr; + new = old == 0 ? old : old-1; + } while (store_conditional((natural *)ptr, (natural) old, (natural) new) != + (natural) old); + return old-1; +} + + +#ifndef USE_FUTEX +int spin_lock_tries = 1; + +void +get_spin_lock(signed_natural *p, TCR *tcr) +{ + int i, n = spin_lock_tries; + + while (1) { + for (i = 0; i < n; i++) { + if (atomic_swap(p,(signed_natural)tcr) == 0) { + return; + } + } +#ifndef WINDOWS + sched_yield(); +#endif + } +} +#endif + +#ifndef USE_FUTEX +int +lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + + if (tcr == NULL) { + tcr = get_tcr(true); + } + if (m->owner == tcr) { + m->count++; + return 0; + } + while (1) { + LOCK_SPINLOCK(m->spinlock,tcr); + ++m->avail; + if (m->avail == 1) { + m->owner = tcr; + m->count = 1; + RELEASE_SPINLOCK(m->spinlock); + break; + } + RELEASE_SPINLOCK(m->spinlock); + SEM_WAIT_FOREVER(m->signal); + } + return 0; +} + +#else /* USE_FUTEX */ + +static void inline +lock_futex(signed_natural *p) +{ + + while (1) { + if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) { + return; + } + while (1) { + if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) { + return; + } + futex_wait(p,FUTEX_CONTENDED); + } + } +} + +static void inline +unlock_futex(signed_natural *p) +{ + if (atomic_decf(p) != FUTEX_AVAIL) { + *p = FUTEX_AVAIL; + futex_wake(p,INT_MAX); + } +} + +int +lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + if (tcr == NULL) { + tcr = get_tcr(true); + } + if (m->owner == tcr) { + m->count++; + return 0; + } + lock_futex(&m->avail); + m->owner = tcr; + m->count = 1; + return 0; +} +#endif /* USE_FUTEX */ + + +#ifndef USE_FUTEX +int +unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + int ret = EPERM, pending; + + if (tcr == NULL) { + tcr = get_tcr(true); + } + + if (m->owner == tcr) { + --m->count; + if (m->count == 0) { + LOCK_SPINLOCK(m->spinlock,tcr); + m->owner = NULL; + pending = m->avail-1 + m->waiting; /* Don't count us */ + m->avail = 0; + --pending; + if (pending > 0) { + m->waiting = pending; + } else { + m->waiting = 0; + } + RELEASE_SPINLOCK(m->spinlock); + if (pending >= 0) { + SEM_RAISE(m->signal); + } + } + ret = 0; + } + return ret; +} +#else /* USE_FUTEX */ +int +unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + int ret = EPERM; + + if (tcr == NULL) { + tcr = get_tcr(true); + } + + if (m->owner == tcr) { + --m->count; + if (m->count == 0) { + m->owner = NULL; + unlock_futex(&m->avail); + } + ret = 0; + } + return ret; +} +#endif /* USE_FUTEX */ + +void +destroy_recursive_lock(RECURSIVE_LOCK m) +{ +#ifndef USE_FUTEX + destroy_semaphore((void **)&m->signal); +#endif + postGCfree((void *)(m->malloced_ptr)); +} + +/* + If we're already the owner (or if the lock is free), lock it + and increment the lock count; otherwise, return EBUSY without + waiting. +*/ + +#ifndef USE_FUTEX +int +recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free) +{ + TCR *owner = m->owner; + + LOCK_SPINLOCK(m->spinlock,tcr); + if (owner == tcr) { + m->count++; + if (was_free) { + *was_free = 0; + RELEASE_SPINLOCK(m->spinlock); + return 0; + } + } + if (store_conditional((natural*)&(m->avail), 0, 1) == 0) { + m->owner = tcr; + m->count = 1; + if (was_free) { + *was_free = 1; + } + RELEASE_SPINLOCK(m->spinlock); + return 0; + } + + RELEASE_SPINLOCK(m->spinlock); + return EBUSY; +} +#else +int +recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free) +{ + TCR *owner = m->owner; + + if (owner == tcr) { + m->count++; + if (was_free) { + *was_free = 0; + return 0; + } + } + if (store_conditional((natural*)&(m->avail), 0, 1) == 0) { + m->owner = tcr; + m->count = 1; + if (was_free) { + *was_free = 1; + } + return 0; + } + + return EBUSY; +} +#endif + +void +sem_wait_forever(SEMAPHORE s) +{ + int status; + + do { +#ifdef USE_MACH_SEMAPHORES + mach_timespec_t q = {1,0}; + status = SEM_TIMEDWAIT(s,q); +#endif +#ifdef USE_POSIX_SEMAPHORES + struct timespec q; + gettimeofday((struct timeval *)&q, NULL); + q.tv_sec += 1; + status = SEM_TIMEDWAIT(s,&q); +#endif +#ifdef USE_WINDOWS_SEMAPHORES + status = (WaitForSingleObject(s,1000L) == WAIT_TIMEOUT) ? 1 : 0; +#endif + } while (status != 0); +} + +int +wait_on_semaphore(void *s, int seconds, int millis) +{ +#ifdef USE_POSIX_SEMAPHORES + int nanos = (millis % 1000) * 1000000; + int status; + + struct timespec q; + gettimeofday((struct timeval *)&q, NULL); + q.tv_nsec *= 1000L; /* microseconds -> nanoseconds */ + + q.tv_nsec += nanos; + if (q.tv_nsec >= 1000000000L) { + q.tv_nsec -= 1000000000L; + seconds += 1; + } + q.tv_sec += seconds; + status = SEM_TIMEDWAIT(s, &q); + if (status < 0) { + return errno; + } + return status; +#endif +#ifdef USE_MACH_SEMAPHORES + int nanos = (millis % 1000) * 1000000; + mach_timespec_t q = {seconds, nanos}; + int status = SEM_TIMEDWAIT(s, q); + + + switch (status) { + case 0: return 0; + case KERN_OPERATION_TIMED_OUT: return ETIMEDOUT; + case KERN_ABORTED: return EINTR; + default: return EINVAL; + } +#endif +#ifdef USE_WINDOWS_SEMAPHORES + switch (WaitForSingleObjectEx(s, seconds*1000L+(DWORD)millis,true)) { + case WAIT_OBJECT_0: + return 0; + case WAIT_TIMEOUT: + return /* ETIMEDOUT */ WAIT_TIMEOUT; + case WAIT_IO_COMPLETION: + return EINTR; + default: + break; + } + return EINVAL; + +#endif +} + + +int +semaphore_maybe_timedwait(void *s, struct timespec *t) +{ + if (t) { + return wait_on_semaphore(s, t->tv_sec, t->tv_nsec/1000000L); + } + SEM_WAIT_FOREVER(s); + return 0; +} + +void +signal_semaphore(SEMAPHORE s) +{ + SEM_RAISE(s); +} + + +#ifdef WINDOWS +LispObj +current_thread_osid() +{ + TCR *tcr = get_tcr(false); + LispObj current = 0; + + if (tcr) { + current = tcr->osid; + } + if (current == 0) { + DuplicateHandle(GetCurrentProcess(), + GetCurrentThread(), + GetCurrentProcess(), + (LPHANDLE)(¤t), + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + if (tcr) { + tcr->osid = current; + } + } + return current; +} +#else +LispObj +current_thread_osid() +{ + return (LispObj)ptr_to_lispobj(pthread_self()); +} +#endif + + +int thread_suspend_signal = 0, thread_kill_signal = 0; + + + +void +linux_exception_init(TCR *tcr) +{ +} + + +TCR * +get_interrupt_tcr(Boolean create) +{ + return get_tcr(create); +} + +void +suspend_resume_handler(int signo, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + + if (tcr == NULL) { + /* Got a suspend signal sent to the pthread. */ + extern natural initial_stack_size; + void register_thread_tcr(TCR *); + + tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE); + tcr->suspend_count = 1; + tcr->vs_area->active -= node_size; + *(--tcr->save_vsp) = lisp_nil; + register_thread_tcr(tcr); + } + if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<suspend_context = context; + SEM_RAISE(tcr->suspend); + SEM_WAIT_FOREVER(tcr->resume); + tcr->suspend_context = NULL; + } +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + SIGRETURN(context); +} + + + +/* + 'base' should be set to the bottom (origin) of the stack, e.g., the + end from which it grows. +*/ + +#ifdef WINDOWS +void +os_get_current_thread_stack_bounds(void **base, natural *size) +{ + natural natbase; + MEMORY_BASIC_INFORMATION info; + void *addr = (void *)current_stack_pointer(); + + VirtualQuery(addr, &info, sizeof(info)); + natbase = (natural)info.BaseAddress+info.RegionSize; + *size = natbase - (natural)(info.AllocationBase); + *base = (void *)natbase; +} +#else +void +os_get_current_thread_stack_bounds(void **base, natural *size) +{ + pthread_t p = pthread_self(); +#ifdef DARWIN + *base = pthread_get_stackaddr_np(p); + *size = pthread_get_stacksize_np(p); +#endif +#ifdef LINUX + pthread_attr_t attr; + + pthread_getattr_np(p,&attr); + pthread_attr_getstack(&attr, base, size); + pthread_attr_destroy(&attr); + *(natural *)base += *size; +#endif +#ifdef FREEBSD + pthread_attr_t attr; + void * temp_base; + size_t temp_size; + + + pthread_attr_init(&attr); + pthread_attr_get_np(p, &attr); + pthread_attr_getstackaddr(&attr,&temp_base); + pthread_attr_getstacksize(&attr,&temp_size); + *base = (void *)((natural)temp_base + temp_size); + *size = temp_size; + pthread_attr_destroy(&attr); +#endif +#ifdef SOLARIS + stack_t st; + + thr_stksegment(&st); + *size = st.ss_size; + *base = st.ss_sp; + +#endif +} +#endif + +void * +new_semaphore(int count) +{ +#ifdef USE_POSIX_SEMAPHORES + sem_t *s = malloc(sizeof(sem_t)); + sem_init(s, 0, count); + return s; +#endif +#ifdef USE_MACH_SEMAPHORES + semaphore_t s = (semaphore_t)0; + semaphore_create(mach_task_self(),&s, SYNC_POLICY_FIFO, count); + return (void *)(natural)s; +#endif +#ifdef USE_WINDOWS_SEMAPHORES + return CreateSemaphore(NULL, count, 0x7fffL, NULL); +#endif +} + +RECURSIVE_LOCK +new_recursive_lock() +{ + extern int cache_block_size; + void *p = calloc(1,sizeof(_recursive_lock)+cache_block_size-1); + RECURSIVE_LOCK m = NULL; +#ifndef USE_FUTEX + void *signal = new_semaphore(0); +#endif + if (p) { + m = (RECURSIVE_LOCK) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1))); + m->malloced_ptr = p; + } + +#ifdef USE_FUTEX + if (m) { + return m; + } +#else + if (m && signal) { + m->signal = signal; + return m; + } + if (m) { + free(p); + } + if (signal) { + destroy_semaphore(&signal); + } +#endif + return NULL; +} + +void +destroy_semaphore(void **s) +{ + if (*s) { +#ifdef USE_POSIX_SEMAPHORES + sem_destroy((sem_t *)*s); + if (lisp_global(IN_GC)) { + postGCfree(*s); + } else { + free(*s); + } +#endif +#ifdef USE_MACH_SEMAPHORES + semaphore_destroy(mach_task_self(),((semaphore_t)(natural) *s)); +#endif +#ifdef USE_WINDOWS_SEMAPHORES + CloseHandle(*s); +#endif + *s=NULL; + } +} + +#ifdef WINDOWS +void +tsd_set(LispObj key, void *datum) +{ + TlsSetValue((DWORD)key, datum); +} + +void * +tsd_get(LispObj key) +{ + return TlsGetValue((DWORD)key); +} +#else +void +tsd_set(LispObj key, void *datum) +{ + pthread_setspecific((pthread_key_t)key, datum); +} + +void * +tsd_get(LispObj key) +{ + return pthread_getspecific((pthread_key_t)key); +} +#endif + +void +dequeue_tcr(TCR *tcr) +{ + TCR *next, *prev; + + next = tcr->next; + prev = tcr->prev; + + prev->next = next; + next->prev = prev; + tcr->prev = tcr->next = NULL; +#ifdef X8664 + tcr->linear = NULL; +#endif +} + +void +enqueue_tcr(TCR *new) +{ + TCR *head, *tail; + + LOCK(lisp_global(TCR_AREA_LOCK),new); + head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)); + tail = head->prev; + tail->next = new; + head->prev = new; + new->prev = tail; + new->next = head; + UNLOCK(lisp_global(TCR_AREA_LOCK),new); +} + +#ifdef WIN_32 +TCR * +allocate_tcr() +{ + void *p = calloc(1,sizeof(TCR)+15); + TCR *tcr = (TCR *)((((natural)p)+15)&~15); + + tcr->allocated = p; + return tcr; +} +#else +TCR * +allocate_tcr() +{ + TCR *tcr, *chain = NULL, *next; +#ifdef DARWIN + extern Boolean use_mach_exception_handling; + kern_return_t kret; + mach_port_t + thread_exception_port, + task_self = mach_task_self(); +#endif + for (;;) { + tcr = calloc(1, sizeof(TCR)); +#ifdef DARWIN +#if WORD_SIZE == 64 + if (((unsigned)((natural)tcr)) != ((natural)tcr)) { + tcr->next = chain; + chain = tcr; + continue; + } +#endif + if (use_mach_exception_handling) { + thread_exception_port = (mach_port_t)((natural)tcr); + kret = mach_port_allocate_name(task_self, + MACH_PORT_RIGHT_RECEIVE, + thread_exception_port); + } else { + kret = KERN_SUCCESS; + } + + if (kret != KERN_SUCCESS) { + tcr->next = chain; + chain = tcr; + continue; + } +#endif + for (;chain;chain = next) { + next = chain->next; + free(chain); + } + return tcr; + } +} +#endif + +#ifdef X8664 +#ifdef LINUX +#include +#include +#endif +#ifdef FREEBSD +#include +#endif + +void +setup_tcr_extra_segment(TCR *tcr) +{ +#ifdef FREEBSD + amd64_set_gsbase(tcr); +#endif +#ifdef LINUX + arch_prctl(ARCH_SET_GS, (natural)tcr); +#endif +#ifdef DARWIN + /* There's no way to do this yet. See DARWIN_GS_HACK */ + /* darwin_set_x8664_fs_reg(tcr); */ +#endif +#ifdef SOLARIS + /* Chris Curtis found this and suggested the use of syscall here */ + syscall(SYS_lwp_private,_LWP_SETPRIVATE, _LWP_GSBASE, tcr); +#endif +} + +#endif + +#ifdef X8632 + +#ifdef DARWIN +#include +#include +#include + +void setup_tcr_extra_segment(TCR *tcr) +{ + uintptr_t addr = (uintptr_t)tcr; + unsigned int size = sizeof(*tcr); + ldt_entry_t desc; + sel_t sel; + int i; + + desc.data.limit00 = (size - 1) & 0xffff; + desc.data.limit16 = ((size - 1) >> 16) & 0xf; + desc.data.base00 = addr & 0xffff; + desc.data.base16 = (addr >> 16) & 0xff; + desc.data.base24 = (addr >> 24) & 0xff; + desc.data.type = DESC_DATA_WRITE; + desc.data.dpl = USER_PRIV; + desc.data.present = 1; + desc.data.stksz = DESC_CODE_32B; + desc.data.granular = DESC_GRAN_BYTE; + + i = i386_set_ldt(LDT_AUTO_ALLOC, &desc, 1); + + if (i < 0) { + perror("i386_set_ldt"); + } else { + sel.index = i; + sel.rpl = USER_PRIV; + sel.ti = SEL_LDT; + tcr->ldt_selector = sel; + } +} + +void free_tcr_extra_segment(TCR *tcr) +{ + /* load %fs with null segement selector */ + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + if (i386_set_ldt(tcr->ldt_selector.index, NULL, 1) < 0) + perror("i386_set_ldt"); + tcr->ldt_selector = NULL_SEL; +} +#endif + +#ifdef LINUX + +#include +#include + +/* see desc_struct in kernel/include/asm-i386/processor.h */ +typedef struct { + uint32_t a; + uint32_t b; +} linux_desc_struct; + + +#define desc_avail(d) (((d)->a) == 0) + +linux_desc_struct linux_ldt_entries[LDT_ENTRIES]; + +/* We have to ask the Linux kernel for a copy of the ldt table + and manage it ourselves. It's not clear that this is + thread-safe in general, but we can at least ensure that + it's thread-safe wrt lisp threads. */ + +pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER; /* simple, non-recursive mutex */ + +int +modify_ldt(int func, void *ptr, unsigned long bytecount) +{ + return syscall(__NR_modify_ldt, func, ptr, bytecount); +} + + +void +setup_tcr_extra_segment(TCR *tcr) +{ + int i, n; + short sel; + struct user_desc u = {1, 0, 0, 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1}; + linux_desc_struct *d = linux_ldt_entries; + + pthread_mutex_lock(&ldt_lock); + n = modify_ldt(0,d,LDT_ENTRIES*LDT_ENTRY_SIZE)/LDT_ENTRY_SIZE; + for (i = 0; i < n; i++,d++) { + if (desc_avail(d)) { + break; + } + } + if (i == LDT_ENTRIES) { + pthread_mutex_unlock(&ldt_lock); + fprintf(dbgout, "All 8192 ldt entries in use ?\n"); + _exit(1); + } + u.entry_number = i; + u.base_addr = (uint32_t)tcr; + u.limit = sizeof(TCR); + u.limit_in_pages = 0; + if (modify_ldt(1,&u,sizeof(struct user_desc)) != 0) { + pthread_mutex_unlock(&ldt_lock); + fprintf(dbgout,"Can't assign LDT entry\n"); + _exit(1); + } + sel = (i << 3) | 7; + tcr->ldt_selector = sel; + pthread_mutex_unlock(&ldt_lock); +} + +void +free_tcr_extra_segment(TCR *tcr) +{ + struct user_desc u = {0, 0, 0, 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0}; + short sel = tcr->ldt_selector; + + pthread_mutex_lock(&ldt_lock); + /* load %fs with null segment selector */ + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + tcr->ldt_selector = 0; + u.entry_number = (sel>>3); + modify_ldt(1,&u,sizeof(struct user_desc)); + pthread_mutex_unlock(&ldt_lock); + +} + +#endif + +#ifdef WINDOWS +bitvector ldt_entries_in_use = NULL; +HANDLE ldt_lock; + +typedef struct { + DWORD offset; + DWORD size; + LDT_ENTRY entry; +} win32_ldt_info; + + +int WINAPI (*NtQueryInformationProcess)(HANDLE,DWORD,VOID*,DWORD,DWORD*); +int WINAPI (*NtSetInformationProcess)(HANDLE,DWORD,VOID*,DWORD); + +void +init_win32_ldt() +{ + HANDLE hNtdll; + int status = 0xc0000002; + win32_ldt_info info; + DWORD nret; + + + ldt_entries_in_use=malloc(8192/8); + zero_bits(ldt_entries_in_use,8192); + ldt_lock = CreateMutex(NULL,0,NULL); + + hNtdll = LoadLibrary("ntdll.dll"); + NtQueryInformationProcess = (void*)GetProcAddress(hNtdll, "NtQueryInformationProcess"); + NtSetInformationProcess = (void*)GetProcAddress(hNtdll, "NtSetInformationProcess"); + if (NtQueryInformationProcess != NULL) { + info.offset = 0; + info.size = sizeof(LDT_ENTRY); + status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret); + } + + if (status) { + fprintf(dbgout, "This application can't run under this OS version\n"); + _exit(1); + } +} + +void +setup_tcr_extra_segment(TCR *tcr) +{ + int i, status; + DWORD nret; + win32_ldt_info info; + LDT_ENTRY *entry = &(info.entry); + DWORD *words = (DWORD *)entry, tcraddr = (DWORD)tcr; + + + WaitForSingleObject(ldt_lock,INFINITE); + + for (i = 0; i < 8192; i++) { + if (!ref_bit(ldt_entries_in_use,i)) { + info.offset = i << 3; + info.size = sizeof(LDT_ENTRY); + words[0] = 0; + words[1] = 0; + status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret); + if (status == 0) { + if ((info.size == 0) || + ((words[0] == 0) && (words[1] == 0))) { + break; + } + } + } + } + if (i == 8192) { + ReleaseMutex(ldt_lock); + fprintf(dbgout, "All 8192 ldt entries in use ?\n"); + _exit(1); + } + set_bit(ldt_entries_in_use,i); + words[0] = 0; + words[1] = 0; + entry->LimitLow = sizeof(TCR); + entry->BaseLow = tcraddr & 0xffff; + entry->HighWord.Bits.BaseMid = (tcraddr >> 16) & 0xff; + entry->HighWord.Bits.BaseHi = (tcraddr >> 24); + entry->HighWord.Bits.Pres = 1; + entry->HighWord.Bits.Default_Big = 1; + entry->HighWord.Bits.Type = 16 | 2; /* read-write data */ + entry->HighWord.Bits.Dpl = 3; /* for use by the great unwashed */ + info.size = sizeof(LDT_ENTRY); + status = NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info)); + if (status != 0) { + ReleaseMutex(ldt_lock); + FBug(NULL, "can't set LDT entry %d, status = 0x%x", i, status); + } +#if 1 + /* Sanity check */ + info.offset = i << 3; + info.size = sizeof(LDT_ENTRY); + words[0] = 0; + words[0] = 0; + NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret); + if (((entry->BaseLow)|((entry->HighWord.Bits.BaseMid)<<16)|((entry->HighWord.Bits.BaseHi)<<24)) != tcraddr) { + Bug(NULL, "you blew it: bad address in ldt entry\n"); + } +#endif + tcr->ldt_selector = (i << 3) | 7; + ReleaseMutex(ldt_lock); +} + +void +free_tcr_extra_segment(TCR *tcr) +{ + win32_ldt_info info; + LDT_ENTRY *entry = &(info.entry); + DWORD *words = (DWORD *)entry; + int idx = tcr->ldt_selector >> 3; + + + info.offset = idx << 3; + info.size = sizeof(LDT_ENTRY); + + words[0] = 0; + words[1] = 0; + + WaitForSingleObject(ldt_lock,INFINITE); + NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info)); + clr_bit(ldt_entries_in_use,idx); + ReleaseMutex(ldt_lock); + + tcr->ldt_selector = 0; +} + +#endif +#ifdef FREEBSD +#include +#include + +/* It'd be tempting to use i386_set_fsbase() here, but there doesn't + seem to be any way to free the GDT entry it creates. Actually, + it's not clear that that really sets a GDT entry; let's see */ + +#define FREEBSD_USE_SET_FSBASE 1 +void +setup_tcr_extra_segment(TCR *tcr) +{ +#if !FREEBSD_USE_SET_FSBASE + struct segment_descriptor sd; + uintptr_t addr = (uintptr_t)tcr; + unsigned int size = sizeof(*tcr); + int i; + + sd.sd_lolimit = (size - 1) & 0xffff; + sd.sd_hilimit = ((size - 1) >> 16) & 0xf; + sd.sd_lobase = addr & ((1<<24)-1); + sd.sd_hibase = (addr>>24)&0xff; + + + + sd.sd_type = 18; + sd.sd_dpl = SEL_UPL; + sd.sd_p = 1; + sd.sd_def32 = 1; + sd.sd_gran = 0; + + i = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor *)&sd, 1); + + if (i < 0) { + perror("i386_set_ldt"); + exit(1); + } else { + tcr->ldt_selector = LSEL(i,SEL_UPL); + } +#else + extern unsigned short get_fs_register(void); + + if (i386_set_fsbase((void*)tcr)) { + perror("i386_set_fsbase"); + exit(1); + } + + + /* Once we've called i386_set_fsbase, we can't write to %fs. */ + tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL); +#endif +} + +void +free_tcr_extra_segment(TCR *tcr) +{ +#if FREEBSD_USE_SET_FSBASE + /* On a 32-bit kernel, this allocates a GDT entry. It's not clear + what it would mean to deallocate that entry. */ + /* If we're running on a 64-bit kernel, we can't write to %fs */ +#else + int idx = tcr->ldt_selector >> 3; + /* load %fs with null segment selector */ + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + if (i386_set_ldt(idx, NULL, 1) < 0) + perror("i386_set_ldt"); +#endif + tcr->ldt_selector = 0; +} +#endif + +#ifdef SOLARIS +#include + +bitvector ldt_entries_in_use = NULL; +pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER; /* simple, non-recursive mutex */ + +void +solaris_ldt_init() +{ + int fd; + struct ssd s; + + ldt_entries_in_use=malloc(8192/8); + zero_bits(ldt_entries_in_use,8192); + + fd = open("/proc/self/ldt", O_RDONLY); + + while(read(fd,&s,sizeof(s)) == sizeof(s)) { + set_bit(ldt_entries_in_use,s.sel>>3); + } + close(fd); +} + + +void +setup_tcr_extra_segment(TCR *tcr) +{ + struct ssd s; + int i; + + pthread_mutex_lock(&ldt_lock); + + for (i = 0; i < 8192; i++) { + if (!ref_bit(ldt_entries_in_use,i)) { + s.sel = (i<<3)|7; + s.bo = (unsigned int)tcr; + s.ls = sizeof(TCR); + s.acc1 = 0xf2; + s.acc2 = 4; + + if (sysi86(SI86DSCR, &s) >= 0) { + set_bit(ldt_entries_in_use,i); + tcr->ldt_selector = (i<<3)|7; + pthread_mutex_unlock(&ldt_lock); + return; + } + set_bit(ldt_entries_in_use,i); + } + } + pthread_mutex_unlock(&ldt_lock); + fprintf(dbgout, "All 8192 LDT descriptors in use\n"); + _exit(1); + + + +} + +void +free_tcr_extra_segment(TCR *tcr) +{ + struct ssd s; + int i; + + pthread_mutex_lock(&ldt_lock); + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + s.sel = tcr->ldt_selector; + i = s.sel>>3; + tcr->ldt_selector = 0; + s.bo = 0; + s.ls = 0; + s.acc1 = 0; + s.acc2 = 0; + sysi86(SI86DSCR, &s); + clr_bit(ldt_entries_in_use,i); + pthread_mutex_unlock(&ldt_lock); +} + +#endif +#endif + +/* + Caller must hold the area_lock. +*/ +TCR * +new_tcr(natural vstack_size, natural tstack_size) +{ + extern area + *allocate_vstack_holding_area_lock(natural), + *allocate_tstack_holding_area_lock(natural); + area *a; + int i; +#ifndef WINDOWS + sigset_t sigmask; + + sigemptyset(&sigmask); + pthread_sigmask(SIG_SETMASK,&sigmask, NULL); +#endif + +#ifdef HAVE_TLS + TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15)); + current_tcr = tcr; +#else /* no TLS */ + TCR *tcr = allocate_tcr(); +#endif + +#ifdef X86 + setup_tcr_extra_segment(tcr); + tcr->linear = tcr; +#ifdef X8632 + tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK; +#endif +#endif + +#if (WORD_SIZE == 64) + tcr->single_float_convert.tag = subtag_single_float; +#endif + lisp_global(TCR_COUNT) += (1<suspend = new_semaphore(0); + tcr->resume = new_semaphore(0); + tcr->reset_completion = new_semaphore(0); + tcr->activate = new_semaphore(0); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + a = allocate_vstack_holding_area_lock(vstack_size); + tcr->vs_area = a; + a->owner = tcr; + tcr->save_vsp = (LispObj *) a->active; + a = allocate_tstack_holding_area_lock(tstack_size); + UNLOCK(lisp_global(TCR_AREA_LOCK),tcr); + tcr->ts_area = a; + a->owner = tcr; + tcr->save_tsp = (LispObj *) a->active; +#ifdef X86 + tcr->next_tsp = tcr->save_tsp; +#endif + + tcr->valence = TCR_STATE_FOREIGN; +#ifdef PPC + tcr->lisp_fpscr.words.l = 0xd0; +#endif +#ifdef X86 + tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | +#if 1 /* Mask underflow; too hard to + deal with denorms if underflow is + enabled */ + (1 << MXCSR_UM_BIT) | +#endif + (1 << MXCSR_PM_BIT); +#endif + tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR; + tcr->tlb_limit = 2048<tlb_pointer = (LispObj *)malloc(tcr->tlb_limit); + for (i = 0; i < 2048; i++) { + tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker; + } + TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS; +#else + tcr->shutdown_count = 1; +#endif + return tcr; +} + +void +shutdown_thread_tcr(void *arg) +{ + TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0); + + area *vs, *ts, *cs; + + if (current == NULL) { + current = tcr; + } + + if (--(tcr->shutdown_count) == 0) { + if (tcr->flags & (1<address; + + tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr)); + ((void (*)())ptr_from_lispobj(callback_ptr))(1); + tsd_set(lisp_global(TCR_KEY), NULL); + } +#ifdef DARWIN + darwin_exception_cleanup(tcr); +#endif + LOCK(lisp_global(TCR_AREA_LOCK),current); + vs = tcr->vs_area; + tcr->vs_area = NULL; + ts = tcr->ts_area; + tcr->ts_area = NULL; + cs = tcr->cs_area; + tcr->cs_area = NULL; + if (vs) { + condemn_area_holding_area_lock(vs); + } + if (ts) { + condemn_area_holding_area_lock(ts); + } + if (cs) { + condemn_area_holding_area_lock(cs); + } + destroy_semaphore(&tcr->suspend); + destroy_semaphore(&tcr->resume); + destroy_semaphore(&tcr->reset_completion); + destroy_semaphore(&tcr->activate); + tcr->tlb_limit = 0; + free(tcr->tlb_pointer); + tcr->tlb_pointer = NULL; +#ifdef WINDOWS + if (tcr->osid != 0) { + CloseHandle((HANDLE)(tcr->osid)); + } +#endif + tcr->osid = 0; + tcr->interrupt_pending = 0; + tcr->termination_semaphore = NULL; +#ifdef HAVE_TLS + dequeue_tcr(tcr); +#endif +#ifdef X8632 + free_tcr_extra_segment(tcr); +#endif +#ifdef WIN32 + CloseHandle((HANDLE)tcr->io_datum); + tcr->io_datum = NULL; + free(tcr->native_thread_info); + tcr->native_thread_info = NULL; +#endif + UNLOCK(lisp_global(TCR_AREA_LOCK),current); + } else { + tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr)); + } +} + +void +tcr_cleanup(void *arg) +{ + TCR *tcr = (TCR *)arg; + area *a; + + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + a = tcr->cs_area; + if (a) { + a->active = a->high; + } + tcr->valence = TCR_STATE_FOREIGN; + tcr->shutdown_count = 1; + shutdown_thread_tcr(tcr); + tsd_set(lisp_global(TCR_KEY), NULL); +} + +void * +current_native_thread_id() +{ + return ((void *) (natural) +#ifdef LINUX +#ifdef __NR_gettid + syscall(__NR_gettid) +#else + getpid() +#endif +#endif +#ifdef DARWIN + mach_thread_self() +#endif +#ifdef FREEBSD + pthread_self() +#endif +#ifdef SOLARIS + pthread_self() +#endif +#ifdef WINDOWS + GetCurrentThreadId() +#endif + ); +} + + +void +thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size) +{ + area *a, *register_cstack_holding_area_lock(BytePtr, natural); + + tcr->osid = current_thread_osid(); + tcr->native_thread_id = current_native_thread_id(); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size); + UNLOCK(lisp_global(TCR_AREA_LOCK),tcr); + tcr->cs_area = a; + a->owner = tcr; + if (!(tcr->flags & (1<cs_limit = (LispObj)ptr_to_lispobj(a->softlimit); + } +#ifdef LINUX +#ifdef PPC +#ifndef PPC64 + tcr->native_thread_info = current_r2; +#endif +#endif +#endif + tcr->errno_loc = &errno; + tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr)); +#ifdef DARWIN + extern Boolean use_mach_exception_handling; + if (use_mach_exception_handling) { + darwin_exception_init(tcr); + } +#endif +#ifdef LINUX + linux_exception_init(tcr); +#endif +#ifdef WINDOWS + tcr->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL); + tcr->native_thread_info = malloc(sizeof(CONTEXT)); +#endif + tcr->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM)); +} + +/* + Register the specified tcr as "belonging to" the current thread. + Under Darwin, setup Mach exception handling for the thread. + Install cleanup handlers for thread termination. +*/ +void +register_thread_tcr(TCR *tcr) +{ + void *stack_base = NULL; + natural stack_size = 0; + + os_get_current_thread_stack_bounds(&stack_base, &stack_size); + thread_init_tcr(tcr, stack_base, stack_size); + enqueue_tcr(tcr); +} + + + + +#ifndef MAP_GROWSDOWN +#define MAP_GROWSDOWN 0 +#endif + +Ptr +create_stack(natural size) +{ + Ptr p; + size=align_to_power_of_2(size, log2_page_size); + p = (Ptr) MapMemoryForStack((size_t)size); + if (p != (Ptr)(-1)) { + *((size_t *)p) = size; + return p; + } + allocation_failure(true, size); + +} + +void * +allocate_stack(natural size) +{ + return create_stack(size); +} + +void +free_stack(void *s) +{ + size_t size = *((size_t *)s); + UnMapMemory(s, size); +} + +Boolean threads_initialized = false; + +#ifndef USE_FUTEX +#ifdef WINDOWS +void +count_cpus() +{ + SYSTEM_INFO si; + + GetSystemInfo(&si); + if (si.dwNumberOfProcessors > 1) { + spin_lock_tries = 1024; + } +} +#else +void +count_cpus() +{ + int n = sysconf(_SC_NPROCESSORS_ONLN); + + if (n > 1) { + spin_lock_tries = 1024; + } +} +#endif +#endif + +void +init_threads(void * stack_base, TCR *tcr) +{ + lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr); +#ifdef WINDOWS + lisp_global(TCR_KEY) = TlsAlloc(); + pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx"); + pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo"); +#else + pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr); + thread_signal_setup(); +#endif + +#ifndef USE_FUTEX + count_cpus(); +#endif + threads_initialized = true; +} + + +#ifdef WINDOWS +unsigned CALLBACK +#else +void * +#endif +lisp_thread_entry(void *param) +{ + thread_activation *activation = (thread_activation *)param; + TCR *tcr = new_tcr(activation->vsize, activation->tsize); + LispObj *start_vsp; +#ifndef WINDOWS + sigset_t mask, old_mask; + + sigemptyset(&mask); + pthread_sigmask(SIG_SETMASK, &mask, &old_mask); +#endif + + register_thread_tcr(tcr); + +#ifndef WINDOWS + pthread_cleanup_push(tcr_cleanup,(void *)tcr); +#endif + tcr->vs_area->active -= node_size; + *(--tcr->save_vsp) = lisp_nil; + start_vsp = tcr->save_vsp; + enable_fp_exceptions(); + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET); + activation->tcr = tcr; + SEM_RAISE(activation->created); + do { + SEM_RAISE(tcr->reset_completion); + SEM_WAIT_FOREVER(tcr->activate); + /* Now go run some lisp code */ + start_lisp(TCR_TO_TSD(tcr),0); + tcr->save_vsp = start_vsp; + } while (tcr->flags & (1<save_vsp; + do { + SEM_RAISE(tcr->reset_completion); + suspend_current_cooperative_thread(); + + start_lisp(tcr, 0); + tcr->save_vsp = start_vsp; + } while (tcr->flags & (1<next; + } while (p != head); + return false; +} + +#ifdef WINDOWS +OSErr +xDisposeThread(TCR *tcr) +{ + return 0; /* I don't think that this is ever called. */ +} +#else +OSErr +xDisposeThread(TCR *tcr) +{ + if (tcr != (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR))) { + if (active_tcr_p(tcr) && (tcr != get_tcr(false))) { + pthread_cancel((pthread_t)(tcr->osid)); + return 0; + } + } + return -50; +} +#endif + +OSErr +xYieldToThread(TCR *target) +{ + Bug(NULL, "xYieldToThread ?"); + return 0; +} + +OSErr +xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP) +{ + Bug(NULL, "xThreadCurrentStackSpace ?"); + return 0; +} + + +#ifdef WINDOWS +Boolean +create_system_thread(size_t stack_size, + void* stackaddr, + unsigned CALLBACK (*start_routine)(void *), + void* param) +{ + HANDLE thread_handle; + Boolean won = false; + + stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1)); + + thread_handle = (HANDLE)_beginthreadex(NULL, + stack_size, + start_routine, + param, + 0, + NULL); + + if (thread_handle == NULL) { + wperror("CreateThread"); + } else { + won = true; + CloseHandle(thread_handle); + } + return won; +} +#else +Boolean +create_system_thread(size_t stack_size, void *stackaddr, + void *(*start_routine)(void *), void *param) +{ + pthread_attr_t attr; + pthread_t returned_thread; + int err; + TCR *current = get_tcr(true); + + pthread_attr_init(&attr); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + + if (stack_size == MINIMAL_THREAD_STACK_SIZE) { + stack_size = PTHREAD_STACK_MIN; + } + + stack_size = ensure_stack_limit(stack_size); + if (stackaddr != NULL) { + /* Size must have been specified. Sort of makes sense ... */ + pthread_attr_setstack(&attr, stackaddr, stack_size); + } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) { + pthread_attr_setstacksize(&attr,stack_size); + } + + /* + I think that's just about enough ... create the thread. + Well ... not quite enough. In Leopard (at least), many + pthread routines grab an internal spinlock when validating + their arguments. If we suspend a thread that owns this + spinlock, we deadlock. We can't in general keep that + from happening: if arbitrary C code is suspended while + it owns the spinlock, we still deadlock. It seems that + the best that we can do is to keep -this- code from + getting suspended (by grabbing TCR_AREA_LOCK) + */ + LOCK(lisp_global(TCR_AREA_LOCK),current); + err = pthread_create(&returned_thread, &attr, start_routine, param); + UNLOCK(lisp_global(TCR_AREA_LOCK),current); + pthread_attr_destroy(&attr); + return (err == 0); +} +#endif + +TCR * +get_tcr(Boolean create) +{ +#ifdef HAVE_TLS + TCR *current = current_tcr; +#else + void *tsd = (void *)tsd_get(lisp_global(TCR_KEY)); + TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd); +#endif + + if ((current == NULL) && create) { + LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell, + callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address; + int i, nbindwords = 0; + extern natural initial_stack_size; + + /* Make one. */ + current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE); + SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN); + register_thread_tcr(current); +#ifdef DEBUG_TCR_CREATION +#ifndef WINDOWS + fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self()); +#endif +#endif + current->vs_area->active -= node_size; + *(--current->save_vsp) = lisp_nil; +#ifdef PPC +#define NSAVEREGS 8 +#endif +#ifdef X8664 +#define NSAVEREGS 4 +#endif +#ifdef X8632 +#define NSAVEREGS 0 +#endif + for (i = 0; i < NSAVEREGS; i++) { + *(--current->save_vsp) = 0; + current->vs_area->active -= node_size; + } + nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1); + for (i = 0; i < nbindwords; i++) { + *(--current->save_vsp) = 0; + current->vs_area->active -= node_size; + } + current->shutdown_count = 1; + ((void (*)())ptr_from_lispobj(callback_ptr))(0); + + } + + return current; +} + +#ifdef WINDOWS +void * +pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where) +{ + /* Thread has started to return from an exception. */ + if (where < restore_windows_context_iret) { + /* In the process of restoring registers; context still in + %rcx. Just make our suspend_context be the context + we're trying to restore, so that we'll resume from + the suspend in the same context that we're trying to + restore */ +#ifdef WIN_64 + *pcontext = * (CONTEXT *)(pcontext->Rcx); +#else + *pcontext = * (CONTEXT *)(pcontext->Ecx); +#endif + } else { + /* Most of the context has already been restored; fix %rcx + if need be, then restore ss:rsp, cs:rip, and flags. */ +#ifdef WIN_64 + x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp); + + pcontext->Rip = iret_frame->Rip; + pcontext->SegCs = (WORD) iret_frame->Cs; + pcontext->EFlags = (DWORD) iret_frame->Rflags; + pcontext->Rsp = iret_frame->Rsp; + pcontext->SegSs = (WORD) iret_frame->Ss; +#else + ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp); + + pcontext->Eip = iret_frame->Eip; + pcontext->SegCs = (WORD) iret_frame->Cs; + pcontext->EFlags = (DWORD) iret_frame->EFlags; + pcontext->Esp += sizeof(ia32_iret_frame); +#endif + } + tcr->pending_exception_context = NULL; +} + +Boolean +suspend_tcr(TCR *tcr) +{ + int suspend_count = atomic_incf(&(tcr->suspend_count)); + DWORD rc; + if (suspend_count == 1) { + CONTEXT *pcontext = (CONTEXT *)tcr->native_thread_info; + HANDLE hthread = (HANDLE)(tcr->osid); + pc where; + area *cs = tcr->cs_area; + LispObj foreign_rsp; + + if (hthread == NULL) { + return false; + } + rc = SuspendThread(hthread); + if (rc == -1) { + /* If the thread's simply dead, we should handle that here */ + return false; + } + pcontext->ContextFlags = CONTEXT_ALL; + rc = GetThreadContext(hthread, pcontext); + if (rc == 0) { + return false; + } + where = (pc)(xpPC(pcontext)); + + if (tcr->valence == TCR_STATE_LISP) { + if ((where >= restore_windows_context_start) && + (where < restore_windows_context_end)) { + pc_luser_restore_windows_context(pcontext, tcr, where); + } else { + area *ts = tcr->ts_area; + /* If we're in the lisp heap, or in x86-spentry??.o, or in + x86-subprims??.o, or in the subprims jump table at #x15000, + or on the tstack ... we're just executing lisp code. Otherwise, + we got an exception while executing lisp code, but haven't + entered the handler yet (still in Windows exception glue + or switching stacks or something.) In the latter case, we + basically want to get to he handler and have it notice + the pending exception request, and suspend the thread at that + point. */ + if (!((where < (pc)lisp_global(HEAP_END)) && + (where >= (pc)lisp_global(HEAP_START))) && + !((where < spentry_end) && (where >= spentry_start)) && + !((where < subprims_end) && (where >= subprims_start)) && + !((where < (pc) 0x16000) && + (where >= (pc) 0x15000)) && + !((where < (pc) (ts->high)) && + (where >= (pc) (ts->low)))) { + /* The thread has lisp valence, but is not executing code + where we expect lisp code to be and is not exiting from + an exception handler. That pretty much means that it's + on its way into an exception handler; we have to handshake + until it enters an exception-wait state. */ + /* There are likely race conditions here */ + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND); + ResumeThread(hthread); + SEM_WAIT_FOREVER(tcr->suspend); + SuspendThread(hthread); + /* The thread is either waiting for its resume semaphore to + be signaled or is about to wait. Signal it now, while + the thread's suspended. */ + SEM_RAISE(tcr->resume); + pcontext->ContextFlags = CONTEXT_ALL; + GetThreadContext(hthread, pcontext); + } + } +#if 0 + } else { + if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) { + if (!tcr->pending_exception_context) { + FBug(pcontext, "we're confused here."); + } + *pcontext = *tcr->pending_exception_context; + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_LISP; + } +#endif + } + tcr->suspend_context = pcontext; + return true; + } + return false; +} +#else +Boolean +suspend_tcr(TCR *tcr) +{ + int suspend_count = atomic_incf(&(tcr->suspend_count)); + pthread_t thread; + if (suspend_count == 1) { + thread = (pthread_t)(tcr->osid); + if ((thread != (pthread_t) 0) && + (pthread_kill(thread, thread_suspend_signal) == 0)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING); + } else { + /* A problem using pthread_kill. On Darwin, this can happen + if the thread has had its signal mask surgically removed + by pthread_exit. If the native (Mach) thread can be suspended, + do that and return true; otherwise, flag the tcr as belonging + to a dead thread by setting tcr->osid to 0. + */ + tcr->osid = 0; + return false; + } + return true; + } + return false; +} +#endif + +#ifdef WINDOWS +Boolean +tcr_suspend_ack(TCR *tcr) +{ + return true; +} +#else +Boolean +tcr_suspend_ack(TCR *tcr) +{ + if (tcr->flags & (1<suspend); + tcr->flags &= ~(1<osid; + + if (osid) { + result = true; +#ifdef WINDOWS + /* What we really want to do here is (something like) + forcing the thread to run quit_handler(). For now, + mark the TCR as dead and kill the Windows thread. */ + tcr->osid = 0; + if (!TerminateThread((HANDLE)osid, 0)) { + CloseHandle((HANDLE)osid); + result = false; + } else { + CloseHandle((HANDLE)osid); + shutdown_thread_tcr(tcr); + } +#else + if (pthread_kill((pthread_t)osid,thread_kill_signal)) { + result = false; + } +#endif + } + } + UNLOCK(lisp_global(TCR_AREA_LOCK), current); + return result; +} + +Boolean +lisp_suspend_tcr(TCR *tcr) +{ + Boolean suspended; + TCR *current = get_tcr(true); + + LOCK(lisp_global(TCR_AREA_LOCK),current); + suspended = suspend_tcr(tcr); + if (suspended) { + while (!tcr_suspend_ack(tcr)); + } + UNLOCK(lisp_global(TCR_AREA_LOCK),current); + return suspended; +} + +#ifdef WINDOWS +Boolean +resume_tcr(TCR *tcr) +{ + int suspend_count = atomic_decf(&(tcr->suspend_count)), err; + DWORD rc; + if (suspend_count == 0) { + CONTEXT *context = tcr->suspend_context; + HANDLE hthread = (HANDLE)(tcr->osid); + + if (context) { + context->ContextFlags = CONTEXT_ALL; + tcr->suspend_context = NULL; + SetThreadContext(hthread,context); + rc = ResumeThread(hthread); + if (rc == -1) { + wperror("ResumeThread"); + return false; + } + return true; + } + } + return false; +} +#else +Boolean +resume_tcr(TCR *tcr) +{ + int suspend_count = atomic_decf(&(tcr->suspend_count)); + if (suspend_count == 0) { + void *s = (tcr->resume); + if (s != NULL) { + SEM_RAISE(s); + return true; + } + } + return false; +} +#endif + + + + +Boolean +lisp_resume_tcr(TCR *tcr) +{ + Boolean resumed; + TCR *current = get_tcr(true); + + LOCK(lisp_global(TCR_AREA_LOCK),current); + resumed = resume_tcr(tcr); + UNLOCK(lisp_global(TCR_AREA_LOCK), current); + return resumed; +} + + +TCR *freed_tcrs = NULL; + +void +enqueue_freed_tcr (TCR *tcr) +{ +#ifndef HAVE_TLS + tcr->next = freed_tcrs; + freed_tcrs = tcr; +#endif +} + +/* It's not clear that we can safely condemn a dead tcr's areas, since + we may not be able to call free() if a suspended thread owns a + malloc lock. At least make the areas appear to be empty. +*/ + + +void +normalize_dead_tcr_areas(TCR *tcr) +{ + area *a; + + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + + a = tcr->cs_area; + if (a) { + a->active = a->high; + } +} + +void +free_freed_tcrs () +{ + TCR *current, *next; + + for (current = freed_tcrs; current; current = next) { + next = current->next; +#ifndef HAVE_TLS +#ifdef WIN32 + free(current->allocated); +#else + free(current); +#endif +#endif + } + freed_tcrs = NULL; +} + +void +suspend_other_threads(Boolean for_gc) +{ + TCR *current = get_tcr(true), *other, *next; + int dead_tcr_count = 0; + Boolean all_acked; + + LOCK(lisp_global(TCR_AREA_LOCK), current); + for (other = current->next; other != current; other = other->next) { + if ((other->osid != 0)) { + suspend_tcr(other); + if (other->osid == 0) { + dead_tcr_count++; + } + } else { + dead_tcr_count++; + } + } + + do { + all_acked = true; + for (other = current->next; other != current; other = other->next) { + if ((other->osid != 0)) { + if (!tcr_suspend_ack(other)) { + all_acked = false; + } + } + } + } while(! all_acked); + + + + /* All other threads are suspended; can safely delete dead tcrs now */ + if (dead_tcr_count) { + for (other = current->next; other != current; other = next) { + next = other->next; + if ((other->osid == 0)) { + normalize_dead_tcr_areas(other); + dequeue_tcr(other); + enqueue_freed_tcr(other); + } + } + } +} + +void +lisp_suspend_other_threads() +{ + suspend_other_threads(false); +} + +void +resume_other_threads(Boolean for_gc) +{ + TCR *current = get_tcr(true), *other; + for (other = current->next; other != current; other = other->next) { + if ((other->osid != 0)) { + resume_tcr(other); + } + } + free_freed_tcrs(); + UNLOCK(lisp_global(TCR_AREA_LOCK), current); +} + +void +lisp_resume_other_threads() +{ + resume_other_threads(false); +} + + + +rwlock * +rwlock_new() +{ + extern int cache_block_size; + + void *p = calloc(1,sizeof(rwlock)+cache_block_size-1); + rwlock *rw = NULL;; + + if (p) { + rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1))); + rw->malloced_ptr = p; +#ifndef USE_FUTEX + rw->reader_signal = new_semaphore(0); + rw->writer_signal = new_semaphore(0); + if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) { + if (rw->reader_signal) { + destroy_semaphore(&(rw->reader_signal)); + } else { + destroy_semaphore(&(rw->writer_signal)); + } + free(rw); + rw = NULL; + } +#endif + } + return rw; +} + + +/* + Try to get read access to a multiple-readers/single-writer lock. If + we already have read access, return success (indicating that the + lock is held another time. If we already have write access to the + lock ... that won't work; return EDEADLK. Wait until no other + thread has or is waiting for write access, then indicate that we + hold read access once. +*/ +#ifndef USE_FUTEX +int +rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + int err = 0; + + LOCK_SPINLOCK(rw->spin, tcr); + + if (rw->writer == tcr) { + RELEASE_SPINLOCK(rw->spin); + return EDEADLK; + } + + while (rw->blocked_writers || (rw->state > 0)) { + rw->blocked_readers++; + RELEASE_SPINLOCK(rw->spin); + err = semaphore_maybe_timedwait(rw->reader_signal,waitfor); + LOCK_SPINLOCK(rw->spin,tcr); + rw->blocked_readers--; + if (err == EINTR) { + err = 0; + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + } + rw->state--; + RELEASE_SPINLOCK(rw->spin); + return err; +} +#else +int +rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + natural waitval; + + lock_futex(&rw->spin); + + if (rw->writer == tcr) { + unlock_futex(&rw->spin); + return EDEADLOCK; + } + while (1) { + if (rw->writer == NULL) { + --rw->state; + unlock_futex(&rw->spin); + return 0; + } + rw->blocked_readers++; + waitval = rw->reader_signal; + unlock_futex(&rw->spin); + futex_wait(&rw->reader_signal,waitval); + lock_futex(&rw->spin); + rw->blocked_readers--; + } + return 0; +} +#endif + + +/* + Try to obtain write access to the lock. + It is an error if we already have read access, but it's hard to + detect that. + If we already have write access, increment the count that indicates + that. + Otherwise, wait until the lock is not held for reading or writing, + then assert write access. +*/ + +#ifndef USE_FUTEX +int +rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + int err = 0; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->writer == tcr) { + rw->state++; + RELEASE_SPINLOCK(rw->spin); + return 0; + } + + while (rw->state != 0) { + rw->blocked_writers++; + RELEASE_SPINLOCK(rw->spin); + err = semaphore_maybe_timedwait(rw->writer_signal, waitfor); + LOCK_SPINLOCK(rw->spin,tcr); + rw->blocked_writers--; + if (err == EINTR) { + err = 0; + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + } + rw->state = 1; + rw->writer = tcr; + RELEASE_SPINLOCK(rw->spin); + return err; +} + +#else +int +rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + int err = 0; + natural waitval; + + lock_futex(&rw->spin); + if (rw->writer == tcr) { + rw->state++; + unlock_futex(&rw->spin); + return 0; + } + + while (rw->state != 0) { + rw->blocked_writers++; + waitval = rw->writer_signal; + unlock_futex(&rw->spin); + futex_wait(&rw->writer_signal,waitval); + lock_futex(&rw->spin); + rw->blocked_writers--; + } + rw->state = 1; + rw->writer = tcr; + unlock_futex(&rw->spin); + return err; +} +#endif + +/* + Sort of the same as above, only return EBUSY if we'd have to wait. +*/ +#ifndef USE_FUTEX +int +rwlock_try_wlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->writer == tcr) { + rw->state++; + ret = 0; + } else { + if (rw->state == 0) { + rw->writer = tcr; + rw->state = 1; + ret = 0; + } + } + RELEASE_SPINLOCK(rw->spin); + return ret; +} +#else +int +rwlock_try_wlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + lock_futex(&rw->spin); + if (rw->writer == tcr) { + rw->state++; + ret = 0; + } else { + if (rw->state == 0) { + rw->writer = tcr; + rw->state = 1; + ret = 0; + } + } + unlock_futex(&rw->spin); + return ret; +} +#endif + +#ifndef USE_FUTEX +int +rwlock_try_rlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->state <= 0) { + --rw->state; + ret = 0; + } + RELEASE_SPINLOCK(rw->spin); + return ret; +} +#else +int +rwlock_try_rlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + lock_futex(&rw->spin); + if (rw->state <= 0) { + --rw->state; + ret = 0; + } + unlock_futex(&rw->spin); + return ret; +} +#endif + + + +#ifndef USE_FUTEX +int +rwlock_unlock(rwlock *rw, TCR *tcr) +{ + + int err = 0; + natural blocked_readers = 0; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->state > 0) { + if (rw->writer != tcr) { + err = EINVAL; + } else { + --rw->state; + if (rw->state == 0) { + rw->writer = NULL; + } + } + } else { + if (rw->state < 0) { + ++rw->state; + } else { + err = EINVAL; + } + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + + if (rw->state == 0) { + if (rw->blocked_writers) { + SEM_RAISE(rw->writer_signal); + } else { + blocked_readers = rw->blocked_readers; + if (blocked_readers) { + SEM_BROADCAST(rw->reader_signal, blocked_readers); + } + } + } + RELEASE_SPINLOCK(rw->spin); + return 0; +} +#else +int +rwlock_unlock(rwlock *rw, TCR *tcr) +{ + + int err = 0; + + lock_futex(&rw->spin); + if (rw->state > 0) { + if (rw->writer != tcr) { + err = EINVAL; + } else { + --rw->state; + if (rw->state == 0) { + rw->writer = NULL; + } + } + } else { + if (rw->state < 0) { + ++rw->state; + } else { + err = EINVAL; + } + } + if (err) { + unlock_futex(&rw->spin); + return err; + } + + if (rw->state == 0) { + if (rw->blocked_writers) { + ++rw->writer_signal; + unlock_futex(&rw->spin); + futex_wake(&rw->writer_signal,1); + return 0; + } + if (rw->blocked_readers) { + ++rw->reader_signal; + unlock_futex(&rw->spin); + futex_wake(&rw->reader_signal, INT_MAX); + return 0; + } + } + unlock_futex(&rw->spin); + return 0; +} +#endif + + +void +rwlock_destroy(rwlock *rw) +{ +#ifndef USE_FUTEX + destroy_semaphore((void **)&rw->reader_signal); + destroy_semaphore((void **)&rw->writer_signal); +#endif + postGCfree((void *)(rw->malloced_ptr)); +} + + + Index: /branches/qres/ccl/lisp-kernel/unix-calls.c =================================================================== --- /branches/qres/ccl/lisp-kernel/unix-calls.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/unix-calls.c (revision 13564) @@ -0,0 +1,155 @@ +/* + Copyright (C) 2008-2009, Clozure Associates and contributors + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +/* Provide wrappers around some standard C library functions that + can't easily be called from CCL's FFI for some reason (or where + we want to override/extend the function's default behavior.) + + Functions in this file should be referenced via the kernel + imports table. + + Callers should generally expect standard C library error-handling + conventions (e.g., return -1 or NULL and set errno on error.) +*/ + +#define _LARGEFILE64_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include + +ssize_t +lisp_read(int fd, void *buf, size_t count) +{ +#ifdef LINUX + return syscall(SYS_read,fd,buf,count); +#else + return read(fd,buf,count); +#endif +} + +ssize_t +lisp_write(int fd, void *buf, size_t count) +{ +#ifdef LINUX + return syscall(SYS_write,fd,buf,count); +#else + return write(fd,buf,count); +#endif +} + +int +lisp_open(char *path, int flags, mode_t mode) +{ +#ifdef LINUX + return syscall(SYS_open,path,flags,mode); +#else + return open(path,flags,mode); +#endif +} + +int +lisp_fchmod(int fd, mode_t mode) +{ + return fchmod(fd,mode); +} + +int64_t +lisp_lseek(int fd, int64_t offset, int whence) +{ +#ifdef LINUX + return lseek64(fd,offset,whence); +#else + return lseek(fd,offset,whence); +#endif +} + +int +lisp_close(int fd) +{ + return close(fd); +} + +int +lisp_ftruncate(int fd, off_t length) +{ + return ftruncate(fd,length); +} + +int +lisp_stat(char *path, void *buf) +{ + return stat(path,buf); +} + +int +lisp_fstat(int fd, void *buf) +{ + return fstat(fd,buf); +} + + +int +lisp_futex(int *uaddr, int op, int val, void *timeout, int *uaddr2, int val3) +{ +#ifdef LINUX + return syscall(SYS_futex,uaddr,op,val,timeout,uaddr2,val3); +#else + errno = ENOSYS; + return -1; +#endif +} + +DIR * +lisp_opendir(char *path) +{ + return opendir(path); +} + +struct dirent * +lisp_readdir(DIR *dir) +{ + return readdir(dir); +} + +int +lisp_closedir(DIR *dir) +{ + return closedir(dir); +} + +int +lisp_pipe(int pipefd[2]) +{ + return pipe(pipefd); +} + +int +lisp_gettimeofday(struct timeval *tp, void *tzp) +{ + return gettimeofday(tp, tzp); +} + +int +lisp_sigexit(int signum) +{ + signal(signum, SIG_DFL); + return kill(getpid(), signum); +} Index: /branches/qres/ccl/lisp-kernel/windows-calls.c =================================================================== --- /branches/qres/ccl/lisp-kernel/windows-calls.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/windows-calls.c (revision 13564) @@ -0,0 +1,1015 @@ +/* + Copyright (C) 2008-2009, Clozure Associates and contributors, + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "x86-exceptions.h" +#include +#include +#include +#include +#include +#include +#include +#include +#include +#undef __argv +#include +#include + +#ifndef WIN_32 +#define _dosmaperr mingw_dosmaperr +#else +void +_dosmaperr(unsigned long oserrno) +{ + switch(oserrno) { + case ERROR_INVALID_FUNCTION: + errno = EINVAL; + break; + case ERROR_FILE_NOT_FOUND: + errno = ENOENT; + break; + case ERROR_PATH_NOT_FOUND: + errno = ENOENT; + break; + case ERROR_TOO_MANY_OPEN_FILES: + errno = EMFILE; + break; + case ERROR_ACCESS_DENIED: + errno = EACCES; + break; + case ERROR_ARENA_TRASHED: + errno = ENOMEM; + break; + case ERROR_NOT_ENOUGH_MEMORY: + errno = ENOMEM; + break; + case ERROR_INVALID_BLOCK: + errno = ENOMEM; + break; + case ERROR_BAD_ENVIRONMENT: + errno = E2BIG; + break; + case ERROR_BAD_FORMAT: + errno = ENOEXEC; + break; + case ERROR_INVALID_ACCESS: + errno = EINVAL; + break; + case ERROR_INVALID_DATA: + errno = EINVAL; + break; + case ERROR_INVALID_DRIVE: + errno = ENOENT; + break; + case ERROR_CURRENT_DIRECTORY: + errno = EACCES; + break; + case ERROR_NOT_SAME_DEVICE: + errno = EXDEV; + break; + case ERROR_NO_MORE_FILES: + errno = ENOENT; + break; + case ERROR_LOCK_VIOLATION: + errno = EACCES; + break; + case ERROR_BAD_NETPATH: + errno = ENOENT; + break; + case ERROR_NETWORK_ACCESS_DENIED: + errno = EACCES; + break; + case ERROR_BAD_NET_NAME: + errno = ENOENT; + break; + case ERROR_FILE_EXISTS: + errno = EEXIST; + break; + case ERROR_CANNOT_MAKE: + errno = EACCES; + break; + case ERROR_FAIL_I24: + errno = EACCES; + break; + case ERROR_INVALID_PARAMETER: + errno = EINVAL; + break; + case ERROR_NO_PROC_SLOTS: + errno = EAGAIN; + break; + case ERROR_DRIVE_LOCKED: + errno = EACCES; + break; + case ERROR_BROKEN_PIPE: + errno = EPIPE; + break; + case ERROR_DISK_FULL: + errno = ENOSPC; + break; + case ERROR_INVALID_TARGET_HANDLE: + errno = EBADF; + break; + case ERROR_INVALID_HANDLE: + errno = EINVAL; + break; + case ERROR_WAIT_NO_CHILDREN: + errno = ECHILD; + break; + case ERROR_CHILD_NOT_COMPLETE: + errno = ECHILD; + break; + case ERROR_DIRECT_ACCESS_HANDLE: + errno = EBADF; + break; + case ERROR_NEGATIVE_SEEK: + errno = EINVAL; + break; + case ERROR_SEEK_ON_DEVICE: + errno = EACCES; + break; + case ERROR_DIR_NOT_EMPTY: + errno = ENOTEMPTY; + break; + case ERROR_NOT_LOCKED: + errno = EACCES; + break; + case ERROR_BAD_PATHNAME: + errno = ENOENT; + break; + case ERROR_MAX_THRDS_REACHED: + errno = EAGAIN; + break; + case ERROR_LOCK_FAILED: + errno = EACCES; + break; + case ERROR_ALREADY_EXISTS: + errno = EEXIST; + break; + case ERROR_FILENAME_EXCED_RANGE: + errno = ENOENT; + break; + case ERROR_NESTING_NOT_ALLOWED: + errno = EAGAIN; + break; + case ERROR_NOT_ENOUGH_QUOTA: + errno = ENOMEM; + break; + case ERROR_OPERATION_ABORTED: + errno = EINTR; + break; + default: + errno = EINVAL; + break; + } +} + +#endif + +#define MAX_FD 32 + +HANDLE +lisp_open(wchar_t *path, int flag, int mode) +{ + HANDLE hfile; + DWORD dwDesiredAccess = 0; + DWORD dwShareMode = 0; + DWORD dwCreationDistribution = 0; + DWORD dwFlagsAndAttributes = 0; + SECURITY_ATTRIBUTES sa = {sizeof(SECURITY_ATTRIBUTES), NULL, TRUE}; + + dwShareMode = FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE; + + if ((flag & _O_WRONLY) == _O_WRONLY) { + dwDesiredAccess |= GENERIC_WRITE; + } else if ((flag & _O_RDWR) == _O_RDWR) { + dwDesiredAccess |= GENERIC_WRITE|GENERIC_READ; + } else { + dwDesiredAccess |= GENERIC_READ; + } + + + if ((flag & (_O_CREAT | _O_EXCL)) == (_O_CREAT | _O_EXCL)) { + dwCreationDistribution |= CREATE_NEW; + } else if ((flag & O_TRUNC) == O_TRUNC) { + if ((flag & O_CREAT) == O_CREAT) { + dwCreationDistribution |= CREATE_ALWAYS; + } else if ((flag & O_RDONLY) != O_RDONLY) { + dwCreationDistribution |= TRUNCATE_EXISTING; + } + } else if ((flag & _O_APPEND) == _O_APPEND) { + dwCreationDistribution |= OPEN_EXISTING; + } else if ((flag & _O_CREAT) == _O_CREAT) { + dwCreationDistribution |= OPEN_ALWAYS; + } else { + dwCreationDistribution |= OPEN_EXISTING; + } + if ((flag & _O_RANDOM) == _O_RANDOM) { + dwFlagsAndAttributes |= FILE_FLAG_RANDOM_ACCESS; + } + if ((flag & _O_SEQUENTIAL) == _O_SEQUENTIAL) { + dwFlagsAndAttributes |= FILE_FLAG_SEQUENTIAL_SCAN; + } + + if ((flag & _O_TEMPORARY) == _O_TEMPORARY) { + dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE; + } + + if ((flag & _O_SHORT_LIVED) == _O_SHORT_LIVED) { + dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE; + } + + if (flag & _O_NOINHERIT) { + sa.bInheritHandle = FALSE; + } + +#if 0 + dwFlagsAndAttributes |= FILE_FLAG_OVERLAPPED; +#endif + + + hfile = CreateFileW(path, + dwDesiredAccess, + dwShareMode, + &sa, + dwCreationDistribution, + dwFlagsAndAttributes, + NULL); + if (hfile == ((HANDLE)-1)) { + _dosmaperr(GetLastError()); + return (HANDLE)-1; + } + return hfile; +} + +int +wopen(wchar_t *path, int flag, int mode) +{ + HANDLE h = lisp_open(path, flag, mode); + + if (h == (HANDLE)-1) { + return -1; /* errno already set */ + } + return _open_osfhandle((intptr_t)h,0); +} + +int +lisp_close(HANDLE hfile) +{ + int err; + + if (closesocket((SOCKET)hfile) == 0) { + return 0; + } + + err = WSAGetLastError(); + if (err != WSAENOTSOCK) { + _dosmaperr(err); + return -1; + } + if (CloseHandle(hfile)) { + return 0; + } + _dosmaperr(GetLastError()); + return -1; +} + +extern TCR *get_tcr(int); + +ssize_t +lisp_standard_read(HANDLE hfile, void *buf, unsigned int count) +{ + HANDLE hevent; + OVERLAPPED overlapped; + DWORD err, nread, wait_result; + pending_io pending; + TCR *tcr; + + + memset(&overlapped,0,sizeof(overlapped)); + + if (GetFileType(hfile) == FILE_TYPE_DISK) { + overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT); + } + + tcr = (TCR *)get_tcr(1); + pending.h = hfile; + pending.o = &overlapped; + tcr->pending_io_info = &pending; + hevent = (HANDLE)(tcr->io_datum); + overlapped.hEvent = hevent; + ResetEvent(hevent); + if (ReadFile(hfile, buf, count, &nread, &overlapped)) { + tcr->pending_io_info = NULL; + return nread; + } + + err = GetLastError(); + + if (err == ERROR_HANDLE_EOF) { + tcr->pending_io_info = NULL; + return 0; + } + + if (err != ERROR_IO_PENDING) { + _dosmaperr(err); + tcr->pending_io_info = NULL; + return -1; + } + + err = 0; + + /* We block here */ + wait_result = WaitForSingleObjectEx(hevent, INFINITE, true); + + + + tcr->pending_io_info = NULL; + if (wait_result == WAIT_OBJECT_0) { + err = overlapped.Internal; + if (err == ERROR_HANDLE_EOF) { + return 0; + } + if (err) { + _dosmaperr(err); + return -1; + } + return overlapped.InternalHigh; + } + + if (wait_result == WAIT_IO_COMPLETION) { + CancelIo(hfile); + errno = EINTR; + return -1; + } + err = GetLastError(); + + + switch (err) { + case ERROR_HANDLE_EOF: + return 0; + default: + _dosmaperr(err); + return -1; + } +} + +ssize_t +pipe_read(HANDLE hfile, void *buf, unsigned int count) +{ + DWORD navail, err;; + + do { + navail = 0; + if (PeekNamedPipe(hfile, NULL, 0, NULL, &navail, NULL) == 0) { + err = GetLastError(); + if (err = ERROR_HANDLE_EOF) { + return 0; + } else { + _dosmaperr(err); + return -1; + } + } + if (navail != 0) { + return lisp_standard_read(hfile, buf, count); + } + if (SleepEx(50, TRUE) == WAIT_IO_COMPLETION) { + errno = EINTR; + return -1; + } + } while (1); +} + +ssize_t +console_read(HANDLE hfile, void *buf, unsigned int count) +{ + DWORD err, eventcount, i, n; + INPUT_RECORD ir; + + do { + err = WaitForSingleObjectEx(hfile, INFINITE, TRUE); + switch (err) { + case WAIT_OBJECT_0: + eventcount = 0; + GetNumberOfConsoleInputEvents(hfile, &eventcount); + for (i = 0; i < eventcount; i++) { + PeekConsoleInput(hfile, &ir, 1, &n); + if (ir.EventType == KEY_EVENT) { + return lisp_standard_read(hfile, buf, count); + } else { + ReadConsoleInput(hfile, &ir, 1, &n); + } + } + break; + case WAIT_IO_COMPLETION: + errno = EINTR; + return -1; + break; + case WAIT_FAILED: + _dosmaperr(GetLastError()); + return -1; + break; + } + } while (1); +} + +ssize_t +lisp_read(HANDLE hfile, void *buf, unsigned int count) { + switch(GetFileType(hfile)) { + case FILE_TYPE_CHAR: + return console_read(hfile, buf, count); + break; + + case FILE_TYPE_PIPE: /* pipe or one of these newfangled socket things */ + { + int socktype, optlen = sizeof(int); + if ((getsockopt((SOCKET)hfile, SOL_SOCKET, SO_TYPE, (char *)&socktype, &optlen) != 0) && (GetLastError() == WSAENOTSOCK)) { + return pipe_read(hfile, buf, count); + } + } + /* It's a socket, fall through */ + + case FILE_TYPE_DISK: + return lisp_standard_read(hfile, buf, count); + break; + + default: + errno = EBADF; + return -1; + } +} + + + +ssize_t +lisp_write(HANDLE hfile, void *buf, ssize_t count) +{ + HANDLE hevent; + OVERLAPPED overlapped; + DWORD err, nwritten, wait_result; + pending_io pending; + TCR *tcr = (TCR *)get_tcr(1); + + hevent = (HANDLE)tcr->io_datum; + if (hfile == (HANDLE)1) { + hfile = GetStdHandle(STD_OUTPUT_HANDLE); + } else if (hfile == (HANDLE) 2) { + hfile = GetStdHandle(STD_ERROR_HANDLE); + } + + + memset(&overlapped,0,sizeof(overlapped)); + + if (GetFileType(hfile) == FILE_TYPE_DISK) { + overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT); + } + + + pending.h = hfile; + pending.o = &overlapped; + tcr->pending_io_info = &pending; + overlapped.hEvent = hevent; + ResetEvent(hevent); + if (WriteFile(hfile, buf, count, &nwritten, &overlapped)) { + tcr->pending_io_info = NULL; + return nwritten; + } + + err = GetLastError(); + if (err != ERROR_IO_PENDING) { + _dosmaperr(err); + tcr->pending_io_info = NULL; + return -1; + } + err = 0; + wait_result = WaitForSingleObjectEx(hevent, INFINITE, true); + tcr->pending_io_info = NULL; + if (wait_result == WAIT_OBJECT_0) { + err = overlapped.Internal; + if (err) { + _dosmaperr(err); + return -1; + } + return overlapped.InternalHigh; + } + if (wait_result == WAIT_IO_COMPLETION) { + CancelIo(hfile); + errno = EINTR; + return -1; + } + err = GetLastError(); + _dosmaperr(err); + return -1; +} + +int +lisp_fchmod(HANDLE hfile, int mode) +{ + errno = ENOSYS; + return -1; +} + +__int64 +lisp_lseek(HANDLE hfile, __int64 offset, int whence) +{ + DWORD high, low; + + high = ((__int64)offset)>>32; + low = offset & 0xffffffff; + low = SetFilePointer(hfile, low, &high, whence); + if (low != INVALID_SET_FILE_POINTER) { + return ((((__int64)high)<<32)|low); + } + _dosmaperr(GetLastError()); + return -1; +} + +#define ALL_USERS(f) ((f) | ((f)>> 3) | ((f >> 6))) +#define STAT_READONLY ALL_USERS(_S_IREAD) +#define STAT_READWRITE ALL_USERS((_S_IREAD|_S_IWRITE)) +int +lisp_stat(wchar_t *path, struct __stat64 *buf) +{ + return _wstat64(path,buf); +} + +#define UNIX_EPOCH_IN_WINDOWS_EPOCH 116444736000000000LL + +__time64_t +filetime_to_unix_time(FILETIME *ft) +{ + __time64_t then = *((__time64_t *) ft); + + then -= UNIX_EPOCH_IN_WINDOWS_EPOCH; + return then/10000000; +} + +int +lisp_fstat(HANDLE hfile, struct __stat64 *buf) +{ + int filetype; + + filetype = GetFileType(hfile) & ~FILE_TYPE_REMOTE; + + if (filetype == FILE_TYPE_UNKNOWN) { + errno = EBADF; + return -1; + } + + memset(buf, 0, sizeof(*buf)); + buf->st_nlink = 1; + + switch(filetype) { + case FILE_TYPE_CHAR: + case FILE_TYPE_PIPE: + if (filetype == FILE_TYPE_CHAR) { + buf->st_mode = _S_IFCHR; + } else { + buf->st_mode = _S_IFIFO; + } + break; + case FILE_TYPE_DISK: + { + BY_HANDLE_FILE_INFORMATION info; + + if (!GetFileInformationByHandle(hfile, &info)) { + _dosmaperr(GetLastError()); + return -1; + } + + if (info.dwFileAttributes & FILE_ATTRIBUTE_READONLY) { + buf->st_mode = STAT_READONLY; + } else { + buf->st_mode = STAT_READWRITE; + } + buf->st_mode |= _S_IFREG; + buf->st_size = ((((__int64)(info.nFileSizeHigh))<<32LL) | + ((__int64)(info.nFileSizeLow))); + buf->st_mtime = filetime_to_unix_time(&info.ftLastWriteTime); + buf->st_atime = filetime_to_unix_time(&info.ftLastAccessTime); + buf->st_ctime = filetime_to_unix_time(&info.ftCreationTime); + } + break; + case FILE_TYPE_UNKNOWN: + default: + errno = EBADF; + return -1; + } + return 0; +} + +int +lisp_futex(int *uaddr, int op, int val, void *timeout, int *uaddr2, int val3) +{ + errno = ENOSYS; + return -1; +} + + +__int64 +lisp_ftruncate(HANDLE hfile, off_t new_size) +{ + __int64 oldpos; + + + oldpos = lisp_lseek(hfile, 0, SEEK_END); + if (oldpos == -1) { + return 0; + } + if (oldpos < new_size) { + char buf[4096]; + __int64 n = new_size-oldpos; + DWORD nwritten, to_write; + + memset(buf,0,sizeof(buf)); + while(n) { + if (n > 4096LL) { + to_write = 4096; + } else { + to_write = n; + } + if (!WriteFile(hfile,buf,to_write,&nwritten,NULL)) { + _dosmaperr(GetLastError()); + return -1; + } + n -= nwritten; + } + return 0; + } + lisp_lseek(hfile, new_size, SEEK_SET); + if (SetEndOfFile(hfile)) { + return 0; + } + _dosmaperr(GetLastError()); + return -1; +} + + +_WDIR * +lisp_opendir(wchar_t *path) +{ + return _wopendir(path); +} + +struct _wdirent * +lisp_readdir(_WDIR *dir) +{ + return _wreaddir(dir); +} + +__int64 +lisp_closedir(_WDIR *dir) +{ + return _wclosedir(dir); +} + +int +lisp_pipe(int fd[2]) +{ + HANDLE input, output; + SECURITY_ATTRIBUTES sa; + + sa.nLength= sizeof(SECURITY_ATTRIBUTES); + sa.lpSecurityDescriptor = NULL; + sa.bInheritHandle = TRUE; + + if (!CreatePipe(&input, &output, &sa, 0)) + { + wperror("CreatePipe"); + return -1; + } + fd[0] = (int) ((intptr_t)input); + fd[1] = (int) ((intptr_t)output); + return 0; +} + +int +lisp_gettimeofday(struct timeval *tp, void *tzp) +{ + __time64_t now; + + gettimeofday(tp,tzp); /* trust it to get time zone right, at least */ + GetSystemTimeAsFileTime((FILETIME*)&now); + now -= UNIX_EPOCH_IN_WINDOWS_EPOCH; + now /= 10000; /* convert time to milliseconds */ + tp->tv_sec = now/1000LL; + tp->tv_usec = 1000 * (now%1000LL); /* convert milliseconds to microseconds */ + return 0; +} + +int +lisp_sigexit(int signum) +{ + signal(signum, SIG_DFL); + return raise(signum); +} + +#ifdef WIN_64 + +/* Make sure that the lisp calls these functions, when they do something */ +/* This code is taken from the 32-bit mingw library and is in the + public domain */ +double +acosh(double x) +{ + if (isnan (x)) + return x; + + if (x < 1.0) + { + errno = EDOM; + return nan(""); + } + + if (x > 0x1p32) + /* Avoid overflow (and unnecessary calculation when + sqrt (x * x - 1) == x). GCC optimizes by replacing + the long double M_LN2 const with a fldln2 insn. */ + return log (x) + 6.9314718055994530941723E-1L; + + /* Since x >= 1, the arg to log will always be greater than + the fyl2xp1 limit (approx 0.29) so just use logl. */ + return log (x + sqrt((x + 1.0) * (x - 1.0))); +} + +float +acoshf(float x) +{ + if (isnan (x)) + return x; + if (x < 1.0f) + { + errno = EDOM; + return nan(""); + } + + if (x > 0x1p32f) + /* Avoid overflow (and unnecessary calculation when + sqrt (x * x - 1) == x). GCC optimizes by replacing + the long double M_LN2 const with a fldln2 insn. */ + return log (x) + 6.9314718055994530941723E-1L; + + /* Since x >= 1, the arg to log will always be greater than + the fyl2xp1 limit (approx 0.29) so just use logl. */ + return log (x + sqrt((x + 1.0) * (x - 1.0))); +} + +double +asinh(double x) +{ + double z; + if (!isfinite (x)) + return x; + z = fabs (x); + + /* Avoid setting FPU underflow exception flag in x * x. */ +#if 0 + if ( z < 0x1p-32) + return x; +#endif + + /* Use log1p to avoid cancellation with small x. Put + x * x in denom, so overflow is harmless. + asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0) + = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0)) */ + + z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0)); + + return ( x >= 0.0 ? z : -z); +} + +float +asinhf(float x) +{ + float z; + if (!isfinite (x)) + return x; + z = fabsf (x); + + /* Avoid setting FPU underflow exception flag in x * x. */ +#if 0 + if ( z < 0x1p-32) + return x; +#endif + + + /* Use log1p to avoid cancellation with small x. Put + x * x in denom, so overflow is harmless. + asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0) + = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0)) */ + + z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0)); + + return ( x >= 0.0 ? z : -z); +} + +double +atanh(double x) +{ + double z; + if (isnan (x)) + return x; + z = fabs (x); + if (z == 1.0) + { + errno = ERANGE; + return (x > 0 ? INFINITY : -INFINITY); + } + if (z > 1.0) + { + errno = EDOM; + return nan(""); + } + /* Rearrange formula to avoid precision loss for small x. + + atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x)) + = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0) + = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x)) + = 0.5 * log1p ((2.0 * x ) / (1.0 - x)) */ + z = 0.5 * log1p ((z + z) / (1.0 - z)); + return x >= 0 ? z : -z; +} + +float +atanhf(float x) +{ + float z; + if (isnan (x)) + return x; + z = fabsf (x); + if (z == 1.0) + { + errno = ERANGE; + return (x > 0 ? INFINITY : -INFINITY); + } + if ( z > 1.0) + { + errno = EDOM; + return nanf(""); + } + /* Rearrange formula to avoid precision loss for small x. + + atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x)) + = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0) + = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x)) + = 0.5 * log1p ((2.0 * x ) / (1.0 - x)) */ + z = 0.5 * log1p ((z + z) / (1.0 - z)); + return x >= 0 ? z : -z; +} + +#endif + +typedef struct { + char *name; + void *addr; +} math_fn_entry; + + +math_fn_entry math_fn_entries [] = { + {"acos",acos}, + {"acosf",acosf}, + {"acosh",acosh}, + {"acoshf",acoshf}, + {"asin",asin}, + {"asinf",asinf}, + {"asinh",asinh}, + {"asinhf",asinhf}, + {"atan",atan}, + {"atan2",atan2}, + {"atan2f",atan2f}, + {"atanf",atanf}, + {"atanh",atanh}, + {"atanhf",atanhf}, + {"cos",cos}, + {"cosf",cosf}, + {"cosh",cosh}, + {"coshf",coshf}, + {"exp",exp}, + {"expf",expf}, + {"log",log}, + {"logf",logf}, + {"pow",pow}, + {"powf",powf}, + {"sin",sin}, + {"sinf",sinf}, + {"sinh",sinh}, + {"sinhf",sinhf}, + {"tan",tan}, + {"tanf",tanf}, + {"tanh",tanh}, + {"tanhf",tanhf}, + {NULL, 0}}; + +void * +lookup_math_fn(char *name) +{ + math_fn_entry *p = math_fn_entries; + char *entry_name; + + while ((entry_name = p->name) != NULL) { + if (!strcmp(name, entry_name)) { + return p->addr; + } + p++; + } + return NULL; +} + +HMODULE *modules = NULL; +DWORD cbmodules = 0; +HANDLE find_symbol_lock = 0; + +void * +windows_find_symbol(void *handle, char *name) +{ + void *addr; + + if ((handle == ((void *)-2L)) || + (handle == ((void *)-1L))) { + handle = NULL; + } + if (handle != NULL) { + addr = GetProcAddress(handle, name); + } else { + DWORD cbneeded, have, i; + WaitForSingleObject(find_symbol_lock,INFINITE); + + if (cbmodules == 0) { + cbmodules = 16 * sizeof(HANDLE); + modules = malloc(cbmodules); + } + + while (1) { + EnumProcessModules(GetCurrentProcess(),modules,cbmodules,&cbneeded); + if (cbmodules >= cbneeded) { + break; + } + cbmodules = cbneeded; + modules = realloc(modules,cbmodules); + } + have = cbneeded/sizeof(HANDLE); + + for (i = 0; i < have; i++) { + addr = GetProcAddress(modules[i],name); + + if (addr) { + break; + } + } + ReleaseMutex(find_symbol_lock); + if (addr) { + return addr; + } + return lookup_math_fn(name); + } +} + +/* Note that we're using 8-bit strings here */ + +void * +windows_open_shared_library(char *path) +{ + HMODULE module = (HMODULE)0; + + /* Try to open an existing module in a way that increments its + reference count without running any initialization code in + the dll. */ + if (!GetModuleHandleExA(0,path,&module)) { + /* If that failed ... */ + module = LoadLibraryA(path); + } + return (void *)module; +} + + +void +init_windows_io() +{ +#ifdef WIN_32 + extern void init_win32_ldt(void); + init_win32_ldt(); +#endif + find_symbol_lock = CreateMutex(NULL,false,NULL); +} + +void +init_winsock() +{ + WSADATA data; + + WSAStartup((2<<8)|2,&data); +} + Index: /branches/qres/ccl/lisp-kernel/x86-asmutils32.s =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-asmutils32.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-asmutils32.s (revision 13564) @@ -0,0 +1,285 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + include(lisp.s) + + _beginfile + +_exportfn(C(current_stack_pointer)) + __(movl %esp,%eax) + __(ret) +_endfn + +_exportfn(C(count_leading_zeros)) + __(bsr 4(%esp),%eax) + __(xor $31,%eax) + __(ret) +_endfn + +_exportfn(C(noop)) + __(ret) +_endfn + +_exportfn(C(set_mxcsr)) + __(ldmxcsr 4(%esp)) + __(ret) +_endfn + +_exportfn(C(get_mxcsr)) + __(push $0) + __(stmxcsr (%esp)) + __(pop %eax) + __(ret) +_endfn + +_exportfn(C(save_fp_context)) +_endfn + +_exportfn(C(restore_fp_context)) +_endfn + +/* Atomically store new in *p, if *p == old. */ +/* Return actual old value. */ +/* natural store_conditional(natural *p, natural old, natural new) */ +_exportfn(C(store_conditional)) + __(movl 12(%esp),%edx) /* new */ + __(movl 8(%esp),%eax) /* old */ + __(movl 4(%esp),%ecx) /* ptr */ + __(lock) + __(cmpxchgl %edx,(%ecx)) + __(cmovne %edx,%eax) + __(ret) +_endfn + +/* Atomically store val in *p; return previous *p */ +/* of *%rdi. */ +/* signed_natural atomic_swap(signed_natural *p, signed_natural val) */ +_exportfn(C(atomic_swap)) + __(movl 8(%esp),%eax) + __(movl 4(%esp),%edx) + __(lock) + __(xchg %eax,(%edx)) + __(ret) +_endfn + +/* Logior the value in *p with mask (presumably a */ +/* bitmask with exactly 1 bit set.) Return non-zero if any of */ +/* the bits in that bitmask were already set. */ +/* natural atomic_ior(natural *p, natural mask) */ +_exportfn(C(atomic_ior)) + __(movl 4(%esp),%edx) /* ptr */ +0: __(movl (%edx),%eax) + __(movl %eax,%ecx) + __(orl 8(%esp),%ecx) + __(lock) + __(cmpxchg %ecx,(%edx)) + __(jnz 0b) + __(andl 8(%esp),%eax) + __(ret) +_endfn + + +/* Logand the value in *p with mask (presumably a bitmask with exactly 1 */ +/* bit set.) Return the value now in *p (for some value of "now"). */ +/* natural atomic_and(natural *p, natural mask) */ +_exportfn(C(atomic_and)) + __(movl 4(%esp),%edx) +0: __(movl (%edx),%eax) + __(movl %eax,%ecx) + __(and 8(%esp),%ecx) + __(lock) + __(cmpxchg %ecx,(%edx)) + __(jnz 0b) + __(movl %ecx,%eax) + __(ret) +_endfn + + + __ifdef(`DARWIN') +_exportfn(C(pseudo_sigreturn)) + __(hlt) + __(jmp C(pseudo_sigreturn)) +_endfn + __endif + +/* int cpuid (int code, int *pebx, int *pecx, int *pedx) */ +_exportfn(C(cpuid)) + __(push %ebx) /* %ebx is non-volatile */ + __(push %esi) /* ditto here */ + __(movl 12(%esp),%eax) + __(xorl %ecx,%ecx) + __(cpuid) + __(movl 16(%esp),%esi) + __(movl %ebx,(%esi)) + __(movl 20(%esp),%esi) + __(movl %ecx,(%esi)) + __(movl 24(%esp),%esi) + __(movl %edx,(%esi)) + __(pop %esi) + __(pop %ebx) + __(ret) +_endfn + +/* switch_to_foreign_stack(new_sp, func, arg_0, arg_1, arg_2) */ +/* Not fully general, but should get us off of the signal stack */ +/* Beware: on Darwin, GDB can get very confused by this code, and + doesn't really get unconfused until the target function - the + handler - has built its stack frame + The lone caller of this function passes 3 arguments (besides + the new stack pointer and the handler address.) + On platforms where the C stack must be 16-byte aligned, pushing + a 4th word helps make the stack aligned before the return + address is (re-)pushed. + On Linux, there are severe constraints on what the top of stack + can look like when rt_sigreturn (the code at the return address) + runs, and there aren't any constraints on stack alignment, so + we don't push the extra word on the new stack.*/ +_exportfn(C(switch_to_foreign_stack)) + __(addl $4,%esp) /* discard return address, on wrong stack */ + __(pop %edi) /* new esp */ + __(pop %esi) /* handler */ + __(pop %eax) /* arg_0 */ + __(pop %ebx) /* arg_1 */ + __(pop %ecx) /* arg_2 */ + __(mov %edi,%esp) + __(pop %edi) /* Return address pushed by caller */ + __ifndef(`LINUX') + __(push $0) /* For alignment. See comment above */ + __endif + __(push %ecx) /* arg_2 */ + __(push %ebx) /* arg_1 */ + __(push %eax) /* arg_0 */ + __(push %edi) /* return address */ + __(jmp *%esi) /* On some platforms, we don't really return */ +_endfn + + __ifdef(`FREEBSD') + .globl C(sigreturn) +_exportfn(C(freebsd_sigreturn)) + __(jmp C(sigreturn)) +_endfn + __endif + + __ifdef(`DARWIN') +_exportfn(C(darwin_sigreturn)) +/* Need to set the sigreturn 'infostyle' argument, which is mostly + undocumented. On x8632 Darwin, sigtramp() sets it to 0x1e, and + since we're trying to do what sigtramp() would do if we'd returned + to it ... */ + __(movl $0x1e,8(%esp)) + __(movl $0xb8,%eax) /* SYS_sigreturn */ + __(int $0x80) + __(ret) /* shouldn't return */ + +_endfn + __endif + +_exportfn(C(get_vector_registers)) + __(ret) +_endfn + +_exportfn(C(put_vector_registers)) + __(ret) +_endfn + + __ifdef(`WIN_32') +_exportfn(C(restore_windows_context)) +Xrestore_windows_context_start: + __(movl 4(%esp),%ecx) /* context */ + __(movl 12(%esp),%edx) /* old valence */ + __(movl 8(%esp),%eax) /* tcr */ + __(movw tcr.ldt_selector(%eax), %rcontext_reg) + __(movl %edx,rcontext(tcr.valence)) + __(movl $0,rcontext(tcr.pending_exception_context)) + __(frstor win32_context.FloatSave(%ecx)) + /* Windows doesn't bother to align the context, so use + 'movupd' here */ + __(movupd win32_context.Xmm0(%ecx),%xmm0) + __(movupd win32_context.Xmm1(%ecx),%xmm1) + __(movupd win32_context.Xmm2(%ecx),%xmm2) + __(movupd win32_context.Xmm3(%ecx),%xmm3) + __(movupd win32_context.Xmm4(%ecx),%xmm4) + __(movupd win32_context.Xmm5(%ecx),%xmm5) + __(movupd win32_context.Xmm6(%ecx),%xmm6) + __(movupd win32_context.Xmm7(%ecx),%xmm7) + __(ldmxcsr win32_context.MXCSR(%ecx)) + __(movl win32_context.Ebp(%ecx),%ebp) + __(movl win32_context.Edi(%ecx),%edi) + __(movl win32_context.Esi(%ecx),%esi) + __(movl win32_context.Edx(%ecx),%edx) + __(movl win32_context.Ebx(%ecx),%ebx) + __(movl win32_context.Eax(%ecx),%eax) + __(movl win32_context.Esp(%ecx),%esp) + __(pushl win32_context.EFlags(%ecx)) + __(pushl %cs) + __(pushl win32_context.Eip(%ecx)) + /* This must be the last thing before the iret, e.g., if we're + interrupted before the iret, the context we're returning to here + is still in %ecx. If we're interrupted -at- the iret, then + everything but that which the iret will restore has been restored. */ + __(movl win32_context.Ecx(%ecx),%ecx) +Xrestore_windows_context_iret: + __(iret) +Xrestore_windows_context_end: + __(nop) +_endfn + +_exportfn(C(windows_switch_to_foreign_stack)) + __(pop %eax) + __(pop %ebx) /* new %esp */ + __(pop %ecx) /* handler */ + __(pop %edx) /* arg */ + __(movl %ebx,%esp) + __(subl $0x10,%esp) + __(movl %edx,(%esp)) + __(push %eax) + __(jmp *%ecx) +_endfn + + .data + .globl C(restore_windows_context_start) + .globl C(restore_windows_context_end) + .globl C(restore_windows_context_iret) +C(restore_windows_context_start): .long Xrestore_windows_context_start +C(restore_windows_context_end): .long Xrestore_windows_context_end +C(restore_windows_context_iret): .long Xrestore_windows_context_iret + .text + + __ifdef(`WIN32_ES_HACK') +/* Something that we shouldn't return to */ +_exportfn(C(windows_halt)) + __(hlt) +_endfn + __endif +_exportfn(C(ensure_safe_for_string_operations)) + __ifdef(`WIN32_ES_HACK') + __(movw %es,%ax) + __(movw %ds,%dx) + __(cmpw %ax,%dx) + __(jne 9f) +0: __(movw %dx,%es) + __endif + __(cld) + __(ret) + __ifdef(`WIN32_ES_HACK') +9: __(hlt) + __(jmp 0b) + __endif +_endfn + __endif + _endfile + Index: /branches/qres/ccl/lisp-kernel/x86-asmutils64.s =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-asmutils64.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-asmutils64.s (revision 13564) @@ -0,0 +1,308 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + include(lisp.s) + + _beginfile + +/* Flush %carg1 cache lines, starting at address in %carg0. Each line is */ +/* assumed to be %carg2 bytes wide. */ +_exportfn(C(flush_cache_lines)) + __(cmpq $0,%carg1) + __(jmp 2f) +1: __(clflush (%carg0)) + __(addq %carg2,%carg0) + __(subq $1,%carg1) +2: __(jg 1b) + __(repret) +_endfn + +_exportfn(C(current_stack_pointer)) + __(movq %rsp,%cret) + __(ret) +_endfn + +_exportfn(C(touch_page)) + __(movq %carg0,(%carg0)) + __(movq $0,(%carg0)) + __(movl $1,%cret_l) + .globl C(touch_page_end) +C(touch_page_end): + __(ret) + +_exportfn(C(count_leading_zeros)) + __(bsrq %carg0,%cret) + __(xorq $63,%cret) + __(ret) +_endfn + +_exportfn(C(noop)) + __(retq) +_endfn + +_exportfn(C(set_mxcsr)) + __(pushq %carg0) + __(ldmxcsr (%rsp)) + __(addq $8,%rsp) + __(ret) +_endfn + +_exportfn(C(get_mxcsr)) + __(pushq $0) + __(stmxcsr (%rsp)) + __(popq %cret) + __(ret) +_endfn + +_exportfn(C(save_fp_context)) +_endfn + +_exportfn(C(restore_fp_context)) +_endfn + +/* Atomically store new value (%carg2) in *%carg0, if old value == %carg1. */ +/* Return actual old value. */ +_exportfn(C(store_conditional)) + __(mov %carg1,%cret) + __(lock) + __(cmpxchgq %carg2,(%carg0)) + __(cmovne %carg2,%cret) + __(ret) +_endfn + +/* Atomically store new_value(%carg1) in *%carg0 ; return previous contents */ +/* of *%carg0. */ + +_exportfn(C(atomic_swap)) + __(lock) + __(xchg %carg1,(%carg0)) + __(mov %carg1,%cret) + __(ret) +_endfn + +/* Logior the value in *%carg0 with the value in %carg1 (presumably a */ +/* bitmask with exactly 1 bit set.) Return non-zero if any of */ +/* the bits in that bitmask were already set. */ +_exportfn(C(atomic_ior)) +0: __(movq (%carg0),%cret) + __(movq %cret,%carg2) + __(orq %carg1,%carg2) + __(lock) + __(cmpxchg %carg2,(%carg0)) + __(jnz 0b) + __(andq %carg1,%cret) + __(ret) +_endfn + + +/* Logand the value in *carg0 with the value in carg1 (presumably a bitmask with exactly 1 */ +/* bit set.) Return the value now in *carg0 (for some value of "now" */ + +_exportfn(C(atomic_and)) +0: __(movq (%carg0),%cret) + __(movq %cret,%carg2) + __(and %carg1,%carg2) + __(lock) + __(cmpxchg %carg2,(%carg0)) + __(jnz 0b) + __(movq %carg2,%cret) + __(ret) +_endfn + + + __ifdef(`DARWIN') +_exportfn(C(pseudo_sigreturn)) + __(hlt) + __(jmp C(pseudo_sigreturn)) +_endfn + __endif + +/* int cpuid (natural code, natural *pebx, natural *pecx, natural *pedx) */ +_exportfn(C(cpuid)) + __(pushq %carg2) + __(pushq %carg3) + __(movq %carg1, %ctemp0) + __(pushq %rbx) /* non-volatile reg, clobbered by CPUID */ + __(movq %carg0, %rax) + __(xorq %rcx,%rcx) + __(cpuid) + __(movq %rbx,(%ctemp0)) + __(popq %rbx) + __(popq %ctemp0) /* recover pedx */ + __(movq %rdx,(%ctemp0)) + __(popq %ctemp0) /* recover pecx */ + __(movq %rcx,(%ctemp0)) + __(ret) +_endfn + +/* switch_to_foreign_stack(new_sp, func, arg_0, arg_1, arg_2, arg_3) */ +/* Not fully general, but should get us off of the signal stack */ + __ifndef(`WINDOWS') +_exportfn(C(switch_to_foreign_stack)) + __(movq %rdi,%rsp) + __(movq %rsi,%rax) + __(movq %rdx,%rdi) + __(movq %rcx,%rsi) + __(movq %r8,%rdx) + __(movq %r9,%rcx) + __(jmp *%rax) +_endfn + __endif + +_exportfn(C(freebsd_sigreturn)) + __(movl $417,%eax) /* SYS_sigreturn */ + __(syscall) + +_exportfn(C(get_vector_registers)) +_endfn + +_exportfn(C(put_vector_registers)) +_endfn + + __ifdef(`DARWIN') +_exportfn(C(darwin_sigreturn)) + .globl C(sigreturn) +/* Need to set the sigreturn 'infostyle' argument, which is mostly + undocumented. On x8664 Darwin, sigtramp() sets it to 0x1e, and + since we're trying to do what sigtramp() would do if we'd returned + to it ... */ + __(movl $0x1e,%esi) + __(movl $0x20000b8,%eax) + __(syscall) + __(ret) +_endfn + __endif + + + + __ifdef(`DARWIN_GS_HACK') +/* Check (in an ugly, non-portable way) to see if %gs is addressing + pthreads data. If it was, return 0; otherwise, assume that it's + addressing a lisp tcr and set %gs to point to the tcr's tcr.osid, + then return 1. */ + +thread_signature = 0x54485244 /* 'THRD' */ + +_exportfn(C(ensure_gs_pthread)) + __(cmpl $thread_signature,%gs:0) + __(movl $0,%eax) + __(je 9f) + __(movq %gs:tcr.osid,%rdi) + __(movl $0x3000003,%eax) + __(syscall) + __(movl $1,%eax) +9: __(repret) +_endfn + + /* Ensure that %gs addresses the linear address in %rdi */ + /* This incidentally returns the segment selector .*/ +_exportfn(C(set_gs_address)) + __(movl $0x3000003,%eax) + __(syscall) + __(ret) +_endfn + __endif + + __ifdef(`WIN_64') +/* %rcx = CONTEXT, %rdx = tcr, %r8 = old_valence. This pretty + much has to be uninterruptible */ +_exportfn(C(restore_windows_context)) +Xrestore_windows_context_start: + __(subq $0x38,%rsp) + __(xorl %eax,%eax) + __(movq %r8,tcr.valence(%rdx)) + __(movq %rax,tcr.pending_exception_context(%rdx)) + __(fxrstor win64_context.fpstate(%rcx)) + __(movapd win64_context.Xmm0(%rcx),%xmm0) + __(movapd win64_context.Xmm1(%rcx),%xmm1) + __(movapd win64_context.Xmm2(%rcx),%xmm2) + __(movapd win64_context.Xmm3(%rcx),%xmm3) + __(movapd win64_context.Xmm4(%rcx),%xmm4) + __(movapd win64_context.Xmm5(%rcx),%xmm5) + __(movapd win64_context.Xmm6(%rcx),%xmm6) + __(movapd win64_context.Xmm7(%rcx),%xmm7) + __(movapd win64_context.Xmm8(%rcx),%xmm8) + __(movapd win64_context.Xmm9(%rcx),%xmm9) + __(movapd win64_context.Xmm10(%rcx),%xmm10) + __(movapd win64_context.Xmm11(%rcx),%xmm11) + __(movapd win64_context.Xmm12(%rcx),%xmm12) + __(movapd win64_context.Xmm13(%rcx),%xmm13) + __(movapd win64_context.Xmm14(%rcx),%xmm14) + __(movapd win64_context.Xmm15(%rcx),%xmm15) + __(ldmxcsr win64_context.MxCsr(%rcx)) + __(movw win64_context.SegSs(%rcx),%ax) + __(movw %ax,0x20(%rsp)) + __(movq win64_context.Rsp(%rcx),%rax) + __(movq %rax,0x18(%rsp)) + __(movl win64_context.EFlags(%rcx),%eax) + __(movl %eax,0x10(%rsp)) + __(movw win64_context.SegCs(%rcx),%ax) + __(movw %ax,8(%rsp)) + __(movq win64_context.Rip(%rcx),%rax) + __(movq %rax,(%rsp)) + __(movq win64_context.Rax(%rcx),%rax) + __(movq win64_context.Rbx(%rcx),%rbx) + __(movq win64_context.Rdx(%rcx),%rdx) + __(movq win64_context.Rdi(%rcx),%rdi) + __(movq win64_context.Rsi(%rcx),%rsi) + __(movq win64_context.Rbp(%rcx),%rbp) + __(movq win64_context.R8(%rcx),%r8) + __(movq win64_context.R9(%rcx),%r9) + __(movq win64_context.R10(%rcx),%r10) + __(movq win64_context.R11(%rcx),%r11) + __(movq win64_context.R12(%rcx),%r12) + __(movq win64_context.R13(%rcx),%r13) + __(movq win64_context.R14(%rcx),%r14) + __(movq win64_context.R15(%rcx),%r15) + /* This must be the last thing before the iret, e.g., if we're + interrupted before the iret, the context we're returning to here + is still in %rcx. If we're interrupted -at- the iret, then + everything but that which the iret will restore has been restored. */ + __(movq win64_context.Rcx(%rcx),%rcx) +Xrestore_windows_context_iret: + __(iretq) +Xrestore_windows_context_end: + __(nop) +_endfn + +_exportfn(C(windows_switch_to_foreign_stack)) + __(pop %rax) + __(lea -0x20(%rcx),%rsp) + __(push %rax) + __(movq %r8,%rcx) + __(jmp *%rdx) +_endfn + + .data + .globl C(restore_windows_context_start) + .globl C(restore_windows_context_end) + .globl C(restore_windows_context_iret) +C(restore_windows_context_start): .quad Xrestore_windows_context_start +C(restore_windows_context_end): .quad Xrestore_windows_context_end +C(restore_windows_context_iret): .quad Xrestore_windows_context_iret + .text + +/* Something that we shouldn't return to */ +_exportfn(C(windows_halt)) + __(hlt) +_endfn +_exportfn(C(ensure_safe_for_string_operations)) + __(cld) + __(ret) +_endfn + __endif + _endfile Index: /branches/qres/ccl/lisp-kernel/x86-constants.h =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-constants.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-constants.h (revision 13564) @@ -0,0 +1,63 @@ +/* + Copyright (C) 2005-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __x86_constants__ +#define __x86_constants__ 1 + +#define TCR_FLAG_BIT_FOREIGN fixnumshift +#define TCR_FLAG_BIT_AWAITING_PRESET (fixnumshift+1) +#define TCR_FLAG_BIT_ALT_SUSPEND (fixnumshift+2) +#define TCR_FLAG_BIT_PROPAGATE_EXCEPTION (fixnumshift+3) +#define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4) +#define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5) +#define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6) +#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7) +#define TCR_STATE_FOREIGN (1) +#define TCR_STATE_LISP (0) +#define TCR_STATE_EXCEPTION_WAIT (2) +#define TCR_STATE_EXCEPTION_RETURN (4) + +#ifdef X8664 +#include "x86-constants64.h" +#else +#include "x86-constants32.h" +#endif + +#define dnode_size (node_size*2) +#define dnode_shift (node_shift+1) + +#define INTERRUPT_LEVEL_BINDING_INDEX (1) + +/* FP exception mask bits */ +#define MXCSR_IM_BIT (7) /* invalid masked when set*/ +#define MXCSR_DM_BIT (8) /* denormals masked when set*/ +#define MXCSR_ZM_BIT (9) /* divide-by-zero masked when set */ +#define MXCSR_OM_BIT (10) /* overflow masked when set */ +#define MXCSR_UM_BIT (11) /* underflow masked when set */ +#define MXCSR_PM_BIT (12) /* precision masked when set */ + +/* Bits in the xFLAGS register */ +#define X86_CARRY_FLAG_BIT (0) +#define X86_PARITY_FLAG_BIT (2) +#define X86_AUX_CARRY_FLAG_BIT (4) +#define X86_ZERO_FLAG_BIT (6) +#define X86_SIGN_FLAG_BIT (7) +#define X86_DIRECTION_FLAG_BIT (10) +#define X86_OVERFLOW_FLAG_BIT (11) + + +#endif /* __x86_constants__ */ + Index: /branches/qres/ccl/lisp-kernel/x86-constants.s =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-constants.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-constants.s (revision 13564) @@ -0,0 +1,140 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + +/* Indices in %builtin-functions% */ + +_builtin_plus = 0 /* +-2 */ +_builtin_minus = 1 /* --2 */ +_builtin_times = 2 /* *-2 */ +_builtin_div = 3 /* /-2 */ +_builtin_eq = 4 /* =-2 */ +_builtin_ne = 5 /* /-2 */ +_builtin_gt = 6 /* >-2 */ +_builtin_ge = 7 /* >=-2 */ +_builtin_lt = 8 /* <-2 */ +_builtin_le = 9 /* <=-2 */ +_builtin_eql = 10 /* eql */ +_builtin_length = 11 /* length */ +_builtin_seqtype = 12 /* sequence-type */ +_builtin_assq = 13 /* assq */ +_builtin_memq = 14 /* memq */ +_builtin_logbitp = 15 /* logbitp */ +_builtin_logior = 16 /* logior-2 */ +_builtin_logand = 17 /* logand-2 */ +_builtin_ash = 18 /* ash */ +_builtin_negate = 19 /* %negate */ +_builtin_logxor = 20 /* logxor-2 */ +_builtin_aref1 = 21 /* %aref1 */ +_builtin_aset1 = 22 /* %aset1 */ + + +ifdef(`X8664',` + include(x86-constants64.s) +',` + include(x86-constants32.s) +') + +/* registers, as used in destructuring-bind/macro-bind */ +ifdef(`X8664',` +define(`whole_reg',`temp1') +define(`arg_reg',`temp0') +define(`keyvect_reg',`arg_x') +',` +define(`arg_reg',`temp1') +define(`arg_reg_b',`temp1_b') +define(`keyvect_reg',`arg_y') +') + +define(`initopt_bit',`24') +define(`keyp_bit',`25') /* note that keyp can be true even when 0 keys. */ +define(`aok_bit',`26') +define(`restp_bit',`27') +define(`seen_aok_bit',`28') + +num_lisp_globals = 49 /* MUST UPDATE THIS !!! */ + + _struct(lisp_globals,lisp_globals_limit-(num_lisp_globals*node_size)) + _node(weakvll) /* all populations as of last GC */ + _node(initial_tcr) /* initial thread tcr */ + _node(image_name) /* --image-name argument */ + _node(BADfpscr_save_high) /* high word of FP reg used to save FPSCR */ + _node(unwind_resume) /* _Unwind_Resume */ + _node(batch_flag) /* -b */ + _node(host_platform) /* for runtime platform-specific stuff */ + _node(argv) /* address of argv`0' */ + _node(errno) /* ADDRESS of errno */ + _node(tenured_area) /* the tenured_area */ + _node(oldest_ephemeral) /* dword address of oldest ephemeral object or 0 */ + _node(lisp_exit_hook) /* install foreign exception_handling */ + _node(lisp_return_hook) /* install lisp exception_handling */ + _node(double_float_one) /* high half of 1.0d0 */ + _node(short_float_zero) /* low half of 1.0d0 */ + _node(objc2_end_catch) /* objc_end_catch() */ + _node(metering_info) /* address of lisp_metering global */ + _node(in_gc) /* non-zero when GC active */ + _node(lexpr_return1v) /* simpler when &lexpr called for single value. */ + _node(lexpr_return) /* magic &lexpr return code. */ + _node(all_areas) /* doubly-linked list of all memory areas */ + _node(kernel_path) /* real executable name */ + _node(objc2_begin_catch) /* objc_begin_catch */ + _node(BAD_current_vs) /* current value-stack area */ + _node(statically_linked) /* non-zero if -static */ + _node(heap_end) /* end of lisp heap */ + _node(heap_start) /* start of lisp heap */ + _node(gcable_pointers) /* linked-list of weak macptrs. */ + _node(gc_num) /* fixnum: GC call count. */ + _node(fwdnum) /* fixnum: GC "forwarder" call count. */ + _node(altivec_present) /* non-zero when AltiVec available */ + _node(oldspace_dnode_count) /* dynamic dnodes older than g0 start */ + _node(refbits) /* EGC refbits */ + _node(gc_inhibit_count) + _node(intflag) /* sigint pending */ + _node(default_allocation_quantum) /* for per-thread allocation */ + _node(deleted_static_pairs) + _node(exception_lock) + _node(area_lock) + _node(tcr_key) /* tsd key for per-thread tcr */ + _node(ret1val_addr) /* address of "dynamic" subprims magic values return addr */ + _node(subprims_base) /* address of dynamic subprims jump table */ + _node(saveR13) /* probably don't really need this */ + _node(saveTOC) /* where the 68K emulator stores the emulated regs */ + _node(objc_2_personality) /* exception "personality routine" address for ObjC 2.0 */ + _node(kernel_imports) /* some things we need imported for us */ + _node(interrupt_signal) /* signal used by PROCESS-INTERRUPT */ + _node(tcr_count) /* tcr_id for next tcr */ + _node(get_tcr) /* address of get_tcr() */ + _ends + + + +define(`TCR_STATE_FOREIGN',1) +define(`TCR_STATE_LISP',0) +define(`TCR_STATE_EXCEPTION_WAIT',2) +define(`TCR_STATE_EXCEPTION_RETURN',4) + +tstack_alloc_limit = 0xffff + +mxcsr_ie_bit = 0 /* invalid */ +mxcsr_de_bit = 1 /* denorm */ +mxcsr_ze_bit = 2 +mxcsr_oe_bit = 3 +mxcsr_ue_bit = 4 +mxcsr_pe_bit = 5 +num_mxcsr_exception_bits = 6 + +mxcsr_all_exceptions = ((1< +#include +#define REG_EAX EAX +#define REG_EBX EBX +#define REG_ECX ECX +#define REG_EDX EDX +#define REG_ESI ESI +#define REG_EDI EDI +#define REG_EBP EBP +#define REG_ESP UESP /* Maybe ... ESP is often 0, but who knows why ? */ +#define REG_EFL EFL +#define REG_EIP EIP +#endif + +/* Indicies of GPRs in the mcontext component of a ucontext */ +#define Iimm0 REG_EAX +#define Iarg_z REG_EBX +#define Itemp0 REG_ECX +#define Itemp1 REG_EDX +#define Ifn REG_EDI +#define Iarg_y REG_ESI +#define Iesp REG_ESP +#define Iebp REG_EBP +#define Ieip REG_EIP +#define Iflags REG_EFL + +#define Isp Iesp +#define Iip Ieip +#define Iallocptr Itemp0 +#define Ira0 Itemp0 +#define Inargs Itemp1 +#define Ixfn Itemp1 +#define Ifp Iebp + +/* MMX register offsets from where mm0 is found in uc_mcontext.fs */ +#define Imm0 0 +#define Imm1 1 + +#define nbits_in_word 32 +#define log2_nbits_in_word 5 +#define nbits_in_byte 8 +#define ntagbits 3 +#define nlisptagbits 2 +#define nfixnumtagbits 2 +#define num_subtag_bits 8 +#define fixnumshift 2 +#define fixnum_shift 2 +#define fulltagmask 7 +#define tagmask 3 +#define fixnummask 3 +#define subtagmask ((1<> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + +#define population_weak_list (0< +#else +typedef unsigned short sel_t; /* for now */ +#endif + +#define TCR_BIAS 0 + +/* + * bits correspond to reg encoding used in instructions + * 7 6 5 4 3 2 1 0 + * edi esi ebp esp ebx edx ecx eax + */ + +#define X8632_DEFAULT_NODE_REGS_MASK 0xce + +typedef struct tcr { + struct tcr *next; + struct tcr *prev; + natural node_regs_mask; /* bit set means correspnding reg contains node */ + struct tcr *linear; + /* this spill area must be 16-byte aligned */ + LispObj save0; /* spill area for node registers */ + LispObj save1; + LispObj save2; + LispObj save3; + LispObj *save_fp; /* EBP when in foreign code */ + u32_t lisp_mxcsr; + u32_t foreign_mxcsr; + special_binding *db_link; /* special binding chain head */ + LispObj catch_top; /* top catch frame */ + LispObj *save_vsp; /* VSP when in foreign code */ + LispObj *save_tsp; /* TSP when in foreign code */ + LispObj *foreign_sp; + struct area *cs_area; /* cstack area pointer */ + struct area *vs_area; /* vstack area pointer */ + struct area *ts_area; /* tstack area pointer */ + LispObj cs_limit; /* stack overflow limit */ + natural bytes_allocated; + natural bytes_consed_high; + natural log2_allocation_quantum; /* for per-thread consing */ + signed_natural interrupt_pending; /* pending interrupt flag */ + xframe_list *xframe; /* exception-frame linked list */ + int *errno_loc; /* per-thread (?) errno location */ + LispObj ffi_exception; /* fpscr bits from ff-call */ + LispObj osid; /* OS thread id */ + signed_natural valence; /* odd when in foreign code */ + signed_natural foreign_exception_status; /* non-zero -> call lisp_exit_hook */ + void *native_thread_info; /* platform-dependent */ + void *native_thread_id; /* mach_thread_t, pid_t, etc. */ + void *last_allocptr; + void *save_allocptr; + void *save_allocbase; + void *reset_completion; + void *activate; + signed_natural suspend_count; + ExceptionInformation *suspend_context; + ExceptionInformation *pending_exception_context; + void *suspend; /* suspension semaphore */ + void *resume; /* resumption semaphore */ + natural flags; + ExceptionInformation *gc_context; + void *termination_semaphore; + signed_natural unwinding; + natural tlb_limit; + LispObj *tlb_pointer; + natural shutdown_count; + LispObj *next_tsp; + void *safe_ref_address; + sel_t ldt_selector; + natural scratch_mxcsr; + natural unboxed0; + natural unboxed1; + LispObj next_method_context; /* used in lieu of register */ + natural save_eflags; + void *allocated; + void *pending_io_info; + void *io_datum; +} TCR; + +#define nil_value ((0x13000 + (fulltag_cons))+(LOWMEM_BIAS)) +#define t_value ((0x13008 + (fulltag_misc))+(LOWMEM_BIAS)) +#define t_offset (t_value-nil_value) +#define misc_header_offset -fulltag_misc +#define misc_data_offset misc_header_offset + node_size + +typedef struct { + natural Eip; + natural Cs; /* in low 16 bits */ + natural EFlags; +} ia32_iret_frame; + +#define heap_segment_size 0x00010000 +#define log2_heap_segment_size 16 + +#ifndef EFL_DF +#define EFL_DF 1024 +#endif Index: /branches/qres/ccl/lisp-kernel/x86-constants32.s =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-constants32.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-constants32.s (revision 13564) @@ -0,0 +1,626 @@ +define(`eax_l',`eax') +define(`ecx_l',`ecx') +define(`edx_l',`edx') +define(`ebx_l',`ebx') +define(`esi_l',`esi') +define(`edi_l',`edi') + +define(`eax_b',`al') +define(`ecx_b',`cl') +define(`edx_b',`dl') +define(`ebx_b',`bl') + +define(`imm0',`eax') + define(`imm0_l',`eax') + define(`imm0_w',`ax') + define(`imm0_b',`al') + define(`imm0_bh',`ah') + define(`Rimm0',`0') + +define(`temp0',`ecx') + define(`temp0_l',`ecx') + define(`temp0_w',`cx') + define(`temp0_b',`cl') + define(`temp0_bh',`ch') + define(`Rtemp0',`1') + +define(`temp1',`edx') + define(`temp1_l',`edx') + define(`temp1_w',`dx') + define(`temp1_b',`dl') + define(`temp1_bh',`dh') + define(`Rtemp1',`2') + +define(`arg_z',`ebx') + define(`arg_z_l',`ebx') + define(`arg_z_w',`bx') + define(`arg_z_b',`bl') + define(`arg_z_bh',`bh') + define(`Rarg_z',`3') + +define(`arg_y',`esi') + define(`Rarg_y',`6') + +define(`fn',`edi') + define(`Rfn',`7') + +define(`rcontext_reg',`fs') + + ifdef(`WINDOWS',` +undefine(`rcontext_reg') +define(`rcontext_reg',`es') + ') + +define(`rcontext',`%rcontext_reg:$1') + +define(`fname',`temp0') +define(`allocptr',`temp0') + +define(`nargs',`temp1') +define(`nargs_w',`temp1_w') + +define(`ra0',`temp0') +define(`xfn',`temp1') + +define(`allocptr',`temp0') +define(`stack_temp',`mm7') + +define(`fp0',`xmm0') +define(`fp1',`xmm1') +define(`fp2',`xmm2') +define(`fp3',`xmm3') +define(`fp4',`xmm4') +define(`fp5',`xmm5') +define(`fp6',`xmm6') +define(`fp7',`xmm7') +define(`fpzero',`fp7') + +nbits_in_word = 32 +nbits_in_byte = 8 +ntagbits = 3 +nlisptagbits = 2 +nfixnumtagbits = 2 +num_subtag_bits = 8 +subtag_shift = num_subtag_bits +fixnumshift = 2 +fixnum_shift = 2 +fulltagmask = 7 +tagmask = 3 +fixnummask = 3 +ncharcodebits = 8 +charcode_shift = 8 +word_shift = 2 +node_size = 4 +dnode_size = 8 +dnode_align_bits = 3 +dnode_shift = dnode_align_bits +bitmap_shift = 5 + +fixnumone = (1< -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(esp) /* saved lisp esp */ + _node(ebp) /* saved lisp ebp */ + _node(foreign_sp) /* necessary? */ + _node(db_link) /* head of special-binding chain */ + _node(xframe) /* exception frame chain */ + _node(pc) /* TRA of catch exit or cleanup form */ + _endstructf + + _struct(_function,-misc_bias) + _node(header) + _node(codevector) + _ends + + _struct(tsp_frame,0) + _node(backlink) + _node(save_ebp) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + + _struct(csp_frame,0) + _node(backlink) + _node(save_ebp) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + + _structf(symbol) + _node(pname) + _node(vcell) + _node(fcell) + _node(package_predicate) + _node(flags) + _node(plist) + _node(binding_index) + _endstructf + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + _struct(lisp_frame,0) + _node(backlink) + _node(savera0) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + +symbol_extra = symbol.size-fulltag_misc + + _struct(nrs,(0x13008+(LOWMEM_BIAS))) + _struct_pad(fulltag_misc) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_misc) + _struct_label(nilsym) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_misc) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_misc) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_misc) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_misc) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_misc) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_misc) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_misc) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_misc) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_misc) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_misc) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_misc) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_misc) + _struct_label(total_bytes_freed) + _struct_pad(symbol_extra) /* *total-bytes-freed* */ + + _struct_pad(fulltag_misc) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_misc) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_misc) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_misc) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_misc) + _struct_label(total_gc_microseconds) + _struct_pad(symbol_extra) /* *total-gc-microseconds* */ + + _struct_pad(fulltag_misc) + _struct_label(builtin_functions) + _struct_pad(symbol_extra) /* %builtin-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_misc) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_misc) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_misc) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_misc) + _struct_label(new_gcable_ptr) + _struct_pad(symbol_extra) /* %new-gcable-ptr */ + + _struct_pad(fulltag_misc) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_misc) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_misc) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + _struct_pad(fulltag_misc) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_misc) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_misc) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_misc) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define(`def_header',`$1 = ($2<Rax) */ +#define REG_RAX 0 +#define REG_RCX 1 +#define REG_RDX 2 +#define REG_RBX 3 +#define REG_RSP 4 +#define REG_RBP 5 +#define REG_RSI 6 +#define REG_RDI 7 +#define REG_R8 8 +#define REG_R9 9 +#define REG_R10 10 +#define REG_R11 11 +#define REG_R12 12 +#define REG_R13 13 +#define REG_R14 14 +#define REG_R15 15 +#define REG_RIP 16 +#endif + +/* Define indices of the GPRs in the mcontext component of a ucontext */ +#define Itemp0 REG_RBX +#define Iarg_y REG_RDI +#define Iarg_x REG_R8 +#define Iarg_z REG_RSI +#define Isave3 REG_R11 +#define Isave2 REG_R12 +#define Isave1 REG_R14 +#define Isave0 REG_R15 +#define Itemp2 REG_R10 +#define Ifn REG_R13 +#define Irbp REG_RBP +#define Iimm0 REG_RAX +#define Iimm1 REG_RDX +#define Iimm2 REG_RCX +#define Itemp1 REG_R9 +#define Isp REG_RSP +#define Iip REG_RIP +#if defined(LINUX) || defined(WINDOWS) +#define Iflags REG_EFL +#endif + +#if defined(SOLARIS) || defined(FREEBSD) || defined(DARWIN) +#define Iflags REG_RFL +#endif + + +#define Iallocptr Itemp0 +#define Ira0 Itemp2 +#define Inargs Iimm2 +#define Ixfn Itemp1 +#define Ifp Irbp + + +#define nbits_in_word 64L +#define log2_nbits_in_word 6L +#define nbits_in_byte 8L +#define ntagbits 4L +#define nlisptagbits 3L +#define nfixnumtagbits 2L +#define num_subtag_bits 8L +#define fixnumshift 3L +#define fixnum_shift 3L +#define fulltagmask 15L +#define tagmask 7L +#define fixnummask 3 +#define subtagmask ((1L<> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + + +#define population_weak_list (0< call lisp_exit_hook */ + void* native_thread_info; /* platform-dependent */ + void* native_thread_id; /* mach_thread_t, pid_t, etc. */ + void* last_allocptr; + void* save_allocptr; + void* save_allocbase; + void* reset_completion; + void* activate; + signed_natural suspend_count; + ExceptionInformation* suspend_context; + ExceptionInformation* pending_exception_context; + void* suspend; /* suspension semaphore */ + void* resume; /* resumption semaphore */ + natural flags; + ExceptionInformation* gc_context; + void* termination_semaphore; + signed_natural unwinding; + natural tlb_limit; + LispObj* tlb_pointer; + natural shutdown_count; + LispObj* next_tsp; + void *safe_ref_address; + void *pending_io_info; + void *io_datum; +} TCR; + +#define t_offset (t_value-nil_value) + +typedef struct { + natural Rip; + natural Cs; /* in low 16 bits */ + natural Rflags; /* in low 32 bits */ + natural Rsp; + natural Ss; /* in low 16 bits*/ +} x64_iret_frame; + +/* + These were previously global variables. There are lots of implicit + assumptions about the size of a heap segment, so they might as well + be constants. +*/ + +#define heap_segment_size 0x00020000L +#define log2_heap_segment_size 17L + Index: /branches/qres/ccl/lisp-kernel/x86-constants64.s =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-constants64.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-constants64.s (revision 13564) @@ -0,0 +1,1045 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +/* Register usage. This is certainly a little short of */ +/* immediate registers; we can maybe use the low bits */ +/* of mmx or xmm registers to hold immediate values and */ +/* do some unboxed arithmetic. */ + + +/* + + Register usage in C calling conventions differ between + Darwin/Linux/FreeBSD (which use the AMD-defined ABI) and + Windows64 (which uses something else). The good news is that + Win64 did away with the cdecl/stdcall/fastcall madness, there + is only one ABI left. Here's a rundown. + + AMD64^Wx86-64 ABI: + * Integer and pointer function arguments passed (from left to + right) in RDI, RSI, RDX, RCX, R8 and R9 + * FP arguments are passed in XMM0..XMM7 + * rest is passed on stack + * return value in RAX + * Callee must preserve RBP, RBX, R12..R15, MXCSR control bits + * On function entry, x87 mode and DF clear is assumed + * `RSP'..`RSP-128' must not be touched by signal handlers + + Win64 ABI: + * Integer and pointers passed in RCX, RDX, R8, R9 + * FP passed in XMM0..XMM3 + * rest is passed on stack + * Return value in RAX or XMM0 + * Caller (!) responsible for creating and cleaning stack space for + spilling integer registers + * Callee must preserve RBP, RBX, RSI, RDI, R12..R15, XMM6..XMM15 + + Both want their stack pointers to be 16 byte aligned on call, + equivalent to 8 byte offset after call due to pushed return address. + + http://msdn2.microsoft.com/en-us/library/zthk2dkh(VS.80).aspx + http://www.tortall.net/projects/yasm/manual/html/objfmt-win64-exception.html + http://www.x86-64.org/documentation/abi.pdf + + + Lisp register usage: + + Clozure CL renames the physical registers, giving them names + based on their usage. An overview: + + imm0..imm2 + temp0..temp2 + save0..save3 + arg_x, arg_y, arg_z + fn + + On top of that, further mappings are defined: + + fname, next_method_context: temp0 + nargs: imm2 + ra0: temp2 + xfn: temp1 + allocptr: temp0 + stack_temp: mm7 + + x86-64 ABI mapping: + + imm0..imm2: RAX, RDX, RCX + temp0..temp2: RBX, R9, R10 + save0..save3: R15, R14, R12, R11 + arg_x, arg_y, arg_z: R8, RDI, RSI + fn: R13 + rcontext_reg: GS + + Win64 specifics: + rcontext_reg: R11 + +*/ + + +/* Redefining these standard register names - with the same _l, _w, _b suffixes */ +/* used in lispy symbolic names - allows us to play Stupid M4 Tricks in macros */ + +define(`rax_l',`eax') +define(`rax_w',`ax') +define(`rax_b',`al') +define(`rbx_l',`ebx') +define(`rbx_w',`bx') +define(`rbx_b',`bl') +define(`rcx_l',`ecx') +define(`rcx_w',`cx') +define(`rdx_l',`edx') +define(`rdx_w',`dx') +define(`rdx_b',`dl') +define(`rsi_l',`esi') +define(`rsi_w',`si') +define(`rsi_b',`sil') +define(`rdi_l',`edo') +define(`rdi_w',`di') +define(`rdi_b',`dil') +define(`r8_l',`r8d') +define(`r8_w',`r8w') +define(`r8_b',`r8b') +define(`r9_l',`r9d') +define(`r9_w',`r9w') +define(`r9_b',`r9b') +define(`r10_l',`r10d') +define(`r10_w',`r10w') +define(`r10_b',`r10b') +define(`r10_l',`r11d') +define(`r11_w',`r11w') +define(`r11_b',`r11b') +define(`r12_l',`r12d') +define(`r12_w',`r12w') +define(`r12_b',`r12b') +define(`r13_l',`r13d') +define(`r13_w',`r13w') +define(`r13_b',`r13b') +define(`r14_l',`r14d') +define(`r14_w',`r14w') +define(`r14_b',`r14b') +define(`r15_l',`r15d') +define(`r15_w',`r15w') +define(`r15_b',`r15b') + +/* Registers when using Lisp calling conventions */ + +define(`imm0',`rax') + define(`imm0_l',`eax') + define(`imm0_w',`ax') + define(`imm0_b',`al') + define(`Rimm0',`0') + +define(`temp0',`rbx') + define(`temp0_l',`ebx') + define(`temp0_w',`bx') + define(`temp0_b',`bl') + define(`Rtemp0',`3') + +define(`imm2',`rcx') + define(`imm2_l',`ecx') + define(`imm2_w',`cx') + define(`imm2_b',`cl') + define(`Rimm2',`1') + +define(`imm1',`rdx') + define(`imm1_l',`edx') + define(`imm1_w',`dx') + define(`imm1_b',`dl') + define(`Rimm1',`2') + +define(`arg_z',`rsi') + define(`arg_z_l',`esi') + define(`arg_z_w',`si') + define(`arg_z_b',`sil') + define(`Rarg_z',`6') + +define(`arg_y',`rdi') + define(`arg_y_l',`edi') + define(`arg_y_w',`di') + define(`arg_y_b',`dil') + define(`Rarg_y',`7') + +define(`arg_x',`r8') + define(`arg_x_l',`r8d') + define(`arg_x_w',`r8w') + define(`arg_x_b',`r8b') + define(`Rarg_x',`8') + +define(`temp1',`r9') + define(`temp1_l',`r9d') + define(`temp1_w',`r9w') + define(`temp1_b',`r9b') + define(`Rtemp1',`9') + +define(`temp2',`r10') + define(`temp2_l',`r10d') + define(`temp2_w',`r10w') + define(`temp2_x_b',`r10b') + define(`Rtemp2',`10') + +define(`save3',`r11') + define(`save3_l',`r11d') + define(`save3_w',`r11w') + define(`save3_b',`r11b') + define(`Rsave3',`11') + +define(`save2',`r12') + define(`save2_l',`r12d') + define(`save2_w',`r12w') + define(`save2_b',`r12b') + define(`Rsave2',`12') + +define(`fn',`r13') /* some addressing restrictions */ + define(`fn_l',`r13d') + define(`fn_w',`r13w') + define(`fn_b',`r13b') + define(`Rfn',`13') + +define(`save1',`r14') + define(`save1_l',`r14d') + define(`save1_w',`r14w') + define(`save1_b',`r14b') + define(`Rsave1',`14') + +define(`save0',`r15') + define(`save0_l',`r15d') + define(`save0_w',`r15w') + define(`save0_b',`r15b') + define(`Rsave0',`15') + + +ifdef(`TCR_IN_GPR',` +/* We keep the TCR pointer in r11 */ + define(`rcontext_reg', r11) + define(`rcontext',`$1(%rcontext_reg)') +',` +/* The TCR can be accessed relative to %gs */ + define(`rcontext_reg',`gs') + define(`rcontext',`%rcontext_reg:$1') +') +define(`fname',`temp0') +define(`next_method_context',`temp0') +define(`nargs_b',`imm2_b') +define(`nargs_w',`imm2_w') +define(`nargs_q',`imm2') +define(`nargs',`imm2_l') +define(`ra0',`temp2') + +define(`xfn',`temp1') + +define(`allocptr',`temp0') +define(`stack_temp',`mm7') + + +define(`fp0',`xmm0') +define(`fp1',`xmm1') +define(`fp2',`xmm2') +define(`fp3',`xmm3') +define(`fp4',`xmm4') +define(`fp5',`xmm5') +define(`fp6',`xmm6') +define(`fp7',`xmm7') +define(`fp8',`xmm8') +define(`fp9',`xmm9') +define(`fp10',`xmm10') +define(`fp11',`xmm11') +define(`fp12',`xmm12') +define(`fp13',`xmm13') +define(`fp14',`xmm14') +define(`fp15',`xmm15') +define(`fpzero',`fp15') + +/* Registers when running with native C calling conventions */ + +define(`cret',`rax') + define(`cret_l',`eax') + define(`cret_w',`ax') + define(`cret_b',`al') + define(`Rcret',`0') + +define(`ctemp0',`r10') + define(`ctemp0_l',`r10d') + define(`ctemp0_w',`r10w') + define(`ctemp0_b',`r10b') + define(`Rctemp0',`10') + +define(`ctemp1',`r11') + define(`ctemp1_l',`r11d') + define(`ctemp1_w',`r11w') + define(`ctemp1_b',`r11b') + define(`Rctemp1',`11') + +define(`csave0',`rbx') + define(`csave0_l',`ebx') + define(`csave0_w',`bx') + define(`csave0_b',`bl') + define(`Rcsave0',`3') + +define(`csave1',`r12') + define(`csave1_l',`r12d') + define(`csave1_w',`r12w') + define(`csave1_b',`r12b') + define(`Rcsave1',`12') + +define(`csave2',`r13') + define(`csave2_l',`r13d') + define(`csave2_w',`r13w') + define(`csave2_b',`r13b') + define(`Rcsave2',`13') + +define(`csave3',`r14') + define(`csave3_l',`r14d') + define(`csave3_w',`r14w') + define(`csave3_b',`r14b') + define(`Rcsave3',`14') + +define(`csave4',`r15') + define(`csave4_l',`r15d') + define(`csave4_w',`r15w') + define(`csave4_b',`r15b') + define(`Rcsave4',`15') + +ifdef(`WINDOWS',` + +define(`carg0',`rcx') + define(`carg0_l',`ecx') + define(`carg0_w',`cx') + define(`carg0_b',`cl') + define(`Rcarg0',`1') + +define(`carg1',`rdx') + define(`carg1_l',`edx') + define(`carg1_w',`dx') + define(`carg1_b',`dl') + define(`Rcarg1',`2') + +define(`carg2',`r8') + define(`carg2_l',`r8d') + define(`carg2_w',`r8w') + define(`carg2_b',`r8b') + define(`Rcarg2',`8') + +define(`carg3',`r9') + define(`carg3_l',`r9d') + define(`carg3_w',`r9w') + define(`carg3_b',`r9b') + define(`Rcarg3',`9') + +define(`csave5',`rsi') + define(`csave5_l',`esi') + define(`csave5_w',`si') + define(`csave5_b',`sil') + define(`csave5_z',`6') + +define(`csave6',`rdi') + define(`csave6_l',`edi') + define(`csave6_w',`di') + define(`csave6_b',`dil') + define(`Rcsave6',`7') + +',` + +define(`carg0',`rdi') + define(`carg0_l',`edi') + define(`carg0_w',`di') + define(`carg0_b',`dil') + define(`Rcarg0',`7') + +define(`carg1',`rsi') + define(`carg1_l',`esi') + define(`carg1_w',`si') + define(`carg1_b',`sil') + define(`carg1_z',`6') + +define(`carg2',`rdx') + define(`carg2_l',`edx') + define(`carg2_w',`dx') + define(`carg2_b',`dl') + define(`Rcarg2',`2') + +define(`carg3',`rcx') + define(`carg3_l',`ecx') + define(`carg3_w',`cx') + define(`carg3_b',`cl') + define(`Rcarg3',`1') + +define(`carg4',`r8') + define(`carg4_l',`r8d') + define(`carg4_w',`r8w') + define(`carg4_b',`r8b') + define(`Rcarg4',`8') + +define(`carg5',`r9') + define(`carg5_l',`r9d') + define(`carg5_w',`r9w') + define(`carg5_b',`r9b') + define(`Rcarg5',`9') +') + +nbits_in_word = 64 +nbits_in_byte = 8 +ntagbits = 4 +nlisptagbits = 3 +nfixnumtagbits = 3 +nlowtagbits = 2 +num_subtag_bits = 8 +subtag_shift = num_subtag_bits +fixnumshift = 3 +fixnum_shift = 3 +fulltagmask = 15 +tagmask = 7 +fixnummask = 7 +ncharcodebits = 8 +charcode_shift = 8 +word_shift = 3 +node_size = 8 +dnode_size = 16 +dnode_align_bits = 4 +dnode_shift = dnode_align_bits +bitmap_shift = 6 + +fixnumone = (1< -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(rsp) /* saved lisp sp */ + _node(rbp) /* saved lisp rbp */ + _node(foreign_sp) /* necessary ? */ + _node(db_link) /* head of special-binding chain */ + _node(_save3) + _node(_save2) + _node(_save1) + _node(_save0) + _node(xframe) /* exception frame chain */ + _node(pc) /* TRA of catch exit or cleanup form */ + _endstructf + + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + + _struct(c_frame,0) /* PowerOpen ABI C stack frame */ + _node(backlink) + _node(crsave) + _node(savelr) + _field(unused, 16) + _node(savetoc) + _struct_label(params) + _node(param0) + _node(param1) + _node(param2) + _node(param3) + _node(param4) + _node(param5) + _node(param6) + _node(param7) + _struct_label(minsiz) + _ends + + + _struct(eabi_c_frame,0) + _word(backlink) + _word(savelr) + _word(param0) + _word(param1) + _word(param2) + _word(param3) + _word(param4) + _word(param5) + _word(param6) + _word(param7) + _struct_label(minsiz) + _ends + + /* For entry to variable-argument-list functions */ + /* (e.g., via callback) */ + _struct(varargs_eabi_c_frame,0) + _word(backlink) + _word(savelr) + _struct_label(va_list) + _word(flags) /* gpr count byte, fpr count byte, padding */ + _word(overflow_arg_area) + _word(reg_save_area) + _field(padding,4) + _struct_label(regsave) + _field(gp_save,8*4) + _field(fp_save,8*8) + _word(old_backlink) + _word(old_savelr) + _struct_label(incoming_stack_args) + _ends + + _struct(lisp_frame,0) + _node(backlink) + _node(savera0) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + + +/* Nilreg-relative globals. Talking the assembler into doing */ +/* something reasonable here */ +/* is surprisingly hard. */ + +symbol_extra = symbol.size-fulltag_symbol + + + _struct(nrs,0x13020) + _struct_pad(fulltag_symbol) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_symbol) + _struct_label(nil) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_symbol) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_symbol) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_symbol) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_symbol) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_symbol) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_symbol) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_symbol) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_symbol) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_symbol) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_symbol) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_symbol) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_symbol) + _struct_label(total_bytes_freed) /* *total-bytes-freed* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_symbol) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_symbol) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_symbol) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_symbol) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_symbol) + _struct_label(total_gc_microseconds) /* *total-gc-microseconds* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(builtin_functions) /* %builtin-functions% */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_symbol) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_symbol) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_symbol) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_symbol) + _struct_label(new_gcable_ptr) /* %new-gcable-ptr */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_symbol) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_symbol) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + + _struct_pad(fulltag_symbol) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_symbol) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_symbol) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_symbol) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define(`def_header',` +$1 = ($2< +#include +#include +#include +#include +#include +#include +#ifdef LINUX +#include +#include +#include +#include +#endif +#ifdef DARWIN +#include +#endif +#ifndef WINDOWS +#include +#endif +#ifdef WINDOWS +#include +#ifdef WIN_64 +#include +#include +#endif +#ifndef EXCEPTION_WRITE_FAULT +#define EXCEPTION_WRITE_FAULT 1 +#endif +#endif + +int +page_size = 4096; + +int +log2_page_size = 12; + + +void +update_bytes_allocated(TCR* tcr, void *cur_allocptr) +{ + BytePtr + last = (BytePtr) tcr->last_allocptr, + current = (BytePtr) cur_allocptr; + if (last && (tcr->save_allocbase != ((void *)VOID_ALLOCPTR))) { + tcr->bytes_allocated += last-current; + } + tcr->last_allocptr = 0; +} + + + +// This doesn't GC; it returns true if it made enough room, false +// otherwise. +// If "extend" is true, it can try to extend the dynamic area to +// satisfy the request. + + +Boolean +new_heap_segment(ExceptionInformation *xp, natural need, Boolean extend, TCR *tcr) +{ + area *a; + natural newlimit, oldlimit; + natural log2_allocation_quantum = tcr->log2_allocation_quantum; + + a = active_dynamic_area; + oldlimit = (natural) a->active; + newlimit = (align_to_power_of_2(oldlimit, log2_allocation_quantum) + + align_to_power_of_2(need, log2_allocation_quantum)); + if (newlimit > (natural) (a->high)) { + if (extend) { + signed_natural inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + natural extend_by = inhibit ? 0 : lisp_heap_gc_threshold; + do { + if (resize_dynamic_heap(a->active, (newlimit-oldlimit)+extend_by)) { + break; + } + extend_by = align_to_power_of_2(extend_by>>1,log2_allocation_quantum); + if (extend_by < 4<<20) { + return false; + } + } while (1); + } else { + return false; + } + } + a->active = (BytePtr) newlimit; + tcr->last_allocptr = (void *)newlimit; + tcr->save_allocptr = (void *)newlimit; + xpGPR(xp,Iallocptr) = (LispObj) newlimit; + tcr->save_allocbase = (void *) oldlimit; + + return true; +} + +Boolean +allocate_object(ExceptionInformation *xp, + natural bytes_needed, + signed_natural disp_from_allocptr, + TCR *tcr) +{ + area *a = active_dynamic_area; + + /* Maybe do an EGC */ + if (a->older && lisp_global(OLDEST_EPHEMERAL)) { + if (((a->active)-(a->low)) >= a->threshold) { + gc_from_xp(xp, 0L); + } + } + + /* Life is pretty simple if we can simply grab a segment + without extending the heap. + */ + if (new_heap_segment(xp, bytes_needed, false, tcr)) { + xpGPR(xp, Iallocptr) -= disp_from_allocptr; + tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr)); + return true; + } + + /* It doesn't make sense to try a full GC if the object + we're trying to allocate is larger than everything + allocated so far. + */ + if ((lisp_global(HEAP_END)-lisp_global(HEAP_START)) > bytes_needed) { + untenure_from_area(tenured_area); /* force a full GC */ + gc_from_xp(xp, 0L); + } + + /* Try again, growing the heap if necessary */ + if (new_heap_segment(xp, bytes_needed, true, tcr)) { + xpGPR(xp, Iallocptr) -= disp_from_allocptr; + tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr)); + return true; + } + + return false; +} + +natural gc_deferred = 0, full_gc_deferred = 0; + +signed_natural +flash_freeze(TCR *tcr, signed_natural param) +{ + return 0; +} + + +Boolean +handle_gc_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj selector = xpGPR(xp,Iimm0); +#ifdef X8664 + LispObj arg = xpGPR(xp,Iimm1); +#else + LispObj arg = xpMMXreg(xp,Imm0); +#endif + area *a = active_dynamic_area; + Boolean egc_was_enabled = (a->older != NULL); + + natural gc_previously_deferred = gc_deferred; + + switch (selector) { + case GC_TRAP_FUNCTION_EGC_CONTROL: + egc_control(arg != 0, a->active); + xpGPR(xp,Iarg_z) = lisp_nil + (egc_was_enabled ? t_offset : 0); + break; + + case GC_TRAP_FUNCTION_CONFIGURE_EGC: +#ifdef X8664 + a->threshold = unbox_fixnum(xpGPR(xp, Iarg_x)); +#else + a->threshold = unbox_fixnum(xpGPR(xp, Itemp0)); +#endif + g1_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_y)); + g2_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_z)); + xpGPR(xp,Iarg_z) = lisp_nil+t_offset; + break; + + case GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD: + if (((signed_natural) arg) > 0) { + lisp_heap_gc_threshold = + align_to_power_of_2((arg-1) + + (heap_segment_size - 1), + log2_heap_segment_size); + } + /* fall through */ + case GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD: + xpGPR(xp, Iimm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD: + /* Try to put the current threshold in effect. This may + need to disable/reenable the EGC. */ + untenure_from_area(tenured_area); + resize_dynamic_heap(a->active,lisp_heap_gc_threshold); + if (egc_was_enabled) { + if ((a->high - a->active) >= a->threshold) { + tenure_to_area(tenured_area); + } + } + xpGPR(xp, Iimm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_FLASH_FREEZE: /* Like freeze below, but no GC */ + untenure_from_area(tenured_area); + gc_like_from_xp(xp,flash_freeze,0); + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + if (egc_was_enabled) { + tenure_to_area(tenured_area); + } + xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift; + break; + + default: + update_bytes_allocated(tcr, (void *) tcr->save_allocptr); + + if (selector == GC_TRAP_FUNCTION_IMMEDIATE_GC) { + if (!full_gc_deferred) { + gc_from_xp(xp, 0L); + break; + } + /* Tried to do a full GC when gc was disabled. That failed, + so try full GC now */ + selector = GC_TRAP_FUNCTION_GC; + } + + if (egc_was_enabled) { + egc_control(false, (BytePtr) a->active); + } + gc_from_xp(xp, 0L); + if (gc_deferred > gc_previously_deferred) { + full_gc_deferred = 1; + } else { + full_gc_deferred = 0; + } + if (selector > GC_TRAP_FUNCTION_GC) { + if (selector & GC_TRAP_FUNCTION_IMPURIFY) { + impurify_from_xp(xp, 0L); + /* nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */ + gc_from_xp(xp, 0L); + release_readonly_area(); + } + if (selector & GC_TRAP_FUNCTION_PURIFY) { + purify_from_xp(xp, 0L); + gc_from_xp(xp, 0L); + } + if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) { + OSErr err; + extern OSErr save_application(unsigned, Boolean); + area *vsarea = tcr->vs_area; + +#ifdef WINDOWS + arg = _open_osfhandle(arg,0); +#endif + nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1); + err = save_application(arg, egc_was_enabled); + if (err == noErr) { + _exit(0); + } + fatal_oserr(": save_application", err); + } + switch (selector) { + case GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE: + xpGPR(xp, Iimm0) = 0; + break; + case GC_TRAP_FUNCTION_FREEZE: + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift; + break; + default: + break; + } + } + if (egc_was_enabled) { + egc_control(true, NULL); + } + break; + } + return true; +} + + + + + +void +push_on_lisp_stack(ExceptionInformation *xp, LispObj value) +{ + LispObj *vsp = (LispObj *)xpGPR(xp,Isp); + *--vsp = value; + xpGPR(xp,Isp) = (LispObj)vsp; +} + + +/* Hard to know if or whether this is necessary in general. For now, + do it when we get a "wrong number of arguments" trap. +*/ +void +finish_function_entry(ExceptionInformation *xp) +{ + natural nargs = xpGPR(xp,Inargs)>>fixnumshift; + signed_natural disp = nargs - nargregs; + LispObj *vsp = (LispObj *) xpGPR(xp,Isp), ra = *vsp++; + + xpGPR(xp,Isp) = (LispObj) vsp; + + if (disp > 0) { /* implies that nargs > nargregs */ + vsp[disp] = xpGPR(xp,Ifp); + vsp[disp+1] = ra; + xpGPR(xp,Ifp) = (LispObj)(vsp+disp); +#ifdef X8664 + push_on_lisp_stack(xp,xpGPR(xp,Iarg_x)); +#endif + push_on_lisp_stack(xp,xpGPR(xp,Iarg_y)); + push_on_lisp_stack(xp,xpGPR(xp,Iarg_z)); + } else { + push_on_lisp_stack(xp,ra); + push_on_lisp_stack(xp,xpGPR(xp,Ifp)); + xpGPR(xp,Ifp) = xpGPR(xp,Isp); +#ifdef X8664 + if (nargs == 3) { + push_on_lisp_stack(xp,xpGPR(xp,Iarg_x)); + } +#endif + if (nargs >= 2) { + push_on_lisp_stack(xp,xpGPR(xp,Iarg_y)); + } + if (nargs >= 1) { + push_on_lisp_stack(xp,xpGPR(xp,Iarg_z)); + } + } +} + +Boolean +object_contains_pc(LispObj container, LispObj addr) +{ + if (fulltag_of(container) >= fulltag_misc) { + natural elements = header_element_count(header_of(container)); + if ((addr >= container) && + (addr < ((LispObj)&(deref(container,1+elements))))) { + return true; + } + } + return false; +} + +LispObj +create_exception_callback_frame(ExceptionInformation *xp, TCR *tcr) +{ + LispObj containing_uvector = 0, + relative_pc, + nominal_function = lisp_nil, + f, tra, tra_f = 0, abs_pc; + + f = xpGPR(xp,Ifn); + tra = *(LispObj*)(xpGPR(xp,Isp)); + +#ifdef X8664 + if (tag_of(tra) == tag_tra) { + if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(tra+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + int sdisp = (*(int *) (tra+3)); + tra_f = RECOVER_FN_FROM_RIP_LENGTH+tra+sdisp; + } + if (fulltag_of(tra_f) != fulltag_function) { + tra_f = 0; + } + } else { + tra = 0; + } +#endif +#ifdef X8632 + if (fulltag_of(tra) == fulltag_tra) { + if (*(unsigned char *)tra == RECOVER_FN_OPCODE) { + tra_f = (LispObj)*(LispObj *)(tra + 1); + } + if (tra_f && header_subtag(header_of(tra_f)) != subtag_function) { + tra_f = 0; + } + } else { + tra = 0; + } +#endif + + abs_pc = (LispObj)xpPC(xp); + +#ifdef X8664 + if (fulltag_of(f) == fulltag_function) +#else + if (fulltag_of(f) == fulltag_misc && + header_subtag(header_of(f)) == subtag_function) +#endif + { + nominal_function = f; + } else { + if (tra_f) { + nominal_function = tra_f; + } + } + + f = xpGPR(xp,Ifn); + if (object_contains_pc(f, abs_pc)) { + containing_uvector = untag(f)+fulltag_misc; + } else { + f = xpGPR(xp,Ixfn); + if (object_contains_pc(f, abs_pc)) { + containing_uvector = untag(f)+fulltag_misc; + } else { + if (tra_f) { + f = tra_f; + if (object_contains_pc(f, abs_pc)) { + containing_uvector = untag(f)+fulltag_misc; + relative_pc = (abs_pc - f) << fixnumshift; + } + } + } + } + if (containing_uvector) { + relative_pc = (abs_pc - (LispObj)&(deref(containing_uvector,1))) << fixnumshift; + } else { + containing_uvector = lisp_nil; + relative_pc = abs_pc << fixnumshift; + } + push_on_lisp_stack(xp,(LispObj)(tcr->xframe->prev)); + push_on_lisp_stack(xp,(LispObj)(tcr->foreign_sp)); + push_on_lisp_stack(xp,tra); + push_on_lisp_stack(xp,(LispObj)xp); + push_on_lisp_stack(xp,containing_uvector); + push_on_lisp_stack(xp,relative_pc); + push_on_lisp_stack(xp,nominal_function); + push_on_lisp_stack(xp,0); + push_on_lisp_stack(xp,xpGPR(xp,Ifp)); + xpGPR(xp,Ifp) = xpGPR(xp,Isp); + return xpGPR(xp,Isp); +} + +#ifndef XMEMFULL +#define XMEMFULL (76) +#endif + +void +lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed ) +{ + LispObj xcf = create_exception_callback_frame(xp, tcr), + cmain = nrs_CMAIN.vcell; + int skip; + + tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR; + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + + skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0); + xpPC(xp) += skip; +} + +/* + Allocate a large list, where "large" means "large enough to + possibly trigger the EGC several times if this was done + by individually allocating each CONS." The number of + ocnses in question is in arg_z; on successful return, + the list will be in arg_z +*/ + +Boolean +allocate_list(ExceptionInformation *xp, TCR *tcr) +{ + natural + nconses = (unbox_fixnum(xpGPR(xp,Iarg_z))), + bytes_needed = (nconses << dnode_shift); + LispObj + prev = lisp_nil, + current, + initial = xpGPR(xp,Iarg_y); + + if (nconses == 0) { + /* Silly case */ + xpGPR(xp,Iarg_z) = lisp_nil; + xpGPR(xp,Iallocptr) = lisp_nil; + return true; + } + update_bytes_allocated(tcr, (void *)tcr->save_allocptr); + if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) { + tcr->save_allocptr -= fulltag_cons; + for (current = xpGPR(xp,Iallocptr); + nconses; + prev = current, current+= dnode_size, nconses--) { + deref(current,0) = prev; + deref(current,1) = initial; + } + xpGPR(xp,Iarg_z) = prev; + } else { + lisp_allocation_failure(xp,tcr,bytes_needed); + } + return true; +} + +Boolean +handle_alloc_trap(ExceptionInformation *xp, TCR *tcr) +{ + natural cur_allocptr, bytes_needed; + unsigned allocptr_tag; + signed_natural disp; + + cur_allocptr = xpGPR(xp,Iallocptr); + allocptr_tag = fulltag_of(cur_allocptr); + if (allocptr_tag == fulltag_misc) { +#ifdef X8664 + disp = xpGPR(xp,Iimm1); +#else + disp = xpGPR(xp,Iimm0); +#endif + } else { + disp = dnode_size-fulltag_cons; + } + bytes_needed = disp+allocptr_tag; + + update_bytes_allocated(tcr,((BytePtr)(cur_allocptr+disp))); + if (allocate_object(xp, bytes_needed, disp, tcr)) { + return true; + } + + lisp_allocation_failure(xp,tcr,bytes_needed); + + return true; +} + + +int +callback_to_lisp (TCR * tcr, LispObj callback_macptr, ExceptionInformation *xp, + natural arg1, natural arg2, natural arg3, natural arg4, natural arg5) +{ + natural callback_ptr; + int delta; + unsigned old_mxcsr = get_mxcsr(); +#ifdef X8632 + natural saved_node_regs_mask = tcr->node_regs_mask; + natural saved_unboxed0 = tcr->unboxed0; + natural saved_unboxed1 = tcr->unboxed1; + LispObj *vsp = (LispObj *)xpGPR(xp, Isp); +#endif + + set_mxcsr(0x1f80); + + /* Put the active stack pointers where .SPcallback expects them */ +#ifdef X8632 + tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK; + + *--vsp = tcr->save0; + *--vsp = tcr->save1; + *--vsp = tcr->save2; + *--vsp = tcr->save3; + *--vsp = tcr->next_method_context; + xpGPR(xp, Isp) = (LispObj)vsp; +#endif + tcr->save_vsp = (LispObj *)xpGPR(xp, Isp); + tcr->save_fp = (LispObj *)xpGPR(xp, Ifp); + + /* Call back. The caller of this function may have modified stack/frame + pointers (and at least should have called prepare_for_callback()). + */ + callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address; + UNLOCK(lisp_global(EXCEPTION_LOCK), tcr); + delta = ((int (*)())callback_ptr) (xp, arg1, arg2, arg3, arg4, arg5); + LOCK(lisp_global(EXCEPTION_LOCK), tcr); + +#ifdef X8632 + tcr->next_method_context = *vsp++; + tcr->save3 = *vsp++; + tcr->save2 = *vsp++; + tcr->save1 = *vsp++; + tcr->save0 = *vsp++; + xpGPR(xp, Isp) = (LispObj)vsp; + + tcr->node_regs_mask = saved_node_regs_mask; + tcr->unboxed0 = saved_unboxed0; + tcr->unboxed1 = saved_unboxed1; +#endif + set_mxcsr(old_mxcsr); + return delta; +} + +void +callback_for_interrupt(TCR *tcr, ExceptionInformation *xp) +{ + LispObj *save_vsp = (LispObj *)xpGPR(xp,Isp), + word_beyond_vsp = save_vsp[-1], + save_fp = xpGPR(xp,Ifp), + xcf = create_exception_callback_frame(xp, tcr); + int save_errno = errno; + + callback_to_lisp(tcr, nrs_CMAIN.vcell,xp, xcf, 0, 0, 0, 0); + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = (LispObj)save_vsp; + save_vsp[-1] = word_beyond_vsp; + errno = save_errno; +} + +Boolean +handle_error(TCR *tcr, ExceptionInformation *xp) +{ + pc program_counter = (pc)xpPC(xp); + unsigned char op0 = program_counter[0], op1 = program_counter[1]; + LispObj rpc, errdisp = nrs_ERRDISP.vcell, + save_vsp = xpGPR(xp,Isp), xcf0, + save_fp = xpGPR(xp,Ifp); + int skip; + + if ((fulltag_of(errdisp) == fulltag_misc) && + (header_subtag(header_of(errdisp)) == subtag_macptr)) { + + if ((op0 == 0xcd) && (op1 >= 0xc0) && (op1 <= 0xc2)) { + finish_function_entry(xp); + } + xcf0 = create_exception_callback_frame(xp, tcr); + skip = callback_to_lisp(tcr, errdisp, xp, xcf0, 0, 0, 0, 0); + if (skip == -1) { + xcf *xcf1 = (xcf *)xcf0; + LispObj container = xcf1->containing_uvector; + + rpc = xcf1->relative_pc >> fixnumshift; + if (container == lisp_nil) { + xpPC(xp) = rpc; + } else { + xpPC(xp) = (LispObj)(&(deref(container, +#ifdef X8664 + 1 +#else + 0 +#endif +)))+rpc; + } + + skip = 0; + } + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = save_vsp; + if ((op0 == 0xcd) && (op1 == 0xc7)) { + /* Continue after an undefined function call. The function + that had been undefined has already been called (in the + break loop), and a list of the values that it returned + in in the xp's %arg_z. A function that returns those + values in in the xp's %fn; we just have to adjust the + stack (keeping the return address in the right place + and discarding any stack args/reserved stack frame), + then set nargs and the PC so that that function's + called when we resume. + */ + LispObj *vsp =(LispObj *)save_vsp, ra = *vsp; + int nargs = xpGPR(xp, Inargs)>>fixnumshift; + +#ifdef X8664 + if (nargs > 3) { + xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3))); + push_on_lisp_stack(xp,ra); + } +#else + if (nargs > 2) { + xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 2))); + push_on_lisp_stack(xp,ra); + } +#endif + xpPC(xp) = xpGPR(xp,Ifn); + xpGPR(xp,Inargs) = 1<why; + Boolean on_TSP = (which == kTSPsoftguard); + LispObj save_fp = xpGPR(xp,Ifp); + LispObj save_vsp = xpGPR(xp,Isp), + xcf, + cmain = nrs_CMAIN.vcell; + area *a; + protected_area_ptr soft; + TCR *tcr = get_tcr(false); + int skip; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + if (on_TSP) { + a = tcr->ts_area; + } else { + a = tcr->vs_area; + } + soft = a->softprot; + unprotect_area(soft); + xcf = create_exception_callback_frame(xp, tcr); + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, on_TSP, 0, 0); + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = save_vsp; + xpPC(xp) += skip; + return true; + } + return false; +} + +Boolean +is_write_fault(ExceptionInformation *xp, siginfo_t *info) +{ +#ifdef DARWIN + return (UC_MCONTEXT(xp)->__es.__err & 0x2) != 0; +#endif +#if defined(LINUX) || defined(SOLARIS) + return (xpGPR(xp,REG_ERR) & 0x2) != 0; +#endif +#ifdef FREEBSD + return (xp->uc_mcontext.mc_err & 0x2) != 0; +#endif +#ifdef WINDOWS + return (info->ExceptionFlags == EXCEPTION_WRITE_FAULT); +#endif +} + +Boolean +handle_fault(TCR *tcr, ExceptionInformation *xp, siginfo_t *info, int old_valence) +{ +#ifdef FREEBSD +#ifdef X8664 + BytePtr addr = (BytePtr) xp->uc_mcontext.mc_addr; +#else + BytePtr addr = (BytePtr) info->si_addr; +#endif +#else +#ifdef WINDOWS + BytePtr addr = (BytePtr) info->ExceptionInformation[1]; +#else + BytePtr addr = (BytePtr) info->si_addr; +#endif +#endif + Boolean valid = IS_PAGE_FAULT(info,xp); + + if (valid) { + if (addr && (addr == tcr->safe_ref_address)) { + xpGPR(xp,Iimm0) = 0; + xpPC(xp) = xpGPR(xp,Ira0); + return true; + } + + { + protected_area *a = find_protected_area(addr); + protection_handler *handler; + + if (a) { + handler = protection_handlers[a->why]; + return handler(xp, a, addr); + } + } + + if ((addr >= readonly_area->low) && + (addr < readonly_area->active)) { + UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), + page_size); + return true; + } + + { + area *a = area_containing(addr); + + if (a && a->code == AREA_WATCHED && addr < a->high) { + /* caught a write to a watched object */ + LispObj *p = (LispObj *)a->low; + LispObj node = *p; + unsigned tag_n = fulltag_of(node); + LispObj cmain = nrs_CMAIN.vcell; + LispObj obj; + + if (immheader_tag_p(tag_n) || nodeheader_tag_p(tag_n)) + obj = (LispObj)p + fulltag_misc; + else + obj = (LispObj)p + fulltag_cons; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + LispObj save_vsp = xpGPR(xp, Isp); + LispObj save_fp = xpGPR(xp, Ifp); + LispObj xcf; + natural offset = (LispObj)addr - obj; + int skip; + + push_on_lisp_stack(xp, obj); + xcf = create_exception_callback_frame(xp, tcr); + + /* The magic 2 means this was a write to a watchd object */ + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, + (natural)addr, offset); + xpPC(xp) += skip; + xpGPR(xp, Ifp) = save_fp; + xpGPR(xp, Isp) = save_vsp; + return true; + } + } + } + } + + if (old_valence == TCR_STATE_LISP) { + LispObj cmain = nrs_CMAIN.vcell, + xcf; + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + xcf = create_exception_callback_frame(xp, tcr); + callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, valid ? is_write_fault(xp,info) : (natural)-1, valid ? (natural)addr : 0, 0); + } + } + return false; +} + +Boolean +handle_floating_point_exception(TCR *tcr, ExceptionInformation *xp, siginfo_t *info) +{ + int code,skip; + LispObj xcf, cmain = nrs_CMAIN.vcell, + save_vsp = xpGPR(xp,Isp), + save_fp = xpGPR(xp,Ifp); +#ifdef WINDOWS + code = info->ExceptionCode; +#else + code = info->si_code; +#endif + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + xcf = create_exception_callback_frame(xp, tcr); + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0); + xpPC(xp) += skip; + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = save_vsp; + return true; + } else { + return false; + } +} + + +Boolean +extend_tcr_tlb(TCR *tcr, ExceptionInformation *xp) +{ + LispObj index, old_limit = tcr->tlb_limit, new_limit, new_bytes; + LispObj *old_tlb = tcr->tlb_pointer, *new_tlb, *work, *tos; + + tos = (LispObj*)(xpGPR(xp,Isp)); + index = *tos++; + (xpGPR(xp,Isp))=(LispObj)tos; + + new_limit = align_to_power_of_2(index+1,12); + new_bytes = new_limit-old_limit; + new_tlb = realloc(old_tlb, new_limit); + + if (new_tlb == NULL) { + return false; + } + work = (LispObj *) ((BytePtr)new_tlb+old_limit); + + while (new_bytes) { + *work++ = no_thread_local_binding_marker; + new_bytes -= sizeof(LispObj); + } + tcr->tlb_pointer = new_tlb; + tcr->tlb_limit = new_limit; + return true; +} + + +#if defined(FREEBSD) || defined(DARWIN) +static +char mxcsr_bit_to_fpe_code[] = { + FPE_FLTINV, /* ie */ + 0, /* de */ + FPE_FLTDIV, /* ze */ + FPE_FLTOVF, /* oe */ + FPE_FLTUND, /* ue */ + FPE_FLTRES /* pe */ +}; + +void +decode_vector_fp_exception(siginfo_t *info, uint32_t mxcsr) +{ + /* If the exception appears to be an XMM FP exception, try to + determine what it was by looking at bits in the mxcsr. + */ + int xbit, maskbit; + + for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) { + if ((mxcsr & (1 << xbit)) && + !(mxcsr & (1 << maskbit))) { + info->si_code = mxcsr_bit_to_fpe_code[xbit]; + return; + } + } +} + +#ifdef FREEBSD +void +freebsd_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp) +{ + if (info->si_code == 0) { +#ifdef X8664 + struct savefpu *fpu = (struct savefpu *) &(xp->uc_mcontext.mc_fpstate); +#else + struct ccl_savexmm *fpu = (struct ccl_savexmm *) &(xp->uc_mcontext.mc_fpstate); +#endif + uint32_t mxcsr = fpu->sv_env.en_mxcsr; + + decode_vector_fp_exception(info, mxcsr); + } +} +#endif + +#ifdef DARWIN +void +darwin_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp) +{ + if (info->si_code == EXC_I386_SSEEXTERR) { + uint32_t mxcsr = UC_MCONTEXT(xp)->__fs.__fpu_mxcsr; + + decode_vector_fp_exception(info, mxcsr); + } +} + +#endif + +#endif + +void +get_lisp_string(LispObj lisp_string, char *c_string, natural max) +{ + lisp_char_code *src = (lisp_char_code *) (ptr_from_lispobj(lisp_string + misc_data_offset)); + natural i, n = header_element_count(header_of(lisp_string)); + + if (n > max) { + n = max; + } + + for (i = 0; i < n; i++) { + c_string[i] = 0xff & (src[i]); + } + c_string[n] = 0; +} + +Boolean +handle_exception(int signum, siginfo_t *info, ExceptionInformation *context, TCR *tcr, int old_valence) +{ + pc program_counter = (pc)xpPC(context); + + switch (signum) { + case SIGNUM_FOR_INTN_TRAP: + if (IS_MAYBE_INT_TRAP(info,context)) { + /* Something mapped to SIGSEGV/SIGBUS that has nothing to do with + a memory fault. On x86, an "int n" instruction that's + not otherwise implemented causes a "protecton fault". Of + course that has nothing to do with accessing protected + memory; of course, most Unices act as if it did.*/ + if ((program_counter != NULL) && + (*program_counter == INTN_OPCODE)) { + program_counter++; + switch (*program_counter) { + case UUO_ALLOC_TRAP: + if (handle_alloc_trap(context, tcr)) { + xpPC(context) += 2; /* we might have GCed. */ + return true; + } + break; + case UUO_GC_TRAP: + if (handle_gc_trap(context, tcr)) { + xpPC(context) += 2; + return true; + } + break; + case UUO_WATCH_TRAP: + /* add or remove watched object */ + if (handle_watch_trap(context, tcr)) { + xpPC(context) += 2; + return true; + } + break; + case UUO_DEBUG_TRAP: + xpPC(context) = (natural) (program_counter+1); + lisp_Debugger(context, info, debug_entry_dbg, false, "Lisp Breakpoint"); + return true; + + case UUO_DEBUG_TRAP_WITH_STRING: + xpPC(context) = (natural) (program_counter+1); + { + char msg[512]; + + get_lisp_string(xpGPR(context,Iarg_z),msg, sizeof(msg)-1); + lisp_Debugger(context, info, debug_entry_dbg, false, msg); + } + return true; + + default: + return handle_error(tcr, context); + } + } else { + return false; + } + + } else { + return handle_fault(tcr, context, info, old_valence); + } + break; + + case SIGNAL_FOR_PROCESS_INTERRUPT: + tcr->interrupt_pending = 0; + callback_for_interrupt(tcr, context); + return true; + break; + + + case SIGILL: + if ((program_counter[0] == XUUO_OPCODE_0) && + (program_counter[1] == XUUO_OPCODE_1)) { + TCR *target = (TCR *)xpGPR(context, Iarg_z); + + switch (program_counter[2]) { + case XUUO_TLB_TOO_SMALL: + if (extend_tcr_tlb(tcr,context)) { + xpPC(context)+=3; + return true; + } + break; + + case XUUO_INTERRUPT_NOW: + callback_for_interrupt(tcr,context); + xpPC(context)+=3; + return true; + + case XUUO_SUSPEND_NOW: + xpPC(context)+=3; + return true; + + case XUUO_INTERRUPT: + raise_thread_interrupt(target); + xpPC(context)+=3; + return true; + + case XUUO_SUSPEND: + xpGPR(context,Iimm0) = (LispObj) lisp_suspend_tcr(target); + xpPC(context)+=3; + return true; + + case XUUO_SUSPEND_ALL: + lisp_suspend_other_threads(); + xpPC(context)+=3; + return true; + + + case XUUO_RESUME: + xpGPR(context,Iimm0) = (LispObj) lisp_resume_tcr(target); + xpPC(context)+=3; + return true; + + case XUUO_RESUME_ALL: + lisp_resume_other_threads(); + xpPC(context)+=3; + return true; + + case XUUO_KILL: + xpGPR(context,Iimm0) = (LispObj)kill_tcr(target); + xpPC(context)+=3; + return true; + + case XUUO_ALLOCATE_LIST: + allocate_list(context,tcr); + xpPC(context)+=3; + return true; + + default: + return false; + } + } else { + return false; + } + break; + + case SIGFPE: +#ifdef FREEBSD + /* As of 6.1, FreeBSD/AMD64 doesn't seem real comfortable + with this newfangled XMM business (and therefore info->si_code + is often 0 on an XMM FP exception. + Try to figure out what really happened by decoding mxcsr + bits. + */ + freebsd_decode_vector_fp_exception(info,context); +#endif +#ifdef DARWIN + /* Same general problem with Darwin as of 8.7.2 */ + darwin_decode_vector_fp_exception(info,context); +#endif + + return handle_floating_point_exception(tcr, context, info); + +#if SIGBUS != SIGNUM_FOR_INTN_TRAP + case SIGBUS: + return handle_fault(tcr, context, info, old_valence); +#endif + +#if SIGSEGV != SIGNUM_FOR_INTN_TRAP + case SIGSEGV: + return handle_fault(tcr, context, info, old_valence); +#endif + + default: + return false; + } +} + + +/* + Current thread has all signals masked. Before unmasking them, + make it appear that the current thread has been suspended. + (This is to handle the case where another thread is trying + to GC before this thread is able to seize the exception lock.) +*/ +int +prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context) +{ + int old_valence = tcr->valence; + + tcr->pending_exception_context = context; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + +#ifdef WINDOWS + if (tcr->flags & (1<suspend); + SEM_WAIT_FOREVER(tcr->resume); + } +#else + ALLOW_EXCEPTIONS(context); +#endif + return old_valence; +} + +void +wait_for_exception_lock_in_handler(TCR *tcr, + ExceptionInformation *context, + xframe_list *xf) +{ + + LOCK(lisp_global(EXCEPTION_LOCK), tcr); +#if 0 + fprintf(dbgout, "0x" LISP " has exception lock\n", tcr); +#endif + xf->curr = context; +#ifdef X8632 + xf->node_regs_mask = tcr->node_regs_mask; +#endif + xf->prev = tcr->xframe; + tcr->xframe = xf; + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_FOREIGN; +} + +void +unlock_exception_lock_in_handler(TCR *tcr) +{ + tcr->pending_exception_context = tcr->xframe->curr; +#ifdef X8632 + tcr->node_regs_mask = tcr->xframe->node_regs_mask; +#endif + tcr->xframe = tcr->xframe->prev; + tcr->valence = TCR_STATE_EXCEPTION_RETURN; + UNLOCK(lisp_global(EXCEPTION_LOCK),tcr); +#if 0 + fprintf(dbgout, "0x" LISP " released exception lock\n", tcr); +#endif +} + +/* + If an interrupt is pending on exception exit, try to ensure + that the thread sees it as soon as it's able to run. +*/ +#ifdef WINDOWS +void +raise_pending_interrupt(TCR *tcr) +{ +} +void +exit_signal_handler(TCR *tcr, int old_valence) +{ +} +void +signal_handler(int signum, siginfo_t *info, ExceptionInformation *context, TCR *tcr, int old_valence) +{ +} +#else +void +raise_pending_interrupt(TCR *tcr) +{ + if ((TCR_INTERRUPT_LEVEL(tcr) >= 0) && + (tcr->interrupt_pending)) { + pthread_kill((pthread_t)(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT); + } +} + +void +exit_signal_handler(TCR *tcr, int old_valence) +{ + sigset_t mask; + sigfillset(&mask); +#ifdef FREEBSD + sigdelset(&mask,SIGTRAP); +#endif + + pthread_sigmask(SIG_SETMASK,&mask, NULL); + tcr->valence = old_valence; + tcr->pending_exception_context = NULL; +} + +void +signal_handler(int signum, siginfo_t *info, ExceptionInformation *context +#ifdef DARWIN + , TCR *tcr, int old_valence +#endif +) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + xframe_list xframe_link; +#ifndef DARWIN + TCR *tcr = get_tcr(false); + + int old_valence = prepare_to_wait_for_exception_lock(tcr, context); +#endif + if (tcr->flags & (1<regs at #x" LISP "", signum, xpPC(context), (natural)xpGPRvector(context)); + + if (lisp_Debugger(context, info, signum, foreign, msg)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); + } + } + unlock_exception_lock_in_handler(tcr); +#ifndef DARWIN_USE_PSEUDO_SIGRETURN + exit_signal_handler(tcr, old_valence); +#endif + /* raise_pending_interrupt(tcr); */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif +#ifndef DARWIN_USE_PSEUDO_SIGRETURN + SIGRETURN(context); +#endif +} +#endif + + + + +#ifdef LINUX +/* type of pointer to saved fp state */ +#ifdef X8664 +typedef fpregset_t FPREGS; +#else +typedef struct _fpstate *FPREGS; +#endif +LispObj * +copy_fpregs(ExceptionInformation *xp, LispObj *current, FPREGS *destptr) +{ + FPREGS src = (FPREGS)(xp->uc_mcontext.fpregs), dest; + + if (src) { + dest = ((FPREGS)current)-1; + *dest = *src; + *destptr = dest; + current = (LispObj *) dest; + } + return current; +} +#endif + +#ifdef DARWIN +LispObj * +copy_darwin_mcontext(MCONTEXT_T context, + LispObj *current, + MCONTEXT_T *out) +{ + MCONTEXT_T dest = ((MCONTEXT_T)current)-1; + dest = (MCONTEXT_T) (((LispObj)dest) & ~15); + + *dest = *context; + *out = dest; + return (LispObj *)dest; +} +#endif + +LispObj * +copy_siginfo(siginfo_t *info, LispObj *current) +{ + siginfo_t *dest = ((siginfo_t *)current) - 1; +#if !defined(LINUX) || !defined(X8632) + dest = (siginfo_t *) (((LispObj)dest)&~15); +#endif + *dest = *info; + return (LispObj *)dest; +} + +#ifdef LINUX +typedef FPREGS copy_ucontext_last_arg_t; +#else +typedef void * copy_ucontext_last_arg_t; +#endif + +#ifndef WINDOWS +LispObj * +copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp) +{ + ExceptionInformation *dest = ((ExceptionInformation *)current)-1; +#if !defined(LINUX) || !defined(X8632) + dest = (ExceptionInformation *) (((LispObj)dest) & ~15); +#endif + + *dest = *context; + /* Fix it up a little; where's the signal mask allocated, if indeed + it is "allocated" ? */ +#ifdef LINUX + dest->uc_mcontext.fpregs = (fpregset_t)fp; +#endif + dest->uc_stack.ss_sp = 0; + dest->uc_stack.ss_size = 0; + dest->uc_stack.ss_flags = 0; + dest->uc_link = NULL; + return (LispObj *)dest; +} +#endif + + +LispObj * +tcr_frame_ptr(TCR *tcr) +{ + ExceptionInformation *xp; + LispObj *fp; + + if (tcr->pending_exception_context) + xp = tcr->pending_exception_context; + else if (tcr->valence == TCR_STATE_LISP) { + xp = tcr->suspend_context; + } else { + xp = NULL; + } + if (xp) { + fp = (LispObj *)xpGPR(xp, Ifp); + } else { + fp = tcr->save_fp; + } + return fp; +} + + +LispObj * +find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr) +{ + + if (((BytePtr)rsp < foreign_area->low) || + ((BytePtr)rsp > foreign_area->high)) { + rsp = (LispObj)(tcr->foreign_sp); + } + return (LispObj *) (((rsp-128) & ~15)); +} + +#ifdef X8632 +#ifdef LINUX +/* This is here for debugging. On entry to a signal handler that + receives info and context arguments, the stack should look exactly + like this. The "pretcode field" of the structure is the address + of code that does an rt_sigreturn syscall, and rt_sigreturn expects + %esp at the time of that syscall to be pointing just past the + pretcode field. + handle_signal_on_foreign_stack() and helpers have to be very + careful to duplicate this "structure" exactly. + Note that on x8664 Linux, rt_sigreturn expects a ucontext to + be on top of the stack (with a siginfo_t underneath it.) + It sort of half-works to do sigreturn via setcontext() on + x8632 Linux, but (a) it may not be available on some distributions + and (b) even a relatively modern version of it uses "fldenv" to + restore FP context, and "fldenv" isn't nearly good enough. +*/ + +struct rt_sigframe { + char *pretcode; + int sig; + siginfo_t *pinfo; + void *puc; + siginfo_t info; + struct ucontext uc; + struct _fpstate fpstate; + char retcode[8]; +}; +struct rt_sigframe *rtsf = 0; + +#endif +#endif + + +#ifndef WINDOWS +/* x8632 Linux requires that the stack-allocated siginfo is nearer + the top of stack than the stack-allocated ucontext. If other + platforms care, they expect the ucontext to be nearer the top + of stack. +*/ + +#if defined(LINUX) && defined(X8632) +#define UCONTEXT_ON_TOP_OF_STACK 0 +#else +#define UCONTEXT_ON_TOP_OF_STACK 1 +#endif +void +handle_signal_on_foreign_stack(TCR *tcr, + void *handler, + int signum, + siginfo_t *info, + ExceptionInformation *context, + LispObj return_address +#ifdef DARWIN_GS_HACK + , Boolean gs_was_tcr +#endif + ) +{ +#ifdef LINUX + FPREGS fpregs = NULL; +#else + void *fpregs = NULL; +#endif +#ifdef DARWIN + MCONTEXT_T mcontextp = NULL; +#endif + siginfo_t *info_copy = NULL; + ExceptionInformation *xp = NULL; + LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr); + +#ifdef LINUX + foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs); +#endif +#ifdef DARWIN + foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp); +#endif +#if UCONTEXT_ON_TOP_OF_STACK + /* copy info first */ + foreign_rsp = copy_siginfo(info, foreign_rsp); + info_copy = (siginfo_t *)foreign_rsp; + foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs); + xp = (ExceptionInformation *)foreign_rsp; +#else + foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs); + xp = (ExceptionInformation *)foreign_rsp; + foreign_rsp = copy_siginfo(info, foreign_rsp); + info_copy = (siginfo_t *)foreign_rsp; +#endif +#ifdef DARWIN + UC_MCONTEXT(xp) = mcontextp; +#endif + *--foreign_rsp = return_address; +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp); +} +#endif + + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ + TCR *tcr = get_interrupt_tcr(false); +#if 1 + if (tcr->valence != TCR_STATE_LISP) { + FBug(context, "exception in foreign context"); + } +#endif + { + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + handle_signal_on_foreign_stack(tcr, + signal_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + , false +#endif + + ); + } else { + signal_handler(signum, info, context, tcr, 0); + } + } +} + +#else +void +altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ + TCR* tcr = get_tcr(true); +#if 1 + if (tcr->valence != TCR_STATE_LISP) { + FBug(context, "exception in foreign context"); + } +#endif + handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + , false +#endif +); +} +#endif +#endif + +Boolean +stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr) +{ + area *a = tcr->vs_area; + + return (((BytePtr)stack_pointer <= a->high) && + ((BytePtr)stack_pointer > a->low)); +} + + +#ifdef WINDOWS +extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int); +#endif + +void +interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + int old_valence = tcr->valence; + + if (tcr) { + if ((TCR_INTERRUPT_LEVEL(tcr) < 0) || + (tcr->valence != TCR_STATE_LISP) || + (tcr->unwinding != 0) || + ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) || + ! stack_pointer_on_vstack_p(xpGPR(context,Ifp), tcr)) { + tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1))); + } else { + LispObj cmain = nrs_CMAIN.vcell; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + /* + This thread can (allegedly) take an interrupt now. + */ + + xframe_list xframe_link; + signed_natural alloc_displacement = 0; + LispObj + *next_tsp = tcr->next_tsp, + *save_tsp = tcr->save_tsp, + *p, + q; + natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION); + + tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION); + + if (next_tsp != save_tsp) { + tcr->next_tsp = save_tsp; + } else { + next_tsp = NULL; + } + /* have to do this before allowing interrupts */ + pc_luser_xp(context, tcr, &alloc_displacement); + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + wait_for_exception_lock_in_handler(tcr, context, &xframe_link); + handle_exception(signum, info, context, tcr, old_valence); + if (alloc_displacement) { + tcr->save_allocptr -= alloc_displacement; + } + if (next_tsp) { + tcr->next_tsp = next_tsp; + p = next_tsp; + while (p != save_tsp) { + *p++ = 0; + } + q = (LispObj)save_tsp; + *next_tsp = q; + } + tcr->flags |= old_foreign_exception; + unlock_exception_lock_in_handler(tcr); +#ifndef WINDOWS + exit_signal_handler(tcr, old_valence); +#endif + } + } + } +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif +#ifdef WINDOWS + restore_windows_context(context,tcr,old_valence); +#else + SIGRETURN(context); +#endif +} + + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + handle_signal_on_foreign_stack(tcr, + interrupt_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); + } else { + /* If we're not on the value stack, we pretty much have to be on + the C stack. Just run the handler. */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + interrupt_handler(signum, info, context); + } +} + +#else /* altstack works */ + +void +altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); +} + +#endif +#endif + +#ifndef WINDOWS +void +install_signal_handler(int signo, void * handler) +{ + struct sigaction sa; + + sa.sa_sigaction = (void *)handler; + sigfillset(&sa.sa_mask); +#ifdef FREEBSD + /* Strange FreeBSD behavior wrt synchronous signals */ + sigdelset(&sa.sa_mask,SIGTRAP); /* let GDB work */ +#endif + sa.sa_flags = + 0 /* SA_RESTART */ +#ifdef USE_SIGALTSTACK + | SA_ONSTACK +#endif + | SA_SIGINFO; + + sigaction(signo, &sa, NULL); +} +#endif + +#ifdef WINDOWS +BOOL +CALLBACK ControlEventHandler(DWORD event) +{ + switch(event) { + case CTRL_C_EVENT: + lisp_global(INTFLAG) = (1 << fixnumshift); + return TRUE; + break; + default: + return FALSE; + } +} + +static +DWORD mxcsr_bit_to_fpe_code[] = { + EXCEPTION_FLT_INVALID_OPERATION, /* ie */ + 0, /* de */ + EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */ + EXCEPTION_FLT_OVERFLOW, /* oe */ + EXCEPTION_FLT_UNDERFLOW, /* ue */ + EXCEPTION_FLT_INEXACT_RESULT /* pe */ +}; + +#ifndef STATUS_FLOAT_MULTIPLE_FAULTS +#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4 +#endif + +#ifndef STATUS_FLOAT_MULTIPLE_TRAPS +#define STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5 +#endif + +int +map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context) +{ + switch (code) { +#ifdef WIN_32 + case STATUS_FLOAT_MULTIPLE_FAULTS: + case STATUS_FLOAT_MULTIPLE_TRAPS: + { + int xbit, maskbit; + DWORD mxcsr = *(xpMXCSRptr(context)); + + for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) { + if ((mxcsr & (1 << xbit)) && + !(mxcsr & (1 << maskbit))) { + info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit]; + break; + } + } + } + return SIGFPE; +#endif + + case EXCEPTION_ACCESS_VIOLATION: + return SIGSEGV; + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INEXACT_RESULT: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + case EXCEPTION_INT_DIVIDE_BY_ZERO: + case EXCEPTION_INT_OVERFLOW: + return SIGFPE; + case EXCEPTION_PRIV_INSTRUCTION: + case EXCEPTION_ILLEGAL_INSTRUCTION: + return SIGILL; + case EXCEPTION_IN_PAGE_ERROR: + return SIGBUS; + default: + return -1; + } +} + + +LONG +windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr) +{ + DWORD code = exception_pointers->ExceptionRecord->ExceptionCode; + int old_valence, signal_number; + ExceptionInformation *context = exception_pointers->ContextRecord; + siginfo_t *info = exception_pointers->ExceptionRecord; + xframe_list xframes; + + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + wait_for_exception_lock_in_handler(tcr, context, &xframes); + + signal_number = map_windows_exception_code_to_posix_signal(code, info, context); + + if (!handle_exception(signal_number, info, context, tcr, old_valence)) { + char msg[512]; + Boolean foreign = (old_valence != TCR_STATE_LISP); + + snprintf(msg, sizeof(msg), "Unhandled exception %d (windows code 0x%x) at 0x%Ix, context->regs at 0x%Ix", signal_number, code, xpPC(context), (natural)xpGPRvector(context)); + + if (lisp_Debugger(context, info, signal_number, foreign, msg)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); + } + } + unlock_exception_lock_in_handler(tcr); + return restore_windows_context(context, tcr, old_valence); +} + +void +setup_exception_handler_call(CONTEXT *context, + LispObj new_sp, + void *handler, + EXCEPTION_POINTERS *new_ep, + TCR *tcr) +{ + extern void windows_halt(void); + LispObj *p = (LispObj *)new_sp; +#ifdef WIN_64 + p-=4; /* win64 abi argsave nonsense */ + *(--p) = (LispObj)windows_halt; + context->Rsp = (DWORD64)p; + context->Rip = (DWORD64)handler; + context->Rcx = (DWORD64)new_ep; + context->Rdx = (DWORD64)tcr; +#else + p-=4; /* args on stack, stack aligned */ + p[0] = (LispObj)new_ep; + p[1] = (LispObj)tcr; + *(--p) = (LispObj)windows_halt; + context->Esp = (DWORD)p; + context->Eip = (DWORD)handler; +#ifdef WIN32_ES_HACK + context->SegEs = context->SegDs; +#endif +#endif + context->EFlags &= ~0x400; /* clear direction flag */ +} + +void +prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr, + CONTEXT *context, + void *handler, + EXCEPTION_POINTERS *original_ep) +{ + LispObj foreign_rsp = + (LispObj) (tcr->foreign_sp - 128) & ~15; + CONTEXT *new_context; + siginfo_t *new_info; + EXCEPTION_POINTERS *new_ep; + + new_context = ((CONTEXT *)(foreign_rsp&~15))-1; + *new_context = *context; + foreign_rsp = (LispObj)new_context; + new_info = ((siginfo_t *)(foreign_rsp&~15))-1; + *new_info = *original_ep->ExceptionRecord; + foreign_rsp = (LispObj)new_info; + new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1; + foreign_rsp = (LispObj)new_ep & ~15; + new_ep->ContextRecord = new_context; + new_ep->ExceptionRecord = new_info; + setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr); +} + +LONG CALLBACK +windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers) +{ + extern void ensure_safe_for_string_operations(void); + DWORD code = exception_pointers->ExceptionRecord->ExceptionCode; + + + + if ((code & 0x80000000L) == 0) { + return EXCEPTION_CONTINUE_SEARCH; + } else { + TCR *tcr = get_interrupt_tcr(false); + area *cs = tcr->cs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + CONTEXT *context = exception_pointers->ContextRecord; + + ensure_safe_for_string_operations(); + + if ((current_sp >= cs->low) && + (current_sp < cs->high)) { + debug_show_registers(context, exception_pointers->ExceptionRecord, 0); + FBug(context, "Exception on foreign stack\n"); + return EXCEPTION_CONTINUE_EXECUTION; + } + + prepare_to_handle_windows_exception_on_foreign_stack(tcr, + context, + windows_exception_handler, + exception_pointers); + return EXCEPTION_CONTINUE_EXECUTION; + } +} + + +void +install_pmcl_exception_handlers() +{ + AddVectoredExceptionHandler(1,windows_arbstack_exception_handler); +} +#else +void +install_pmcl_exception_handlers() +{ +#ifndef DARWIN + void *handler = (void *) +#ifdef USE_SIGALTSTACK + altstack_signal_handler +#else + arbstack_signal_handler; +#endif + ; + install_signal_handler(SIGILL, handler); + + install_signal_handler(SIGBUS, handler); + install_signal_handler(SIGSEGV,handler); + install_signal_handler(SIGFPE, handler); +#endif + + install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, +#ifdef USE_SIGALTSTACK + altstack_interrupt_handler +#else + arbstack_interrupt_handler +#endif +); + signal(SIGPIPE, SIG_IGN); +} +#endif + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + if (tcr != NULL) { + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + return + handle_signal_on_foreign_stack(tcr, + suspend_resume_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); + } else { + /* If we're not on the value stack, we pretty much have to be on + the C stack. Just run the handler. */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + } + } + suspend_resume_handler(signum, info, context); +} + + +#else /* altstack works */ +void +altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR* tcr = get_tcr(true); + handle_signal_on_foreign_stack(tcr, + suspend_resume_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); +} +#endif +#endif + + +/* This should only be called when the tcr_area_lock is held */ +void +empty_tcr_stacks(TCR *tcr) +{ + if (tcr) { + area *a; + + tcr->valence = TCR_STATE_FOREIGN; + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + a = tcr->cs_area; + if (a) { + a->active = a->high; + } + } +} + +#ifdef WINDOWS +void +thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp) +{ +} +#else +void +thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_tcr(false); + sigset_t mask; + + sigemptyset(&mask); + + empty_tcr_stacks(tcr); + + pthread_sigmask(SIG_SETMASK,&mask,NULL); + pthread_exit(NULL); +} +#endif + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + handle_signal_on_foreign_stack(tcr, + thread_kill_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); + } else { + /* If we're not on the value stack, we pretty much have to be on + the C stack. Just run the handler. */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + thread_kill_handler(signum, info, context); + } +} + + +#else +void +altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR* tcr = get_tcr(true); + handle_signal_on_foreign_stack(tcr, + thread_kill_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); +} +#endif +#endif + +#ifdef USE_SIGALTSTACK +#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler +#define THREAD_KILL_HANDLER altstack_thread_kill_handler +#else +#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler +#define THREAD_KILL_HANDLER arbstack_thread_kill_handler +#endif + +#ifdef WINDOWS +void +thread_signal_setup() +{ +} +#else +void +thread_signal_setup() +{ + thread_suspend_signal = SIG_SUSPEND_THREAD; + thread_kill_signal = SIG_KILL_THREAD; + + install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER); + install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER); +} +#endif + +void +enable_fp_exceptions() +{ +} + +void +exception_init() +{ + install_pmcl_exception_handlers(); +} + +void +adjust_exception_pc(ExceptionInformation *xp, int delta) +{ + xpPC(xp) += delta; +} + +/* + Lower (move toward 0) the "end" of the soft protected area associated + with a by a page, if we can. +*/ + +void + +adjust_soft_protection_limit(area *a) +{ + char *proposed_new_soft_limit = a->softlimit - 4096; + protected_area_ptr p = a->softprot; + + if (proposed_new_soft_limit >= (p->start+16384)) { + p->end = proposed_new_soft_limit; + p->protsize = p->end-p->start; + a->softlimit = proposed_new_soft_limit; + } + protect_area(p); +} + +void +restore_soft_stack_limit(unsigned restore_tsp) +{ + TCR *tcr = get_tcr(false); + area *a; + + if (restore_tsp) { + a = tcr->ts_area; + } else { + a = tcr->vs_area; + } + adjust_soft_protection_limit(a); +} + + +#ifdef USE_SIGALTSTACK +void +setup_sigaltstack(area *a) +{ + stack_t stack; + stack.ss_sp = a->low; + a->low += SIGSTKSZ*8; + stack.ss_size = SIGSTKSZ*8; + stack.ss_flags = 0; + mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0); + if (sigaltstack(&stack, NULL) != 0) { + perror("sigaltstack"); + exit(-1); + } +} +#endif + +extern opcode egc_write_barrier_start, egc_write_barrier_end, + egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test, + egc_set_hash_key_conditional_retry, + egc_store_node_conditional_success_end, egc_store_node_conditional_retry, + egc_store_node_conditional_success_test,egc_store_node_conditional, + egc_set_hash_key, egc_gvset, egc_rplacd; + +/* We use (extremely) rigidly defined instruction sequences for consing, + mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted + while consing. + + Note that we can usually identify which of these instructions is about + to be executed by a stopped thread without comparing all of the bytes + to those at the stopped program counter, but we generally need to + know the sizes of each of these instructions. +*/ + +#ifdef X8664 +opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] = +#ifdef TCR_IN_GPR + {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00} +#else + {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00} +#endif +; +opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] = +#ifdef TCR_IN_GPR + {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00} +#else + {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00} +#endif + +; +opcode branch_around_alloc_trap_instruction[] = + {0x77,0x02}; +opcode alloc_trap_instruction[] = + {0xcd,0xc5}; +opcode clear_tcr_save_allocptr_tag_instruction[] = +#ifdef TCR_IN_GPR + {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0} +#else + {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0} +#endif +; +opcode set_allocptr_header_instruction[] = + {0x48,0x89,0x43,0xf3}; + + +alloc_instruction_id +recognize_alloc_instruction(pc program_counter) +{ + switch(program_counter[0]) { + case 0xcd: return ID_alloc_trap_instruction; + /* 0x7f is jg, which we used to use here instead of ja */ + case 0x7f: + case 0x77: return ID_branch_around_alloc_trap_instruction; + case 0x48: return ID_set_allocptr_header_instruction; +#ifdef TCR_IN_GPR + case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction; + case 0x49: + switch(program_counter[1]) { + case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction; + case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction; + } +#else + case 0x65: + switch(program_counter[1]) { + case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction; + case 0x48: + switch(program_counter[2]) { + case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction; + case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction; + } + } +#endif + default: break; + } + return ID_unrecognized_alloc_instruction; +} +#endif +#ifdef X8632 +/* The lisp assembler might use both a modrm byte and a sib byte to + encode a memory operand that contains a displacement but no + base or index. Using the sib byte is necessary for 64-bit code, + since the sib-less form is used to indicate %rip-relative addressing + on x8664. On x8632, it's not necessary, slightly suboptimal, and + doesn't match what we expect; until that's fixed, we may need to + account for this extra byte when adjusting the PC */ +#define LISP_ASSEMBLER_EXTRA_SIB_BYTE +#ifdef WIN32_ES_HACK +/* Win32 keeps the TCR in %es */ +#define TCR_SEG_PREFIX 0x26 /* %es: */ +#else +/* Other platfroms use %fs */ +#define TCR_SEG_PREFIX 0x64 /* %fs: */ +#endif +opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] = + {TCR_SEG_PREFIX,0x8b,0x0d,0x84,0x00,0x00,0x00}; /* may have extra SIB byte */ +opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] = + {TCR_SEG_PREFIX,0x3b,0x0d,0x88,0x00,0x00,0x00}; /* may have extra SIB byte */ +opcode branch_around_alloc_trap_instruction[] = + {0x77,0x02}; /* no SIB byte issue */ +opcode alloc_trap_instruction[] = + {0xcd,0xc5}; /* no SIB byte issue */ +opcode clear_tcr_save_allocptr_tag_instruction[] = + {TCR_SEG_PREFIX,0x80,0x25,0x84,0x00,0x00,0x00,0xf8}; /* maybe SIB byte */ +opcode set_allocptr_header_instruction[] = + {0x0f,0x7e,0x41,0xfa}; /* no SIB byte issue */ + +alloc_instruction_id +recognize_alloc_instruction(pc program_counter) +{ + switch(program_counter[0]) { + case 0xcd: return ID_alloc_trap_instruction; + /* 0x7f is jg, which we used to use here instead of ja */ + case 0x7f: + case 0x77: return ID_branch_around_alloc_trap_instruction; + case 0x0f: return ID_set_allocptr_header_instruction; + case TCR_SEG_PREFIX: + switch(program_counter[1]) { + case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction; + case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction; + case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction; + } + } + return ID_unrecognized_alloc_instruction; +} +#endif + +void +pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement) +{ + pc program_counter = (pc)xpPC(xp); + int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr)); + + if (allocptr_tag != 0) { + alloc_instruction_id state = recognize_alloc_instruction(program_counter); + signed_natural + disp = (allocptr_tag == fulltag_cons) ? + sizeof(cons) - fulltag_cons : +#ifdef X8664 + xpGPR(xp,Iimm1) +#else + xpGPR(xp,Iimm0) +#endif + ; + LispObj new_vector; + + if ((state == ID_unrecognized_alloc_instruction) || + ((state == ID_set_allocptr_header_instruction) && + (allocptr_tag != fulltag_misc))) { + Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr); + } + switch(state) { + case ID_set_allocptr_header_instruction: + /* We were consing a vector and we won. Set the header of the + new vector (in the allocptr register) to the header in %rax + (%mm0 on ia32) and skip over this instruction, then fall into + the next case. */ + new_vector = xpGPR(xp,Iallocptr); + deref(new_vector,0) = +#ifdef X8664 + xpGPR(xp,Iimm0) +#else + xpMMXreg(xp,Imm0) +#endif + ; + + xpPC(xp) += sizeof(set_allocptr_header_instruction); + + /* Fall thru */ + case ID_clear_tcr_save_allocptr_tag_instruction: + tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (((pc)(xpPC(xp)))[2] == 0x24) { + xpPC(xp) += 1; + } +#endif + xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction); + + break; + case ID_alloc_trap_instruction: + /* If we're looking at another thread, we're pretty much committed to + taking the trap. We don't want the allocptr register to be pointing + into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp' + was determined above. + */ + if (interrupt_displacement == NULL) { + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp; + tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp); + } else { + /* Back out, and tell the caller how to resume the allocation attempt */ + *interrupt_displacement = disp; + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + tcr->save_allocptr += disp; +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + /* This assumes that TCR_SEG_PREFIX can't appear + anywhere but at the beginning of one of these + magic allocation-sequence instructions. */ + xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+ + sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction)); + if (*((pc)(xpPC(xp))) == TCR_SEG_PREFIX) { + xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction); + } else { + xpPC(xp) -= (sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction) + 2); + } + +#else + xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+ + sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) + + sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction)); +#endif + } + break; + case ID_branch_around_alloc_trap_instruction: + /* If we'd take the branch - which is a "ja" - around the alloc trap, + we might as well finish the allocation. Otherwise, back out of the + attempt. */ + { + int flags = (int)eflags_register(xp); + + if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) && + (!(flags & (1 << X86_CARRY_FLAG_BIT)))) { + /* The branch (ja) would have been taken. Emulate taking it. */ + xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+ + sizeof(alloc_trap_instruction)); + if (allocptr_tag == fulltag_misc) { + /* Slap the header on the new uvector */ + new_vector = xpGPR(xp,Iallocptr); + deref(new_vector,0) = xpGPR(xp,Iimm0); + xpPC(xp) += sizeof(set_allocptr_header_instruction); + } + tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (((pc)xpPC(xp))[2] == 0x24) { + xpPC(xp) += 1; + } +#endif + xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction); + } else { + /* Back up */ + xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) + + sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction)); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (*((pc)(xpPC(xp))) != TCR_SEG_PREFIX) { + /* skipped two instructions with extra SIB byte */ + xpPC(xp) -= 2; + } +#endif + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + if (interrupt_displacement) { + *interrupt_displacement = disp; + tcr->save_allocptr += disp; + } else { + tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp); + } + } + } + break; + case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction: + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (*((pc)xpPC(xp)) != TCR_SEG_PREFIX) { + xpPC(xp) -= 1; + } +#endif + /* Fall through */ + case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction: + if (interrupt_displacement) { + tcr->save_allocptr += disp; + *interrupt_displacement = disp; + } else { + tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp); + } + break; + default: + break; + } + return; + } + if ((program_counter >= &egc_write_barrier_start) && + (program_counter < &egc_write_barrier_end)) { + LispObj *ea = 0, val, root = 0; + bitvector refbits = (bitvector)(lisp_global(REFBITS)); + Boolean need_store = true, need_check_memo = true, need_memoize_root = false; + + if (program_counter >= &egc_set_hash_key_conditional) { + if (program_counter <= &egc_set_hash_key_conditional_retry) { + return; + } + if ((program_counter < &egc_set_hash_key_conditional_success_test) || + ((program_counter == &egc_set_hash_key_conditional_success_test) && + !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) { + /* Back up the PC, try again */ + xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry; + return; + } + /* The conditional store succeeded. Set the refbit, return to ra0 */ + val = xpGPR(xp,Iarg_z); +#ifdef X8664 + root = xpGPR(xp,Iarg_x); + ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0)))); +#else + root = xpGPR(xp,Itemp1); + ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0)); +#endif + need_memoize_root = true; + need_store = false; + xpGPR(xp,Iarg_z) = t_value; + } else if (program_counter >= &egc_store_node_conditional) { + if (program_counter <= &egc_store_node_conditional_retry) { + return; + } + if ((program_counter < &egc_store_node_conditional_success_test) || + ((program_counter == &egc_store_node_conditional_success_test) && + !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) { + /* Back up the PC, try again */ + xpPC(xp) = (LispObj) &egc_store_node_conditional_retry; + return; + } + if (program_counter >= &egc_store_node_conditional_success_end) { + return; + } + + /* The conditional store succeeded. Set the refbit, return to ra0 */ + val = xpGPR(xp,Iarg_z); +#ifdef X8664 + ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural) + xpGPR(xp,Itemp0)))); +#else + ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0)); +#endif + xpGPR(xp,Iarg_z) = t_value; + need_store = false; + } else if (program_counter >= &egc_set_hash_key) { +#ifdef X8664 + root = xpGPR(xp,Iarg_x); +#else + root = xpGPR(xp,Itemp0); +#endif + ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset); + val = xpGPR(xp,Iarg_z); + need_memoize_root = true; + } else if (program_counter >= &egc_gvset) { +#ifdef X8664 + ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset); +#else + ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset); +#endif + val = xpGPR(xp,Iarg_z); + } else if (program_counter >= &egc_rplacd) { + ea = (LispObj *) untag(xpGPR(xp,Iarg_y)); + val = xpGPR(xp,Iarg_z); + } else { /* egc_rplaca */ + ea = ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1; + val = xpGPR(xp,Iarg_z); + } + if (need_store) { + *ea = val; + } + if (need_check_memo) { + natural bitnumber = area_dnode(ea, lisp_global(HEAP_START)); + if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) && + ((LispObj)ea < val)) { + atomic_set_bit(refbits, bitnumber); + if (need_memoize_root) { + bitnumber = area_dnode(root, lisp_global(HEAP_START)); + atomic_set_bit(refbits, bitnumber); + } + } + } + { + /* These subprimitives are called via CALL/RET; need + to pop the return address off the stack and set + the PC there. */ + LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++; + xpPC(xp) = ra; + xpGPR(xp,Isp)=(LispObj)sp; + } + return; + } +} + + +void +normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr) +{ + void *cur_allocptr = (void *)(tcr->save_allocptr); + LispObj lisprsp; + area *a; + + if (xp) { + if (is_other_tcr) { + pc_luser_xp(xp, tcr, NULL); + } + a = tcr->vs_area; + lisprsp = xpGPR(xp, Isp); + if (((BytePtr)lisprsp >= a->low) && + ((BytePtr)lisprsp < a->high)) { + a->active = (BytePtr)lisprsp; + } else { + a->active = (BytePtr) tcr->save_vsp; + } + a = tcr->ts_area; + a->active = (BytePtr) tcr->save_tsp; + } else { + /* In ff-call; get area active pointers from tcr */ + tcr->vs_area->active = (BytePtr) tcr->save_vsp; + tcr->ts_area->active = (BytePtr) tcr->save_tsp; + } + if (cur_allocptr) { + update_bytes_allocated(tcr, cur_allocptr); + } + tcr->save_allocbase = (void *)VOID_ALLOCPTR; + if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) { + tcr->save_allocptr = (void *)VOID_ALLOCPTR; + } +} + + +/* Suspend and "normalize" other tcrs, then call a gc-like function + in that context. Resume the other tcrs, then return what the + function returned */ + +TCR *gc_tcr = NULL; + + +signed_natural +gc_like_from_xp(ExceptionInformation *xp, + signed_natural(*fun)(TCR *, signed_natural), + signed_natural param) +{ + TCR *tcr = get_tcr(false), *other_tcr; + int result; + signed_natural inhibit; + + suspend_other_threads(true); + inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + if (inhibit != 0) { + if (inhibit > 0) { + lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit); + } + resume_other_threads(true); + gc_deferred++; + return 0; + } + gc_deferred = 0; + + gc_tcr = tcr; + + /* This is generally necessary if the current thread invoked the GC + via an alloc trap, and harmless if the GC was invoked via a GC + trap. (It's necessary in the first case because the "allocptr" + register - %rbx - may be pointing into the middle of something + below tcr->save_allocbase, and we wouldn't want the GC to see + that bogus pointer.) */ + xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; + + normalize_tcr(xp, tcr, false); + + + for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) { + if (other_tcr->pending_exception_context) { + other_tcr->gc_context = other_tcr->pending_exception_context; + } else if (other_tcr->valence == TCR_STATE_LISP) { + other_tcr->gc_context = other_tcr->suspend_context; + } else { + /* no pending exception, didn't suspend in lisp state: + must have executed a synchronous ff-call. + */ + other_tcr->gc_context = NULL; + } + normalize_tcr(other_tcr->gc_context, other_tcr, true); + } + + + + result = fun(tcr, param); + + other_tcr = tcr; + do { + other_tcr->gc_context = NULL; + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + gc_tcr = NULL; + + resume_other_threads(true); + + return result; + +} + +signed_natural +purify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, purify, param); +} + +signed_natural +impurify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, impurify, param); +} + +/* Returns #bytes freed by invoking GC */ + +signed_natural +gc_from_tcr(TCR *tcr, signed_natural param) +{ + area *a; + BytePtr oldfree, newfree; + BytePtr oldend, newend; + +#if 0 + fprintf(dbgout, "Start GC in 0x" LISP "\n", tcr); +#endif + a = active_dynamic_area; + oldend = a->high; + oldfree = a->active; + gc(tcr, param); + newfree = a->active; + newend = a->high; +#if 0 + fprintf(dbgout, "End GC in 0x" LISP "\n", tcr); +#endif + return ((oldfree-newfree)+(newend-oldend)); +} + +signed_natural +gc_from_xp(ExceptionInformation *xp, signed_natural param) +{ + signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param); + + freeGCptrs(); + return status; +} + +#ifdef DARWIN + +#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p)) +#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr))) + +extern void pseudo_sigreturn(void); + + + +#define LISP_EXCEPTIONS_HANDLED_MASK \ + (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC) + +/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */ +#define NUM_LISP_EXCEPTIONS_HANDLED 4 + +typedef struct { + int foreign_exception_port_count; + exception_mask_t masks[NUM_LISP_EXCEPTIONS_HANDLED]; + mach_port_t ports[NUM_LISP_EXCEPTIONS_HANDLED]; + exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED]; + thread_state_flavor_t flavors[NUM_LISP_EXCEPTIONS_HANDLED]; +} MACH_foreign_exception_state; + + + + +/* + Mach's exception mechanism works a little better than its signal + mechanism (and, not incidentally, it gets along with GDB a lot + better. + + Initially, we install an exception handler to handle each native + thread's exceptions. This process involves creating a distinguished + thread which listens for kernel exception messages on a set of + 0 or more thread exception ports. As threads are created, they're + added to that port set; a thread's exception port is destroyed + (and therefore removed from the port set) when the thread exits. + + A few exceptions can be handled directly in the handler thread; + others require that we resume the user thread (and that the + exception thread resumes listening for exceptions.) The user + thread might eventually want to return to the original context + (possibly modified somewhat.) + + As it turns out, the simplest way to force the faulting user + thread to handle its own exceptions is to do pretty much what + signal() does: the exception handlng thread sets up a sigcontext + on the user thread's stack and forces the user thread to resume + execution as if a signal handler had been called with that + context as an argument. We can use a distinguished UUO at a + distinguished address to do something like sigreturn(); that'll + have the effect of resuming the user thread's execution in + the (pseudo-) signal context. + + Since: + a) we have miles of code in C and in Lisp that knows how to + deal with Linux sigcontexts + b) Linux sigcontexts contain a little more useful information + (the DAR, DSISR, etc.) than their Darwin counterparts + c) we have to create a sigcontext ourselves when calling out + to the user thread: we aren't really generating a signal, just + leveraging existing signal-handling code. + + we create a Linux sigcontext struct. + + Simple ? Hopefully from the outside it is ... + + We want the process of passing a thread's own context to it to + appear to be atomic: in particular, we don't want the GC to suspend + a thread that's had an exception but has not yet had its user-level + exception handler called, and we don't want the thread's exception + context to be modified by a GC while the Mach handler thread is + copying it around. On Linux (and on Jaguar), we avoid this issue + because (a) the kernel sets up the user-level signal handler and + (b) the signal handler blocks signals (including the signal used + by the GC to suspend threads) until tcr->xframe is set up. + + The GC and the Mach server thread therefore contend for the lock + "mach_exception_lock". The Mach server thread holds the lock + when copying exception information between the kernel and the + user thread; the GC holds this lock during most of its execution + (delaying exception processing until it can be done without + GC interference.) + +*/ + +#ifdef PPC64 +#define C_REDZONE_LEN 320 +#define C_STK_ALIGN 32 +#else +#define C_REDZONE_LEN 224 +#define C_STK_ALIGN 16 +#endif +#define C_PARAMSAVE_LEN 64 +#define C_LINKAGE_LEN 48 + +#define TRUNC_DOWN(a,b,c) (((((natural)a)-(b))/(c)) * (c)) + +void +fatal_mach_error(char *format, ...); + +#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);} + + +void +restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext) +{ + kern_return_t kret; +#if WORD_SIZE == 64 + MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext); +#else + mcontext_t mc = UC_MCONTEXT(pseudosigcontext); +#endif + + /* Set the thread's FP state from the pseudosigcontext */ +#if WORD_SIZE == 64 + kret = thread_set_state(thread, + x86_FLOAT_STATE64, + (thread_state_t)&(mc->__fs), + x86_FLOAT_STATE64_COUNT); +#else + kret = thread_set_state(thread, + x86_FLOAT_STATE32, + (thread_state_t)&(mc->__fs), + x86_FLOAT_STATE32_COUNT); +#endif + MACH_CHECK_ERROR("setting thread FP state", kret); + + /* The thread'll be as good as new ... */ +#if WORD_SIZE == 64 + kret = thread_set_state(thread, + x86_THREAD_STATE64, + (thread_state_t)&(mc->__ss), + x86_THREAD_STATE64_COUNT); +#else + kret = thread_set_state(thread, + x86_THREAD_STATE32, + (thread_state_t)&(mc->__ss), + x86_THREAD_STATE32_COUNT); +#endif + MACH_CHECK_ERROR("setting thread state", kret); +} + +/* This code runs in the exception handling thread, in response + to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g., + in response to a call to pseudo_sigreturn() from the specified + user thread. + Find that context (the user thread's R3 points to it), then + use that context to set the user thread's state. When this + function's caller returns, the Mach kernel will resume the + user thread. +*/ + +kern_return_t +do_pseudo_sigreturn(mach_port_t thread, TCR *tcr) +{ + ExceptionInformation *xp; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr); +#endif + xp = tcr->pending_exception_context; + if (xp) { + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_LISP; + restore_mach_thread_state(thread, xp); + raise_pending_interrupt(tcr); + } else { + Bug(NULL, "no xp here!\n"); + } +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr); +#endif + return KERN_SUCCESS; +} + +ExceptionInformation * +create_thread_context_frame(mach_port_t thread, + natural *new_stack_top, + siginfo_t **info_ptr, + TCR *tcr, +#ifdef X8664 + x86_thread_state64_t *ts +#else + x86_thread_state32_t *ts +#endif + ) +{ + mach_msg_type_number_t thread_state_count; + ExceptionInformation *pseudosigcontext; +#ifdef X8664 + MCONTEXT_T mc; +#else + mcontext_t mc; +#endif + natural stackp; + +#ifdef X8664 + stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr); + stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN); +#else + stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr); +#endif + stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN); + if (info_ptr) { + *info_ptr = (siginfo_t *)stackp; + } + stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN); + pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp); + + stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN); + mc = (MCONTEXT_T) ptr_from_lispobj(stackp); + + memmove(&(mc->__ss),ts,sizeof(*ts)); + +#ifdef X8664 + thread_state_count = x86_FLOAT_STATE64_COUNT; + thread_get_state(thread, + x86_FLOAT_STATE64, + (thread_state_t)&(mc->__fs), + &thread_state_count); + + thread_state_count = x86_EXCEPTION_STATE64_COUNT; + thread_get_state(thread, + x86_EXCEPTION_STATE64, + (thread_state_t)&(mc->__es), + &thread_state_count); +#else + thread_state_count = x86_FLOAT_STATE32_COUNT; + thread_get_state(thread, + x86_FLOAT_STATE32, + (thread_state_t)&(mc->__fs), + &thread_state_count); + + thread_state_count = x86_EXCEPTION_STATE32_COUNT; + thread_get_state(thread, + x86_EXCEPTION_STATE32, + (thread_state_t)&(mc->__es), + &thread_state_count); +#endif + + + UC_MCONTEXT(pseudosigcontext) = mc; + if (new_stack_top) { + *new_stack_top = stackp; + } + return pseudosigcontext; +} + +/* + This code sets up the user thread so that it executes a "pseudo-signal + handler" function when it resumes. Create a fake ucontext struct + on the thread's stack and pass it as an argument to the pseudo-signal + handler. + + Things are set up so that the handler "returns to" pseudo_sigreturn(), + which will restore the thread's context. + + If the handler invokes code that throws (or otherwise never sigreturn()'s + to the context), that's fine. + + Actually, check that: throw (and variants) may need to be careful and + pop the tcr's xframe list until it's younger than any frame being + entered. +*/ + +int +setup_signal_frame(mach_port_t thread, + void *handler_address, + int signum, + int code, + TCR *tcr, +#ifdef X8664 + x86_thread_state64_t *ts +#else + x86_thread_state32_t *ts +#endif + ) +{ +#ifdef X8664 + x86_thread_state64_t new_ts; +#else + x86_thread_state32_t new_ts; +#endif + ExceptionInformation *pseudosigcontext; + int old_valence = tcr->valence; + natural stackp, *stackpp; + siginfo_t *info; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr); +#endif + pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr, ts); + bzero(info, sizeof(*info)); + info->si_code = code; + info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr); + info->si_signo = signum; + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + pseudosigcontext->uc_stack.ss_sp = 0; + pseudosigcontext->uc_stack.ss_size = 0; + pseudosigcontext->uc_stack.ss_flags = 0; + pseudosigcontext->uc_link = NULL; + pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext)); + tcr->pending_exception_context = pseudosigcontext; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + + + /* + It seems like we've created a sigcontext on the thread's + stack. Set things up so that we call the handler (with appropriate + args) when the thread's resumed. + */ + +#ifdef X8664 + new_ts.__rip = (natural) handler_address; + stackpp = (natural *)stackp; + *--stackpp = (natural)pseudo_sigreturn; + stackp = (natural)stackpp; + new_ts.__rdi = signum; + new_ts.__rsi = (natural)info; + new_ts.__rdx = (natural)pseudosigcontext; + new_ts.__rcx = (natural)tcr; + new_ts.__r8 = (natural)old_valence; + new_ts.__rsp = stackp; + new_ts.__rflags = ts->__rflags; +#else +#define USER_CS 0x17 +#define USER_DS 0x1f + bzero(&new_ts, sizeof(new_ts)); + new_ts.__cs = ts->__cs; + new_ts.__ss = ts->__ss; + new_ts.__ds = ts->__ds; + new_ts.__es = ts->__es; + new_ts.__fs = ts->__fs; + new_ts.__gs = ts->__gs; + + new_ts.__eip = (natural)handler_address; + stackpp = (natural *)stackp; + *--stackpp = 0; /* alignment */ + *--stackpp = 0; + *--stackpp = 0; + *--stackpp = (natural)old_valence; + *--stackpp = (natural)tcr; + *--stackpp = (natural)pseudosigcontext; + *--stackpp = (natural)info; + *--stackpp = (natural)signum; + *--stackpp = (natural)pseudo_sigreturn; + stackp = (natural)stackpp; + new_ts.__esp = stackp; + new_ts.__eflags = ts->__eflags; +#endif + +#ifdef X8664 + thread_set_state(thread, + x86_THREAD_STATE64, + (thread_state_t)&new_ts, + x86_THREAD_STATE64_COUNT); +#else + thread_set_state(thread, + x86_THREAD_STATE32, + (thread_state_t)&new_ts, + x86_THREAD_STATE32_COUNT); +#endif +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context); +#endif + return 0; +} + + + + + + +/* + This function runs in the exception handling thread. It's + called (by this precise name) from the library function "exc_server()" + when the thread's exception ports are set up. (exc_server() is called + via mach_msg_server(), which is a function that waits for and dispatches + on exception messages from the Mach kernel.) + + This checks to see if the exception was caused by a pseudo_sigreturn() + UUO; if so, it arranges for the thread to have its state restored + from the specified context. + + Otherwise, it tries to map the exception to a signal number and + arranges that the thread run a "pseudo signal handler" to handle + the exception. + + Some exceptions could and should be handled here directly. +*/ + +/* We need the thread's state earlier on x86_64 than we did on PPC; + the PC won't fit in code_vector[1]. We shouldn't try to get it + lazily (via catch_exception_raise_state()); until we own the + exception lock, we shouldn't have it in userspace (since a GCing + thread wouldn't know that we had our hands on it.) +*/ + +#ifdef X8664 +#define ts_pc(t) t.__rip +#else +#define ts_pc(t) t.__eip +#endif + + +#define DARWIN_EXCEPTION_HANDLER signal_handler + + +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_vector, + mach_msg_type_number_t code_count) +{ + int signum = 0, code = *code_vector; + TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port); + kern_return_t kret, call_kret; +#ifdef X8664 + x86_thread_state64_t ts; +#else + x86_thread_state32_t ts; +#endif + mach_msg_type_number_t thread_state_count; + + + + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "obtaining Mach exception lock in exception thread\n"); +#endif + + + if (1) { +#ifdef X8664 + do { + thread_state_count = x86_THREAD_STATE64_COUNT; + call_kret = thread_get_state(thread, + x86_THREAD_STATE64, + (thread_state_t)&ts, + &thread_state_count); + } while (call_kret == KERN_ABORTED); + MACH_CHECK_ERROR("getting thread state",call_kret); +#else + thread_state_count = x86_THREAD_STATE32_COUNT; + call_kret = thread_get_state(thread, + x86_THREAD_STATE32, + (thread_state_t)&ts, + &thread_state_count); + MACH_CHECK_ERROR("getting thread state",call_kret); +#endif + if (tcr->flags & (1<flags & (1<native_thread_info; + int i; + unsigned n = NUM_LISP_EXCEPTIONS_HANDLED; + mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port; + exception_mask_t mask = 0; + + kret = thread_swap_exception_ports(thread, + LISP_EXCEPTIONS_HANDLED_MASK, + lisp_port, + EXCEPTION_DEFAULT, + THREAD_STATE_NONE, + fxs->masks, + &n, + fxs->ports, + fxs->behaviors, + fxs->flavors); + if (kret == KERN_SUCCESS) { + fxs->foreign_exception_port_count = n; + for (i = 0; i < n; i ++) { + foreign_port = fxs->ports[i]; + + if ((foreign_port != lisp_port) && + (foreign_port != MACH_PORT_NULL)) { + mask |= fxs->masks[i]; + } + } + tcr->foreign_exception_status = (int) mask; + } + return kret; +} + +kern_return_t +tcr_establish_lisp_exception_port(TCR *tcr) +{ + return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id)); +} + +/* + Do this when calling out to or returning from foreign code, if + any conflicting foreign exception ports were established when we + last entered lisp code. +*/ +kern_return_t +restore_foreign_exception_ports(TCR *tcr) +{ + exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status; + + if (m) { + MACH_foreign_exception_state *fxs = + (MACH_foreign_exception_state *) tcr->native_thread_info; + int i, n = fxs->foreign_exception_port_count; + exception_mask_t tm; + + for (i = 0; i < n; i++) { + if ((tm = fxs->masks[i]) & m) { + thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id), + tm, + fxs->ports[i], + fxs->behaviors[i], + fxs->flavors[i]); + } + } + } +} + + +/* + This assumes that a Mach port (to be used as the thread's exception port) whose + "name" matches the TCR's 32-bit address has already been allocated. +*/ + +kern_return_t +setup_mach_exception_handling(TCR *tcr) +{ + mach_port_t + thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr), + task_self = mach_task_self(); + kern_return_t kret; + + kret = mach_port_insert_right(task_self, + thread_exception_port, + thread_exception_port, + MACH_MSG_TYPE_MAKE_SEND); + MACH_CHECK_ERROR("adding send right to exception_port",kret); + + kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id)); + if (kret == KERN_SUCCESS) { + mach_port_t exception_port_set = mach_exception_port_set(); + + kret = mach_port_move_member(task_self, + thread_exception_port, + exception_port_set); + } + return kret; +} + +void +darwin_exception_init(TCR *tcr) +{ + void tcr_monitor_exception_handling(TCR*, Boolean); + kern_return_t kret; + MACH_foreign_exception_state *fxs = + calloc(1, sizeof(MACH_foreign_exception_state)); + + tcr->native_thread_info = (void *) fxs; + + if ((kret = setup_mach_exception_handling(tcr)) + != KERN_SUCCESS) { + fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret); + terminate_lisp(); + } + lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports; + lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port; +} + +/* + The tcr is the "name" of the corresponding thread's exception port. + Destroying the port should remove it from all port sets of which it's + a member (notably, the exception port set.) +*/ +void +darwin_exception_cleanup(TCR *tcr) +{ + void *fxs = tcr->native_thread_info; + extern Boolean use_mach_exception_handling; + + if (fxs) { + tcr->native_thread_info = NULL; + free(fxs); + } + if (use_mach_exception_handling) { + mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + } +} + + +Boolean +suspend_mach_thread(mach_port_t mach_thread) +{ + kern_return_t status; + Boolean aborted = false; + + do { + aborted = false; + status = thread_suspend(mach_thread); + if (status == KERN_SUCCESS) { + status = thread_abort_safely(mach_thread); + if (status == KERN_SUCCESS) { + aborted = true; + } else { + fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread); + thread_resume(mach_thread); + } + } else { + return false; + } + } while (! aborted); + return true; +} + +/* + Only do this if pthread_kill indicated that the pthread isn't + listening to signals anymore, as can happen as soon as pthread_exit() + is called on Darwin. The thread could still call out to lisp as it + is exiting, so we need another way to suspend it in this case. +*/ +Boolean +mach_suspend_tcr(TCR *tcr) +{ + mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id)); + ExceptionInformation *pseudosigcontext; + Boolean result = false; + + result = suspend_mach_thread(mach_thread); + if (result) { + mach_msg_type_number_t thread_state_count; +#ifdef X8664 + x86_thread_state64_t ts; + thread_state_count = x86_THREAD_STATE64_COUNT; + thread_get_state(mach_thread, + x86_THREAD_STATE64, + (thread_state_t)&ts, + &thread_state_count); +#else + x86_thread_state32_t ts; + thread_state_count = x86_THREAD_STATE_COUNT; + thread_get_state(mach_thread, + x86_THREAD_STATE, + (thread_state_t)&ts, + &thread_state_count); +#endif + + pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts); + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + tcr->suspend_context = pseudosigcontext; + } + return result; +} + +void +mach_resume_tcr(TCR *tcr) +{ + ExceptionInformation *xp; + mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id)); + + xp = tcr->suspend_context; +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + tcr->suspend_context = NULL; + restore_mach_thread_state(mach_thread, xp); +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + thread_resume(mach_thread); +} + +void +fatal_mach_error(char *format, ...) +{ + va_list args; + char s[512]; + + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + + Fatal("Mach error", s); +} + + + + +#endif + +/* watchpoint stuff */ + +area * +new_watched_area(natural size) +{ + void *p; + + p = MapMemory(NULL, size, MEMPROTECT_RWX); + if ((signed_natural)p == -1) { + allocation_failure(true, size); + } + return new_area(p, p + size, AREA_WATCHED); +} + +void +delete_watched_area(area *a, TCR *tcr) +{ + natural nbytes = a->high - a->low; + char *base = a->low; + + condemn_area_holding_area_lock(a); + + if (nbytes) { + int err; + +/* can't use UnMapMemory() beacuse it only uses MEM_DECOMMIT */ +#ifdef WINDOWS + err = VirtualFree(base, nbytes, MEM_RELEASE); +#else + err = munmap(base, nbytes); +#endif + if (err != 0) + Fatal("munmap in delete_watched_area", ""); + } +} + +natural +uvector_total_size_in_bytes(LispObj *u) +{ + LispObj header = header_of(u); + natural header_tag = fulltag_of(header); + natural subtag = header_subtag(header); + natural element_count = header_element_count(header); + natural nbytes = 0; + +#ifdef X8632 + if ((nodeheader_tag_p(header_tag)) || + (subtag <= max_32_bit_ivector_subtag)) { + nbytes = element_count << 2; + } else if (subtag <= max_8_bit_ivector_subtag) { + nbytes = element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + nbytes = element_count << 1; + } else if (subtag == subtag_double_float_vector) { + nbytes = element_count << 3; + } else { + nbytes = (element_count + 7) >> 3; + } + /* add 4 byte header and round up to multiple of 8 bytes */ + return ~7 & (4 + nbytes + 7); +#endif +#ifdef X8664 + if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) { + nbytes = element_count << 3; + } else if (header_tag == ivector_class_32_bit) { + nbytes = element_count << 2; + } else { + /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */ + if (subtag == subtag_bit_vector) { + nbytes = (element_count + 7) >> 3; + } else if (subtag >= min_8_bit_ivector_subtag) { + nbytes = element_count; + } else { + nbytes = element_count << 1; + } + } + /* add 8 byte header and round up to multiple of 16 bytes */ + return ~15 & (8 + nbytes + 15); +#endif +} + +extern void wp_update_references(TCR *, LispObj, LispObj); + +/* + * Other threads are suspended and pc-lusered. + * + * param contains a tagged pointer to a uvector or a cons cell + */ +signed_natural +watch_object(TCR *tcr, signed_natural param) +{ + LispObj object = (LispObj)param; + unsigned tag = fulltag_of(object); + LispObj *noderef = (LispObj *)untag(object); + area *object_area = area_containing((BytePtr)noderef); + natural size; + + if (tag == fulltag_cons) + size = 2 * node_size; + else + size = uvector_total_size_in_bytes(noderef); + + if (object_area && object_area->code == AREA_DYNAMIC) { + area *a = new_watched_area(size); + LispObj old = object; + LispObj new = (LispObj)((natural)a->low + tag); + + add_area_holding_area_lock(a); + + /* move object to watched area */ + memcpy(a->low, noderef, size); + ProtectMemory(a->low, size); + memset(noderef, 0, size); + wp_update_references(tcr, old, new); + check_all_areas(tcr); + return 1; + } + return 0; +} + +/* + * We expect the watched object in arg_y, and the new uninitialized + * object (which is just zeroed) in arg_z. + */ +signed_natural +unwatch_object(TCR *tcr, signed_natural param) +{ + ExceptionInformation *xp = tcr->xframe->curr; + LispObj old = xpGPR(xp, Iarg_y); + unsigned tag = fulltag_of(old); + LispObj new = xpGPR(xp, Iarg_z); + LispObj *oldnode = (LispObj *)untag(old); + LispObj *newnode = (LispObj *)untag(new); + area *a = area_containing((BytePtr)old); + + if (a && a->code == AREA_WATCHED) { + natural size; + + if (tag == fulltag_cons) + size = 2 * node_size; + else + size = uvector_total_size_in_bytes(oldnode); + + memcpy(newnode, oldnode, size); + delete_watched_area(a, tcr); + wp_update_references(tcr, old, new); + /* because wp_update_references doesn't update refbits */ + tenure_to_area(tenured_area); + check_all_areas(tcr); + xpGPR(xp, Iarg_z) = new; + } + return 0; +} + +Boolean +handle_watch_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj selector = xpGPR(xp,Iimm0); + LispObj object = xpGPR(xp, Iarg_z); + signed_natural result; + + switch (selector) { + case WATCH_TRAP_FUNCTION_WATCH: + result = gc_like_from_xp(xp, watch_object, object); + if (result == 0) + xpGPR(xp,Iarg_z) = lisp_nil; + break; + case WATCH_TRAP_FUNCTION_UNWATCH: + gc_like_from_xp(xp, unwatch_object, 0); + break; + default: + break; + } + return true; +} + Index: /branches/qres/ccl/lisp-kernel/x86-exceptions.h =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-exceptions.h (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-exceptions.h (revision 13564) @@ -0,0 +1,269 @@ +/* + Copyright (C) 2005-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef X86_EXCEPTIONS_H +#define X86_EXCEPTIONS_H 1 + +typedef u8_t opcode, *pc; + +#ifdef LINUX +#define xpGPRvector(x) ((natural *)(&((x)->uc_mcontext.gregs))) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) (xpGPR(x,Iip)) +#define xpMMXreg(x,n) *((natural *)(&((x)->uc_mcontext.fpregs->_st[n]))) +#define eflags_register(xp) xpGPR(xp,Iflags) +#endif + +#ifdef DARWIN +#define DARWIN_USE_PSEUDO_SIGRETURN 1 +#include +#define DarwinSigReturn(context) do {\ + darwin_sigreturn(context);\ + Bug(context,"sigreturn returned");\ + } while (0) + +#define xpGPRvector(x) ((natural *)(&(UC_MCONTEXT(x)->__ss))) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) (xpGPR(x,Iip)) +#define eflags_register(xp) xpGPR(xp,Iflags) +#define xpFPRvector(x) ((natural *)(&(UC_MCONTEXT(x)->__fs.__fpu_xmm0))) +#define xpMMXvector(x) (&(UC_MCONTEXT(x)->__fs.__fpu_stmm0)) +/* Note that this yields only the lower half of the MMX reg on x8632 */ +#define xpMMXreg(x,n) *(natural *)&(xpMMXvector(x)[n]) + +#include +#include +#include +#include + +pthread_mutex_t *mach_exception_lock; + +#endif + +#ifdef FREEBSD +#ifdef X8664 +#include +#else +#include "freebsdx8632/fpu.h" +#endif +#define xpGPRvector(x) ((natural *)(&((x)->uc_mcontext))) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define eflags_register(xp) xpGPR(xp,Iflags) +#define xpPC(x) xpGPR(x,Iip) +#ifdef X8664 +#define xpMMXreg(x,n) *((natural *)(&(((struct savefpu *)(&(x)->uc_mcontext.mc_fpstate))->sv_fp[n]))) +#define xpXMMregs(x)(&(((struct savefpu *)(&(x)->uc_mcontext.mc_fpstate))->sv_xmm[0])) +#else +#define xpMMXreg(x,n) *((natural *)(&(((struct ccl_savexmm *)(&(x)->uc_mcontext.mc_fpstate))->sv_fp[n]))) +#define xpXMMregs(x)(&(((struct ccl_savexmm *)(&(x)->uc_mcontext.mc_fpstate))->sv_xmm[0])) +#endif +#endif + +#ifdef SOLARIS +#define xpGPRvector(x) ((x)->uc_mcontext.gregs) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) xpGPR(x,Iip) +#define eflags_register(xp) xpGPR(xp,Iflags) +#define xpXMMregs(x)(&((x)->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm[0])) +#ifdef X8632 +#define xpMMXreg(x,n)*(natural *)(&(((struct fnsave_state *)(&(((x)->uc_mcontext.fpregs))))->f_st[n])) +#endif +#endif + +#ifdef WINDOWS +#ifdef X8664 +#define xpGPRvector(x) ((DWORD64 *)(&(x)->Rax)) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define xpPC(x) xpGPR(x,Iip) +#define eflags_register(xp) xp->EFlags +#define xpMXCSRptr(x) (DWORD *)(&(x->MxCsr)) +#else +#define xpGPRvector(x) ((DWORD *)(&(x)->Edi)) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define xpPC(x) xpGPR(x,Iip) +#define eflags_register(xp) xp->EFlags +#define xpFPRvector(x) ((natural *)(&(x->ExtendedRegisters[10*16]))) +#define xpMMXreg(x,n) (*((u64_t *)(&(x->FloatSave.RegisterArea[10*(n)])))) +#define xpMXCSRptr(x) (DWORD *)(&(x->ExtendedRegisters[24])) +#endif +#endif + +#ifdef DARWIN +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGUSR1 +#endif +#ifdef LINUX +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGPWR +#endif +#ifdef FREEBSD +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGEMT +#endif +#ifdef SOLARIS +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGUSR1 +#endif +#ifdef WINDOWS +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGINT +#ifndef SIGBUS +#define SIGBUS 10 +#endif +#ifndef CONTEXT_ALL +#define CONTEXT_ALL (CONTEXT_CONTROL | CONTEXT_INTEGER | CONTEXT_SEGMENTS | CONTEXT_FLOATING_POINT | CONTEXT_DEBUG_REGISTERS | CONTEXT_EXTENDED_REGISTERS) +#endif +#endif + + + +void switch_to_foreign_stack(void*, ...); + +#define INTN_OPCODE 0xcd + +#define UUO_GC_TRAP 0xc4 +#define UUO_ALLOC_TRAP 0xc5 +#define UUO_DEBUG_TRAP 0xca +#define UUO_DEBUG_TRAP_WITH_STRING 0xcd +#define UUO_WATCH_TRAP 0xce + #define WATCH_TRAP_FUNCTION_WATCH 0 + #define WATCH_TRAP_FUNCTION_UNWATCH 1 + +#define XUUO_OPCODE_0 0x0f +#define XUUO_OPCODE_1 0x0b + +#define XUUO_TLB_TOO_SMALL 1 +#define XUUO_INTERRUPT_NOW 2 +#define XUUO_SUSPEND_NOW 3 +#define XUUO_INTERRUPT 4 +#define XUUO_SUSPEND 5 +#define XUUO_SUSPEND_ALL 6 +#define XUUO_RESUME 7 +#define XUUO_RESUME_ALL 8 +#define XUUO_KILL 9 +#define XUUO_ALLOCATE_LIST 10 + +void +pc_luser_xp(ExceptionInformation*, TCR*, signed_natural*); + + +typedef enum { + ID_unrecognized_alloc_instruction, + ID_load_allocptr_reg_from_tcr_save_allocptr_instruction, + ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction, + ID_branch_around_alloc_trap_instruction, + ID_alloc_trap_instruction, + ID_set_allocptr_header_instruction, + ID_clear_tcr_save_allocptr_tag_instruction +} alloc_instruction_id; + +#ifdef LINUX +#define SIGNUM_FOR_INTN_TRAP SIGSEGV +#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,REG_TRAPNO)==0xd)&&((xpGPR(xp,REG_ERR)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,REG_TRAPNO)==0xe) +#define SIGRETURN(context) +#endif + +#ifdef FREEBSD +extern void freebsd_sigreturn(ExceptionInformation *); +#define SIGNUM_FOR_INTN_TRAP SIGBUS +#define IS_MAYBE_INT_TRAP(info,xp) ((xp->uc_mcontext.mc_trapno == T_PROTFLT) && ((xp->uc_mcontext.mc_err & 7) == 2)) +#define IS_PAGE_FAULT(info,xp) (xp->uc_mcontext.mc_trapno == T_PAGEFLT) +#define SIGRETURN(context) freebsd_sigreturn(context) +#endif + +#ifdef DARWIN +#define SIGNUM_FOR_INTN_TRAP SIGSEGV /* Not really, but our Mach handler fakes that */ +#define IS_MAYBE_INT_TRAP(info,xp) ((UC_MCONTEXT(xp)->__es.__trapno == 0xd) && (((UC_MCONTEXT(xp)->__es.__err)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (UC_MCONTEXT(xp)->__es.__trapno == 0xe) +/* The x86 version of sigreturn just needs the context argument; the + hidden, magic "flavor" argument that sigtramp uses is ignored. */ +#define SIGRETURN(context) DarwinSigReturn(context) +#endif + +#ifdef SOLARIS +#define SIGNUM_FOR_INTN_TRAP SIGSEGV +#ifdef X8664 +#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,REG_TRAPNO)==0xd)&&((xpGPR(xp,REG_ERR)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,REG_TRAPNO)==0xe) +#else +#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,TRAPNO)==0xd)&&((xpGPR(xp,ERR)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,TRAPNO)==0xe) +#endif +#define SIGRETURN(context) setcontext(context) +#endif + +#ifdef WINDOWS +#define SIGNUM_FOR_INTN_TRAP SIGSEGV /* Also fake */ +#define IS_MAYBE_INT_TRAP(info,xp) \ + ((info->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) && \ + (info->ExceptionInformation[0]==0) && \ + (info->ExceptionInformation[1]==(ULONG_PTR)(-1L))) +#define IS_PAGE_FAULT(info,xp) (1) +#define SIGRETURN(context) /* for now */ +#endif + +/* Please go away. */ +#ifdef DARWIN_GS_HACK +extern Boolean ensure_gs_pthread(void); +extern void set_gs_address(void *); +#endif + + +/* sigaltstack isn't thread-specific on The World's Most Advanced OS */ +#ifdef DARWIN +#undef USE_SIGALTSTACK +#else +#ifdef WINDOWS +#undef USE_SIGALTSTACK +#else +#define USE_SIGALTSTACK 1 +#endif +#endif + +#ifdef USE_SIGALTSTACK +void setup_sigaltstack(area *); +#endif + +/* recognizing the function associated with a tagged return address */ +/* now involves recognizinig an "(lea (@ disp (% rip)) (% rn))" */ +/* instruction at the tra */ + +#define RECOVER_FN_FROM_RIP_LENGTH 7 /* the instruction is 7 bytes long */ +#define RECOVER_FN_FROM_RIP_DISP_OFFSET 3 /* displacement word is 3 bytes in */ +#define RECOVER_FN_FROM_RIP_WORD0 0x8d4c /* 0x4c 0x8d, little-endian */ +#define RECOVER_FN_FROM_RIP_BYTE2 0x2d /* third byte of opcode */ + +extern natural get_mxcsr(); +extern void set_mxcsr(natural); + +#ifdef WINDOWS +typedef struct { + HANDLE h; + OVERLAPPED *o; +} pending_io; +#endif + +#ifdef X8632 +/* The 32-bit immediate value in the instruction + * "(mov ($ 0x12345678) (% fn))" at a tagged return address + * refers to the associated function. + */ +#define RECOVER_FN_OPCODE 0xbf +#define RECOVER_FN_LENGTH 5 +#endif + +#endif /* X86_EXCEPTIONS_H */ + Index: /branches/qres/ccl/lisp-kernel/x86-gc.c =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-gc.c (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-gc.c (revision 13564) @@ -0,0 +1,3103 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "bits.h" +#include "gc.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include +#include + +#ifdef X8632 +inline natural +imm_word_count(LispObj fn) +{ + natural w = ((unsigned short *)fn)[-1]; + + if (w & 0x8000) { + /* + * The low 15 bits encode the number of contants. + * Compute and return the immediate word count. + */ + LispObj header = header_of(fn); + natural element_count = header_element_count(header); + + return element_count - (w & 0x7fff); + } else { + /* The immediate word count is encoded directly. */ + return w; + } +} +#endif + +/* Heap sanity checking. */ + +void +check_node(LispObj n) +{ + int tag = fulltag_of(n), header_tag; + area *a; + LispObj header; + + if (n == (n & 0xff)) { + return; + } + + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: +#ifdef X8632 + case fulltag_imm: +#endif +#ifdef X8664 + case fulltag_imm_0: + case fulltag_imm_1: +#endif + return; + +#ifdef X8664 + case fulltag_nil: + if (n != lisp_nil) { + Bug(NULL,"Object tagged as nil, not nil : " LISP, n); + } + return; +#endif + +#ifdef X8632 + case fulltag_nodeheader: + case fulltag_immheader: +#endif +#ifdef X8664 + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: +#endif + Bug(NULL, "Header not expected : 0x" LISP, n); + return; + +#ifdef X8632 + case fulltag_tra: +#endif +#ifdef X8664 + case fulltag_tra_0: + case fulltag_tra_1: +#endif + a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); + if (a == NULL) { + a = active_dynamic_area; + if ((n > (ptr_to_lispobj(a->active))) && + (n < (ptr_to_lispobj(a->high)))) { + Bug(NULL, "TRA points to heap free space: 0x" LISP, n); + } + return; + } + /* tra points into the heap. Check displacement, then + check the function it (should) identify. + */ +#ifdef X8632 + { + LispObj fun = 0; + + if (*(unsigned char *)n == RECOVER_FN_OPCODE) + fun = *(LispObj *)(n + 1); + if (fun == 0 || + (header_subtag(header_of(fun)) != subtag_function) || + (heap_area_containing((BytePtr)ptr_from_lispobj(fun)) != a)) { + Bug(NULL, "TRA at 0x" LISP " has bad function address 0x" LISP "\n", n, fun); + } + n = fun; + } +#endif +#ifdef X8664 + { + int disp = 0; + LispObj m = n; + + if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + disp = (*(int *) (n+3)); + n = RECOVER_FN_FROM_RIP_LENGTH+m+disp; + } + if ((disp == 0) || + (fulltag_of(n) != fulltag_function) || + (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) { + Bug(NULL, "TRA at 0x" LISP " has bad displacement %d\n", n, disp); + } + } +#endif + /* Otherwise, fall through and check the header on the function + that the tra references */ + + case fulltag_misc: + case fulltag_cons: +#ifdef X8664 + case fulltag_symbol: + case fulltag_function: +#endif + a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); + + if (a == NULL) { + /* Can't do as much sanity checking as we'd like to + if object is a defunct stack-consed object. + If a dangling reference to the heap, that's + bad .. */ + a = active_dynamic_area; + if ((n > (ptr_to_lispobj(a->active))) && + (n < (ptr_to_lispobj(a->high)))) { + Bug(NULL, "Node points to heap free space: 0x" LISP, n); + } + return; + } + break; + } + /* Node points to heap area, so check header/lack thereof. */ + header = header_of(n); + header_tag = fulltag_of(header); + if (tag == fulltag_cons) { + if ((nodeheader_tag_p(header_tag)) || + (immheader_tag_p(header_tag))) { + Bug(NULL, "Cons cell at 0x" LISP " has bogus header : 0x" LISP, n, header); + } + return; + } + + if ((!nodeheader_tag_p(header_tag)) && + (!immheader_tag_p(header_tag))) { + Bug(NULL,"Vector at 0x" LISP " has bogus header : 0x" LISP, n, header); + } + return; +} + +void +check_all_mark_bits(LispObj *nodepointer) +{ +} + + + + + +void +check_range(LispObj *start, LispObj *end, Boolean header_allowed) +{ + LispObj node, *current = start, *prev = NULL; + int tag; + natural elements; + + while (current < end) { + prev = current; + node = *current++; + tag = fulltag_of(node); + if (immheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x" LISP "\n", prev); + } + current = (LispObj *)skip_over_ivector((natural)prev, node); + } else if (nodeheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x" LISP "\n", prev); + } + elements = header_element_count(node) | 1; + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + int skip = *(unsigned short *)current; + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = elements - (skip & 0x7fff); +#else + int skip = *(int *)current; +#endif + current += skip; + elements -= skip; + } + while (elements--) { + check_node(*current++); + } + } else { + check_node(node); + check_node(*current++); + } + } + + if (current != end) { + Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x", + start, end, prev, current); + } +} + +#ifdef X8632 +void +check_xp(ExceptionInformation *xp, natural node_regs_mask) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + + if (node_regs_mask & (1<<0)) check_node(regs[REG_EAX]); + if (node_regs_mask & (1<<1)) check_node(regs[REG_ECX]); + if (regs[REG_EFL] & EFL_DF) { + /* DF set means EDX should be treated as an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) check_node(regs[REG_EDX]); + + if (node_regs_mask & (1<<3)) check_node(regs[REG_EBX]); + if (node_regs_mask & (1<<4)) check_node(regs[REG_ESP]); + if (node_regs_mask & (1<<5)) check_node(regs[REG_EBP]); + if (node_regs_mask & (1<<6)) check_node(regs[REG_ESI]); + if (node_regs_mask & (1<<7)) check_node(regs[REG_EDI]); +} +#else +void +check_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + + check_node(regs[Iarg_z]); + check_node(regs[Iarg_y]); + check_node(regs[Iarg_x]); + check_node(regs[Isave3]); + check_node(regs[Isave2]); + check_node(regs[Isave1]); + check_node(regs[Isave0]); + check_node(regs[Ifn]); + check_node(regs[Itemp0]); + check_node(regs[Itemp1]); + check_node(regs[Itemp2]); +} +#endif + +void +check_tcrs(TCR *first) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + TCR *tcr = first; + LispObj *tlb_start,*tlb_end; + + do { + xp = tcr->gc_context; + if (xp) { +#ifdef X8632 + check_xp(xp,tcr->node_regs_mask); +#else + check_xp(xp); +#endif + } +#ifdef X8632 + check_node(tcr->save0); + check_node(tcr->save1); + check_node(tcr->save2); + check_node(tcr->save3); + check_node(tcr->next_method_context); +#endif + for (xframes = (xframe_list *) tcr->xframe; + xframes; + xframes = xframes->prev) { +#ifndef X8632 + check_xp(xframes->curr); +#else + check_xp(xframes->curr, xframes->node_regs_mask); +#endif + } + tlb_start = tcr->tlb_pointer; + if (tlb_start) { + tlb_end = tlb_start + ((tcr->tlb_limit)>>fixnumshift); + check_range(tlb_start,tlb_end,false); + } + tcr = tcr->next; + } while (tcr != first); +} + + +void +check_all_areas(TCR *tcr) +{ + area *a = active_dynamic_area; + area_code code = a->code; + + while (code != AREA_VOID) { + switch (code) { + case AREA_DYNAMIC: + case AREA_WATCHED: + case AREA_STATIC: + case AREA_MANAGED_STATIC: + check_range((LispObj *)a->low, (LispObj *)a->active, true); + break; + + case AREA_VSTACK: + { + LispObj* low = (LispObj *)a->active; + LispObj* high = (LispObj *)a->high; + + if (((natural)low) & node_size) { + check_node(*low++); + } + check_range(low, high, false); + } + break; + + case AREA_TSTACK: + { + LispObj *current, *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) a->high; + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + check_range(current+2, end, true); + } + } + break; + } + a = a->succ; + code = (a->code); + } + + check_tcrs(tcr); +} + + + + + + + + +/* Sooner or later, this probably wants to be in assembler */ +void +mark_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + +#ifdef X8632 + if (tag_n == fulltag_tra) { + if (*(unsigned char *)n == RECOVER_FN_OPCODE) { + n = *(LispObj *)(n + 1); + tag_n = fulltag_misc; + dnode = gc_area_dnode(n); + } else + return; + } +#endif +#ifdef X8664 + if (tag_of(n) == tag_tra) { + if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + int sdisp = (*(int *) (n+3)); + n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; + tag_n = fulltag_function; + dnode = gc_area_dnode(n); + } + else { + return; + } + } +#endif + + set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (tag_n == fulltag_cons) { + cons *c = (cons *) ptr_from_lispobj(untag(n)); + + rmark(c->car); + rmark(c->cdr); + return; + } + { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, /* including 4/8-byte header */ + suffix_dnodes; + natural prefix_nodes = 0; + + tag_n = fulltag_of(header); + +#ifdef X8664 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + total_size_in_bytes = 8 + element_count; + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#endif +#ifdef X8632 + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (nodeheader_tag_p(tag_n)) { + if (subtag == subtag_hash_vector) { + /* Don't invalidate the cache here. It should get + invalidated on the lisp side, if/when we know + that rehashing is necessary. */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if ((flags & nhash_keys_frozen_mask) && + (((hash_table_vector_header *) base)->deleted_count > 0)) { + /* We're responsible for clearing out any deleted keys, since + lisp side can't do it without breaking the state machine + */ + LispObj *pairp = base + hash_table_vector_header_count; + natural + npairs = (element_count - (hash_table_vector_header_count - 1)) >> 1; + + while (npairs--) { + if ((pairp[1] == unbound) && (pairp[0] != unbound)) { + pairp[0] = slot_unbound; + } + pairp +=2; + } + ((hash_table_vector_header *) base)->deleted_count = 0; + } + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(n, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) { + element_count -= 2; + } else { + element_count -= 1; + } + } + + if (subtag == subtag_function) { +#ifdef X8632 + prefix_nodes = (natural) ((unsigned short) deref(base,1)); + + /* XXX bootstrapping */ + if (prefix_nodes & 0x8000) + prefix_nodes = element_count - (prefix_nodes & 0x7fff); +#else + prefix_nodes = (natural) ((int) deref(base,1)); +#endif + if (prefix_nodes > element_count) { + Bug(NULL, "Function 0x" LISP " trashed",n); + } + } + base += (1+element_count); + + element_count -= prefix_nodes; + + while(element_count--) { + rmark(*--base); + } + if (subtag == subtag_weak) { + deref(n, 1) = GCweakvll; + GCweakvll = untag(n); + } + } + } +} + + +/* + This marks the node if it needs to; it returns true if the node + is either a hash table vector header or a cons/misc-tagged pointer + to ephemeral space. + Note that it might be a pointer to ephemeral space even if it's + not pointing to the current generation. +*/ + +Boolean +mark_ephemeral_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural eph_dnode; + + if (nodeheader_tag_p(tag_n)) { + return (header_subtag(n) == subtag_hash_vector); + } + + if (is_node_fulltag (tag_n)) { + eph_dnode = area_dnode(n, GCephemeral_low); + if (eph_dnode < GCn_ephemeral_dnodes) { + mark_root(n); /* May or may not mark it */ + return true; /* but return true 'cause it's an ephemeral node */ + } + } + return false; /* Not a heap pointer or not ephemeral */ +} + + + +#ifdef X8664 +#define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */ +#define RMARK_PREV_CAR fulltag_nil /* fulltag_cons + node_size. Coincidence ? I think not. */ +#else +#define RMARK_PREV_ROOT fulltag_imm /* fulltag of 'undefined' value */ +#define RMARK_PREV_CAR fulltag_odd_fixnum +#endif + + +/* + This wants to be in assembler even more than "mark_root" does. + For now, it does link-inversion: hard as that is to express in C, + reliable stack-overflow detection may be even harder ... +*/ +void +rmark(LispObj n) +{ + int tag_n = fulltag_of(n); + bitvector markbits = GCmarkbits; + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + +#ifdef X8632 + if (tag_n == fulltag_tra) { + if (*(unsigned char *)n == RECOVER_FN_OPCODE) { + n = *(LispObj *)(n + 1); + tag_n = fulltag_misc; + dnode = gc_area_dnode(n); + } else { + return; + } + } +#endif +#ifdef X8664 + if (tag_of(n) == tag_tra) { + if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + int sdisp = (*(int *) (n+3)); + n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; + tag_n = fulltag_function; + dnode = gc_area_dnode(n); + } else { + return; + } + } +#endif + + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (current_stack_pointer() > GCstack_limit) { + if (tag_n == fulltag_cons) { + rmark(deref(n,1)); + rmark(deref(n,0)); + } else { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, + suffix_dnodes, + nmark; + + tag_n = fulltag_of(header); + +#ifdef X8664 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + total_size_in_bytes = 8 + element_count; + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) return; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then return */ + /* In general, there's no reason to invalidate the cached + key/value pair here. However, if the hash table's weak, + we don't want to retain an otherwise unreferenced key + or value simply because they're referenced from the + cache. Clear the cached entries iff the hash table's + weak in some sense. + */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(n, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + + nmark = element_count; + + if (subtag == subtag_function) { +#ifdef X8664 + int code_words = (int)base[1]; +#else + int code_words = (unsigned short)base[1]; + + /* XXX bootstrapping */ + if (code_words & 0x8000) + code_words = element_count - (code_words & 0x7fff); +#endif + if (code_words >= nmark) { + Bug(NULL,"Bad function at 0x" LISP,n); + } + nmark -= code_words; + } + + while (nmark--) { + rmark(deref(n,element_count)); + element_count--; + } + + if (subtag == subtag_weak) { + deref(n, 1) = GCweakvll; + GCweakvll = untag(n); + } + + } + } else { + /* This is all a bit more complicated than the PPC version: + + - a symbol-vector can be referenced via either a FULLTAG-MISC + pointer or a FULLTAG-SYMBOL pointer. When we've finished + marking the symbol-vector's elements, we need to know which tag + the object that pointed to the symbol-vector had originally. + + - a function-vector can be referenced via either a FULLTAG-MISC + pointer or a FULLTAG-FUNCTION pointer. That introduces pretty + much the same set of issues, but ... + + - a function-vector can also be referenced via a TRA; the + offset from the TRA to the function header is arbitrary (though + we can probably put an upper bound on it, and it's certainly + not going to be more than 32 bits.) + + - function-vectors contain a mixture of code and constants, + with a "boundary" word (that doesn't look like a valid + constant) in between them. There are 56 unused bits in the + boundary word; the low 8 bits must be = to the constant + 'function_boundary_marker'. We can store the byte displacement + from the address of the object which references the function + (tagged fulltag_misc, fulltag_function, or tra) to the address + of the boundary marker when the function vector is first marked + and recover that offset when we've finished marking the + function vector. (Note that the offset is signed; it's + probably simplest to keep it in the high 32 bits of the + boundary word.) + + So: + + - while marking a CONS, the 'this' pointer as a 3-bit tag of + tag_list; the 4-bit fulltag indicates which cell is being + marked. + + - while marking a gvector (other than a symbol-vector or + function-vector), the 'this' pointer is tagged tag_misc. + (Obviously, it alternates between fulltag_misc and + fulltag_nodeheader_0, arbitrarily.) When we encounter the + gvector header when the 'this' pointer has been tagged as + fulltag_misc, we can restore 'this' to the header's address + + fulltag_misc and enter the 'climb' state. (Note that this + value happens to be exactly what's in 'this' when the header's + encountered.) + + - if we encounter a symbol-vector via the FULLTAG-MISC pointer + to the symbol (not very likely, but legal and possible), it's + treated exactly like the gvector case above. + + - in the more likely case where a symbol-vector is referenced + via a FULLTAG-SYMBOL, we do the same loop as in the general + gvector case, backing up through the vector with 'this' tagged + as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter + the symbol header, 'this' gets fulltag_symbol added to the + dnode-aligned address of the header, and we climb. + + - if anything (fulltag_misc, fulltag_function, tra) references + an unmarked function function vector, we store the byte offfset + from the tagged reference to the address of the boundary word + in the high 32 bits of the boundary word, then we back up + through the function-vector's constants, with 'this' tagged + tag_function/ fulltag_immheader_0, until the (specially-tagged) + boundary word is encountered. The displacement stored in the boundary + word is added to the aligned address of the boundary word (restoring + the original 'this' pointer, and we climb. + + Not that bad. + */ + + LispObj prev = undefined, this = n, next, *base; + natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary; + + if (tag_n == fulltag_cons) goto MarkCons; + goto MarkVector; + + ClimbCdr: + prev = deref(this,0); + deref(this,0) = next; + + Climb: + next = this; + this = prev; + tag_n = fulltag_of(prev); + switch(tag_n) { + case tag_misc: + case fulltag_misc: +#ifdef X8664 + case tag_symbol: + case fulltag_symbol: + case tag_function: + case fulltag_function: +#endif + goto ClimbVector; + + case RMARK_PREV_ROOT: + return; + + case fulltag_cons: + goto ClimbCdr; + + case RMARK_PREV_CAR: + goto ClimbCar; + + default: abort(); + } + + DescendCons: + prev = this; + this = next; + + MarkCons: + next = deref(this,1); +#ifdef X8632 + this += (RMARK_PREV_CAR-fulltag_cons); +#else + this += node_size; +#endif + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto MarkCdr; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkCdr; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkCdr; + *bitsp = (bits | mask); + deref(this,1) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + ClimbCar: + prev = deref(this,1); + deref(this,1) = next; + + MarkCdr: + next = deref(this, 0); +#ifdef X8632 + this -= (RMARK_PREV_CAR-fulltag_cons); +#else + this -= node_size; +#endif + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto Climb; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto Climb; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto Climb; + *bitsp = (bits | mask); + deref(this, 0) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + /* goto DescendVector; */ + + DescendVector: + prev = this; + this = next; + + MarkVector: +#ifdef X8664 + if ((tag_n == fulltag_tra_0) || + (tag_n == fulltag_tra_1)) { + int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH; + + base = (LispObj *) (untag(n-disp)); + header = *((natural *) base); + subtag = header_subtag(header); + boundary = base + (int)(base[1]); + (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); + this = (LispObj)(base)+fulltag_function; + /* Need to set the initial markbit here */ + dnode = gc_area_dnode(this); + set_bit(markbits,dnode); + } else { + base = (LispObj *) ptr_from_lispobj(untag(this)); + header = *((natural *) base); + subtag = header_subtag(header); + if (subtag == subtag_function) { + boundary = base + (int)(base[1]); + (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); + } + } + element_count = header_element_count(header); + tag_n = fulltag_of(header); + + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + total_size_in_bytes = 8 + element_count; + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if (tag_n == fulltag_tra) { + LispObj fn = *(LispObj *)(n + 1); + + base = (LispObj *)untag(fn); + header = *(natural *)base; + subtag = header_subtag(header); + boundary = base + imm_word_count(fn); + + /* + * On x8632, the upper 24 bits of the boundary word are zero. + * Functions on x8632 can be no more than 2^16 words (or 2^24 + * bytes) long (including the self-reference table but excluding + * any constants). Therefore, we can do the same basic thing + * that the x8664 port does: namely, we keep the byte + * displacement from the address of the object (tagged tra or + * fulltag_misc) that references the function to the address of + * the boundary marker in those 24 bits, recovering it when + * we've finished marking the function vector. + */ + *((int *)boundary) &= 0xff; + *((int *)boundary) |= ((this-(LispObj)boundary) << 8); + this = (LispObj)(base)+fulltag_misc; + dnode = gc_area_dnode(this); + set_bit(markbits,dnode); + } else { + base = (LispObj *) ptr_from_lispobj(untag(this)); + header = *((natural *) base); + subtag = header_subtag(header); + if (subtag == subtag_function) { + boundary = base + imm_word_count(this); + + *((int *)boundary) &= 0xff; + *((int *)boundary) |= ((this-((LispObj)boundary)) << 8); + } + } + element_count = header_element_count(header); + tag_n = fulltag_of(header); + + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) goto Climb; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then climb */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + dws_mark_weak_htabv(this); + element_count = hash_table_vector_header_count; + } + } + + if (subtag == subtag_pool) { + deref(this, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + + this = (LispObj)(base) + (tag_of(this)) + ((element_count+1) << node_shift); + goto MarkVectorLoop; + + ClimbVector: + prev = indirect_node(this); + indirect_node(this) = next; + + MarkVectorLoop: + this -= node_size; + next = indirect_node(this); +#ifdef X8664 + if ((tag_of(this) == tag_function) && + (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; +#else + if ((tag_of(this) == tag_misc) && + (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; +#endif + + tag_n = fulltag_of(next); + if (nodeheader_tag_p(tag_n)) goto MarkVectorDone; + if (!is_node_fulltag(tag_n)) goto MarkVectorLoop; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkVectorLoop; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkVectorLoop; + *bitsp = (bits | mask); + indirect_node(this) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + MarkVectorDone: + /* "next" is vector header; "this" tagged tag_misc or tag_symbol. + If header subtag = subtag_weak_header, put it on weakvll */ + this += node_size; /* make it fulltag_misc/fulltag_symbol */ + + if (header_subtag(next) == subtag_weak) { + deref(this, 1) = GCweakvll; + GCweakvll = untag(this); + } + goto Climb; + + MarkFunctionDone: + boundary = (LispObj *)(node_aligned(this)); +#ifdef X8664 + this = ((LispObj)boundary) + (((int *)boundary)[1]); + (((int *)boundary)[1]) = 0; +#else + this = ((LispObj)boundary) + ((*((int *)boundary)) >> 8); + ((int *)boundary)[0] &= 0xff; +#endif + goto Climb; + } +} + +LispObj * +skip_over_ivector(natural start, LispObj header) +{ + natural + element_count = header_element_count(header), + subtag = header_subtag(header), + nbytes; + + +#ifdef X8664 + switch (fulltag_of(header)) { + case ivector_class_64_bit: + nbytes = element_count << 3; + break; + case ivector_class_32_bit: + nbytes = element_count << 2; + break; + case ivector_class_other_bit: + default: + if (subtag == subtag_bit_vector) { + nbytes = (element_count+7)>>3; + } else if (subtag >= min_8_bit_ivector_subtag) { + nbytes = element_count; + } else { + nbytes = element_count << 1; + } + } + return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15))); +#else + if (subtag <= max_32_bit_ivector_subtag) { + nbytes = element_count << 2; + } else if (subtag <= max_8_bit_ivector_subtag) { + nbytes = element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + nbytes = element_count << 1; + } else if (subtag == subtag_double_float_vector) { + nbytes = 4 + (element_count << 3); + } else { + nbytes = (element_count+7) >> 3; + } + return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7))); +#endif +} + + +void +check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits) +{ + LispObj x1, *base = start, *prev = start; + int tag; + natural ref_dnode, node_dnode; + Boolean intergen_ref; + + while (start < end) { + x1 = *start; + prev = start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = skip_over_ivector(ptr_to_lispobj(start), x1); + } else { + if (header_subtag(x1) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)deref(start,1); + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(x1) - (skip & 0x7fff); +#else + int skip = (int) deref(start,1); +#endif + start += ((1+skip)&~1); + x1 = *start; + tag = fulltag_of(x1); + } + intergen_ref = false; + if (is_node_fulltag(tag)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + if (intergen_ref == false) { + x1 = start[1]; + tag = fulltag_of(x1); + if (is_node_fulltag(tag)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + } + if (intergen_ref) { + ref_dnode = area_dnode(start, base); + if (!ref_bit(refbits, ref_dnode)) { + Bug(NULL, "Missing memoization in doublenode at 0x" LISP "\n", start); + set_bit(refbits, ref_dnode); + } + } + start += 2; + } + } + if (start > end) { + Bug(NULL, "Overran end of range!"); + } +} + + + +void +mark_memoized_area(area *a, natural num_memo_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2; + natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0; + Boolean keep_x1, keep_x2; + natural hash_dnode_limit = 0; + hash_table_vector_header *hashp = NULL; + int mark_method = 3; + + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + /* The distinction between "inbits" and "outbits" is supposed to help us + detect cases where "uninteresting" setfs have been memoized. Storing + NIL, fixnums, immediates (characters, etc.) or node pointers to static + or readonly areas is definitely uninteresting, but other cases are + more complicated (and some of these cases are hard to detect.) + + Some headers are "interesting", to the forwarder if not to us. + + */ + + /* + We need to ensure that there are no bits set at or beyond + "num_memo_dnodes" in the bitvector. (This can happen as the EGC + tenures/untenures things.) We find bits by grabbing a fullword at + a time and doing a cntlzw instruction; and don't want to have to + check for (< memo_dnode num_memo_dnodes) in the loop. + */ + + { + natural + bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask), + index_of_last_word = (num_memo_dnodes >> bitmap_shift); + + if (bits_in_last_word != 0) { + natural mask = ~((NATURAL1<<(nbits_in_word-bits_in_last_word))- NATURAL1); + refbits[index_of_last_word] &= mask; + } + } + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + inbits = outbits = bits; + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + if (outbits != inbits) { + *bitsp = outbits; + } + bits = *++bitsp; + inbits = outbits = bits; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = *p++; + x2 = *p++; + bits &= ~(BIT0_MASK >> bitidx); + + if (hashp) { + Boolean force_x1 = false; + if ((memo_dnode >= hash_dnode_limit) && (mark_method == 3)) { + /* if vector_header_count is odd, x1 might be the last word of the header */ + force_x1 = (hash_table_vector_header_count & 1) && (memo_dnode == hash_dnode_limit); + /* was marking header, switch to data */ + hash_dnode_limit = area_dnode(((LispObj *)hashp) + + 1 + + header_element_count(hashp->header), + a->low); + /* In traditional weak method, don't mark vector entries at all. */ + /* Otherwise mark the non-weak elements only */ + mark_method = ((lisp_global(WEAK_GC_METHOD) == 0) ? 0 : + ((hashp->flags & nhash_weak_value_mask) + ? (1 + (hash_table_vector_header_count & 1)) + : (2 - (hash_table_vector_header_count & 1)))); + } + + if (memo_dnode < hash_dnode_limit) { + /* perhaps ignore one or both of the elements */ + if (!force_x1 && !(mark_method & 1)) x1 = 0; + if (!(mark_method & 2)) x2 = 0; + } else { + hashp = NULL; + } + } + + if (header_subtag(x1) == subtag_hash_vector) { + if (hashp) Bug(NULL, "header inside hash vector?"); + hash_table_vector_header *hp = (hash_table_vector_header *)(p - 2); + if (hp->flags & nhash_weak_mask) { + /* If header_count is odd, this cuts off the last header field */ + /* That case is handled specially above */ + hash_dnode_limit = memo_dnode + ((hash_table_vector_header_count) >>1); + hashp = hp; + mark_method = 3; + } + } + + keep_x1 = mark_ephemeral_root(x1); + keep_x2 = mark_ephemeral_root(x2); + if ((keep_x1 == false) && + (keep_x2 == false) && + (hashp == NULL)) { + outbits &= ~(BIT0_MASK >> bitidx); + } + memo_dnode++; + bitidx++; + } + } + if (GCDebug) { + p = (LispObj *) a->low; + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } +} + +void +mark_headerless_area_range(LispObj *start, LispObj *end) +{ + while (start < end) { + mark_root(*start++); + } +} + +void +mark_simple_area_range(LispObj *start, LispObj *end) +{ + LispObj x1, *base; + int tag; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1)); + } else if (!nodeheader_tag_p(tag)) { + ++start; + mark_root(x1); + mark_root(*start++); + } else { + int subtag = header_subtag(x1); + natural element_count = header_element_count(x1); + natural size = (element_count+1 + 1) & ~1; + + if (subtag == subtag_hash_vector) { + LispObj flags = ((hash_table_vector_header *) start)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) start)->cache_key = undefined; + ((hash_table_vector_header *) start)->cache_value = lisp_nil; + mark_weak_htabv((LispObj)start); + element_count = 0; + } + } + if (subtag == subtag_pool) { + start[1] = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) start[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + start[1] = GCweakvll; + GCweakvll = ptr_to_lispobj(start); + } + + base = start + element_count + 1; + if (subtag == subtag_function) { +#ifdef X8632 + natural skip = (unsigned short)start[1]; + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = element_count - (skip & 0x7fff); + + element_count -= skip; + +#else + element_count -= (int)start[1]; +#endif + } + while(element_count--) { + mark_root(*--base); + } + start += size; + } + } +} + + +/* Mark a tstack area */ +void +mark_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + mark_simple_area_range(current+2, end); + } +} + +/* + It's really important that headers never wind up in tagged registers. + Those registers would (possibly) get pushed on the vstack and confuse + the hell out of this routine. + + vstacks are just treated as a "simple area range", possibly with + an extra word at the top (where the area's active pointer points.) + */ + +void +mark_vstack_area(area *a) +{ + LispObj + *start = (LispObj *) a->active, + *end = (LispObj *) a->high; + +#if 0 + fprintf(dbgout, "mark VSP range: 0x" LISP ":0x" LISP "\n", start, end); +#endif + mark_headerless_area_range(start, end); +} + +/* No lisp objects on cstack on x86, at least x86-64 */ +void +mark_cstack_area(area *a) +{ +} + + +/* Mark the lisp objects in an exception frame */ +#ifdef X8664 +void +mark_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + LispObj rip; + + + + mark_root(regs[Iarg_z]); + mark_root(regs[Iarg_y]); + mark_root(regs[Iarg_x]); + mark_root(regs[Isave3]); + mark_root(regs[Isave2]); + mark_root(regs[Isave1]); + mark_root(regs[Isave0]); + mark_root(regs[Ifn]); + mark_root(regs[Itemp0]); + mark_root(regs[Itemp1]); + mark_root(regs[Itemp2]); + /* If the RIP isn't pointing into a marked function, + we can -maybe- recover from that if it's tagged as + a TRA. */ + rip = regs[Iip]; + dnode = gc_area_dnode(rip); + if ((dnode < GCndnodes_in_area) && + (! ref_bit(GCmarkbits,dnode))) { + if (tag_of(rip) == tag_tra) { + mark_root(rip); + } else if ((fulltag_of(rip) == fulltag_function) && + (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) && + ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) { + mark_root(rip); + } else { + Bug(NULL, "Can't find function for rip 0x%16lx",rip); + } + } +} +#else +void +mark_xp(ExceptionInformation *xp, natural node_regs_mask) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + LispObj eip; + int i; + + if (node_regs_mask & (1<<0)) mark_root(regs[REG_EAX]); + if (node_regs_mask & (1<<1)) mark_root(regs[REG_ECX]); + if (regs[REG_EFL] & EFL_DF) { + /* DF set means EDX should be treated as an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) mark_root(regs[REG_EDX]); + + if (node_regs_mask & (1<<3)) mark_root(regs[REG_EBX]); + if (node_regs_mask & (1<<4)) mark_root(regs[REG_ESP]); + if (node_regs_mask & (1<<5)) mark_root(regs[REG_EBP]); + if (node_regs_mask & (1<<6)) mark_root(regs[REG_ESI]); + if (node_regs_mask & (1<<7)) mark_root(regs[REG_EDI]); + + /* If the EIP isn't pointing into a marked function, we're probably + in trouble. We can -maybe- recover from that if it's tagged as a + TRA. */ + eip = regs[Ieip]; + dnode = gc_area_dnode(eip); + if ((dnode < GCndnodes_in_area) && + (! ref_bit(GCmarkbits,dnode))) { + if (fulltag_of(eip) == fulltag_tra) { + mark_root(eip); + } else if ((fulltag_of(eip) == fulltag_misc) && + (header_subtag(header_of(eip)) == subtag_function) && + (*(unsigned char *)eip == RECOVER_FN_OPCODE) && + (*(LispObj *)(eip + 1)) == eip) { + mark_root(eip); + } else { + Bug(NULL, "Can't find function for eip 0x%4x", eip); + } + } +} +#endif + +/* A "pagelet" contains 32 doublewords. The relocation table contains + a word for each pagelet which defines the lowest address to which + dnodes on that pagelet will be relocated. + + The relocation address of a given pagelet is the sum of the relocation + address for the preceding pagelet and the number of bytes occupied by + marked objects on the preceding pagelet. +*/ + +LispObj +calculate_relocation() +{ + LispObj *relocptr = GCrelocptr; + LispObj current = GCareadynamiclow; + bitvector + markbits = GCdynamic_markbits; + qnode *q = (qnode *) markbits; + natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift); + natural thesebits; + LispObj first = 0; + + if (npagelets) { + do { + *relocptr++ = current; + thesebits = *markbits++; + if (thesebits == ALL_ONES) { + current += nbits_in_word*dnode_size; + q += 4; /* sic */ + } else { + if (!first) { + first = current; + while (thesebits & BIT0_MASK) { + first += dnode_size; + thesebits += thesebits; + } + } + /* We're counting bits in qnodes in the wrong order here, but + that's OK. I think ... */ + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + } + } while(--npagelets); + } + *relocptr++ = current; + return first ? first : current; +} + + +#if 0 +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned int near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> bitmap_shift; + nbits = dnode & bitmap_shift_count_mask; + near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)]; + + if (nbits < 32) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffffffff) { + return (new + (nbits << 4)); + } else { + near_bits &= (0xffffffff00000000 >> nbits); + if (nbits > 15) { + new += one_bits(near_bits & 0xffff); + } + return (new + (one_bits(near_bits >> 16))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 64-nbits; + + if (near_bits == 0xffffffff) { + return (new - (nbits << 4)); + } else { + near_bits &= (1< 15) { + new -= one_bits(near_bits >> 16); + } + return (new - one_bits(near_bits & 0xffff)); + } + } +} +#else +#ifdef X8664 +/* Quicker, dirtier */ +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits, marked; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> bitmap_shift; + nbits = dnode & bitmap_shift_count_mask; + new = GCrelocptr[pagelet] + tag_n;; + if (nbits) { + marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits); + while (marked) { + new += one_bits((qnode)marked); + marked >>=16; + } + } + return new; +} +#endif +#ifdef X8632 +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned short near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> 5; + nbits = dnode & 0x1f; + /* On little-endian x86, we have to flip the low bit of dnode>>4 to + get the near_bits from the appropriate half-word. */ + near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1]; + + if (nbits < 16) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffff) { + return (new + (nbits << 3)); + } else { + near_bits &= (0xffff0000 >> nbits); + if (nbits > 7) { + new += one_bits(near_bits & 0xff); + } + return (new + (one_bits(near_bits >> 8))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 32-nbits; + + if (near_bits == 0xffff) { + return (new - (nbits << 3)); + } else { + near_bits &= (1< 7) { + new -= one_bits(near_bits >> 8); + } + return (new - one_bits(near_bits & 0xff)); + } + } +} +#endif +#endif + +LispObj +locative_forwarding_address(LispObj obj) +{ + int tag_n = fulltag_of(obj); + natural dnode = gc_dynamic_area_dnode(obj); + + + if ((dnode >= GCndynamic_dnodes_in_area) || + (obj < GCfirstunmarked)) { + return obj; + } + + return dnode_forwarding_address(dnode, tag_n); +} + + +void +forward_headerless_range(LispObj *range_start, LispObj *range_end) +{ + LispObj *p = range_start; + + while (p < range_end) { + update_noderef(p); + p++; + } +} + +void +forward_range(LispObj *range_start, LispObj *range_end) +{ + LispObj *p = range_start, node, new; + int tag_n; + natural nwords; + hash_table_vector_header *hashp; + + while (p < range_end) { + node = *p; + tag_n = fulltag_of(node); + if (immheader_tag_p(tag_n)) { + p = (LispObj *) skip_over_ivector((natural) p, node); + } else if (nodeheader_tag_p(tag_n)) { + nwords = header_element_count(node); + nwords += (1 - (nwords&1)); + if ((header_subtag(node) == subtag_hash_vector) && + ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { + natural skip = hash_table_vector_header_count-1; + hashp = (hash_table_vector_header *) p; + p++; + nwords -= skip; + while(skip--) { + update_noderef(p); + p++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "p" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (update_noderef(p) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + p++; + update_noderef(p); + p++; + } + *p++ = 0; + } else { + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)(p[1]); + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(node) - (skip & 0x7fff); + +#else + int skip = (int)(p[1]); +#endif + p += skip; + nwords -= skip; + } + p++; + while(nwords--) { + update_noderef(p); + p++; + } + } + } else { + new = node_forwarding_address(node); + if (new != node) { + *p = new; + } + p++; + update_noderef(p); + p++; + } + } +} + + + + + + +/* Forward a tstack area */ +void +forward_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + forward_range(current+2, end); + } +} + +/* Forward a vstack area */ +void +forward_vstack_area(area *a) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + forward_headerless_range(p, q); +} + +/* Nothing of interest on x86 cstack */ +void +forward_cstack_area(area *a) +{ +} + +#ifdef X8664 +void +forward_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp); + + update_noderef(&(regs[Iarg_z])); + update_noderef(&(regs[Iarg_y])); + update_noderef(&(regs[Iarg_x])); + update_noderef(&(regs[Isave3])); + update_noderef(&(regs[Isave2])); + update_noderef(&(regs[Isave1])); + update_noderef(&(regs[Isave0])); + update_noderef(&(regs[Ifn])); + update_noderef(&(regs[Itemp0])); + update_noderef(&(regs[Itemp1])); + update_noderef(&(regs[Itemp2])); + update_locref(&(regs[Iip])); +} +#else +void +forward_xp(ExceptionInformation *xp, natural node_regs_mask) +{ + natural *regs = (natural *) xpGPRvector(xp); + + if (node_regs_mask & (1<<0)) update_noderef(®s[REG_EAX]); + if (node_regs_mask & (1<<1)) update_noderef(®s[REG_ECX]); + + if (regs[REG_EFL] & EFL_DF) { + /* then EDX is an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) update_noderef(®s[REG_EDX]); + + if (node_regs_mask & (1<<3)) update_noderef(®s[REG_EBX]); + if (node_regs_mask & (1<<4)) update_noderef(®s[REG_ESP]); + if (node_regs_mask & (1<<5)) update_noderef(®s[REG_EBP]); + if (node_regs_mask & (1<<6)) update_noderef(®s[REG_ESI]); + if (node_regs_mask & (1<<7)) update_noderef(®s[REG_EDI]); + + update_locref(&(regs[Iip])); +} +#endif + + +void +forward_tcr_xframes(TCR *tcr) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifdef X8664 + forward_xp(xp); +#else + forward_xp(xp, tcr->node_regs_mask); + + update_noderef(&tcr->save0); + update_noderef(&tcr->save1); + update_noderef(&tcr->save2); + update_noderef(&tcr->save3); + update_noderef(&tcr->next_method_context); +#endif + } + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { +#ifdef X8664 + forward_xp(xframes->curr); +#else + forward_xp(xframes->curr, xframes->node_regs_mask); +#endif + } +} + + +#ifdef X8632 +void +update_self_references(LispObj *node) +{ + LispObj fn = fulltag_misc + (LispObj)node; + unsigned char *p = (unsigned char *)node; + natural i = imm_word_count(fn); + + if (i) { + natural offset = node[--i]; + + while (offset) { + *(LispObj *)(p + offset) = fn; + offset = node[--i]; + } + } +} +#endif + +/* + Compact the dynamic heap (from GCfirstunmarked through its end.) + Return the doublenode address of the new freeptr. + */ + +LispObj +compact_dynamic_heap() +{ + LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current, *prev = NULL; + natural + elements, + dnode = gc_area_dnode(GCfirstunmarked), + node_dnodes = 0, + imm_dnodes = 0, + bitidx, + *bitsp, + bits, + nextbit, + diff; + int tag; + bitvector markbits = GCmarkbits; + + if (dnode < GCndnodes_in_area) { + lisp_global(FWDNUM) += (1<>1; + dnode += node_dnodes; + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + LispObj *f = dest; + int skip = imm_word_count(fulltag_misc + (LispObj)current); +#else + int skip = *((int *)src); +#endif + *dest++ = node; + if (skip) { + elements -= skip; + while(skip--) { + *dest++ = *src++; + } +#ifdef X8632 + update_self_references(f); +#endif + } + while(elements--) { + *dest++ = node_forwarding_address(*src++); + } + if (((LispObj)src) & node_size) { + src++; + *dest++ = 0; + } + } else { + if ((header_subtag(node) == subtag_hash_vector) && + (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) { + hash_table_vector_header *hashp = (hash_table_vector_header *) dest; + int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + *dest++ = node; + elements -= skip; + while(skip--) { + *dest++ = node_forwarding_address(*src++); + } + /* There should be an even number of (key/value) pairs in elements; + an extra alignment word follows. */ + elements >>= 1; + while (elements--) { + if (hashp) { + node = *src++; + new = node_forwarding_address(node); + if (new != node) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + *dest++ = new; + } else { + *dest++ = node; + } + } else { + *dest++ = node_forwarding_address(*src++); + } + *dest++ = node_forwarding_address(*src++); + } + *dest++ = 0; + src++; + } else { + *dest++ = node; + *dest++ = node_forwarding_address(*src++); + while(--node_dnodes) { + *dest++ = node_forwarding_address(*src++); + *dest++ = node_forwarding_address(*src++); + } + } + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else if (immheader_tag_p(tag)) { + *dest++ = node; + *dest++ = *src++; + elements = header_element_count(node); + tag = header_subtag(node); + +#ifdef X8664 + switch(fulltag_of(tag)) { + case ivector_class_64_bit: + imm_dnodes = ((elements+1)+1)>>1; + break; + case ivector_class_32_bit: + imm_dnodes = (((elements+2)+3)>>2); + break; + case ivector_class_other_bit: + if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+64)+127)>>7); + } else if (tag >= min_8_bit_ivector_subtag) { + imm_dnodes = (((elements+8)+15)>>4); + } else { + imm_dnodes = (((elements+4)+7)>>3); + } + } +#endif +#ifdef X8632 + if (tag <= max_32_bit_ivector_subtag) { + imm_dnodes = (((elements+1)+1)>>1); + } else if (tag <= max_8_bit_ivector_subtag) { + imm_dnodes = (((elements+4)+7)>>3); + } else if (tag <= max_16_bit_ivector_subtag) { + imm_dnodes = (((elements+2)+3)>>2); + } else if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+32)+63)>>6); + } else { + imm_dnodes = elements+1; + } +#endif + + dnode += imm_dnodes; + while (--imm_dnodes) { + *dest++ = *src++; + *dest++ = *src++; + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else { + *dest++ = node_forwarding_address(node); + *dest++ = node_forwarding_address(*src++); + bits &= ~(BIT0_MASK >> bitidx); + dnode++; + bitidx++; + } + } + } + } + return ptr_to_lispobj(dest); +} + + + + + + + +/* + Total the (physical) byte sizes of all ivectors in the indicated memory range +*/ + +natural +unboxed_bytes_in_range(LispObj *start, LispObj *end) +{ + natural total=0, elements, tag, subtag, bytes; + LispObj header; + + while (start < end) { + header = *start; + tag = fulltag_of(header); + + if ((nodeheader_tag_p(tag)) || + (immheader_tag_p(tag))) { + elements = header_element_count(header); + if (nodeheader_tag_p(tag)) { + start += ((elements+2) & ~1); + } else { + subtag = header_subtag(header); + +#ifdef X8664 + switch(fulltag_of(header)) { + case ivector_class_64_bit: + bytes = 8 + (elements<<3); + break; + case ivector_class_32_bit: + bytes = 8 + (elements<<2); + break; + case ivector_class_other_bit: + default: + if (subtag == subtag_bit_vector) { + bytes = 8 + ((elements+7)>>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + bytes = 8 + elements; + } else { + bytes = 8 + (elements<<1); + } + } +#endif +#ifdef X8632 + if (subtag <= max_32_bit_ivector_subtag) { + bytes = 4 + (elements<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + bytes = 4 + elements; + } else if (subtag <= max_16_bit_ivector_subtag) { + bytes = 4 + (elements<<1); + } else if (subtag == subtag_double_float_vector) { + bytes = 8 + (elements<<3); + } else { + bytes = 4 + ((elements+7)>>3); + } +#endif + + bytes = (bytes+dnode_size-1) & ~(dnode_size-1); + total += bytes; + start += (bytes >> node_shift); + } + } else { + start += 2; + } + } + return total; +} + + +/* + This assumes that it's getting called with a simple-{base,general}-string + or code vector as an argument and that there's room for the object in the + destination area. +*/ + + +LispObj +purify_displaced_object(LispObj obj, area *dest, natural disp) +{ + BytePtr + free = dest->active, + *old = (BytePtr *) ptr_from_lispobj(untag(obj)); + LispObj + header = header_of(obj), + new; + natural + start = (natural)old, + physbytes; + + physbytes = ((natural)(skip_over_ivector(start,header))) - start; + + dest->active += physbytes; + + new = ptr_to_lispobj(free)+disp; + + memcpy(free, (BytePtr)old, physbytes); + /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ + /* Actually, it's best to always leave a trail, for two reasons. + a) We may be walking the same heap that we're leaving forwaring + pointers in, so we don't want garbage that we leave behind to + look like a header. + b) We'd like to be able to forward code-vector locatives, and + it's easiest to do so if we leave a {forward_marker, dnode_locative} + pair at every doubleword in the old vector. + */ + while(physbytes) { + *old++ = (BytePtr) forward_marker; + *old++ = (BytePtr) free; + free += dnode_size; + physbytes -= dnode_size; + } + return new; +} + +LispObj +purify_object(LispObj obj, area *dest) +{ + return purify_displaced_object(obj, dest, fulltag_of(obj)); +} + +Boolean +copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest) +{ + LispObj obj = *ref, header, new; + natural tag = fulltag_of(obj), header_tag; + Boolean changed = false; + + if ((tag == fulltag_misc) && + (((BytePtr)ptr_from_lispobj(obj)) > low) && + (((BytePtr)ptr_from_lispobj(obj)) < high)) { + header = deref(obj, 0); + if (header == forward_marker) { /* already copied */ + *ref = (untag(deref(obj,1)) + tag); + changed = true; + } else { + header_tag = fulltag_of(header); + if (immheader_tag_p(header_tag)) { + if (header_subtag(header) != subtag_macptr) { + new = purify_object(obj, dest); + *ref = new; + changed = (new != obj); + } + } + } + } + return changed; +} + + +void +purify_gcable_ptrs(BytePtr low, BytePtr high, area *to) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + copy_ivector_reference(prev, low, high, to); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + +void +purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) +{ + while (start < end) { + copy_ivector_reference(start, low, high, to); + start++; + } +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) +{ + LispObj header; + unsigned tag; + natural nwords; + hash_table_vector_header *hashp; + + while (start < end) { + header = *start; + if (header == forward_marker) { + start += 2; + } else { + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else if (nodeheader_tag_p(tag)) { + nwords = header_element_count(header); + nwords += (1 - (nwords&1)); + if ((header_subtag(header) == subtag_hash_vector) && + ((((hash_table_vector_header *)start)->flags) & + nhash_track_keys_mask)) { + natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + hashp = (hash_table_vector_header *) start; + start++; + nwords -= skip; + while(skip--) { + copy_ivector_reference(start, low, high, to); + start++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "start" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (copy_ivector_reference(start, low, high, to) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + start++; + copy_ivector_reference(start, low, high, to); + start++; + } + *start++ = 0; + } else { + if (header_subtag(header) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)(start[1]); + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(header) - (skip & 0x7fff); +#else + int skip = (int)(start[1]); +#endif + start += skip; + nwords -= skip; + } + start++; + while(nwords--) { + copy_ivector_reference(start, low, high, to); + start++; + } + } + } else { + /* Not a header, just a cons cell */ + copy_ivector_reference(start, low, high, to); + start++; + copy_ivector_reference(start, low, high, to); + start++; + } + } + } +} + +/* Purify references from tstack areas */ +void +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + purify_range(current+2, end, low, high, to); + } +} + +/* Purify a vstack area */ +void +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + purify_headerless_range(p, q, low, high, to); +} + + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to) +{ + natural *regs = (natural *) xpGPRvector(xp); + + +#ifdef X8664 + copy_ivector_reference(&(regs[Iarg_z]), low, high, to); + copy_ivector_reference(&(regs[Iarg_y]), low, high, to); + copy_ivector_reference(&(regs[Iarg_x]), low, high, to); + copy_ivector_reference(&(regs[Isave3]), low, high, to); + copy_ivector_reference(&(regs[Isave2]), low, high, to); + copy_ivector_reference(&(regs[Isave1]), low, high, to); + copy_ivector_reference(&(regs[Isave0]), low, high, to); + copy_ivector_reference(&(regs[Ifn]), low, high, to); + copy_ivector_reference(&(regs[Itemp0]), low, high, to); + copy_ivector_reference(&(regs[Itemp1]), low, high, to); + copy_ivector_reference(&(regs[Itemp2]), low, high, to); +#if 0 + purify_locref(&(regs[Iip]), low, high, to); +#endif +#else +#endif +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + purify_range(start, end, low, high, to); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + purify_xp(xp, low, high, to); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + purify_xp(xframes->curr, low, high, to); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + purify_tstack_area(next_area, low, high, target); + break; + + case AREA_VSTACK: + purify_vstack_area(next_area, low, high, target); + break; + + case AREA_CSTACK: + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target); + break; + + default: + break; + } + } +} + +/* + So far, this is mostly for save_application's benefit. + We -should- be able to return to lisp code after doing this, + however. + +*/ + + +signed_natural +purify(TCR *tcr, signed_natural param) +{ + extern area *extend_readonly_area(unsigned); + area + *a = active_dynamic_area, + *new_pure_area; + + TCR *other_tcr; + natural max_pure_size; + BytePtr new_pure_start, + low = (a->low + (static_dnodes_for_area(a) << dnode_shift)), + high = a->active; + + + max_pure_size = unboxed_bytes_in_range((LispObj *) low, (LispObj *) high); + new_pure_area = extend_readonly_area(max_pure_size); + if (new_pure_area) { + new_pure_start = new_pure_area->active; + lisp_global(IN_GC) = (1<next; + } while (other_tcr != tcr); + + purify_gcable_ptrs(low, high, new_pure_area); + { + natural puresize = (unsigned) (new_pure_area->active-new_pure_start); + if (puresize != 0) { + xMakeDataExecutable(new_pure_start, puresize); + + } + } + ProtectMemory(new_pure_area->low, + align_to_power_of_2(new_pure_area->active-new_pure_area->low, + log2_page_size)); + lisp_global(IN_GC) = 0; + just_purified_p = true; + return 0; + } + return -1; +} + + + +Boolean +impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta) +{ + LispObj q = *p; + + if (is_node_fulltag(fulltag_of(q)) && + (q >= low) && + (q < high)) { + *p = (q+delta); + return true; + } + return false; +} + + +void +impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + impurify_noderef(prev, low, high, delta); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + + +void +impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta) +{ + natural *regs = (natural *) xpGPRvector(xp); + + +#ifdef X8664 + impurify_noderef(&(regs[Iarg_z]), low, high, delta); + impurify_noderef(&(regs[Iarg_y]), low, high, delta); + impurify_noderef(&(regs[Iarg_x]), low, high, delta); +#ifndef WINDOWS + impurify_noderef(&(regs[Isave3]), low, high, delta); +#endif + impurify_noderef(&(regs[Isave2]), low, high, delta); + impurify_noderef(&(regs[Isave1]), low, high, delta); + impurify_noderef(&(regs[Isave0]), low, high, delta); + impurify_noderef(&(regs[Ifn]), low, high, delta); + impurify_noderef(&(regs[Itemp0]), low, high, delta); + impurify_noderef(&(regs[Itemp1]), low, high, delta); +#if 0 + impurify_locref(&(regs[Iip]), low, high, delta); +#endif +#else +#endif + +} + +void +impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta) +{ + while (start < end) { + impurify_noderef(start, low, high, delta); + start++; + } +} + + +void +impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta) +{ + LispObj header; + unsigned tag; + natural nwords; + hash_table_vector_header *hashp; + + while (start < end) { + header = *start; + if (header == forward_marker) { + start += 2; + } else { + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else if (nodeheader_tag_p(tag)) { + nwords = header_element_count(header); + nwords += (1 - (nwords&1)); + if ((header_subtag(header) == subtag_hash_vector) && + ((((hash_table_vector_header *)start)->flags) & + nhash_track_keys_mask)) { + natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + hashp = (hash_table_vector_header *) start; + start++; + nwords -= skip; + while(skip--) { + impurify_noderef(start, low, high, delta); + start++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "start" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (impurify_noderef(start, low, high, delta) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + start++; + impurify_noderef(start, low, high, delta); + start++; + } + *start++ = 0; + } else { + if (header_subtag(header) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)start[1]; +#else + int skip = (int)(start[1]); +#endif + start += skip; + nwords -= skip; + } + start++; + while(nwords--) { + impurify_noderef(start, low, high, delta); + start++; + } + } + } else { + /* Not a header, just a cons cell */ + impurify_noderef(start, low, high, delta); + start++; + impurify_noderef(start, low, high, delta); + start++; + } + } + } +} + + + + +void +impurify_tcr_tlb(TCR *tcr, LispObj low, LispObj high, signed_natural delta) +{ + unsigned n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + impurify_range(start, end, low, high, delta); +} + +void +impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + impurify_xp(xp, low, high, delta); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + impurify_xp(xframes->curr, low, high, delta); + } +} + +void +impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + impurify_range(current+2, end, low, high, delta); + } + } +} +void +impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + impurify_headerless_range(p, q, low, high, delta); +} + + +void +impurify_areas(LispObj low, LispObj high, signed_natural delta) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + impurify_tstack_area(next_area, low, high, delta); + break; + + case AREA_VSTACK: + impurify_vstack_area(next_area, low, high, delta); + break; + + case AREA_CSTACK: + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta); + break; + + default: + break; + } + } +} + +signed_natural +impurify(TCR *tcr, signed_natural param) +{ + area *r = find_readonly_area(); + + if (r) { + area *a = active_dynamic_area; + BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active, + oldhigh = a->high, newhigh; + unsigned n = ro_limit - ro_base; + signed_natural delta = oldfree-ro_base; + TCR *other_tcr; + + if (n) { + lisp_global(IN_GC) = 1; + newhigh = (BytePtr) (align_to_power_of_2(oldfree+n, + log2_heap_segment_size)); + if (newhigh > oldhigh) { + grow_dynamic_area(newhigh-oldhigh); + } + a->active += n; + memmove(oldfree, ro_base, n); + UnMapMemory((void *)ro_base, n); + a->ndnodes = area_dnode(a, a->active); + pure_space_active = r->active = r->low; + r->ndnodes = 0; + + impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + + other_tcr = tcr; + do { + impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + lisp_global(IN_GC) = 0; + } + return 0; + } + return -1; +} + +/* + * This stuff is all adapted from the forward_xxx functions for use by + * the watchpoint code. It's a lot of duplicated code, and it would + * be nice to generalize it somehow. + */ + +static inline int +wp_maybe_update(LispObj *p, LispObj old, LispObj new) +{ + if (*p == old) { + *p = new; + return true; + } + return false; +} + +static void +wp_update_headerless_range(LispObj *start, LispObj *end, + LispObj old, LispObj new) +{ + LispObj *p = start; + + while (p < end) { + wp_maybe_update(p, old, new); + p++; + } +} + +static void +wp_update_range(LispObj *start, LispObj *end, LispObj old, LispObj new) +{ + LispObj *p = start, node; + int tag_n; + natural nwords; + + while (p < end) { + node = *p; + tag_n = fulltag_of(node); + + if (immheader_tag_p(tag_n)) { + p = (LispObj *)skip_over_ivector(ptr_to_lispobj(p), node); + } else if (nodeheader_tag_p(tag_n)) { + nwords = header_element_count(node); + nwords += 1 - (nwords & 1); + + if ((header_subtag(node) == subtag_hash_vector) && + ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { + natural skip = hash_table_vector_header_count - 1; + hash_table_vector_header *hashp = (hash_table_vector_header *)p; + + p++; + nwords -= skip; + while(skip--) { + wp_maybe_update(p, old, new); + p++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "p" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (wp_maybe_update(p, old, new) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + p++; + wp_maybe_update(p, old, new); + p++; + } + *p++ = 0; + } else { + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)(p[1]); + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(node) - (skip & 0x7fff); + +#else + int skip = (int)(p[1]); +#endif + p += skip; + nwords -= skip; + } + p++; + while(nwords--) { + wp_maybe_update(p, old, new); + p++; + } + } + } else { + /* a cons cell */ + wp_maybe_update(p, old, new); + p++; + wp_maybe_update(p, old, new); + p++; + } + } +} + +#ifdef X8664 +static void +wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new) +{ + natural *regs = (natural *)xpGPRvector(xp); + + wp_maybe_update(®s[Iarg_z], old, new); + wp_maybe_update(®s[Iarg_y], old, new); + wp_maybe_update(®s[Iarg_x], old, new); + wp_maybe_update(®s[Isave3], old, new); + wp_maybe_update(®s[Isave2], old, new); + wp_maybe_update(®s[Isave1], old, new); + wp_maybe_update(®s[Isave0], old, new); + wp_maybe_update(®s[Ifn], old, new); + wp_maybe_update(®s[Itemp0], old, new); + wp_maybe_update(®s[Itemp1], old, new); + wp_maybe_update(®s[Itemp2], old, new); + +#if 0 + /* + * We don't allow watching functions, so this presumably doesn't + * matter. + */ + update_locref(&(regs[Iip])); +#endif +} +#else +static void +wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new, natural node_regs_mask) +{ + natural *regs = (natural *)xpGPRvector(xp); + + if (node_regs_mask & (1<<0)) wp_maybe_update(®s[REG_EAX], old, new); + if (node_regs_mask & (1<<1)) wp_maybe_update(®s[REG_ECX], old, new); + + if (regs[REG_EFL] & EFL_DF) { + /* then EDX is an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) wp_maybe_update(®s[REG_EDX], old, new); + + if (node_regs_mask & (1<<3)) wp_maybe_update(®s[REG_EBX], old, new); + if (node_regs_mask & (1<<4)) wp_maybe_update(®s[REG_ESP], old, new); + if (node_regs_mask & (1<<5)) wp_maybe_update(®s[REG_EBP], old, new); + if (node_regs_mask & (1<<6)) wp_maybe_update(®s[REG_ESI], old, new); + if (node_regs_mask & (1<<7)) wp_maybe_update(®s[REG_EDI], old, new); + /* we shouldn't watch functions, so no need to update PC */ +} +#endif + +static void +wp_update_tcr_xframes(TCR *tcr, LispObj old, LispObj new) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifdef X8664 + wp_update_xp(xp, old, new); +#else + wp_update_xp(xp, old, new, tcr->node_regs_mask); + wp_maybe_update(&tcr->save0, old, new); + wp_maybe_update(&tcr->save1, old, new); + wp_maybe_update(&tcr->save2, old, new); + wp_maybe_update(&tcr->save3, old, new); + wp_maybe_update(&tcr->next_method_context, old, new); +#endif + } + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { +#ifdef X8664 + wp_update_xp(xframes->curr, old, new); +#else + wp_update_xp(xframes->curr, old, new, xframes->node_regs_mask); +#endif + } +} + +/* + * Scan all pointer-bearing areas, updating all references to + * "old" to "new". + */ +static void +wp_update_all_areas(LispObj old, LispObj new) +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + switch (code) { + case AREA_DYNAMIC: + case AREA_STATIC: + case AREA_MANAGED_STATIC: + case AREA_WATCHED: + wp_update_range((LispObj *)a->low, (LispObj *)a->active, old, new); + break; + case AREA_VSTACK: + { + LispObj *low = (LispObj *)a->active; + LispObj *high = (LispObj *)a->high; + + wp_update_headerless_range(low, high, old, new); + } + break; + case AREA_TSTACK: + { + LispObj *current, *next; + LispObj *start = (LispObj *)a->active, *end = start; + LispObj *limit = (LispObj *)a->high; + + for (current = start; end != limit; current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + wp_update_range(current+2, end, old, new); + } + break; + } + default: + break; + } + a = a->succ; + code = a->code; + } +} + +static void +wp_update_tcr_tlb(TCR *tcr, LispObj old, LispObj new) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer; + LispObj *end = start + (n >> fixnumshift); + + while (start < end) { + wp_maybe_update(start, old, new); + start++; + } +} + +void +wp_update_references(TCR *tcr, LispObj old, LispObj new) +{ + TCR *other_tcr = tcr; + + do { + wp_update_tcr_xframes(other_tcr, old, new); + wp_update_tcr_tlb(other_tcr, old, new); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + unprotect_watched_areas(); + wp_update_all_areas(old, new); + protect_watched_areas(); +} Index: /branches/qres/ccl/lisp-kernel/x86-macros.s =================================================================== --- /branches/qres/ccl/lisp-kernel/x86-macros.s (revision 13564) +++ /branches/qres/ccl/lisp-kernel/x86-macros.s (revision 13564) @@ -0,0 +1,765 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +/* Try to make macros follow GAS/ATT conventions, where source precedes */ +/* destination. */ + +define(`lisp_global',`lisp_globals.$1') + +define(`ref_global',` + __(mov lisp_global($1),$2) +') + +define(`set_global',` + __(mov $1,lisp_global($2)) +') + +define(`ref_nrs_value',` + __(mov nrs.$1+symbol.vcell,$2) +') + +define(`set_nrs_value',` + __(mov $1,nrs.$2+symbol.vcell) +') + +define(`unbox_fixnum',` + __(mov $1,$2) + __(sar `$'fixnumshift,$2) +') + +define(`box_fixnum',` + __(imul `$'fixnumone,$1,$2) +') + + +/* box_fixnum, with no effect on flags */ +define(`box_fixnum_no_flags',` + __(lea (,$1,fixnumone),$2) +') + + +/* Zero $3 bytes worth of dnodes, starting at offset $2 relative */ +/* to the base register $1. */ + + +ifdef(`DarwinAssembler',` + .macro zero_dnodes + .if $2 + ifdef(`X8664',` + __(movapd %fpzero,$1($0)) + ',` + __(movsd %fpzero,$1($0)) + ') + __(zero_dnodes $0,$1+dnode_size,$2-dnode_size) + .endif + .endmacro +',` + .macro zero_dnodes base,disp,nbytes + .ifgt \nbytes + ifdef(`X8664',` + movapd %fpzero,\disp(\base) + ',` + movsd %fpzero,\disp(\base) + ') + zero_dnodes \base,"\disp+dnode_size","\nbytes-dnode_size" + .endif + .endm +') + + +/* Allocate $1+dnode_size zeroed bytes on the tstack, using $2 as a temp */ +/* reg. */ + +ifdef(`X8632',` +define(`TSP_Alloc_Fixed',` + define(`TSP_Alloc_Size',`((($1+node_size) & ~(dnode_size-1))+dnode_size)') + __(subl `$'TSP_Alloc_Size,rcontext(tcr.next_tsp)) + __(movd rcontext(tcr.save_tsp),%stack_temp) + __(movl rcontext(tcr.next_tsp),$2) + zero_dnodes $2,0,TSP_Alloc_Size + __(movd %stack_temp,($2)) + __(movl %ebp,tsp_frame.save_ebp($2)) + __(movl $2,rcontext(tcr.save_tsp)) + undefine(`TSP_Alloc_Size') +')',` +define(`TSP_Alloc_Fixed',` + define(`TSP_Alloc_Size',`((($1+node_size) & ~(dnode_size-1))+dnode_size)') + __(subq `$'TSP_Alloc_Size,rcontext(tcr.next_tsp)) + __(movq rcontext(tcr.save_tsp),%stack_temp) + __(movq rcontext(tcr.next_tsp),$2) + zero_dnodes $2,0,TSP_Alloc_Size + __(movq %stack_temp,($2)) + __(movq %rbp,tsp_frame.save_rbp($2)) + __(movq $2,rcontext(tcr.save_tsp)) + undefine(`TSP_Alloc_Size') +')') + +/* $1 = size (dnode-aligned, including tsp overhead, $2 scratch. */ +/* Modifies both $1 and $2; on exit, $2 = new_tsp+tsp_overhead, $1 = old tsp */ + +ifdef(`X8632',` +define(`TSP_Alloc_Var',` + new_macro_labels() + __(subl $1,rcontext(tcr.next_tsp)) + __(movd rcontext(tcr.save_tsp),%stack_temp) + __(movl rcontext(tcr.next_tsp),$2) + __(jmp macro_label(test)) +macro_label(loop): + __(movsd %fpzero,0($2)) + __(addl $dnode_size,$2) +macro_label(test): + __(subl $dnode_size,$1) + __(jge macro_label(loop)) + __(movl rcontext(tcr.next_tsp),$2) + __(movd %stack_temp,$1) + __(movl $1,($2)) + __(movl %ebp,tsp_frame.save_ebp($2)) + __(movl $2,rcontext(tcr.save_tsp)) + __(addl $dnode_size,$2) +')',` +define(`TSP_Alloc_Var',` + new_macro_labels() + subq $1,rcontext(tcr.next_tsp) + __(movq rcontext(tcr.save_tsp),%stack_temp) + __(movq rcontext(tcr.next_tsp),$2) + __(jmp macro_label(test)) +macro_label(loop): + __(movapd %fpzero,0($2)) + __(addq $dnode_size,$2) +macro_label(test): + __(subq $dnode_size,$1) + __(jge macro_label(loop)) + __(movq rcontext(tcr.next_tsp),$2) + __(movd %stack_temp,$1) + __(movq $1,($2)) + __(movq %rbp,tsp_frame.save_rbp($2)) + __(movq $2,rcontext(tcr.save_tsp)) + __(addq $dnode_size,$2) +')') + + +ifdef(`X8632',` +define(`Allocate_Catch_Frame',` + TSP_Alloc_Fixed(catch_frame.size,$1) + __(movl `$'(catch_frame.element_count<15),1,` + __(movl `$'$1< %arg_y %arg_z). */ +_spentry(builtin_gt) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(g,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_gt,2)) +_endsubp(builtin_gt) + +/* %arg_z <- (>= %arg_y %arg_z). */ +_spentry(builtin_ge) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(ge,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_ge,2)) +_endsubp(builtin_ge) + +/* %arg_z <- (< %arg_y %arg_z). */ +_spentry(builtin_lt) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(l,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_lt,2)) +_endsubp(builtin_lt) + +/* %arg_z <- (<= %arg_y %arg_z). */ +_spentry(builtin_le) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(le,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_le,2)) +_endsubp(builtin_le) + +_spentry(builtin_eql) + __(cmpl %arg_y,%arg_z) + __(je 1f) + /* Not EQ. Could only possibly be EQL if both are tag-misc */ + /* and both have the same subtag. */ + __(movl %arg_y,%imm0) + __(andb $tagmask,%imm0_b) + __(cmpb $tag_misc,%imm0_b) + __(jne 2f) + __(movb %arg_z_b,%imm0_bh) + __(andb $tagmask,%imm0_bh) + __(cmpb %imm0_bh,%imm0_b) + __(jne 2f) + __(extract_subtag(%arg_y,%imm0_b)) + __(extract_subtag(%arg_z,%imm0_bh)) + __(cmpb %imm0_b,%imm0_bh) + __(jne 2f) + __(jump_builtin(_builtin_eql,2)) +1: __(movl $t_value,%arg_z) + __(ret) +2: __(movl $nil_value,%arg_z) + __(ret) +_endsubp(builtin_eql) + +_spentry(builtin_length) + __(extract_fulltag(%arg_z,%imm0)) + __(cmpl $tag_list,%imm0) + __(jz 2f) + __(andl $tagmask,%imm0) + __(cmpl $tag_misc,%imm0) + __(jnz 8f) + __(extract_subtag(%arg_z,%imm0_b)) + __(rcmpb(%imm0_b,$min_vector_subtag)) + __(jb 8f) + __(je 1f) + /* (simple-array * (*)) */ + __(movl %arg_z,%arg_y) + __(vector_length(%arg_y,%arg_z)) + __(ret) +1: /* vector header */ + __(movl vectorH.logsize(%arg_z),%arg_z) + __(ret) +2: /* list. Maybe null, maybe dotted or circular. */ + __(movl $-fixnumone,%arg_y) + __(movl %arg_z,%temp0) /* fast pointer */ + __(movl %arg_z,%temp1) /* slow pointer */ +3: __(movb %temp0_b,%al) + __(andb $fulltagmask,%al) + __(addl $fixnumone,%arg_y) + __(compare_reg_to_nil(%temp0)) + __(je 9f) + __(cmpb $fulltag_cons,%al) + __(jne 8f) + __(movb %temp1_b,%ah) + __(andb $fulltagmask,%ah) + __(_cdr(%temp0,%temp0)) + __(testl $fixnumone,%arg_y) + __(je 3b) + __(cmpb $fulltag_cons,%ah) + __(jne 8f) + __(_cdr(%temp1,%temp1)) + __(cmpl %temp0,%temp1) + __(jne 3b) +8: + __(jump_builtin(_builtin_length,1)) +9: + __(movl %arg_y,%arg_z) + __(ret) +_endsubp(builtin_length) + +_spentry(builtin_seqtype) + __(extract_fulltag(%arg_z,%imm0)) + __(cmpb $fulltag_cons,%imm0_b) + __(jz 1f) + __(cmpb $tag_misc,%imm0_b) + __(jne 2f) + __(movb misc_subtag_offset(%arg_z),%imm0_b) + __(rcmpb(%imm0_b,$min_vector_subtag)) + __(jb 2f) + __(movl $nil_value,%arg_z) + __(ret) +1: __(movl $t_value,%arg_z) + __(ret) +2: + __(jump_builtin(_builtin_seqtype,1)) +_endsubp(builtin_seqtype) + +_spentry(builtin_assq) + __(cmpl $nil_value,%arg_z) + __(je 5f) +1: __(movl %arg_z,%imm0) + __(andb $fulltagmask,%imm0_b) + __(cmpb $fulltag_cons,%imm0_b) + __(jne 2f) + __(_car(%arg_z,%temp0)) + __(_cdr(%arg_z,%arg_z)) + __(cmpl $nil_value,%temp0) + __(je 4f) + __(movl %temp0,%imm0) + __(andb $fulltagmask,%imm0_b) + __(cmpb $fulltag_cons,%imm0_b) + __(jne 3f) + __(_car(%temp0,%temp1)) + __(cmpl %temp1,%arg_y) + __(jne 4f) + __(movl %temp0,%arg_z) + __(ret) +4: __(cmpl $nil_value,%arg_z) +5: __(jnz 1b) + __(repret) +2: __(uuo_error_reg_not_list(Rarg_z)) +3: __(uuo_error_reg_not_list(Rtemp0)) +_endsubp(builtin_assq) + +_spentry(builtin_memq) + __(cmpl $nil_value,%arg_z) + __(jmp 3f) +1: __(movb $fulltagmask,%imm0_b) + __(andb %arg_z_b,%imm0_b) + __(cmpb $fulltag_cons,%imm0_b) + __(jne 2f) + __(_car(%arg_z,%temp1)) + __(_cdr(%arg_z,%temp0)) + __(cmpl %temp1,%arg_y) + __(jz 4f) + __(cmpl $nil_value,%temp0) + __(movl %temp0,%arg_z) +3: __(jnz 1b) +4: __(repret) +2: __(uuo_error_reg_not_list(Rarg_z)) +_endsubp(builtin_memq) + +logbitp_max_bit = 30 + +_spentry(builtin_logbitp) + /* Call out unless: both args fixnums, arg_y in `0, logbitp_max_bit) */ + __(movl %arg_z,%imm0) + __(orl %arg_y,%imm0) + __(testb $fixnummask,%imm0_b) + __(jnz 1f) + __(unbox_fixnum(%arg_y,%imm0)) + __(js 1f) /* bit number negative */ + __(addb $fixnumshift,%imm0_b) + __(cmpl $logbitp_max_bit<